Index: trunk/DOC/000-MODELS
===================================================================
--- trunk/DOC/000-MODELS	(revision 174)
+++ trunk/DOC/000-MODELS	(revision 175)
@@ -75,4 +75,24 @@
 MESOSCALE     martian mesoscale modeling system  + (for new martian physics) links to martian physics [LMDZ.MARS needed]
 
+**********************************************
+**********************************************
+FIRST STEPS TOWARD COMPILATION
+******************************
+
+- install netcdf with the same compiler you plan to use for the GCM and keep in mind where the lib and include directories are located.
+
+- if needed, install ioipsl:
+   # ADVICE: copy the [GCMdir]/LMDZ.COMMON/ioipsl directory 
+   # to [GCMdir]/ioipsl to get it out of svn
+   # then go to [GCMdir]/ioipsl
+   # Edit the compile_ioipsl.bash script to get the right paths for NCDF_INC and NCDF_LIB, then run it.
+
+- choose your compilation options and paths in arch files tuned for your machine:
+   LMDZ.COMMON/arch/arch-<youroptions>.[fcm/path]
+
+- use makelmdz to compile the GCM (when you are using the common dynamical core):
+   makelmdz -arch <youroptions> -d <nlon>x<nlat>x<nlev> -p <dirphy> gcm
+
 ----------------------------------------------------
 AS -- 25/05/2011 - 08/06/2011
+SL -- 24/06/2011
Index: trunk/DOC/000-USERS
===================================================================
--- trunk/DOC/000-USERS	(revision 174)
+++ trunk/DOC/000-USERS	(revision 175)
@@ -26,2 +26,4 @@
 Jean-Yves Chauffray		LMD [CNRS]			25 - 05 - 2011			Mars GCM
 Luca Montabone			LMD [CNRS]			25 - 05 - 2011			Mars GCM
+Jeremie Burgalat		GSMA [URCA]			01 - 06 - 2011			Titan GCM
+Pascal Rannou   		GSMA [URCA]			01 - 06 - 2011			Titan GCM
Index: trunk/LMDZ.TITAN/deftank/physiq.def
===================================================================
--- trunk/LMDZ.TITAN/deftank/physiq.def	(revision 174)
+++ trunk/LMDZ.TITAN/deftank/physiq.def	(revision 175)
@@ -28,4 +28,6 @@
 ### OK_instan=y, ecrire sorties "instantanees" (chaque pas de temps de la  physique)
 OK_instan=n
+# frequence ecriture du fichier histins en jours
+ecritphy=0.01
 #
 # Parametres niveau de sorties differents fichiers 
@@ -93,4 +95,11 @@
 # facteur de correction
 tcorrect=1.
-# 1 pour albedo ok ; 2 pour T tropopause ok
+# pressure level for aerosol production (in Pa)
+p_prodaer=1.
+# 0: pas de cutoff ; 1 pour albedo ok ; 2 pour T tropopause ok
 cutoff=2 
+# activation nuages (si 1, mettre cutoff=0)
+clouds=0
+# fraction nuageuse
+xnuf=0.5
+
Index: trunk/LMDZ.TITAN/deftank/traceur.def.chimie_noclouds
===================================================================
--- trunk/LMDZ.TITAN/deftank/traceur.def.chimie_noclouds	(revision 175)
+++ trunk/LMDZ.TITAN/deftank/traceur.def.chimie_noclouds	(revision 175)
@@ -0,0 +1,55 @@
+54
+10 10 q01
+10 10 q02
+10 10 q03
+10 10 q04
+10 10 q05
+10 10 q06
+10 10 q07
+10 10 q08
+10 10 q09
+10 10 q10
+10 10 H
+10 10 H2
+10 10 CH
+10 10 CH2s
+10 10 CH2
+10 10 CH3
+10 10 CH4
+10 10 C2
+10 10 C2H
+10 10 C2H2
+10 10 C2H3
+10 10 C2H4
+10 10 C2H5
+10 10 C2H6
+10 10 C3H3
+10 10 C3H5
+10 10 C3H6
+10 10 C3H7
+10 10 C4H
+10 10 C4H3
+10 10 C4H4
+10 10 C4H2s
+10 10 CH2CCH2
+10 10 CH3CCH
+10 10 C3H8
+10 10 C4H2
+10 10 C4H6
+10 10 C4H10
+10 10 AC6H6
+10 10 C3H2
+10 10 C4H5
+10 10 AC6H5
+10 10 N2
+10 10 N4S
+10 10 CN
+10 10 HCN
+10 10 H2CN
+10 10 CHCN
+10 10 CH2CN
+10 10 CH3CN
+10 10 C3N
+10 10 HC3N
+10 10 NCCN
+10 10 C4N2
Index: trunk/LMDZ.TITAN/deftank/traceur.def.clouds_nochimie
===================================================================
--- trunk/LMDZ.TITAN/deftank/traceur.def.clouds_nochimie	(revision 175)
+++ trunk/LMDZ.TITAN/deftank/traceur.def.clouds_nochimie	(revision 175)
@@ -0,0 +1,55 @@
+53
+10 10 q01
+10 10 q02
+10 10 q03
+10 10 q04
+10 10 q05
+10 10 q06
+10 10 q07
+10 10 q08
+10 10 q09
+10 10 q10
+10 10 q11
+10 10 q12
+10 10 q13
+10 10 q14
+10 10 q15
+10 10 q16
+10 10 q17
+10 10 q18
+10 10 q19
+10 10 q20
+10 10 q21
+10 10 q22
+10 10 q23
+10 10 q24
+10 10 q25
+10 10 q26
+10 10 q27
+10 10 q28
+10 10 q29
+10 10 q30
+10 10 q31
+10 10 q32
+10 10 q33
+10 10 q34
+10 10 q35
+10 10 q36
+10 10 q37
+10 10 q38
+10 10 q39
+10 10 q40
+10 10 q41
+10 10 q42
+10 10 q43
+10 10 q44
+10 10 q45
+10 10 q46
+10 10 q47
+10 10 q48
+10 10 q49
+10 10 q50
+10 10 CH4
+10 10 C2H6
+10 10 C2H2
+
Index: trunk/LMDZ.TITAN/deftank/traceur.def.nochimie_noclouds
===================================================================
--- trunk/LMDZ.TITAN/deftank/traceur.def.nochimie_noclouds	(revision 175)
+++ trunk/LMDZ.TITAN/deftank/traceur.def.nochimie_noclouds	(revision 175)
@@ -0,0 +1,11 @@
+10
+10 10 q01
+10 10 q02
+10 10 q03
+10 10 q04
+10 10 q05
+10 10 q06
+10 10 q07
+10 10 q08
+10 10 q09
+10 10 q10
Index: trunk/LMDZ.TITAN/libf/phytitan/brume3D.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/brume3D.F	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/brume3D.F	(revision 175)
@@ -0,0 +1,1216 @@
+         subroutine brume(ngrid,tab1,x1,
+     &                    xnz,xnrad,taused,ihor,
+     &                    pmu0,pfract,
+     &                    precip)
+
+
+*1  c nombre de particules de la grille de rayon r a l'altitude z 
+*2  dt, pas de temps, en heure.  
+
+*--------------------------------------------------------------*
+*                                                              *
+*            ENTRE 0 ET 1000 KILOMETRES                        *     
+*                                                              * 
+*    la dimension fractale est en tableau, attention au        *
+*    raccordement entre le regime moleculaire et le regime     *
+*    fluide                                                    *
+*                                                              *
+*    Modele microphysique:    Cabane et al.,1992 /             *
+*    Modele version fractale: Cabane et al.,1993 /             *
+*                                                              *
+*--------------------------------------------------------------*
+* VERSION DU 2 JUIN 1993  --- AUT 1994 --- 11/04/96
+*
+* changer: altitude de production z0=/taux de production ctot= 
+*        : la charge/micron, ne
+*        : df(h),rf... 
+* raccordement aknc 
+*
+* declaration des blocs communs
+*------------------------------
+
+         use dimphy
+         IMPLICIT NONE
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+
+
+         real pmu0,pfract
+
+         common/ctps/li,lf,dt
+         common/con/c
+         common/coag/k
+         common/effets/xsaison
+
+ 
+* declaration des variables communes
+* ----------------------------------
+
+         integer xnz,xnrad,ngrid
+         integer li,lf,ihor
+         real dt
+         real c0(nz,nrad),c(nz,nrad,2)
+         real k(nz,nrad,nrad),knu
+         real xsaison
+         real taused(nz,nrad)
+         real precip(ngrid,5)
+
+        
+
+*  variables internes
+*  ------------------
+
+         integer h,ti,itime,i,j
+         real tab1(nz,nrad)
+         real x1 
+         real somme,v1,dice3
+         
+         real vitesse
+
+         save itime
+         data itime/0/
+
+* initialisation
+* --------------
+
+* effet saisonnier
+* ----------------
+
+
+         xsaison=0.
+         xsaison=pmu0*4.*pfract
+                              !=Pi si fract=1/2 (equinoxe) et 
+                              !    si mu0(ihor)=1 sous le soleil
+                              !    exactement.
+
+c        xsaison=0.
+c        if (ihor.le.9.or.ihor.ge.41) xsaison=8.  ! rapport des surfaces
+c        xsaison=1.
+
+* controles
+* ---------
+
+         if (nrad.ne.xnrad)  stop 'nrad.ne.xnrad'
+         if (nz.ne.xnz)    stop 'nz.ne.xnz'
+
+         do i=1,nz
+           do j=1,nrad 
+             c(i,j,1)=tab1(i,j)
+             c(i,j,2)=0.0 
+           enddo 
+         enddo 
+
+         dt=x1 
+
+         if (itime.eq.0) then 
+           ITIME=1
+           call init
+           call calcoag
+         endif
+
+         do i=1,nz,1
+           do j=1,nrad
+             v1=vitesse(i,j,0)
+             taused(i,j)=(8.314*t(i)/28.e-3/1.35)/v1
+           enddo
+         enddo
+
+         call coagul
+
+         call production(ihor)
+ 
+         li=3-li
+         lf=3-lf
+
+         call sedif(dice3)
+c        En theorie, dice3 est NEGATIF (en sedimentant on ne fait que perdre des aerosols)
+c        Le precipitations sont comptées positivement.
+         precip(ihor,5)=-dice3/rhol    ! m3/m2=m 
+
+         li=3-li
+         lf=3-lf
+
+         do i=1,nz
+           do j=1,nrad
+             tab1(i,j)=c(i,j,li)     ! li=1
+           enddo
+         enddo 
+         
+         return  
+
+         end 
+*________________________________________________________________________ 
+
+         subroutine coagul
+
+*********************************************************
+* ce programme calcule la nouvelle concentration dans   *
+* le a ieme intervalle de rayon, a l'altitude h, a      *
+* l'instant t+dt                                        *
+*********************************************************
+         use dimphy
+         IMPLICIT NONE
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+
+
+* declaration des blocs communs
+*------------------------------
+
+         common/ctps/li,lf,dt
+         common/con/c
+
+* declaration des variables
+* --------------------------
+
+         integer li,lf
+         real dt
+         real c(nz,nrad,2)
+
+* declaration des variables propres au ss-programme
+* -------------------------------------------------
+
+         integer h,a
+         real pr,pe
+
+*  traitement
+*  ----------
+
+         do h=nztop,nz
+           do a=1,nrad
+             call pertpro(h,a,pe,pr)
+c            if((1+dt*pe).lt.0.) stop 'denom.eq.0'
+             c(h,a,lf)=(c(h,a,li)+pr*dt)/(1+dt*pe)
+           enddo
+         enddo 
+
+         if (nztop.ne.1) then
+           do h=1,nztop-1
+             do a=1,nrad
+               c(h,a,lf)=c(h,a,li)
+             enddo
+           enddo 
+         endif
+
+         return
+         end
+      
+      
+*__________________________________________________________________________
+
+         subroutine  calcoag
+
+***************************************************************
+*                                                             *
+*  Ce programme calcule les coefficients de collection  d'une *
+* particule de rayon x avec une particule de rayon b a une    *
+* altitude donnee h                                           *
+*************************************************************** 
+
+* declaration des blocs communs
+*------------------------------
+         use dimphy
+         IMPLICIT NONE
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+
+         common/ctps/li,lf,dt
+         common/con/c
+         common/coag/k
+
+* declaration des variables
+* --------------------------
+
+         integer li,lf,i
+         real dt
+         real c(nz,nrad,2)
+         real knu,nud,k(nz,nrad,nrad)
+
+* declaration des variables propres au ss-programme
+* -------------------------------------------------
+
+         integer h,b,x
+         real nua,lambb,lambx,knb,knx,alphab,alphax,d,e,f,kcg
+         real db,dx,rm,dm,deltab,deltax,del,g,beta,gx,gb
+         real rfx,rfb,rpr
+         real*8 ne,qe,epso
+         real*8 corelec,yy
+
+         real kco,vx,vb,vitesse,sto,ee,a,dd,bb,p0,t0,l0,ccol
+         real st(37),ef(37)
+
+* initialisation
+* --------------
+c        print*,'**** calcoag'
+
+*  -nombres de STOCKES
+
+         data(st(i),i=1,37)/1.35,1.5,1.65,1.85,2.05,2.25,2.5,2.8,3.1,
+     s    3.35,3.6,3.95,4.3,4.7,5.05,5.45,5.9,6.4,7.,7.6,8.3,9.05,9.9,
+     s       10.9,11.1,13.5,15.3,17.25,20.5,24.5,30.4,39.3,48,57,86.,
+     s       187.,600./
+
+*  -coef. d'efficacite de collection
+
+         ef(1)=3.75
+         ef(2)=8.75
+         do i=3,37
+           ef(i)=ef(i-1)+2.5
+         enddo
+
+         do i=1,37
+           ef(i)=ef(i)*1e-2
+         enddo
+
+         qe=1.6e-19
+         ne=-30.e+6         ! "vieille valeur!"
+         ne=-15.e+6          ! pour fitter DISR !
+
+         epso=1e-9/(36*pi)
+
+         d=1.257
+         e=0.4
+         f=-1.1
+
+*  iteration sur z
+ 
+         do 1 h=1,nz
+           nua=nud(h,1)      
+
+*  iteration sur les rayons
+
+           do 1 b=1,nrad
+
+             knb=knu(h,b,1)
+             vb=vitesse(h,b,1)
+
+             do 1 x=1,b
+
+               knx=knu(h,x,1)
+               vx=vitesse(h,x,1)
+
+**  COAGULATION  ****************************************************
+** --------------****************************************************
+* calcul du terme correcteur 'slip-flow'
+
+               alphab=d+e*exp(f/knb)
+               alphax=d+e*exp(f/knx)
+
+* calcul du coefficient de diffusion
+
+               rfb=(r_e(b)**(3./df(b)))*((rf(b))**(1.-3./df(b)))
+               rfx=(r_e(x)**(3./df(x)))*((rf(x))**(1.-3./df(x)))
+               db=kbz*t(h)*(1+alphab*knb)/(6*pi*nua*rfb)
+               dx=kbz*t(h)*(1+alphax*knx)/(6*pi*nua*rfx)
+
+* calcul du coefficient de coagulation
+
+               rpr=rfb+rfx
+               kcg=4*pi*rpr*(db+dx)
+
+* calcul de la vitesse thermique
+
+               gx=sqrt(6*kbz*t(h)/(rhol*pi**2*r_e(x)**3))
+               gb=sqrt(6*kbz*t(h)/(rhol*pi**2*r_e(b)**3))
+
+* calcul du libre parcours apparent des aerosols
+
+               lambb=8*db/(pi*gb)
+               lambx=8*dx/(pi*gx)
+
+*calcul du terme correcteur beta
+
+               rm=rpr/2.
+               dm=(dx+db)/2.
+               g=sqrt(gx**2+gb**2)
+               deltab=(((2*rfb+lambb)**3-(4*rfb**2+lambb**2)**1.5)
+     s         /(6*rfb*lambb)-2*rfb)*sqrt(2.)
+               deltax=(((2*rfx+lambx)**3-(4*rfx**2+lambx**2)**1.5)
+     s         /(6*rfx*lambx)-2*rfx)*sqrt(2.)
+               del=sqrt(deltab**2+deltax**2)
+               beta=1/((rm/(rm+del/2))+(4*dm/(g*rm)))
+
+* calcul du coefficient de coagulation corrige
+
+               kcg=kcg*beta
+c       print*,' kcg:', rfb,rfx,knb,knx,db,dx
+c       print*,' beta:', gx,gb,lambb,lambx,rm,dm
+c       print*,' beta:', g,deltab,deltax,del,beta
+c       print*,' '
+
+**  COALESCENCE  **************************************************
+**  -------------**************************************************
+
+               kco=0.
+
+               if (b.eq.x) goto 9
+
+* calcul du nombre de Stockes de la petite particule
+
+               sto=2*rhol*rfx**2*abs(vx-vb)/(9*nua*rfb)
+
+* calcul du coef. de Cunningham-Millikan
+
+               a=1.246
+               bb=0.42
+               dd=0.87
+               l0=0.653e-7
+               p0=101325.
+               t0=288.
+
+               ee=1+(l0*t(h)*p0*
+     &         (a+bb*exp(-dd*rfx*t0*p(h)/(l0*t(h)*p0))))
+     s         /(rfx*t0*p(h))
+
+* calcul du nombre de Stockes corrige
+
+               sto=sto*ee
+
+               if (sto .le. 1.2) goto 9
+
+               if (sto .ge. 600.) then 
+                 ccol=1.
+                 goto 8
+               endif
+
+*  recherche du coefficient de collection
+
+               do 3 i=1,37
+                 if (sto .gt. st(i)) then
+                   goto 3
+                 endif
+                 if (sto .eq. st(i)) then
+                   ccol=ef(i+1)
+                 else
+                   ccol=ef(i)
+                 endif
+                 goto 8
+3              continue
+
+*  calcul du coefficient de coalescence
+
+8              kco=pi*(rfb+rfx)**2*ccol*abs(vb-vx)
+
+9              continue
+
+**  CORRECTION ELECTRICITE *******************************
+**  ------------------------******************************
+
+               yy=1.d0*ne**2*r_e(x)*r_e(b)*qe**2
+     &         /(1.d0*kbz*t(h)*(r_e(b)+r_e(x))*4*pi*epso)
+
+
+               corelec=0.
+               if (yy.lt.50.) corelec=yy/(exp(yy)-1.)
+               if (yy.le.1.e-3)  corelec=1.
+
+               k(h,b,x)=(kcg+kco)*corelec
+               k(h,x,b)=k(h,b,x)
+ 
+
+1        continue
+         return
+         end
+
+*______________________________________________________________________
+
+         real function lambda(j,indic)
+*
+*------------------------------------------------------------------*
+*  fonction calculant le libre parcours moyen des molecules        *
+*  atmospheriques( rayon =ra) se trouvant dans la couche no j.     *
+*  pour indic=0  ...... la particule se trouve a la frontiere entre*
+*                        les couches j et j-1                      *
+*  pour indic=1  ...... la particule se trouve au milieu de la     *
+*                         la couche j                              *
+*------------------------------------------------------------------*
+*
+* declaration des blocs communs
+*------------------------------
+         IMPLICIT NONE
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+
+* declaration des variables communes
+* ----------------------------------
+
+         integer i,j
+
+*  declaration des variables internes
+*  ----------------------------------
+
+         integer indic
+         real pp,ra
+
+         ra=1.75e-10
+
+* traitement
+* ----------
+
+         if (indic.eq.0) then
+           pp=pb(j)
+         else
+           if (indic.ne.1) then
+             print*,'erreur argument fonction lambda'
+             return
+           endif
+           pp=p(j)
+         endif
+
+         lambda=kbz*t(j)/(4*sqrt(2.)*pi*(ra**2)*pp)
+         end
+
+*******************************************************************************
+
+         real function knu(j,k,indic)
+*
+*--------------------------------------------------------------*
+*  fonction calculant le nombre de knudsen d'une particule     *
+*  d'aerosol de rayon r_e(k) se trouvant dans la couche no j   *
+*  indic ......  idem function lambda                          *
+*--------------------------------------------------------------*
+*
+* declaration des blocs communs
+*------------------------------
+         IMPLICIT NONE
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+
+*  declaration des variables internes
+*  ----------------------------------
+
+         integer indic,j,k
+         real lambda,rfk
+
+* traitement
+* ----------
+
+         if (indic.ne.0 .and.indic.ne.1) then
+           print*,'erreur argument fonction knu'
+           return
+         endif
+
+         rfk=(r_e(k)**(3./df(k)))*((rf(k))**(1.-3./df(k)))
+         knu=lambda(j,indic)/rfk
+         end
+
+*****************************************************************************
+
+         real function nud(j,indic)
+*
+*--------------------------------------------------------------*
+*  fonction calculant la viscosite dynamique (en USI) de l'air *
+*  d'apres la formule de Sutherlant a l'altitude j             *
+*  indic  ......... idem fonction lambda                       *
+*--------------------------------------------------------------*
+*
+         IMPLICIT NONE
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+
+
+         integer indic,j
+         real nud0,c,tt
+*
+         nud0=1.74e-5
+         c=109.
+ 
+         if(indic.ne.0.and.indic.ne.1) then
+           print*,'erreur argument fonction nud'
+           return
+         endif
+ 
+         if(indic.eq.0) tt=tb(j)
+         if (indic.eq.1) tt=t(j)
+ 
+         nud=nud0*sqrt(tt/293)*(1+c/293)/(1+c/tt)
+         end
+
+****************************************************************************
+
+         real function vitesse(j,k,indic)
+*
+*-----------------------------------------------------------------*
+*   fonction calculant la vitesse de chute d'une particule de rayon*
+*   k se trouvant a l'altitude j  suivant la valeur du nombre de   *
+*    Knudsen                                                       *
+*   indic ....... idem function lambda                             *
+*-----------------------------------------------------------------*
+*
+*  declaration des blocs communs
+*------------------------------
+         IMPLICIT NONE
+#include  "dimensions.h"
+#include  "microtab.h"
+#include  "varmuphy.h"
+
+*   declaration des variables internes
+*   ----------------------------------
+
+         integer indic,j,k
+         real w,g,m,a0,zz,nud,knud,tt,rhoh
+         real rbis, rfk,vb,zbx
+         real akncx,knu
+
+*   traitement
+*   ----------
+
+         if (indic.ne.0.and.indic.ne.1) then
+           print*,'erreur argument fonction vitesse'
+           return
+         endif
+
+         if(indic.eq.0) then
+           zz=z(j)+dz(j)/2.
+           tt=tb(j)
+           rhoh=rhob(j)
+         endif
+         if(indic.eq.1) then
+           zz=z(j)
+           tt=t(j)
+           rhoh=rho(j)
+         endif
+
+         g=g0*(rtit/(rtit+zz))**2
+         a0=0.74
+         m=(ach4(j)*mch4+aar(j)*mar+an2(j)*mn2)/nav
+         knud=knu(j,k,indic)
+
+
+         rfk=(r_e(k)**(3./df(k)))*((rf(k))**(1.-3./df(k)))
+c        rfk=r_e(7)
+
+
+          w=2./9.*rfk**(df(k)-1.)*rf(k)**(3.-df(k))*g*rhol/nud(j,indic)
+
+         w=w*(1+1.2517*knud+0.4*knud*exp(-1.1/knud))
+
+
+c        if (p(j).lt.500..and.k.eq.nrad) then
+c           w=0.
+c        endif
+
+         vitesse=w
+
+         end
+***********************************************************************
+
+         real function kd(h)
+*
+*--------------------------------------------------------------------*
+*   cette fonction calcule le coefficient du terme de 'eddy diffusion'*
+*   a l altitude j						     *
+*--------------------------------------------------------------------*
+*
+         IMPLICIT NONE
+#include  "dimensions.h"
+#include  "microtab.h"
+#include  "varmuphy.h"
+
+         real zbx
+
+         integer h
+
+         zbx=z(h)+dz(h)/2.
+         if(zbx.le.42000.) then
+           kd=1.64e+12*(pb(h)/(kbz*tb(h)))**(-1./2.)
+           kd=4.
+         else
+           kd=0.0*kd
+           kd=1.64e+12*(pb(h)/(kbz*tb(h)))**(-1./2.)
+         endif
+
+         if(zbx.le.50000.) then
+           kd=1.64e+12*(pb(h)/(kbz*tb(h)))**(-1./2.)
+         endif
+
+         kd=0.0*kd
+
+         return
+         end
+
+
+*____________________________________________________________________________
+
+         subroutine init
+*
+*--------------------------------------------------------------------*
+*   cette routine effectue  :                                         *
+*                1) interpolation a partir des donnees initiales des  *
+*                    valeurs de p,t,rho,ach4,aar,an2  sur la grille   *
+*                2) initialisation des constantes (common/phys/)      *
+*                3) initialisation des variables temporelles (common  *
+*                     /temps/)                                        *
+*                4) definition des grilles en rayon et verticale      *
+*                5)  initialisation de c(z,r,t) avec les donnees du   *
+*                      fichier unit=1                                 *
+*                                                                     *
+*   les donnees sont des valeurs caracterisques de l'atmosphere de    *
+*     TITAN  ( voir Lelouch and co )                                  *
+*--------------------------------------------------------------------*
+
+*  declaration des blocs communs
+*------------------------------
+         use dimphy
+         IMPLICIT NONE
+#include  "dimensions.h"
+#include  "microtab.h"
+#include  "varmuphy.h"
+
+
+         common/ctps/li,lf,dt
+         common/con/c
+
+*  declaration des variables communes
+*  ----------------------------------
+
+         real c(nz,nrad,2)
+         integer li,lf
+         integer i,ii
+         real dt
+
+*  declaration des variables internes
+*  ----------------------------------
+
+         integer nzd
+         parameter (nzd=254)
+         integer limsup,liminf,j1,j2
+         real zd(nzd),ach4d(nzd),rap
+         real m
+
+
+*  initialisation des variables temporelles
+*  ----------------------------------------
+
+         li=1
+         lf=2
+
+
+*  interpolation de xch4,xar et xn2 sur la grille
+*  ----------------------------------------------
+
+*  donnees initiales (Lellouch et al,87) 
+*  ------------------------------------- 
+
+c        print*,'****** init'
+         do 1 i=1,168
+           zd(i)=(1000.-5*(i-1))*1000.
+1        continue
+         do 2 i=1,78
+           zd(168+i)=(160.-2*(i-1))*1000.
+2        continue
+         do 3 i=1,4
+           zd(246+i)=(5.-(i-1))*1000.
+3        continue
+         do 4 i=1,4
+           zd(250+i)=(1.5-(i-1)*0.5)*1000.
+4        continue
+
+         data (ach4d(i),i=1,168)/168*1.5e-2/
+         data (ach4d(i),i=169,254)/63*1.5e-2,1.6e-2,1.8e-2,1.8e-2,
+     &   1.9e-2,2.e-2,2.1e-2,2.3e-2,2.5e-2,2.8e-2,3.1e-2,3.6e-2,
+     &   4.1e-2,4.7e-2,5.7e-2,6.7e-2,7.5e-2,7*8.e-2/
+
+         liminf=0
+         limsup=0
+
+*  interpolation des taux de melange de ch4,ar,n2  
+*-----------------------------------------------   
+
+!        do 20 j1=1,nz
+!           do 21 j2=1,nzd
+!               if( zd(j2).le.z(j1)) goto 22
+!21	    continue
+!22         liminf=j2
+
+          do 20 j1=1,nz
+             do 21 j2=1,nzd
+                 if( zd(j2).le.z(j1)) goto 22
+  21         continue
+  22         if (j2.ge.254) j2=254
+             liminf = j2
+
+          if (zd(liminf).eq.z(j1) )then
+            ach4(j1)=ach4d(liminf)
+            goto 20
+          endif
+          if (j2.ne.1) then
+            limsup=j2-1
+          else
+            limsup=j2
+          endif
+
+          if (limsup.eq.liminf) then
+            ach4(j1)=ach4(limsup)
+          else
+            ach4(j1)=ach4d(liminf)-(ach4d(limsup)-ach4d(liminf))/
+     s       (zd(limsup)-zd(liminf))*(zd(liminf)-z(j1))
+          endif
+20      continue
+
+*   rap= aar/an2  cst sur l'altitude
+
+         rap=0.191
+         do 23 i=1,nz
+           an2(i)=(1.-ach4(i))/(1.+rap)
+           aar(i)=rap*an2(i)
+23       continue
+
+         do 24 i=1,nz
+           m=ach4(i)*mch4+an2(i)*mn2+aar(i)*mar
+           rho(i)=p(i)*m/(rgp*t(i))
+24       continue
+
+         do 34 i=1,nz
+           m=ach4(i)*mch4+an2(i)*mn2+aar(i)*mar
+           rhob(i)=pb(i)*m/(rgp*tb(i))
+c          print*,pb(i),m,rgp,tb(i),rhob(i),rho(i)
+34       continue
+
+*  fin d'interpolation des taux de melange
+*----------------------------------------  
+
+c        print*,'**** fin init'
+540      continue
+         return
+
+500       print*,'erreur lecture initialisation de c...erreur=',ii
+          stop
+
+        end
+
+*____________________________________________________________________________
+
+         subroutine pertpro(h,a,l_,pr_)
+
+*****************************************************************************
+*                                                                           *
+*  ce programme permet le calcul du terme de production (pr) et de perte (l)*
+*  pour le phenomene de coagulation                                         *
+*  dans le a ieme intervalle de rayon a une altitude h                      *
+*****************************************************************************
+
+*  declaration des blocs communs
+*------------------------------
+         use dimphy
+         IMPLICIT NONE
+#include  "dimensions.h"
+#include  "microtab.h"
+#include  "varmuphy.h"
+
+
+         common/ctps/li,lf,dt
+         common/con/c
+         common/coag/k
+
+*  declaration des variables
+*  --------------------------
+
+         integer li,lf
+         real dt
+         real c(nz,nrad,2),k(nz,nrad,nrad)
+
+*  declaration des variables propres au ss-programme
+*  -------------------------------------------------
+
+         integer h,b,a,x,i
+         real*8 pr,ss,s,l
+         real pr_,l_,vol,del
+
+*  traitement
+*  -----------
+
+*   production
+*+++++++++++++
+         s=0.d0
+         ss=0.d0
+         pr=0.
+
+         if (a .eq. 1) goto 2  
+         b=a-1
+
+         if (c(h,b,lf) .eq. 0 .and. c(h,b,li) .eq. 0) goto 2
+  
+         do 1 i=1,b
+
+         if(c(h,i,li) .eq. 0 .and. c(h,i,lf) .eq. 0) goto 1
+     
+         if (i .ne. b)del=1.
+         if (i .eq. b) del=.5
+
+         s=(v_e(i)*1.d0)*del*(k(h,b,i)*1.d0)*(c(h,i,li)*1.d0)+s
+         ss=(v_e(i)*1.d0)*del*(k(h,b,i)*1.d0)*(c(h,i,lf)*1.d0)+ss
+
+c        if (a.eq.2) print*,'SS>',v_e(i),k(h,b,i),c(h,b,lf)
+c        if (a.eq.2) print*,'SS>',del*v_e(i)*k(h,b,i)*c(h,b,lf)
+
+
+1        continue
+
+*   calcul du terme de production
+
+          pr=(c(h,b,lf)*s/(vrat_e-1.)+c(h,b,li)*ss)/v_e(a)
+c         if (a.eq.2) print*,'PR>',s,ss,c(h,b,lf),v_e(a)
+
+2         continue
+
+
+*   perte
+*-  - - - -
+
+          l=0
+
+
+*     condition limite : pas de perte dans le dernier intervalle
+
+         if (a .eq. nrad) goto 9
+
+         do 10 x=1,nrad
+
+         if (c(h,x,li) .eq. 0) goto 10
+
+         if (a .lt. x) vol=1.
+         if (a .eq. x) vol=.5*vrat_e/(vrat_e-1)
+         if (a .gt. x) vol=v_e(x)/(v_e(a)*(vrat_e-1))
+
+         l=l+k(h,a,x)*c(h,x,li)*vol*1.d0
+
+      
+10       continue
+9        continue
+
+#ifdef  CRAY
+         l_=l
+         pr_=pr
+#else
+         l_=sngl(l)
+         pr_=sngl(pr)
+#endif
+c        l_=sngl(l)
+c        pr_=sngl(pr)
+c          if (a.eq.2) print*,'pr_,l_',h,a,pr_,l_
+c          if (a.eq.2) print*,'-----------------------'
+c          if (a.eq.2) STOP
+
+
+
+         return
+
+         end
+
+*_____________________________________________________________________________
+
+         subroutine production(ihor)
+*
+*--------------------------------------------------------------------*
+*   routine calculant le terme de production des molecules organiques *
+*   composant les aerosols . rini= rayon des aerosols initiaux        *
+*--------------------------------------------------------------------*
+*
+         use dimphy
+         IMPLICIT NONE
+#include  "dimensions.h"
+#include  "microtab.h"
+#include  "varmuphy.h"
+#include  "clesphys.h"
+
+c#include  "aerprod.h"
+
+
+         integer ndz,i,ihor,k,k1
+         real c(nz,nrad,2)
+         integer li,lf
+         real dt
+         real zprod,zy,c0,ctot,prod,rini,rfron
+         real xsaison,p0
+         common/ctps/li,lf,dt
+         common /con/c
+         common/effets/xsaison
+
+! Pressure level of aerosol production
+          p0=p_prodaer
+
+          do i=1,nz-1
+           if (pb(i).lt.p0.and.pb(i+1).gt.p0) zprod=(z(i)+z(i+1))/2.
+          enddo
+
+         ctot=3.5e-13*tx ! ATTENTION, ??COHERENT AVEC INITPAR??
+         ctot=ctot*xsaison  ! 
+
+c        z0=385.e+3
+         zy=20.e+3
+         rini=1.3e-9
+         rini=r_e(1)   
+         ndz=50
+*
+         do 10 i=1,nrad 
+           if(rini.lt.r_e(i)) goto 100
+10       continue
+100      continue
+         if (i.eq.1) then
+           rini=r_e(1)
+         else
+           rfron=(r_e(i)+r_e(i-1))/2
+           if (rini .lt.rfron) then 
+             rini=r_e(i-1)
+             i=i-1
+           else
+             rini=r_e(i)
+           endif
+         endif
+*
+         c0=ctot/(sqrt(2.*pi)*zy)
+         c0=c0*3./(4.*pi*rhol*rini**3)
+*
+         do 20 k=nztop,nz
+         prod=0.
+         do 201 k1=1,ndz
+           prod=prod+c0*exp(-0.5*(((z(k)+dz(k)/2.-k1*dz(k)/(2.*ndz)
+     s     -zprod)/zy)**2))*dt/ndz
+201      continue
+
+          if (prod .le. 1) prod=0.
+            c(k,i,lf)=c(k,i,lf)+prod
+20       continue
+
+!        do 30 k=nztop,nz
+!        c(k,i,lf)=c(k,i,lf)+prodaer(ihor,nz-k+1,1)
+!     & *3./(4.*pi*rhol*rini**3)
+!30      continue
+
+         return
+         end
+
+*-------------------------------------------------------------------*
+
+
+
+        subroutine sedif(dice3)
+*
+*------------------------------------------------------------------*
+*   cette routine calcule l'evolution de la fonction de distribution*
+*   c(z,r,t) pour les phenomenes de sedimentation et de diffusion   *
+*------------------------------------------------------------------*
+*
+*
+*  declaration des blocs communs
+*------------------------------
+         use dimphy
+         IMPLICIT NONE
+#include  "dimensions.h"
+#include  "microtab.h"
+#include  "varmuphy.h"
+
+         common/ctps/li,lf,dt
+         common/con/c
+
+*  declaration des variables communes
+*  ----------------------------------
+
+         integer li,lf
+         integer i,j,k,nb
+         real dt
+         real c(nz,nrad,2),dice3,bilan4,bilan14
+
+*  declaration des variables internes
+*  ----------------------------------
+
+         real w,w1,dzbX,dc
+         double precision sigma,theta,hc,l,rap,cmp,wp 
+         double precision fs(nz+1),ft(nz+1)
+         real as(nz),bs(nz),cs(nz),ds(nz)
+         double precision asi(nztop:nz),bsi(nztop:nz),
+     &                    csi(nztop:nz)
+         double precision dsi(nztop:nz),xsol(nztop:nz)
+         real vitesse,kd
+
+         external dtridgl
+*  resolution
+*------------
+
+            
+            bilan4=0.
+            do  k=1,nrad
+            do  j=nztop,nz
+              bilan4=bilan4+c(j,k,li)*dzb(j)*
+     &        4./3.*pi*rf(k)**3.*vrat_e**(k-imono)
+            enddo
+            enddo
+
+
+            do 10 k=1,nrad  
+            do 20 j=nztop,nz
+
+            if (j.eq.1) goto 20
+
+*  calcul de la vitesse corrigee
+
+              dzbX=(dz(j)+dz(j-1))/2.
+              w=-1*vitesse(j,k,0)
+              if (kd(j).ne.0.) then
+                theta=0.5*(w*dzbX/kd(j)+log(rho(j-1)/rho(j)))
+                if (theta.ne.0) then
+                  sigma=1./dtanh(theta)-1./theta
+                else
+                  sigma=1.
+                endif
+              else
+                sigma=1.
+              endif
+              if(c(j,k,li).eq.0.) then
+                rap=10.
+              else
+                rap=c(j-1,k,li)/c(j,k,li)
+                if( rap.gt.10.) rap=10.
+                if( rap.lt.0.1) rap=0.1
+              endif
+              if (rap.gt.0.9 .and. rap.lt.1.1) then
+                w1=w
+              else
+                if(w.ne.0) then
+                  hc=dzbX/dlog(rap)
+                  l=dzbX/(w*dt)*(dexp(-w*dt/hc)-1.)/(1.-rap)
+                  wp=w*1.d0
+                  cmp=dlog(-wp)+abs(sigma)*dlog(l)
+                  if (cmp.gt.38) then
+                    goto 20
+                  endif
+                  w1=-dexp(cmp)
+
+                else
+                  w1=0.
+                endif
+              endif
+
+c               if(w1.ge.0. .or. w1.le.0.) then 
+c                continue
+c               else
+c                print*,j,k,w1,hc,dzbx,rap,dlog(rap),' w1'
+c               endif
+
+*   calcul des flux aux interfaces
+
+
+             if (kd(j).ne.0.) then
+               if (theta.ne.0.) then
+                 ft(j)=(w1+log(rho(j-1)/rho(j))*kd(j)/dzbX)/(dexp(2.*
+     s           theta)-1.)
+                 fs(j)=ft(j)*dexp(2.*theta)
+               else
+                 ft(j)=kd(j)/dzbX
+                 fs(j)=kd(j)/dzbX
+               endif
+            else
+              if (w1.lt.0.)then
+                ft(j)=-w1
+                fs(j)=0.
+              else
+                ft(j)=0.
+                fs(j)=w1
+              endif
+            endif
+
+20          continue
+
+*  conditions aux limites pour les flux aux interfaces
+
+            fs(1)=0.
+            ft(1)=0.
+            fs(nz+1)=0.
+            ft(nz+1)=-w1
+
+*  calcul des coefficients de l'equation discrete
+
+            do 21 j=nztop,nz
+              as(j)=-dz(j)/dt
+              bs(j)=-ft(j)
+              cs(j)=ft(j+1)+fs(j)-dz(j)/dt
+              ds(j)=-fs(j+1)
+
+              if ( cs(j).gt.0) goto 100
+21         continue
+
+*  cas explicite (mu=0) : calcul de la fonction c(z,r,t+1)
+
+           do 22 j=nztop,nz-1
+
+           if (j.eq.nztop) then
+             dc=(cs(nztop)*c(nztop,k,li)+ds(nztop)
+     &                    *c(nztop+1,k,li))/as(nztop)
+             c(nztop,k,lf)=dc
+             goto 22
+           endif
+
+           dc=(bs(j)*c(j-1,k,li)+cs(j)*c(j,k,li)+ds(j)*c(j+1,k,li))
+     s         /as(j)
+           c(j,k,lf)=dc
+
+
+22          continue
+
+            dc=(bs(nz)*c(nz-1,k,li)+cs(nz)*c(nz,k,li))/as(nz)
+            c(nz,k,lf)=dc
+
+           if (nztop.ne.1) then
+           do 32 j=1,nztop-1
+             c(j,k,lf)=c(j,k,li)
+32         continue
+           endif
+
+           goto 10
+
+100        continue
+
+*  cas implicite (mu=1) : calcul de la fonction c(z,r,t+1)
+
+          do 101 j=nztop,nz
+            asi(j)=ft(j)
+            bsi(j)=-(ft(j+1)+fs(j)+dz(j)/dt)
+            csi(j)=fs(j+1)
+            dsi(j)=-dz(j)/dt*c(j,k,li)
+            xsol(j)=0.
+101       continue
+
+*  inversion de la matrice tridiagonale 
+
+         nb=nz-nztop+1
+
+         call dtridgl(nb,asi,bsi,csi,dsi,xsol) 
+
+
+         do 102 j=nztop,nz
+          c(j,k,lf)=xsol(j)
+102      continue
+
+         if (nztop.ne.1) then
+           do 110 j=1,nztop-1
+           c(j,k,lf)=c(j,k,li)
+110        continue
+         endif
+
+
+
+10       continue
+
+         bilan14=0.
+         do  k=1,nrad
+         do  j=nztop,nz
+           bilan14=bilan14+c(j,k,lf)*dzb(j)*
+     &     4./3.*pi*rf(k)**3.*vrat_e**(k-imono)
+         enddo
+         enddo
+
+
+         dice3=(bilan14-bilan4)*rhol
+
+
+         return
+
+          end
+
Index: trunk/LMDZ.TITAN/libf/phytitan/cfffv11.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/cfffv11.F	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/cfffv11.F	(revision 175)
@@ -0,0 +1,1117 @@
+         subroutine cfffv11(lambda,xn,xk,rad,DFS,NB,fsca,fext,fabs,fg)
+*
+*   NEW VERSION MARCH, 31, 1999.
+*   WITHOUT MAXWELL-GARNETT APPROACH FOR IM{M} > 0.1
+*   
+ 
+ 
+       parameter (nang=91)
+
+       complex mtest,refrel,s1(2000),s2(2000)
+       real rad,lambda,s11(2000),theta(10000)
+       real s110u(2000),s111u(2000)
+       real s110d(2000),s111d(2000)
+       real pol(2000),pp(2,2000),strS(2000)
+       real NB
+       real xxn
+
+* COMMON WITH INTMIE
+
+       common/angle11/theta  
+
+* COMMON WITH CORRINT11
+
+       common/pack1/cjup1,cju,cjup1_,cju_,xrap,xechj,xechjp1
+       common/pack2/cjdp1,cjd,cjdp1_,cjd_,xku,xkd,jindex
+       common/pack3/xexp5,xexp6
+
+* COMMON WITH FFFV11
+
+       DATA IND /0/
+
+
+       if(nang*2.gt.2000) 
+     & stop 'INCREASE THE SIZE OF THE ARRAYS IN CFFFV11' 
+
+c      refrel=(xn,xk)
+       refrel=cmplx(xn,xk)
+       nindex=int(xn*100.)                
+       x=2.*3.14159265*rad/lambda
+       dang=1.570796327/dfloat(nang-1)
+       pi=3.14159265
+       NC=20 
+          DF=1.99999
+          alpha=1.1
+          alphaS=(1.4-1.1)/(2.5-2.)*DFS-.1  !APPROXIMATED!
+                                            !EXACT FOR D=2 AND 2.5!
+
+******************************************************************
+* STEP # 1
+******************************************************************
+* CALL THE ROUTINE THAT GIVE THE SCALING FACTOR'S PSI_s AND PSI_e
+* FOR EACH BOUND OF THE INTERVAL  nX(j) < n*X < nX(j+1)  AND   
+* xku < xk < xkd. 
+* THESE FACTORS ARE GIVEN ASSUMING : N=20, DF=2 AND KNOWING n
+*
+* NB: HERE PSI ARE NOTED  cju,cjd,cjup1,cjdp1.....
+******************************************************************
+
+          call corrint11(x,xn,xk,NC)
+
+
+******************************************************************
+* STEP # 2
+******************************************************************
+* FOR EACH OF THE FOUR "POINTS" (nX,k), COMPUTE THE MIE CROSS-SECTIONS
+* AND PHASE FUNCTION FOR A SPHERE AS ONE MONOMER. 
+* DERIVE, THANKS TO THE PSI, THE MONOMER CROSS-SECTIONS
+* COMPUTE ALSO THE ACTUAL MIE CROSS SECTION (I.E FOR THE ACTUAL 
+* VALUES OF n,X and k)
+******************************************************************
+
+* STEP #2.1
+******************************************
+* if Mie & monomer in Rayleigh scattering: 
+******************************************
+* the phase function shape does not depends
+* on x neither the PSI's: for each values of
+* k, only one computation is to be done 
+*****************************************
+
+       IF (x*xn.le.0.085) THEN 
+
+
+* pour k=xku
+*            # x=xech(j)
+*            # x=xech(j+1)
+
+c      refrel=(xn,xku)
+       refrel=cmplx(xn,xku)
+
+       call intmie(x,refrel,nang,s1,s2,qext_,qsca_)
+        qsca1u=alog10(qsca_*400.)
+        qext1u=alog10(qext_*20.)
+        qsca2u=alog10(qsca_*400.)
+        qext2u=alog10(qext_*20.)
+
+* pour k=xkd
+*            # x=xech(j)
+*            # x=xech(j+1)
+
+c      refrel=(xn,xkd)
+       refrel=cmplx(xn,xkd)
+
+       call intmie(x,refrel,nang,s1,s2,qext_,qsca_)
+        qsca1d=alog10(qsca_*400.)
+        qext1d=alog10(qext_*20.)
+        qsca2d=alog10(qsca_*400.)
+        qext2d=alog10(qext_*20.)
+
+        xrap=0.
+
+* Mie exact
+*
+
+c      refrel=(xn,xk)
+       refrel=cmplx(xn,xk)
+
+       call intmie(x,refrel,nang,s1,s2,qext_,qsca_)
+        do j=1,2*nang-1
+        s11(j)=cabs(s2(j))*cabs(s2(j))+cabs(s1(j))*cabs(s1(j))
+        s11(j)=s11(j)/(2.*pi*x**2.*qsca_)
+        enddo
+
+
+       ELSE
+
+* STEP #2.2
+************************************************
+* if Mie & monomer in the range X about 1 to 5 *
+************************************************
+
+* pour k=xkd
+*            # x=xech(j)
+*            # x=xech(j+1)
+
+
+        qsca1d=alog10(cjd)
+        qext1d=alog10(cjd_)
+
+        qsca2d=alog10(cjdp1)
+        qext2d=alog10(cjdp1_)
+
+* pour k=xku
+*            # x=xech(j)
+*            # x=xech(j+1)
+
+
+        qsca1u=alog10(cju)
+        qext1u=alog10(cju_)
+
+        qsca2u=alog10(cjup1)
+        qext2u=alog10(cjup1_)
+ 
+
+* Mie exact:
+*  
+
+c      refrel=(xn,xk)
+       refrel=cmplx(xn,xk)
+       call intmie(x,refrel,nang,s1,s2,qext_,qsca_)
+        do j=1,2*nang-1
+        s11(j)=cabs(s2(j))*cabs(s2(j))+cabs(s1(j))*cabs(s1(j))
+        enddo
+
+       ENDIF
+
+* THIS IS MIE:
+
+          qabs_ =qext_ -qsca_ 
+
+* THIS IS FRACTAL 20 MONOMERS
+* d
+        qabs2d=alog10(10.**qext2d-10.**qsca2d)
+        qabs1d=alog10(10.**qext1d-10.**qsca1d)
+* u
+        qabs2u=alog10(10.**qext2u-10.**qsca2u)
+        qabs1u=alog10(10.**qext1u-10.**qsca1u)
+
+ 
+***********************************************************************
+*       QUICK FIX FOR NEGATIVE ABSORPTION WHEN APPEARS [OUT OF n RANGE]
+**********************************************************************
+        GOTO 505
+* This avoid a "crash" if one among four of the qsca is larger than qext
+* Averaging the w=qsca/qext, and applied to the "wrong" qsca
+* NOTE this occurs only if real refractive index > 2
+
+        w1=10.**qsca2d/10.**qext2d 
+        w2=10.**qsca1d/10.**qext1d 
+        w3=10.**qsca2u/10.**qext2u 
+        w4=10.**qsca1u/10.**qext1u 
+
+
+        IF(10.**qext2d.lt.10.**qsca2d) 
+     &   qsca2d=alog10((10.**qext2d)*(w2+w3+w4)/3.)
+        IF(10.**qext1d.lt.10.**qsca1d)
+     &   qsca1d=alog10((10.**qext1d)*(w1+w3+w4)/3.)
+        IF(10.**qext2u.lt.10.**qsca2u)
+     &   qsca2u=alog10((10.**qext2u)*(w2+w1+w4)/3.)
+        IF(10.**qext1u.lt.10.**qsca1u)
+     &   qsca1u=alog10((10.**qext1u)*(w2+w3+w1)/3.)
+
+        qabs2d=alog10(10.**qext2d-10.**qsca2d)
+        qabs1d=alog10(10.**qext1d-10.**qsca1d)
+        qabs2u=alog10(10.**qext2u-10.**qsca2u)
+        qabs1u=alog10(10.**qext1u-10.**qsca1u)
+ 505    continue
+
+************************************************
+* STEP # 5
+************************************************
+* INTERPOLATION OVER THE TWO VARIABLES n*X AND K 
+************************************************
+
+* X*n VARIABLE/ interpolation log-log. 
+
+          sextu=((qext2u-qext1u)*xrap+qext1u)
+          sscau=((qsca2u-qsca1u)*xrap+qsca1u)
+          sabsu=((qabs2u-qabs1u)*xrap+qabs1u)
+          sextd=((qext2d-qext1d)*xrap+qext1d)
+          sscad=((qsca2d-qsca1d)*xrap+qsca1d)
+          sabsd=((qabs2d-qabs1d)*xrap+qabs1d)
+
+* K VARIABLE/ interpolation log-log
+          xki=xk 
+          if (xk.lt.1.e-2) xki=1.e-2
+          if (xk.gt.1.) xki=1.
+          rki=-alog10(xki)
+          rku=-alog10(xku)
+          rkd=-alog10(xkd)
+          ssca=(sscau-sscad)*(rki-rkd)+sscad
+          sext=(sextu-sextd)*(rki-rkd)+sextd
+          sabs=(sabsu-sabsd)*(rki-rkd)+sabsd
+
+          sscap=(sscau-sscad)*(rki-rkd)+sscad
+          sextp=(sextu-sextd)*(rki-rkd)+sextd
+          sabsp=(sabsu-sabsd)*(rki-rkd)+sabsd
+
+* storage Mie down and up
+c         refrel=(xn,1.)
+          refrel=cmplx(xn,1.)
+          call intmie(x,refrel,nang,s1,s2,qextmd_,qscamd_)
+          qabsmd_=qextmd_-qscamd_
+
+c         refrel=(xn,.1)
+          refrel=cmplx(xn,.1)
+          call intmie(x,refrel,nang,s1,s2,qextmu_,qscamu_)
+          qabsmu_=qextmu_-qscamu_
+
+******************************************************
+* STEP # 5.1 :   
+******************************************************
+* SPECIAL CASE FOR LARGE k (>.1) : MAXWELL GARNETT
+******************************************************
+
+
+          if (xk.gt.0.1) then         ! THIS CONCERNS THE LARGE IMAGINARY REFRACTIVE INDEXES
+
+*Prepare Maxwell Garnett approx. (see B&H) 
+*-----------------------------------------
+
+          xbulk=x*(NC*1.)**.3333333
+          xsphe=x*(NC*1.)**.5
+          frac=(xbulk/xsphe)**3.
+              xkff=xk*frac
+              xnff=1.+(xn-1.)*frac
+
+* For small x, aggregate scattering= N**2 monmer scatt.:
+* -----------------------------------------------------
+
+          mtest=cmplx(xn,xk)
+          call intmie(x,mtest,nang,s1,s2,qe,qs)
+          sscaR=alog10(qs*NC*(xsphe/x)**2.)
+
+ 
+*      For small x, aggregate abs. is proportionnal to N
+* -----------------------------------------------------
+          mtest=cmplx(xn,xk)
+          call intmie(x,mtest,nang,s1,s2,qe,qs)
+          sabsR=alog10((qe-qs)*20.)
+
+
+          endif 
+
+
+ 
+*****************************************************************
+*     FINALLY, WE GET THE VALUES FOR AN AGGREGATE OF 20 MONOMERS
+*          FOR THE ACTUAL X,k, AND n
+*****************************************************************
+
+
+         ssca=10.**ssca
+         sext=10.**sext
+         sabs=10.**sabs
+ 
+* Sharp cross over between Rayleigh 
+           xup=0.3             !            |<----------
+           xdo=0.3             !  --------->|
+
+          if (xk.gt.0.1) then       ! large imaginary refractive index
+
+              if (x*xn.ge.xup) then  ! large size parameter
+                 sext=sabs+ssca    
+                 scal1=(10.**sabsd)/qabsmd_
+                 scal2=(10.**sabsu)/qabsmu_
+                 scalx=(alog10(xk)+1.)*(scal1-scal2)+scal2
+                 sabs=qabs_*scalx
+                 ssca=sext-sabs
+               endif
+
+              if (x*xn.le.xdo) then  ! PURE RAYLEIGH
+                 sabs=10.**sabsR
+                 ssca=10.**sscaR 
+                 sext=sabs+ssca    
+              endif
+
+         
+          else
+
+                 sext=sabs+ssca   !self-consistent ext sca abs set
+
+          endif
+
+
+*****************************************************************
+* STEP # 6
+*****************************************************************
+* NOW, USE USE THE N-LAWS TO COMPUTE THE Q(N) FROM Q(N=20) AND
+* THE Q(MIE) [EQUATIONS (9) AND (10)].
+*****************************************************************
+
+         g0=0.
+         g1=0.
+         g2=0.
+
+       surf=rad**2.*3.1415926*1.e18
+
+
+* STEP # 6.1
+*****************************************************************
+* FIRST; COMPUTE THE STRUCTURE TERM THAT IS ONLY USED TO COMPUTE
+* THE ASYMETRY PARAMETER THAT DEPENDS ON THE SHAPE OF THE PHASE
+* FUNCTION.
+*****************************************************************
+
+
+       do 367 j=1,2*nang-1
+         z=sin(theta(j)/2.)
+         xx_=alphaS*x*(NB*1.)**(1./DFS)
+         call structure(NB,xx_,z,str,DFS)
+         if (z.eq.0.) str=(NB*1.)**2.
+         strS(j)=str
+  367   continue
+
+
+       do 365 j=1,2*nang-2,2
+
+        g1=2*dang/6*(s11(j)*sin(theta(j))*strS(j)
+     &              +s11(j+2)*sin(theta(j+2))*strS(j+2)
+     &            +4*s11(j+1)*sin(theta(j+1))*strS(j+1))
+     &                          *2*3.141592+g1
+
+        g2=2*dang/6*(s11(j)*sin(theta(j))*cos(theta(j))*strS(j)
+     &        +s11(j+2)*sin(theta(j+2))*cos(theta(j+2))*strS(j+2)
+     &      +4*s11(j+1)*sin(theta(j+1))*cos(theta(j+1))*strS(j+1))
+     &           *2.*3.141592+g2
+
+ 365    continue
+
+
+* STEP # 6.2
+*****************************************************************
+* USE THE EQUATIONS (10) AND (9)  FOR MEDIUM RANGE OR THE RAYLEIGH
+* RANGE. 
+*****************************************************************
+
+
+* 1: FOR MEDIUM X RANGE: 1< X < 10 to 50  [EQ 10]
+* 2: FOR VERY LARGE X RANGE:  X >> 50     [EQ 11]
+*    N^a LOG(N^b) IS REPLACED BY A PURE N^a LAW. THIS OCCURS
+*    WHEN N>50 FOR ABSORPTION AND WHEN N>25/x FOR SCATTERING,
+*    AND CORRESPOND TO THE GEOMETRIC RANGE. THE EXPONENT a IS
+*    SET BY EMPIRIC CONSIDERATIONS (SEE PAPER).
+
+* XEXP5 AND XEXP6 ARE THE EXPONENT FACTOR USED IN EQ 10
+* XEXP1 AND XEXP2 ARE THE EXPONENT FACTOR USED VERY LARGE BEHAVIOUR
+
+         xkf=1.
+         if (xk.le.1.e-2) xkf=xk/1.e-2
+
+
+        rho=(NC*1.)**xexp5
+        rho_=(NB*1.)**xexp5
+
+* EQ 10 RESULT FOR ABSORPTION:
+*-----------------------------
+
+        sabs1=(sabs*xkf-qabs_)/alog10(20.)*alog10(NB*1.)
+     &                        *rho_/rho+qabs_
+
+
+* NB: IF NB>NTA OR NB>NTS , EFFICIENCY FACTOR FOLLOW A POWER LAW
+*     BEHAVIOUR. ELSE, EQUATION 10 IS VALIDE.
+
+        NTA=50
+
+       if(NB.gt.NTA) then
+       rhox=(NTA*1.)**xexp5
+
+* COMPUTE sabs1 FOR NTA TO START THE POWER LAW:
+        sabs1=(sabs*xkf-qabs_)/alog10(20.)*alog10(NTA*1.)
+     &  *rhox/rho+qabs_
+
+* COMPUTE xexp1 EXPONENT FACTOR: 
+                        xexp1=.85
+        if(x*xn.lt.2.2) xexp1=(.85-.96)*1.42*(x*xn-1.5)+.96
+        if(x*xn.lt.1.5) xexp1=.96
+
+* COMPUTE sabs1 VALUE FOR LARGE X:
+        sabs1=sabs1*(NB*1./(NTA*1.))**xexp1
+       endif
+
+* HERE SABS1 MEDIUM RANGE IS KNOWN
+
+        rho=(NC*1.)**xexp6
+        rho_=(NB*1.)**xexp6
+
+
+* EQ 10 RESULT FOR SCATTERING:
+*-----------------------------
+
+        ssca1=(ssca-qsca_)/alog10(20.)*alog10(NB*1.)
+     &        *rho_/rho+qsca_
+
+        NTS=int((20./x)**(1./.65))
+
+* NB: IF NB>NTA OR NB>NTS , EFFICIENCY FACTOR FOLLOW A POWER LAW
+*     BEHAVIOUR. ELSE, EQUATION 10 IS VALIDE.
+
+       if(NB.gt.NTS) then
+        rhox=(NTS*1.)**xexp6
+
+* COMPUTE sabs1 FOR NTS TO START THE POWER LAW:
+        ssca1=(ssca-qsca_)/alog10(20.)*alog10(NTS*1.)
+     &  *rhox/rho+qsca_
+
+* COMPUTE xexp2 EXPONENT FACTOR: 
+                     xexp2=.95
+        if(x.lt.1.0) xexp2=(.95-1.1)*2*(x-.5)+1.1
+
+* COMPUTE sabs1 VALUE FOR LARGE X:
+        ssca1=ssca1*(NB*1./(NTS*1.))**xexp2 
+       endif
+
+* HERE SSCA1 MEDIUM RANGE IS KNOWN
+
+
+        sext1=ssca1+sabs1
+
+
+
+
+
+* 3: FOR THE RAYLEIGH RANGE [EQ 9]
+
+        ssca2=(alog10(ssca)-alog10(qsca_))/alog10(20.)
+     &            *alog10(NB*1.)+alog10(qsca_)
+        sext2=(alog10(sext)-alog10(qext_))/alog10(20.)
+     &            *alog10(NB*1.)+alog10(qext_)
+        sabs2=(alog10(sabs*xkf)-alog10(qabs_))/alog10(20.)
+     &            *alog10(NB*1.)+alog10(qabs_)
+
+
+
+************************************************
+* STEP # 7
+************************************************
+* THE CROSS OVER BETWEEN RAYLEYGH AND MEDIUM RANGE
+************************************************
+
+        rho_=(NB*1.)**.66666
+* 1< X < 50.
+        sext1=alog10(sext1/rho_)
+        ssca1=alog10(ssca1/rho_)
+        sabs1=alog10(sabs1/rho_)
+* RAYLEIGH
+        sext2=alog10((10.**sext2)/rho_)
+        ssca2=alog10((10.**ssca2)/rho_)
+        sabs2=alog10((10.**sabs2)/rho_)
+
+
+
+        
+
+
+* 7.1: SCATTERING AND EXTINCTION  + CROSS OVER
+************************************************
+
+
+* RAYLEIGH RANGE:
+            fsca=10.**(ssca2)
+            fext=10.**(sext2)
+            fg=g2/g1
+
+         xx=.5*alpha*x*(NB*1.)**.33333
+         xup=10.
+         xdo=.1 
+
+         f=alog10(xx/xdo)/alog10(xup/xdo)
+         g=1.-f
+
+
+* MEDIUM X
+        if (xx.le.xup.and.xx.ge.xdo) then
+           fsca=10.**(f*ssca1+g*ssca2)
+           fext=10.**(f*sext1+g*sext2)
+           fg=g2/g1
+        endif
+
+* LARGE X
+        if (xx.gt.xup) then
+           fsca=10.**(ssca1)
+           fext=10.**(sext1)
+           fg=g2/g1
+        endif
+
+* 7.2: ABSORPTION + CROSS OVER
+************************************************
+
+* RAYLEIGH RANGE
+
+         fabs=10.**(sabs2)
+
+         xx=.5*alpha*x*(NB*1.)**.5
+         f=alog10(xx/xdo)/alog10(xup/xdo)
+         g=1.-f
+
+* MEDIUM X
+        if (xx.le.xup.and.xx.ge.xdo) then
+           fabs=10.**(f*sabs1+g*sabs2)
+        endif
+
+* LARGE X
+        if (xx.gt.xup) then
+           fabs=10.**(sabs1)
+        endif
+
+         fext=fsca+fabs
+           
+
+***********************************************
+* STEP # 8
+***********************************************
+*   DISPLAY  THE RESULTS : PHASE FUNCTION OR 
+*  EFFICIENCY COEFFICIENTS 
+***********************************************
+
+         IF (IND.eq.1) THEN
+
+* 8.1:    CROSS SECTIONS  &  PHASE FUNCTION
+***********************************************
+
+         tot =0.
+         scoef=NB**(2./3.)*rad**2.*3.1415926
+
+        do 366 j=1,2*nang-1
+ 
+         pp(1,j)=theta(j)*180./3.1415926
+         pp(2,j)=s11(j)*2*3.1415936*strS(j)*1./g1
+ 366    continue
+* 
+        ELSE
+
+* 8.2:       EFFICIENCY COEFFICIENTS
+***********************************************
+
+       scoef=NB**(2./3.)*rad**2.*3.1415926  ! METERS^2
+        fsca=fsca*scoef
+        fext=fext*scoef
+        fabs=fabs*scoef
+
+c new fashion...
+
+        fabs=(qext_-qsca_)*NB/(NB*1.)**(2./3.)*scoef
+        fext=fsca+fabs
+ 
+
+        ENDIF
+
+        return
+       end
+
+c------------------------------------------------------------
+        subroutine intmie(x,refrel,nang,s1,s2,
+     &                     qext,qsca)
+**********************************************************
+* THIS ROUTINE COMES FROM BORHEN AND HUFFMAN BOOK:
+* "ABSORPTION AND SCATTERING OF LIGHT BY SMALL PARTICLES"
+*  WILEY INTERSCIENCE PUBLICATION, 1983
+**********************************************************
+       common/angle11/theta  
+      
+        real amu(10000),theta(10000),pi(10000)
+        real tau(10000),pi0(10000),pi1(10000)
+        complex d(300000),y,refrel,xi,xi0,xi1,an,bn,s1(20000),s2(20000)
+        complex s_(20000)
+        double precision psi0,psi1,psi,dn,dx
+       dx=x            !dx en double precision ....            
+       y=x*refrel
+  
+       xstop=x+4*x**.3333+2.
+       nstop=xstop
+       ymod=cabs(y)
+       nmx=amax1(xstop,ymod)+15
+c      print*,nmx,xstop,nstop,ymod
+       dang=1.570796327/dfloat(nang-1)
+         do 555 j=1,2*nang-1           
+         theta(j)=(dfloat(j)-1.)*dang
+ 555     amu(j)=cos(theta(j))
+c      d(nmx)=(0.,0.)  
+       d(nmx)=cmplx(0.,0.)  
+       nn=nmx-1
+          
+         do 120 n=1,nn
+         rn=nmx-n+1
+         d(nmx-n)=(rn/y)-(1./(d(nmx-n+1)+rn/y))
+ 120     continue
+  
+         do 666 j=1,nang
+         pi0(j)=0.       ! fonction de legendre 
+ 666     pi1(j)=1.
+   
+       nn=2*nang-1
+        
+         do 777 j=1,nn
+c        s_(j)=(0.,0.)
+c        s1(j)=(0.,0.)
+c777     s2(j)=(0.,0.)
+         s_(j)=cmplx(0.,0.)
+         s1(j)=cmplx(0.,0.)
+ 777     s2(j)=cmplx(0.,0.)
+       psi0=dcos(dx)      !initialisation des fonctions de Bessel
+       psi1=dsin(dx)
+       chi0=-sin(x)
+       chi1=cos(x)
+       apsi0=psi0        !psi en double prec. et apsi en simple
+       apsi1=psi1
+c      xi0=(apsi0,-chi0)
+c      xi1=(apsi1,-chi1)
+       xi0=cmplx(apsi0,-chi0)
+       xi1=cmplx(apsi1,-chi1)
+       qsca=0.
+       qsca_=0.
+       n=1
+c      *************debut de l'iteration sur n *************
+ 200   dn=n
+       rn=n
+       fn=(2.*rn+1.)/(rn*(rn+1.))
+      
+       psi=(2.*dn-1.)*psi1/dx-psi0     ! calcul des fct de Bessel  
+       chi=(2.*rn-1.)*chi1/x-chi0      ! relation recurrente a 2 niveaux
+       apsi=psi
+c      xi=(apsi,-chi)
+       xi=cmplx(apsi,-chi)
+       an=(d(n)/refrel+rn/x)*apsi-apsi1
+       an=an/((d(n)/refrel+rn/x)*xi-xi1)
+       bn=(refrel*d(n)+rn/x)*apsi-apsi1
+       bn=bn/((refrel*d(n)+rn/x)*xi-xi1)
+       qsca=qsca+(2*rn+1.)*(cabs(an)*cabs(an)+cabs(bn)*cabs(bn))
+  
+c     ***************debut de la boucle sur les angles******* 
+       do 789 j=1,nang
+       jj=2*nang-j
+          pi(j)=pi1(j)                           !
+          tau(j)=rn*amu(j)*pi(j)-(rn+1.)*pi0(j)  ! fonction de legendre
+          s1(j)=s1(j)+fn*(an*pi(j)+bn*tau(j))
+          s2(j)=s2(j)+fn*(an*tau(j)+bn*pi(j))
+          p=(-1)**(n-1)
+          t=(-1)**n
+       if (j.eq.jj) goto 789
+         s1(jj)=s1(jj)+fn*(an*pi(j)*p+bn*tau(j)*t)
+         s2(jj)=s2(jj)+fn*(an*tau(j)*t+bn*pi(j)*p)
+ 789   continue
+       psi0=psi1
+       psi1=psi
+       apsi1=psi1           ! double prec=simple
+       chi0=chi1
+       chi1=chi
+c      xi1=(apsi1,-chi1)
+       xi1=cmplx(apsi1,-chi1)
+       n=n+1
+       rn=n
+       do 999 j=1,nang
+        pi1(j)=((2.*rn-1.)/(rn-1.))*amu(j)*pi(j)
+        pi1(j)=pi1(j)-rn*pi0(j)/(rn-1.)
+ 999    pi0(j)=pi(j)
+       if (n-1-nstop) 200,300,300
+ 300   qsca=(2./(x*x))*qsca
+       qext=(4./(x*x))*real(s1(1))
+       qabs=qext-qsca
+       
+       
+       return
+       end
+ 
+    
+       subroutine corrint11(x,xn,xk,NB)
+      parameter (nech=28)
+      parameter (nex=6)
+      real xech(nech)
+      real A0(2*nech), B0(2*nech), C0(2*nech), D0(2*nech)
+      real A1(2*nech), B1(2*nech), C1(2*nech), D1(2*nech)
+      real A2(2*nech), B2(2*nech), C2(2*nech), D2(2*nech)
+      real A3(2*nech), B3(2*nech), C3(2*nech), D3(2*nech)
+      real x,xn,xk,correct,correct_
+      integer NB,ifirst
+      real ww1(nex),ww2(nex)
+      real xx1(nex),xx2(nex)
+      real yy1(nex),yy2(nex)
+      real zz1(nex),zz2(nex)
+      real xldo(nex)
+      real xexp5,xexp6
+       common/pack1/cjup1_,cju_,cjup1,cju,xrapl,xechj,xechjp1
+       common/pack2/cjdp1_,cjd_,cjdp1,cjd,xku,xkd,jindex
+       common/pack3/xexp5,xexp6
+*      * ATTENTION: ORDRE INVERSE DANS cfffpf, cfffcs,...  *
+      DATA xech/0.05,0.1,0.25,0.5,0.6,0.7,0.8,0.9,1.0,1.1,1.2,1.3,
+     & 1.4,1.5,1.75,2.0,2.25,2.5,2.75,3.0,3.25,3.5,3.75,4.0,4.25,
+     & 4.5,4.75,5.0/
+      DATA A0/ .1117E+00, .2284E+00, .4473E+00,-.3351E+00,-.7323E+00,
+     &        -.8070E+00,-.5968E+00,-.2956E+00, .1171E-01, .2515E+00,
+     &         .3607E+00, .3653E+00, .2658E+00, .1145E+00,-.1505E+00,
+     &         .1982E-01, .8496E-01,-.5869E-01,-.7623E-01,-.5410E-02,
+     &        -.2850E-01,-.5501E-01,-.5267E-01,-.2317E-01,-.3344E-01,
+     &        -.3936E-01,-.3094E-01,-.3099E-01,
+     &         .6136E-03, .7863E-02, .9823E-01, .6704E-01,-.8727E-01,
+     &        -.1741E+00,-.1402E+00,-.3270E-01, .1074E+00, .2397E+00,
+     &         .3254E+00, .3654E+00, .3495E+00, .2869E+00, .7161E-01,
+     &         .6914E-01, .1319E+00, .7578E-01, .2340E-01, .4031E-01,
+     &         .4202E-01, .2560E-01, .1679E-01, .2965E-01, .3108E-01,
+     &         .2983E-01, .3023E-01, .2988E-01/
+      DATA B0/-.5034E+00,-.1033E+01,-.2186E+01, .3670E+00, .2014E+01,
+     &         .2646E+01, .2279E+01, .1496E+01, .5713E+00,-.2137E+00,
+     &        -.6203E+00,-.7014E+00,-.4274E+00, .3641E-01, .8890E+00,
+     &         .3026E+00, .4121E-01, .4774E+00, .5016E+00, .2491E+00,
+     &         .3097E+00, .3754E+00, .3536E+00, .2500E+00, .2734E+00,
+     &         .2838E+00, .2453E+00, .2429E+00,
+     &        -.2493E-02,-.3224E-01,-.4251E+00,-.5115E+00, .7309E-01,
+     &         .5198E+00, .5940E+00, .3982E+00, .3812E-01,-.3514E+00,
+     &        -.6344E+00,-.7949E+00,-.7802E+00,-.6081E+00, .5837E-01,
+     &         .4640E-01,-.1963E+00,-.4932E-01, .9157E-01, .1454E-01,
+     &        -.6767E-02, .3216E-01, .4963E-01,-.9453E-04,-.1184E-01,
+     &        -.1405E-01,-.2189E-01,-.2395E-01/
+      DATA C0/ .6106E+00, .1257E+01, .2904E+01, .1547E+01, .1531E+00,
+     &        -.5216E+00,-.4001E+00, .1061E+00, .7939E+00, .1421E+01,
+     &         .1776E+01, .1883E+01, .1693E+01, .1334E+01, .6370E+00,
+     &         .1107E+01, .1329E+01, .9812E+00, .9691E+00, .1171E+01,
+     &         .1119E+01, .1070E+01, .1086E+01, .1164E+01, .1145E+01,
+     &         .1135E+01, .1167E+01, .1164E+01,
+     &         .2614E-02, .3429E-01, .4919E+00, .1051E+01, .6861E+00,
+     &         .3474E+00, .2567E+00, .3720E+00, .6355E+00, .9464E+00,
+     &         .1195E+01, .1361E+01, .1388E+01, .1283E+01, .7888E+00,
+     &         .8176E+00, .1038E+01, .9433E+00, .8490E+00, .9234E+00,
+     &         .9487E+00, .9256E+00, .9171E+00, .9601E+00, .9731E+00,
+     &         .9774E+00, .9868E+00, .9892E+00/
+      DATA A1/ .8917E-02, .1683E-01, .1060E-01,-.2180E+00,-.4334E+00,
+     &        -.6977E+00,-.9510E+00,-.1114E+01,-.1154E+01,-.1186E+01,
+     &        -.1170E+01,-.1184E+01,-.1214E+01,-.1243E+01,-.1324E+01,
+     &        -.1570E+01,-.1304E+01,-.7215E+00,-.9031E+00,-.1164E+01,
+     &        -.5731E+00,-.4235E+00,-.8438E+00,-.3892E+00, .3259E+00,
+     &         .2680E+00, .6864E+00, .1542E+01,
+     &        -.6903E-04,-.1081E-02,-.2849E-01,-.2557E+00,-.4515E+00,
+     &        -.6935E+00,-.9313E+00,-.1098E+01,-.1165E+01,-.1222E+01,
+     &        -.1239E+01,-.1285E+01,-.1353E+01,-.1432E+01,-.1606E+01,
+     &        -.1809E+01,-.1613E+01,-.1139E+01,-.1174E+01,-.1452E+01,
+     &        -.1075E+01,-.7739E+00,-.1122E+01,-.8658E+00, .8014E-02,
+     &         .2460E+00, .7393E+00, .1802E+01/
+      DATA B1/-.4265E-01,-.8221E-01,-.9239E-01, .7328E+00, .1571E+01,
+     &         .2661E+01, .3805E+01, .4705E+01, .5192E+01, .5586E+01,
+     &         .5713E+01, .5844E+01, .5940E+01, .5939E+01, .5617E+01,
+     &         .6022E+01, .5165E+01, .2970E+01, .3196E+01, .4005E+01,
+     &         .1932E+01, .1164E+01, .2469E+01, .8862E+00,-.1572E+01,
+     &        -.1359E+01,-.2718E+01,-.5456E+01,
+     &         .2345E-03, .3756E-02, .1058E+00, .9941E+00, .1787E+01,
+     &         .2813E+01, .3909E+01, .4823E+01, .5400E+01, .5881E+01,
+     &         .6131E+01, .6373E+01, .6598E+01, .6769E+01, .6816E+01,
+     &         .7097E+01, .6380E+01, .4542E+01, .4294E+01, .5046E+01,
+     &         .3642E+01, .2361E+01, .3303E+01, .2337E+01,-.6819E+00,
+     &        -.1528E+01,-.3110E+01,-.6542E+01/
+      DATA C1/ .5537E-01, .1094E+00, .1933E+00,-.3295E+00,-.9664E+00,
+     &        -.1836E+01,-.2791E+01,-.3579E+01,-.4033E+01,-.4384E+01,
+     &        -.4467E+01,-.4506E+01,-.4480E+01,-.4338E+01,-.3594E+01,
+     &        -.3592E+01,-.2857E+01,-.9067E+00,-.8569E+00,-.1483E+01,
+     &         .2426E+00, .1010E+01,-.2250E-01, .1272E+01, .3286E+01,
+     &         .3064E+01, .4112E+01, .6241E+01,
+     &        -.1499E-03,-.2538E-02,-.7950E-01,-.7859E+00,-.1437E+01,
+     &        -.2302E+01,-.3255E+01,-.4084E+01,-.4636E+01,-.5081E+01,
+     &        -.5287E+01,-.5434E+01,-.5522E+01,-.5524E+01,-.5105E+01,
+     &        -.5006E+01,-.4323E+01,-.2649E+01,-.2219E+01,-.2726E+01,
+     &        -.1514E+01,-.3276E+00,-.9927E+00,-.1745E+00, .2306E+01,
+     &         .2984E+01, .4190E+01, .6871E+01/
+      DATA A2/ .8210E-03, .6438E-03,-.2567E-01,-.2701E+00,-.4978E+00,
+     &        -.8074E+00,-.1155E+01,-.1458E+01,-.1649E+01,-.1731E+01,
+     &        -.1683E+01,-.1675E+01,-.1646E+01,-.1544E+01,-.1234E+01,
+     &        -.1855E+01,-.1307E+01,-.2446E+00,-.5417E+00,-.1624E+01,
+     &        -.2091E+00, .2351E+00,-.1552E+01,-.5738E+00, .1313E+01,
+     &         .4078E-01, .1116E+01, .5153E+01,
+     &        -.7454E-04,-.1152E-02,-.2981E-01,-.2758E+00,-.5027E+00,
+     &        -.8111E+00,-.1158E+01,-.1463E+01,-.1658E+01,-.1747E+01,
+     &        -.1709E+01,-.1708E+01,-.1687E+01,-.1596E+01,-.1308E+01,
+     &        -.1910E+01,-.1371E+01,-.3399E+00,-.6009E+00,-.1651E+01,
+     &        -.3374E+00, .1413E+00,-.1566E+01,-.7407E+00, .1151E+01,
+     &         .9063E-01, .1134E+01, .5181E+01/
+      DATA B2/-.4020E-02,-.4571E-02, .9034E-01, .1031E+01, .1929E+01,
+     &         .3185E+01, .4662E+01, .6060E+01, .7090E+01, .7687E+01,
+     &         .7703E+01, .7758E+01, .7644E+01, .7176E+01, .5232E+01,
+     &         .6690E+01, .4972E+01, .1198E+01, .1616E+01, .5180E+01,
+     &         .4740E+00,-.1502E+01, .4302E+01, .9918E+00,-.5496E+01,
+     &        -.1222E+01,-.4838E+01,-.1792E+02,
+     &         .2569E-03, .4046E-02, .1111E+00, .1065E+01, .1964E+01,
+     &         .3219E+01, .4696E+01, .6101E+01, .7148E+01, .7768E+01,
+     &         .7824E+01, .7907E+01, .7820E+01, .7389E+01, .5527E+01,
+     &         .6926E+01, .5219E+01, .1545E+01, .1852E+01, .5278E+01,
+     &         .8977E+00,-.1184E+01, .4303E+01, .1494E+01,-.5022E+01,
+     &        -.1536E+01,-.4991E+01,-.1814E+02/
+      DATA C2/ .5370E-02, .8378E-02,-.5663E-01,-.7911E+00,-.1516E+01,
+     &        -.2549E+01,-.3786E+01,-.4980E+01,-.5871E+01,-.6372E+01,
+     &        -.6307E+01,-.6228E+01,-.5961E+01,-.5361E+01,-.3045E+01,
+     &        -.3777E+01,-.2316E+01, .8933E+00, .8813E+00,-.1974E+01,
+     &         .1810E+01, .3680E+01,-.9658E+00, .1690E+01, .7053E+01,
+     &         .3513E+01, .6392E+01, .1679E+02,
+     &        -.1729E-03,-.2839E-02,-.8489E-01,-.8456E+00,-.1578E+01,
+     &        -.2617E+01,-.3861E+01,-.5067E+01,-.5977E+01,-.6502E+01,
+     &        -.6476E+01,-.6425E+01,-.6184E+01,-.5615E+01,-.3369E+01,
+     &        -.4053E+01,-.2592E+01, .5416E+00, .6159E+00,-.2112E+01,
+     &         .1417E+01, .3365E+01,-.9937E+00, .1261E+01, .6647E+01,
+     &         .3797E+01, .6509E+01, .1696E+02/
+      DATA itime /0/
+         data xldo/0.1,0.5,1.0,2.0,4.0,8.0/
+         data  xx1/0.66,0.70,0.60,0.50,0.50,0.59/
+         data  xx2/0.66,0.70,0.81,0.60,0.59,0.62/
+         data  yy1/0.66,0.70,0.52,0.44,0.59,0.59/
+         data  yy2/0.66,0.70,0.74,0.55,0.62,0.62/
+         data  zz1/0.66,0.70,0.42,0.48,0.55,0.59/
+         data  zz2/0.66,0.70,0.65,0.55,0.63,0.62/
+
+      save ifirst
+
+         if (ifirst.eq.0) then
+         print*,' IFIRST', ifirst
+          do i=1,nech
+             xech(i)=xech(i)*1.7
+          enddo
+          ifirst=1
+         endif
+
+**    1: compute the exponent of the law N^a LOG N
+**    with the index n and the size parameter x
+****************************************************
+           xexp5=0.66666
+           xexp6=0.66666
+******     INTERPOLATION WITH THE VALUE OF REAL REFR. INDEX 
+           do i=1,nex
+           if(xn.lt.1.7) then
+           ww1(i)=(yy1(i)-xx1(i))/.3*(xn-1.4)+xx1(i)
+           ww2(i)=(yy2(i)-xx2(i))/.3*(xn-1.4)+xx2(i)
+           endif
+           if(xn.ge.1.7) then
+           ww1(i)=(zz1(i)-yy1(i))/.3*(xn-1.7)+yy1(i)
+           ww2(i)=(zz2(i)-yy2(i))/.3*(xn-1.7)+yy2(i)
+           endif
+           enddo
+******     INTERPOLATION  WITH THE SIZE PARAMETER
+********  XEXP5 AND XEXP6 ARE THE EXPONENT TO USE IN N^a LOGN LAW
+           do i=2,nex
+           if(x.lt.xldo(i).and.x.ge.xldo(i-1)) then
+            rap=xldo(i)-xldo(i-1)
+            xexp5=(ww1(i)-ww1(i-1))/rap*(x-xldo(i-1))+ww1(i-1)
+            xexp6=(ww2(i)-ww2(i-1))/rap*(x-xldo(i-1))+ww2(i-1)
+           endif
+           enddo
+           if(x.ge.xldo(nex)) then
+              xexp5=ww1(nex)
+              xexp6=ww2(nex)
+           endif
+ 
+         xxn=xn*x
+
+**   location in the defined range of n
+********************************************
+**   Out of the range
+            xni=xn
+            dxn=0.
+            if (xn.lt.1.4) then 
+                 dxn=(xn-1.4)
+                 xn=1.4
+            endif
+            if (xn.gt.2.0) then 
+                 dxn=(xn-2.0)
+                 xn=2.0
+            endif
+           
+**   location in the defined ranges of n*X
+********************************************
+**   Out of the range
+            if (xxn.ge.xech(nech)) xxn=xech(nech)*.99 
+**   Rayleigh range
+            if (xxn.lt.xech(1)) xxn=xech(1)
+              do i=1,nech
+             if(xech(i).le.xxn) j=i
+              enddo
+**  Location inside the slab j to j+1
+            xechj=xech(j)
+            xechjp1=xech(j+1)
+            jindex=j
+            xrap=(xxn-xech(j))/(xech(j+1)-xech(j))
+            xrapl=(alog10(xxn)-alog10(xech(j)))
+     &        /(alog10(xech(j+1))-alog10(xech(j)))
+             if(xxn.gt.1.7) xrapl=xrap
+***************************************************
+** Calculation of the (parabolic) coefficients   **
+***************************************************
+          xki=xk
+          if (xk.lt.1.e-2) xki=1.e-2
+          if (xk.gt.1.) xki=1.
+          rki=-alog10(xki)                                                      
+****   Computation of the parabolic coefficients
+**     For index j
+*       f(x0+dx)=f(x0)+[df/dx](x0)*dx
+* with f=ax^2+bx+c  ---> f'=[f-c+ax^2]/x=2ax+b
+*
+       if(rki.gt.2.) then 
+        cjd =A2(j)     *xn**2.+B2(j)     *xn+C2(j)
+        cjd_=A2(j+nech)*xn**2.+B2(j+nech)*xn+C2(j+nech) 
+        cju =A2(j)     *xn**2.+B2(j)     *xn+C2(j)
+        cju_=A2(j+nech)*xn**2.+B2(j+nech)*xn+C2(j+nech) 
+* neutre si dxn=0  :  
+        cjd =cjd +(cjd -C2(j)     +A2(j)     *xn**2.)/xn*dxn
+        cjd_=cjd_+(cjd_-C2(j+nech)+A2(j+nech)*xn**2.)/xn*dxn
+        cju =cju +(cju -C2(j)     +A2(j)     *xn**2.)/xn*dxn
+        cju_=cju_+(cju_-C2(j+nech)+A2(j+nech)*xn**2.)/xn*dxn
+         xku=1.e-2
+         xkd=1.e-2
+       endif
+       if(rki.le.2.) then
+        cjd =A1(j)     *xn**2.+B1(j)     *xn+C1(j)
+        cjd_=A1(j+nech)*xn**2.+B1(j+nech)*xn+C1(j+nech) 
+        cju =A2(j)     *xn**2.+B2(j)     *xn+C2(j)
+        cju_=A2(j+nech)*xn**2.+B2(j+nech)*xn+C2(j+nech) 
+* neutre si dxn=0  :
+        cjd =cjd +(cjd -C1(j)     +A1(j)     *xn**2.)/xn*dxn
+        cjd_=cjd_+(cjd_-C1(j+nech)+A1(j+nech)*xn**2.)/xn*dxn
+        cju =cju +(cju -C2(j)     +A2(j)     *xn**2.)/xn*dxn
+        cju_=cju_+(cju_-C2(j+nech)+A2(j+nech)*xn**2.)/xn*dxn
+         xku=1.e-2
+         xkd=1.e-1
+       endif
+       if(rki.le.1.) then 
+        cju =A1(j)     *xn**2.+B1(j)     *xn+C1(j)
+        cju_=A1(j+nech)*xn**2.+B1(j+nech)*xn+C1(j+nech) 
+        cjd =A0(j)     *xn**2.+B0(j)     *xn+C0(j)
+        cjd_=A0(j+nech)*xn**2.+B0(j+nech)*xn+C0(j+nech) 
+* neutre si dxn=0  :
+        cjd =cjd +(cjd -C0(j)     +A0(j)     *xn**2.)/xn*dxn
+        cjd_=cjd_+(cjd_-C0(j+nech)+A0(j+nech)*xn**2.)/xn*dxn
+        cju =cju +(cju -C1(j)     +A1(j)     *xn**2.)/xn*dxn
+        cju_=cju_+(cju_-C1(j+nech)+A1(j+nech)*xn**2.)/xn*dxn
+         xku=1.e-1
+         xkd=1.e-0
+       endif
+ 
+ 
+**     For index j+1
+       if(rki.gt.2.) then 
+        cjdp1 =A2(j+1)     *xn**2.+B2(j+1)     *xn+C2(j+1)
+        cjdp1_=A2(j+1+nech)*xn**2.+B2(j+1+nech)*xn+C2(j+1+nech) 
+        cjup1 =A2(j+1)     *xn**2.+B2(j+1)     *xn+C2(j+1)
+        cjup1_=A2(j+1+nech)*xn**2.+B2(j+1+nech)*xn+C2(j+1+nech) 
+* neutre si dxn=0  :
+        cjdp1 =cjdp1 +(cjdp1 -C2(j+1)     +A2(j+1)     *xn**2.)/xn*dxn
+        cjdp1_=cjdp1_+(cjdp1_-C2(j+1+nech)+A2(j+1+nech)*xn**2.)/xn*dxn
+        cjup1 =cjup1 +(cjup1 -C2(j+1)     +A2(j+1)     *xn**2.)/xn*dxn
+        cjup1_=cjup1_+(cjup1_-C2(j+1+nech)+A2(j+1+nech)*xn**2.)/xn*dxn
+         xku=1.e-2
+         xkd=1.e-2
+       endif
+       if(rki.le.2.) then
+        cjdp1 =A1(j+1)     *xn**2.+B1(j+1)     *xn+C1(j+1)
+        cjdp1_=A1(j+1+nech)*xn**2.+B1(j+1+nech)*xn+C1(j+1+nech) 
+        cjup1 =A2(j+1)     *xn**2.+B2(j+1)     *xn+C2(j+1)
+        cjup1_=A2(j+1+nech)*xn**2.+B2(j+1+nech)*xn+C2(j+1+nech) 
+* neutre si dxn=0  :
+        cjdp1 =cjdp1 +(cjdp1 -C1(j+1)     +A1(j+1)     *xn**2.)/xn*dxn
+        cjdp1_=cjdp1_+(cjdp1_-C1(j+1+nech)+A1(j+1+nech)*xn**2.)/xn*dxn
+        cjup1 =cjup1 +(cjup1 -C2(j+1)     +A2(j+1)     *xn**2.)/xn*dxn
+        cjup1_=cjup1_+(cjup1_-C2(j+1+nech)+A2(j+1+nech)*xn**2.)/xn*dxn
+         xku=1.e-2
+         xkd=1.e-1
+       endif
+       if(rki.le.1.) then 
+        cjup1 =A1(j+1)     *xn**2.+B1(j+1)     *xn+C1(j+1)
+        cjup1_=A1(j+1+nech)*xn**2.+B1(j+1+nech)*xn+C1(j+1+nech) 
+        cjdp1 =A0(j+1)     *xn**2.+B0(j+1)     *xn+C0(j+1)
+        cjdp1_=A0(j+1+nech)*xn**2.+B0(j+1+nech)*xn+C0(j+1+nech) 
+* neutre si dxn=0  :
+        cjdp1 =cjdp1 +(cjdp1 -C0(j+1)     +A0(j+1)     *xn**2.)/xn*dxn
+        cjdp1_=cjdp1_+(cjdp1_-C0(j+1+nech)+A0(j+1+nech)*xn**2.)/xn*dxn
+        cjup1 =cjup1 +(cjup1 -C1(j+1)     +A1(j+1)     *xn**2.)/xn*dxn
+        cjup1_=cjup1_+(cjup1_-C1(j+1+nech)+A1(j+1+nech)*xn**2.)/xn*dxn
+         xku=1.e-1
+         xkd=1.e-0
+       endif
+ 
+ 
+**     Computation of the monomer-factor
+ 
+         cjup1 =cjup1*20.   
+         cjup1_=cjup1_*20.
+         cju   =cju*20.
+         cju_  =cju_*20.
+         cjdp1 =cjdp1*20.   
+         cjdp1_=cjdp1_*20.
+         cjd   =cjd*20.
+         cjd_  =cjd_*20.
+         xn=xni              ! restitution de xn
+
+         return
+         end
+        
+        subroutine structure(NB,X,Z,STRUCT,DF)
+        implicit real (a-h,o-z)
+c       integer NB
+        real NB
+        real X,Z,D
+ 
+        D=DF
+        if (DF.eq.2) D=2.0001
+        if (z.eq.0.) z=1.e-4
+ 
+         STRUCT=1.
+         NOSTRUCT=0       ! if asymetry parameters are not needed
+                          ! just skip the computation: save your time!
+        if (NOSTRUCT.eq.1)  goto 102 
+        u0=5.
+        pi=3.1415926
+* If convergence test in on (end of the loop):
+        xacc=1.e-3
+* Else, computation is done once: accuracy is generally about 1%
+        
+* The structure factor is computed in order to evaluate the asymetry
+* parameter (not for cross sections). We need to compute the integral 
+* of the following function:
+*
+*        sin(2XZu)exp(-1/2u**2) for u between 0 and 5.
+*
+*   where  X,Z are provided through the subroutine calling
+*   A=4*pi (normalization factor for D=2 --> Botet et al., 1995)
+*
+* And STRUCT is given as:
+*
+* STRUCT=N*[1+(N-1)*2*pi/(A*X*Z) INTEGRAL[sin(2XZu)exp(-1/2u**2)du]
+*
+* The number of oscillations for sin(2XZu) between 0 and U is:
+*  n=UXZ/pi.... let integer (simpson integration).
+         
+         A=-5.026*D+22.618
+         A=A/(2.*pi)                    !<---- here is A/(2*PI)
+         nplt=6*int(5.*Z*X/3.1415926+1.)
+*        nplt=int(5.*Z*X/3.1415926+1.)
+*        This is  the number of periods for the sinus in the range 
+*        u E [0,5]. Integration is done with 6 points per period.
+*        Accuracy is about 1% on the final result STRUCT. 
+*
+*        The minimum value for nplt is set to 17 to do computation 
+*        in the Rayleigh range ( when Z*X  reaches 0)
+         STRUCT=1.e-10
+ 101     if ((nplt/2)*1..eq.nplt*.5) nplt=nplt+1  !---> odd
+         if (nplt.lt.17) nplt=17   
+         dint=u0/(nplt-1)
+         STRUCT_OLD=STRUCT
+         STRUCT=0.
+       
+***   EXTENDED  SIMPSON INTEGRATION
+         iint=0
+         ucr=iint*dint
+         um1=sin(2.*x*z*ucr)*exp(-.5*ucr**D)*ucr**(D-2.)
+          STRUCT=STRUCT+um1
+         iint=nplt-1
+         ucr=iint*dint
+         um1=sin(2.*x*z*ucr)*exp(-.5*ucr**D)*ucr**(D-2.)
+          STRUCT=STRUCT+um1
+         
+         do iint=1,nplt-2,2
+         ucr=iint*dint
+         um1=4.*sin(2.*x*z*ucr)*exp(-.5*ucr**D)*ucr**(D-2.)
+          STRUCT=STRUCT+um1
+         enddo 
+   
+         do iint=2,nplt-3,2
+         ucr=iint*dint
+         um1=2.*sin(2.*x*z*ucr)*exp(-.5*ucr**D)*ucr**(D-2.)
+          STRUCT=STRUCT+um1
+         enddo 
+         STRUCT=dint/3.*STRUCT
+         ERR=abs(STRUCT_OLD-STRUCT)/STRUCT  
+         nplt=int(nplt*2)
+C        UNCOMMENT THE IF STATEMENT TO
+c        SET ON THE CONVERGENCE TEST: 
+c        if (ERR.gt.xacc) GOTO 101 
+         STRUCT=(STRUCT/(x*z*a)*(NB-1)+1.)*NB
+
+ 102     continue        
+         return 
+         end
+
+      
Index: trunk/LMDZ.TITAN/libf/phytitan/clesphys.h
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/clesphys.h	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/clesphys.h	(revision 175)
@@ -11,21 +11,36 @@
        INTEGER nbapp_rad, nbapp_chim, iflag_con, iflag_ajs
        REAL    ecritphy
+       INTEGER lev_histmth, lev_histday
        REAL    solaire
+
+! Parametres pour PBL:
        REAL    z0, lmixmin
-       REAL    ksta, inertie
+       REAL    ksta
        LOGICAL ok_kzmin
-       INTEGER lev_histmth, lev_histday
+
+! Parametres surface:
+       REAL    inertie
+
+! Parametres Chimie:
        logical chimi,ylellouch,hcnrad
        integer vchim,aerprod,htoh2
-       integer microfi,cutoff
-       real    tx,tcorrect
+       
+! Parametres Microphysique:
+       integer microfi,cutoff,clouds
+       real    tx,tcorrect,p_prodaer
+       real    xnuf 
 
 
-       COMMON/clesphys/cycle_diurne, soil_model,                        &
-     &     ok_orodr, ok_orolf, ok_gw_nonoro, nbapp_rad, nbapp_chim      &
-     &     , ecritphy                                                   &
-     &     , iflag_con, iflag_ajs, solaire, z0, lmixmin, ksta           &
-     &     , ok_kzmin, lev_histmth, lev_histday                         &
-     &     , inertie, chimi,vchim,aerprod,htoh2,ylellouch,hcnrad        &
-     &     , microfi,cutoff,tx,tcorrect
+       COMMON/clesphys_i/                                               &
+     &     nbapp_rad, nbapp_chim, iflag_con, iflag_ajs,                 &
+     &     lev_histmth, lev_histday, vchim,aerprod,htoh2,               &
+     &     microfi,cutoff,clouds
 
+       COMMON/clesphys_r/                                               &
+     &     ecritphy, solaire, z0, lmixmin, ksta, inertie,               &
+     &     tx,tcorrect,p_prodaer,xnuf
+
+       COMMON/clesphys_l/cycle_diurne, soil_model,                      &
+     &     ok_orodr, ok_orolf, ok_gw_nonoro, ok_kzmin,                  &
+     &     chimi,ylellouch,hcnrad
+
Index: trunk/LMDZ.TITAN/libf/phytitan/cnuages3D.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/cnuages3D.F	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/cnuages3D.F	(revision 175)
@@ -0,0 +1,437 @@
+         subroutine cnuages(
+     &   tq,tqc1,tqc2,tqc3,tqcn,gaz1,gaz2,gaz3,   ! aerosol/glace/gas
+     &   ddt)
+
+c
+c
+c  °
+c              °
+c  SERT A APPELE LA ROUTINE MICROPHYSIQUE DES NUAGES 
+c
+c     °
+c  ICI ON NE FAIT QUE LA NUCLEATION/CONDENSATION 
+c  ET GESTION°DES NOYAUX. LA SEDIMENTATION EST DANS
+c  SNUAGES.F
+c            °   °
+c
+c        °
+c                °
+c              °   °
+c                      
+c                  °   °
+c                   °  
+c                    ° °
+c                   ° \|/  °
+c                    (@ @)°
+c-----------------oOo--O--oOo--------------------------
+c                        
+c
+c
+c Interface entre physiq.F et les routines n_<nom_compose>.F 
+c
+c Date: 3 Nov 2003
+c
+c   EN ENTREE/SORTIE DE LA ROUTINE
+c ------------------------------------
+c
+c     Les aerosols, noyaux (tq,tqcn) sont en nbre/m^2 dans la colonne
+c     Les  condensats (tqc1,tqc2)   sont en volume/m^2 dans la colonne
+c     Le gaz (gaz1, gaz2) est en fraction molaire
+c
+c   EN APPEL DES ROUTINES NUAGES
+c ------------------------------------
+c
+c     Les aerosols et noyaux doivent etre en nombre /kg d'air
+c     Les condensats doivent etre en volume / kg d'air
+c     Le gaz en kg/kg d'air
+c
+c   LES TENDANCES ET DIFFERENCES SONT HOMOGENES AUX QUANTITES
+c ------------------------------------------------------------
+c
+c
+c------------------------------------------------------
+
+         use dimphy
+         IMPLICIT NONE
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+
+         integer NG1,NG,NL 
+         parameter (NG1=1,NG=NG1,NL=llm)
+  
+c*************************************
+c  declaration des variables internes *
+c*************************************
+
+c        INTERNE!        *
+c-----------------------*
+
+         real  tqc1(NG,NL,nrad)
+         real  tqc2(NG,NL,nrad)
+         real  tqc3(NG,NL,nrad)
+         real  tqcn(NG,NL,nrad)
+         real  tq(NG,NL,nrad)
+*
+         real  tdqc1(NG,NL,nrad)
+         real  tdqc2(NG,NL,nrad)
+         real  tdqc3(NG,NL,nrad)
+         real  tdq(NG,NL,nrad,ntype-2+1)
+         real  tdqcn(NG,NL,nrad,ntype-2+1)
+*
+         real  gaz1(NG,NL)
+         real  gaz2(NG,NL)
+         real  gaz3(NG,NL)
+         real  dgaz1(NG,NL)
+         real  dgaz2(NG,NL)
+         real  dgaz3(NG,NL)
+*
+         real  ppch4(NG,NL)
+         real  ppc2h6(NG,NL)
+         real  ppn2(NG,NL)
+*
+         real  pmixch4(NL)
+         real  pmixc2h6(NL)
+         real  pmixn2(NL)
+c   composition initiale estimée (interne)
+         real  xprime1(NG,NL)
+         real  xprime2(NG,NL)
+         real  xprime3(NG,NL)
+c   composition calculée (output)
+         real  x1(NL)
+         real  x2(NL)
+         real  x3(NL)
+c   moyenne "glissante" pondéréee (output + mémoire)
+         real  x1o(NL)
+         real  x2o(NL)
+         real  x3o(NL)
+         real  icefrac(NL)
+         real  dmn2(NL+1)
+
+         real  ppch4t,ppc2h6t,ppn2t
+         real  psatch4,psatc2h6,psatn2
+         real  xprime(3),x(3),frac
+         real  melange
+         real  sum,sum0
+
+*                    RAPPEL: NG=1
+
+         real ddt
+         real masspaer
+
+         common/mixing/x1,x2,x3,icefrac,
+     &         pmixch4,pmixc2h6,pmixn2,
+     &         x1o,x2o,x3o
+
+
+
+c  FORMAT MICRO DES NUAGES
+c------------------------*
+
+         real  especes(NG,NL,3*nrad+1)          
+         real  condens(NG,NL,nrad)          
+         real gg,xmair
+
+         integer jsup,jinf,h,i,j,k,ndim
+         integer ival1,ival2,ival3
+
+         integer iprem
+
+         save iprem,xprime
+         data iprem/0/
+
+         ndim=3*nrad+1
+
+         gg=g0
+
+*********************************************
+*********************************************
+*  Appel de la condensation du methane
+*********************************************
+*********************************************
+
+
+
+*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
+*                   Bilan avant sur le methane                         *
+*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
+
+         do i=1,ng1  ! ng1=1 !!
+           do j=1,NL
+
+*  RAZ des delta d'especes communes.
+*----------------------------------
+             do k=1,nrad
+               tdqcn(i,j,k,1)= 0.
+               tdq( i,j,k,1) = 0.
+             enddo
+
+             gg=g0*rtit**2/(rtit+z(j))**2.
+             xmair=(pb(j+1)-pb(j))/gg/dzb(j)
+
+             do k=1,nrad
+               especes(i,j,k)=tq(i,j,k)         /xmair       ! aerosols, noyaux,
+               especes(i,j,k+nrad)=tqc1(i,j,k)  /xmair       ! methane condense,
+               condens(i,j,k)=(tqc2(i,j,k)+tqc3(i,j,k))/xmair! autre(s) condensat(s)
+               especes(i,j,k+2*nrad)=tqcn(i,j,k)/xmair       ! nombre/kg &  volume/kg
+             enddo
+             especes(i,j,3*nrad+1)=gaz1(i,j)*mch4/mair       ! methane gazeux kg/kg
+           enddo
+         enddo
+
+
+1001   format(7(1x,e12.6),' avN2CH4C2H6')
+1003   format(7(1x,e12.6),' miN2CH4C2H6')
+1002   format(7(1x,e12.6),' apN2CH4C2H6')
+*
+         call n_methane(ng1,ndim,nrad,ddt,
+     &                  p,t,r_e,especes,condens)
+
+
+*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
+*                   Bilan apres sur le methane                         *
+*=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
+
+         do i=1,ng1
+           do j=1,NL
+
+             gg=g0*rtit**2/(rtit+z(j))**2.
+             xmair=(pb(j+1)-pb(j))/gg/dzb(j)
+
+*  ici ce sont les tendances a sortir de nuages.F pour le methane....
+*-------------------------------------------------------------------
+             sum=0.   
+             do k=1,nrad
+               tdqc1(i,j,k)=(especes(i,j,k+nrad)*xmair-tqc1(i,j,k) )
+               sum =sum+tdqc1(i,j,k)/xmair*rhoi_ch4
+               tqc1(i,j,k) = especes(i,j,k+nrad)*xmair
+             enddo
+
+             dgaz1(i,j)= especes(i,j,3*nrad+1)*mair/mch4-gaz1(i,j)
+             gaz1(i,j)= especes(i,j,3*nrad+1)*mair/mch4
+
+c         dgaz1(i,j)=-sum*xmuair/16.
+c          gaz1(i,j)=gaz1(i,j)+dgaz1(i,j) 
+
+*  Premiere tendance sur les variables communes (aerosols et noyaux)
+*------------------------------------------------------------------
+             do k=1,nrad
+               tdqcn(i,j,k,1)=(especes(i,j,k+2*nrad)*xmair-tqcn(i,j,k))
+               tdq( i,j,k,1) =(especes(i,j,k)*xmair       -tq(i,j,k))  
+             enddo
+           enddo
+         enddo
+
+
+
+*     attention, si il y a  de l'ethane sur les noyaux... il est impossible
+*     de les restituer - en revanche on peut en creer de nouveaux ! !!
+*     Le corrolaire de la condition ci dessus est que si il est impossible de 
+*     restituer des noyaux, le nombre d'aeorsols ne peux pas augmenter, il
+*     peut en revanche diminuer
+
+
+*********************************************
+*********************************************
+*  Appel de la condensation de l'ethane
+*********************************************
+*********************************************
+
+         do i=1,ng1
+           do j=1,NL
+             do k=1,nrad
+               tdqcn(i,j,k,2)= 0.
+               tdq( i,j,k,2) = 0.
+             enddo
+
+             gg=g0*rtit**2/(rtit+z(j))**2.
+             xmair=(pb(j+1)-pb(j))/gg/dzb(j)
+
+             do k=1,nrad
+               especes(i,j,k)=tq(i,j,k)/xmair
+               especes(i,j,k+nrad)=tqc2(i,j,k)/xmair           ! ethane condense
+               condens(i,j,k)=(tqc1(i,j,k)+tqc3(i,j,k))/xmair  ! autres condensats
+               especes(i,j,k+2*nrad)=tqcn(i,j,k)/xmair
+             enddo
+
+             especes(i,j,3*nrad+1)=gaz2(i,j)*mc2h6/mair       ! ethane gazeux
+
+           enddo
+         enddo
+
+
+
+         call n_ethane(ng1,ndim,nrad,ddt,
+     &                 p,t,r_e,especes,condens)
+
+         do i=1,ng1
+           do j=1,NL
+             gg=g0*rtit**2/(rtit+z(j))**2.
+             xmair=(pb(j+1)-pb(j))/gg/dzb(j)
+
+*  ici ce sont les tendances a sortir de nuages.F pour l'ethane....
+*-----------------------------------------------------------------
+
+             sum=0.
+             do k=1,nrad
+               tdqc2(i,j,k)=(especes(i,j,k+nrad)*xmair-tqc2(i,j,k) )
+               sum =sum+tdqc2(i,j,k)/xmair*rhoi_c2h6
+               tqc2(i,j,k) = especes(i,j,k+nrad)*xmair
+             enddo
+
+             dgaz2(i,j)=especes(i,j,3*nrad+1)*mair/mc2h6 - gaz2(i,j)
+             gaz2(i,j)=especes(i,j,3*nrad+1)*mair/mc2h6 
+
+c         dgaz2(i,j)=-sum*xmuair/30.
+c          gaz2(i,j)=gaz2(i,j)+dgaz2(i,j) 
+
+
+*  Deuxieme tendance sur les variables communes (aerosols et noyaux)
+*------------------------------------------------------------------
+   
+             do k=1,nrad
+               tdqcn(i,j,k,2)=(especes(i,j,k+2*nrad)*xmair-tqcn(i,j,k))
+               tdq(i,j,k,2)  =(especes(i,j,k)*xmair       -tq(i,j,k))
+             enddo
+
+           enddo
+         enddo
+
+
+*********************************************
+*********************************************
+*  Appel de la condensation de l'acethylene
+*********************************************
+*********************************************
+
+         do i=1,ng1
+           do j=1,NL
+             do k=1,nrad
+               tdqcn(i,j,k,3)= 0.
+               tdq( i,j,k,3) = 0.
+             enddo
+             gg=g0*rtit**2/(rtit+z(j))**2.
+             xmair=(pb(j+1)-pb(j))/gg/dzb(j)
+
+             do k=1,nrad
+               especes(i,j,k)=tq(i,j,k)/xmair
+               especes(i,j,k+nrad)=tqc3(i,j,k)/xmair           ! acethylene condense
+               condens(i,j,k)=(tqc1(i,j,k)+tqc2(i,j,k))/xmair  ! autres condensats
+               especes(i,j,k+2*nrad)=tqcn(i,j,k)/xmair
+             enddo
+
+             especes(i,j,3*nrad+1)=gaz3(i,j)*mc2h2/mair      ! acethylene gazeux
+
+           enddo
+         enddo
+
+         call n_acethylene(ng1,ndim,nrad,ddt,
+     &                     p,t,r_e,especes,condens)
+
+
+         do i=1,ng1
+           do j=1,NL
+
+             gg=g0*rtit**2/(rtit+z(j))**2.
+             xmair=(pb(j+1)-pb(j))/gg/dzb(j)
+
+*  ici ce sont les tendances a sortir de nuages.F pour l'ethane....
+*-----------------------------------------------------------------
+
+             sum=0.
+             do k=1,nrad
+               tdqc3(i,j,k)=(especes(i,j,k+nrad)*xmair-tqc3(i,j,k) )
+               sum =sum+tdqc3(i,j,k)/xmair*rhoi_c2h2
+               tqc3(i,j,k) = especes(i,j,k+nrad)*xmair
+             enddo
+
+             dgaz3(i,j)=especes(i,j,3*nrad+1)*mair/mc2h2 - gaz3(i,j)
+             gaz3(i,j)=especes(i,j,3*nrad+1)*mair/mc2h2 
+
+c         dgaz3(i,j)=-sum*xmuair/26.
+c         gaz3(i,j)=gaz3(i,j)+dgaz3(i,j) 
+
+*  Troisieme tendance sur les variables communes (aerosols et noyaux)
+*------------------------------------------------------------------
+
+
+             do k=1,nrad
+               tdqcn(i,j,k,3)=(especes(i,j,k+2*nrad)*xmair-tqcn(i,j,k))
+               tdq(i,j,k,3)  =(especes(i,j,k)*xmair       -tq(i,j,k))
+             enddo
+
+           enddo
+         enddo
+
+
+*  FIN DES APPELS DE NUAGES ET BILAN DES TENDANCES...
+*------------------------------------------------------------------
+
+
+         do i=1,ng1
+           do j=1,NL
+             do k=1,nrad
+
+*          Ici on test l'activité nuageuse : si on a l'association
+*          tdqcX(i,j,k) = 0 et tqcX(i,j,k) = 0 alors ivalX reste à 0 (pas d'ativité)
+*                                              sinon ivalX passe à 1 (activité)
+*------------------------------------------------------------------------------------
+
+               ival1=0
+               ival2=0
+               ival3=0
+
+               if(tdqc1(i,j,k).ne.0. .or. tqc1(i,j,k).gt.0.)  ival1=1
+               if(tdqc2(i,j,k).ne.0. .or. tqc2(i,j,k).gt.0.)  ival2=1
+               if(tdqc3(i,j,k).ne.0. .or. tqc3(i,j,k).gt.0.)  ival3=1
+
+*          Ici on definit la tendances des noyaux en faisant deux choses: 
+*          -1 On ecarte les cas  tdqcn(i,j,k,X)=0 si ils sont associés à une 
+*          absence d'activité nuageuse de l'espèce (tdqcX(i,j,k)=0.)
+*          -2 Sélectionne la tendance la plus élevée. Si aucune activité nuageuse
+*           n'exits dans cette case (ivalX=0 pour les 3 especes), alors on
+*           retrouve la valeur -1.e40 que l'on mets alors à 0. 
+*----------------------------------------------------------------------
+c23456789012345678901234567890123456789012345678901234567890123456789012
+
+               tdqcn(i,j,k,ntype-1)=-1.e40                      ! plus petite valeur possible 
+
+               if(ival1.eq.1.and.
+     &         tdqcn(i,j,k,1).ge.tdqcn(i,j,k,ntype-1)) ! Si activité de l'espece 1
+     &         tdqcn(i,j,k,ntype-1)=tdqcn(i,j,k,1)
+               if(ival2.eq.1.and.
+     &         tdqcn(i,j,k,2).ge.tdqcn(i,j,k,ntype-1)) ! Si activité de l'espece 2
+     &         tdqcn(i,j,k,ntype-1)=tdqcn(i,j,k,2)
+               if(ival3.eq.1.and.
+     &         tdqcn(i,j,k,3).ge.tdqcn(i,j,k,ntype-1)) ! Si activité de l'espece 3
+     &         tdqcn(i,j,k,ntype-1)=tdqcn(i,j,k,3)
+
+               if(tdqcn(i,j,k,ntype-1).le.-0.99e39) 
+     &         tdqcn(i,j,k,ntype-1)=0.
+
+               tdq(i,j,k,ntype-1)=1.e40                    ! plus grande valeur possible 
+
+               if(ival1.eq.1 .and. tdq(i,j,k,1).le.tdq(i,j,k,ntype-1)) ! Si activité de l'espece 1
+     &           tdq(i,j,k,ntype-1)=tdq(i,j,k,1)
+               if(ival2.eq.1 .and. tdq(i,j,k,2).le.tdq(i,j,k,ntype-1)) ! Si activité de l'espece 2
+     &           tdq(i,j,k,ntype-1)=tdq(i,j,k,2)
+               if(ival3.eq.1 .and. tdq(i,j,k,3).le.tdq(i,j,k,ntype-1)) ! Si activité de l'espece 3
+     &           tdq(i,j,k,ntype-1)=tdq(i,j,k,3)
+
+               if(tdq(i,j,k,ntype-1).ge.0.99e39) tdq(i,j,k,ntype-1)=0.
+
+                tqcn(i,j,k)=tqcn(i,j,k)+tdqcn(i,j,k,ntype-1)           ! Alors on ajoute les tendances (positive pour qcn ?)
+                tq(i,j,k)  =tq(i,j,k)  +tdq(i,j,k,ntype-1)             !
+
+                if(tqcn(i,j,k).le.0.) tqcn(i,j,k)=0.                   ! et on régularise les tableaux noyaux et aerosols.
+                if(tq(i,j,k)  .le.0.) tq(i,j,k)=0.                     !
+
+             enddo
+           enddo
+         enddo
+
+        continue
+
+1202    format(i2,1x,i2,6(1x,e12.4) )
+       return 
+       end
Index: trunk/LMDZ.TITAN/libf/phytitan/conf_phys.F90
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/conf_phys.F90	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/conf_phys.F90	(revision 175)
@@ -367,4 +367,12 @@
 
 !
+!Config Key  = p_prodaer
+!Config Desc = pressure level for aerosol production (in Pa)
+!Config Def  = 1.
+!Config Help =
+!
+  p_prodaer = 1.
+  call getin('p_prodaer',p_prodaer)
+!
 !Config Key  = cutoff
 !Config Desc =
@@ -375,4 +383,25 @@
   call getin('cutoff',cutoff)
 
+!
+!Config Key  = clouds
+!Config Desc = activation des nuages
+!Config Def  = 1
+!Config Help =
+!
+  clouds = 1
+  call getin('clouds',clouds)
+  if (microfi.ne.1) clouds = 0      ! On  ne fait pas de nuages sans microphysique !
+
+!
+!Config Key  = xnuf
+!Config Desc = fraction nuageuse
+!Config Def  = 0.5
+!Config Help =
+!
+  xnuf = 0.5
+  call getin('xnuf',xnuf)
+  xnuf = amax1(xnuf,0.1)          ! On garde au minimum 10% de nuages.
+  if (clouds.eq.0) xnuf = 0.      ! Si il n'y pas de nuages, on ne met pas de fraction
+                                  ! nuageuse -> permet de retomber sur le TR habituel.
 !
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -448,5 +477,8 @@
   write(numout,*)' tx = ', tx
   write(numout,*)' tcorrect = ', tcorrect
+  write(numout,*)' p_prodaer = ', p_prodaer
   write(numout,*)' cutoff = ', cutoff
+  write(numout,*)' clouds = ', clouds
+  write(numout,*)' xnuf = ', xnuf
   write(numout,*)' lev_histmth = ',lev_histmth
   write(numout,*)' lev_histday = ',lev_histday 
Index: trunk/LMDZ.TITAN/libf/phytitan/cooling.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/cooling.F	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/cooling.F	(revision 175)
@@ -1,3 +1,3 @@
-      SUBROUTINE COOLING(NL,PRESS,TEMP,Z,Q0,lwnet,pfluxi)
+      SUBROUTINE COOLING(NG,NL,PRESS,TEMP,Z,Q0,lwnet,pfluxi,icld)
 
 c=======================================================================
@@ -66,9 +66,9 @@
 c   ----------
 
-      INTEGER NL
-      REAL PRESS(ngrid,nl),TEMP(ngrid,nl)
-      REAL Z(ngrid,nl),Q0(ngrid,nl-1)
-      REAL lwnet(ngrid,nl),UBARI2
-      real pfluxi(ngrid)
+      INTEGER NG,NL,icld
+      REAL PRESS(NG,NL),TEMP(NG,NL)
+      REAL Z(NG,NL),Q0(NG,NL-1)
+      REAL lwnet(NG,NL),UBARI2
+      real pfluxi(NG)
 
 
@@ -77,6 +77,7 @@
 
 C DTAU IS PASSED EN-MASS, SO ITS DEMENSIONS ARE CRITICAL
-      COMMON /IRTAUS/ DTAUI(ngrid,NLAYER,NSPECI)
-      REAL dtaui
+      REAL dtaui(ngrid,NLAYER,NSPECI)
+      REAL dtauip(ngrid,NLAYER,NSPECI)
+      COMMON /IRTAUS/ dtaui,dtauip
 
 c   Local:
@@ -88,5 +89,5 @@
       REAL DW,WAVEN,TJ,BSURF,QOUT,QIN,eff_g,COLDEN
 
-      INTEGER ig,K,J,NLEVEL,I,L
+      INTEGER ig,K,J,I,L
 
 c     EXTERNAL PLNCK
@@ -139,5 +140,4 @@
       UBARI2=1./1.66
       UBARI2=UBARI
-      NLEVEL=NL
 
 C ZERO THE NET FLUXES
@@ -161,6 +161,6 @@
           B0 = 0.
 
-          DO J=1,NLEVEL-1
-             DO ig=1,ngrid
+          DO J=1,NL-1
+             DO ig=1,NG
                 TJ=TEMP(ig,J)
 
@@ -182,8 +182,15 @@
              ENDDO
 
-             DO ig=1,ngrid
-             zz4=EXP(-DTAUI(ig,J,K)/UBARI2)
-                EM(ig,J)=zz4
-            ENDDO
+             IF (ICLD.EQ.1) THEN
+               DO ig=1,NG
+                 zz4=EXP(-DTAUI(ig,J,K)/UBARI2)
+                 EM(ig,J)=zz4
+               ENDDO
+             ELSE
+               DO ig=1,NG
+                 zz4=EXP(-DTAUIP(ig,J,K)/UBARI2)
+                 EM(ig,J)=zz4
+               ENDDO
+             ENDIF
           ENDDO
 
@@ -197,6 +204,6 @@
            FUPIS=0.
 
-        DO 2220 J=1,NLEVEL-1
-           DO 2230 ig=1,ngrid
+        DO 2220 J=1,NL-1
+           DO 2230 ig=1,NG
               FDI(ig,J+1) = FDI(ig,J)*EM(ig,J) + 2.*RPI*UBARI*
      &        B0(ig,J)*(1.-EM(ig,J))
@@ -218,26 +225,26 @@
 C UPWARD FLUXES: SURFACE EMISSIONS
 
-        DO 2310 ig=1,ngrid
+        DO 2310 ig=1,NG
           PLNCK=0.
           DO I=-2,2,1
              WAVNUM=WAVEN + I*zz1
-             zz2=EXP(-1.4388 * WAVNUM/TEMP(ig,NLEVEL))
+             zz2=EXP(-1.4388 * WAVNUM/TEMP(ig,NL))
              zz3=WAVNUM*WAVNUM*WAVNUM
              PLNCK=PLNCK+1.191E-5* zz3*zz2/(1.-zz2)
           ENDDO
-c          BSURF=PLNCK( WAVEN, TEMP(ig,NLEVEL), DW)
+c          BSURF=PLNCK( WAVEN, TEMP(ig,NL), DW)
            BSURF=.2*PLNCK
-        FUPI(ig,NLEVEL)=BSURF * 2.*RPI*UBARI + RSFI*FDI(ig,NLEVEL)
-        FUPIS(ig,NLEVEL,K)=BSURF*2.*RPI*UBARI+RSFI*FDIS(ig,NLEVEL,K)
+        FUPI(ig,NL)=BSURF * 2.*RPI*UBARI + RSFI*FDI(ig,NL)
+        FUPIS(ig,NL,K)=BSURF*2.*RPI*UBARI+RSFI*FDIS(ig,NL,K)
 2310    CONTINUE
 c     write(*,*)
-c     write(*,*) 'cooling : FUPI/NLEVEL =' ,
-c    & ((FUPI(i,l),l=nl,nl),i=1,ngrid)
-c     write(*,*)
-c     write(*,*) 'cooling : FDI/NLEVEL =' ,
-c    & ((FDI(i,l),l=nl,nl),i=1,ngrid)
-
-        DO 2320 J=NLEVEL-1,1,-1
-           DO 2330 ig=1,ngrid
+c     write(*,*) 'cooling : FUPI/NL =' ,
+c    & ((FUPI(i,l),l=nl,nl),i=1,NG)
+c     write(*,*)
+c     write(*,*) 'cooling : FDI/NL =' ,
+c    & ((FDI(i,l),l=nl,nl),i=1,NG)
+
+        DO 2320 J=NL-1,1,-1
+           DO 2330 ig=1,NG
               FUPI(ig,J) = FUPI(ig,J+1)*EM(ig,J) + 2.*RPI*UBARI*
      &        B0(ig,J)*(1.-EM(ig,J))
@@ -258,18 +265,18 @@
 c compute the downward IR flux at the surface:
 c 
-          DO 3520 ig=1,ngrid
-             pfluxi(ig)=pfluxi(ig)+ DWNI(K)*FDI(ig,NLEVEL)
+          DO 3520 ig=1,NG
+             pfluxi(ig)=pfluxi(ig)+ DWNI(K)*FDI(ig,NL)
 3520      CONTINUE
 
 c compute the net IR flux, (+) upward:
 c 
-          DO J=1,NLEVEL
-          DO ig=1,ngrid
+          DO J=1,NL
+          DO ig=1,NG
              lwnet(ig,J)= lwnet(ig,J)+ DWNI(K)*(FUPI(ig,J)-FDI(ig,J))
           ENDDO
           ENDDO
 	  
-          DO 3210 J=1,NLEVEL-1
-             DO 3220 ig=1,ngrid
+          DO 3210 J=1,NL-1
+             DO 3220 ig=1,NG
                 QOUT=FUPI(ig,J) + FDI(ig,J+1)   ! OUT OF LAYER
                 QIN =FDI(ig,J)  + FUPI(ig,J+1)  ! INTO LAYER
@@ -297,5 +304,5 @@
 
 c   convertion erg/cm2 -> J/m2
-      DO 3550 ig=1,ngrid
+      DO 3550 ig=1,NG
          pfluxi(ig)  = 1.e-3*pfluxi(ig)
 	 lwnet(ig,:) = 1.e-3*lwnet(ig,:)
@@ -307,7 +314,7 @@
 C COMPUTE THE BASELINE COOLING RATE
 
-       DO 3000 J=1,NLEVEL-1
+       DO 3000 J=1,NL-1
 C TURN THE Q'S INTO TIMESCALES.....
-          DO 3300 ig=1,ngrid
+          DO 3300 ig=1,NG
              eff_g = RG*(RA/(RA+Z(ig,J)))**2 ! 10% DIFF AT 1 MBAR
              COLDEN = RHOP*(PRESS(ig,J+1)-PRESS(ig,J))/eff_g
Index: trunk/LMDZ.TITAN/libf/phytitan/diagmuphy.h
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/diagmuphy.h	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/diagmuphy.h	(revision 175)
@@ -0,0 +1,35 @@
+!     Ce header contient toutes les variables
+!     diagnostiques sorties de la microphysique.
+!
+!  ASTUCE POUR EVITER klon... EN ATTENDANT MIEUX
+      INTEGER   ngd
+      PARAMETER (ngd=(jjm-1)*iim+2)  ! = klon
+!
+! ---- flux de glace (1:CH4 / 2:C2H6 / 3:C2H2)
+       REAL flxesp_i(ngd,llm,3)
+! ---- taux sedimentation gouttes
+       REAL tau_drop(ngd,llm)
+! ---- taux sedimentation aerosols sec
+       REAL tau_aer(ngd,llm,nrad)
+! ---- Production de glace (negatif si disparition)
+       REAL solesp(ngd,llm+1,3)
+! ---- occurences des nuages
+       REAL occcld_m(ngd,llm,12) 
+! ---- occcld sert a obtenir les opacités/extinction des nuages (proxy)
+       REAL occcld(ngd,llm)
+! ---- saturation CH4 
+       REAL satch4(ngd,llm)
+! ---- saturation C2H6
+       REAL satc2h6(ngd,llm)
+! ---- saturation C2H2 
+       REAL satc2h2(ngd,llm)
+! ---- precipitations (CH4, C2H6, C2H2, noyaux, aerosols)
+       REAL prec(ngd,5)
+! ---- rayon moyen des gouttes
+       REAL rmcloud(ngd,llm)
+    
+       common/diagmuphy/flxesp_i,tau_drop,tau_aer,                      &
+     &                  solesp,occcld_m,occcld,                         &
+     &                  satch4,satc2h6,satc2h2,                         &
+     &                  prec,rmcloud
+
Index: trunk/LMDZ.TITAN/libf/phytitan/effg.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/effg.F	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/effg.F	(revision 175)
@@ -1,6 +1,5 @@
       FUNCTION EFFG(Z)
-      DATA G/1.35/
-      DATA RPLANT/2575./
-      EFFG = G * (RPLANT/(RPLANT + Z ) )**2
+#include "YOMCST.h"
+      EFFG = RG * (RA/(RA + Z ) )**2
       RETURN
       END
Index: trunk/LMDZ.TITAN/libf/phytitan/getimes.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/getimes.F	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/getimes.F	(revision 175)
@@ -0,0 +1,128 @@
+c==========================================================
+c                       getimes.F
+c==========================================================
+c    Pack de routines pour calculer des temps d'execution.
+c
+c    UTILISATION :
+c    L'appel a la routine initimes() doit se faire en 
+c    début de programme.
+c    Pour calculer le temps d'execution d'une portion de
+c    code il suffit de placer la routine begintime devant
+c    la portion et la routine endtime après la portion.
+c
+c    L'argument tps de la routine endtime retourne le 
+c    temps d'execution en seconde de la portion de code.
+c==========================================================
+
+**************************************************
+*  routine begintime                             *
+*  Retourne dans la variable nb_ini, le nombre de*
+*  cycle au moment de l'appel a begintime.       *
+*                                                *
+*  ARGUMENTS :                                   *
+*  nb_ini (output) : nombre de cycle au lancement*
+*                    de la routine.              *
+**************************************************
+      subroutine begintime(nb_ini)
+        integer nb_ini
+        CALL SYSTEM_CLOCK(COUNT=nb_ini)
+        return
+      end
+
+
+**************************************************
+*  routine endtime                               *
+*  Retourne dans la variable tps, le temps entre *
+*  l'appel a begintime et endtime.               *
+*                                                *
+*  ARGUMENTS :                                   *
+*  nb_ini (input) : nombre de cycle au lancement *
+*                   de la routine begintime      *
+*  tps (output)   : temps en secondes ecoules    *
+*                   entre begintime et endtime   *
+**************************************************
+       subroutine endtime(nb_ini,tps)
+       implicit none
+         integer nb_max,nb_sec
+         common/horloge/nb_max,nb_sec
+         integer nb_ini
+         integer nb_fin,tmp
+         real tps
+         CALL SYSTEM_CLOCK(COUNT=nb_fin)
+         tmp =nb_fin-nb_ini
+         if (nb_fin.lt.nb_ini) tmp=tmp+nb_max
+         tps = FLOAT(tmp)/ nb_sec
+         return
+       end
+
+**************************************************
+*  routine initimes                              *
+*  Initialise le compteur                        *
+*  Cette routine doit se positionnee en debut de *
+*  programme                                     *
+**************************************************
+       subroutine initimes()
+#include "itemps.h"
+         integer nb_max,nb_sec
+         common/horloge/nb_max,nb_sec
+         CALL SYSTEM_CLOCK(COUNT_RATE=nb_sec,
+     &                      COUNT_MAX=nb_max)
+*        initialisation variables de stockage
+         ttdynt   = 0.
+         ttadvtr  = 0.
+         ttphys   = 0.
+         ttmuphys = 0.
+         tthaze   = 0.         
+         ttcclds  = 0.
+         ttsclds  = 0.
+         ttrad    = 0.
+         ttphytra = 0.
+         
+         return
+       end
+
+
+**************************************************
+*  routine printimes                             *
+*  affiche des temps d'execution.                *
+*  iout : sortie dans un fichier.                *
+*   iout = 0 ---> sortie ecran                   *
+*   iout = 1 ---> sortie dans temps.out          *
+**************************************************
+       subroutine printimes(iout)
+#include "itemps.h"
+         integer iunit
+         logical ok
+         ok = .true.
+         iunit = 9
+         if (iout.eq.0) then
+           iunit = 6
+         else
+           do while (ok)
+             iunit = iunit+1
+             inquire(unit=iunit,OPENED=ok)
+             if (iunit.eq.100) exit
+           enddo
+             if (iunit.eq.100) then
+               print*,"Je n'ai pas trouve d'unite logique libre."
+               print*,"J'affiche les temps a l'ecran."
+               iunit = 6
+             endif
+         endif 
+         if (iunit.ne.6) open(iunit,file="tpsprog")
+         write(iunit,*) "#############################################"
+         write(iunit,*) "ttdynt        :",ttdynt
+         write(iunit,*) "  ttdyn       :",ttdynt-ttphys
+         write(iunit,*) "  ttadvtr     :",ttdyntr
+         write(iunit,*) "  ttphys      :",ttphys
+         write(iunit,*) "    ttrad     :",tthaze
+         write(iunit,*) "    ttphytra  :",ttphytra
+         write(iunit,*) "    ttmuphys  :",ttmuphys
+         write(iunit,*) "      tthaze  :",tthaze
+         write(iunit,*) "      ttcclds :",ttcclds
+         write(iunit,*) "      ttsclds :",ttsclds
+         write(iunit,*) "#############################################"
+         if (iunit.ne.6) close(iunit)
+         return
+       end
+
Index: trunk/LMDZ.TITAN/libf/phytitan/heating.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/heating.F	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/heating.F	(revision 175)
@@ -1,3 +1,3 @@
-       SUBROUTINE heating(dist,rmu0,fract,sol_htg,swnet)
+       SUBROUTINE heating(dist,rmu0,fract,sol_htg,swnet,icld)
 
 
@@ -16,4 +16,5 @@
 c rmu0-----input-R- cosinus de l'angle zenithal
 c fract----input-R- duree d'ensoleillement normalisee
+c icld-----input-I- calcul avec nuages.
 c        p(klon,nl)    pressure (level)
 c
@@ -46,4 +47,5 @@
 
       real dist, rmu0(klon), fract(klon)
+      integer icld
 
       real sol_htg(klon,klev)
@@ -96,5 +98,5 @@
                ubar0=rmu0(ig)
 
-               CALL sfluxv(iprint,ig,dist)           ! #3
+               CALL sfluxv(iprint,ig,dist,icld)           ! #3
 
                fnetv(ig,:) = fnetv(ig,:) *fract(ig)   ! >0 vers le haut
Index: trunk/LMDZ.TITAN/libf/phytitan/ini_histday.h
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/ini_histday.h	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/ini_histday.h	(revision 175)
@@ -1,5 +1,2 @@
-!
-! $Header: /home/cvsroot/LMDZ4/libf/phylmd/ini_histday.h,v 1.2 2005/01/27 10:06:12 fairhead Exp $
-!
       IF (ok_journe) THEN
 c
@@ -104,19 +101,76 @@
      .                "ave(X)", zsto,zout)
 c
-      ENDIF !lev_histday.GE.2
-c
-c-------------------------------------------------------
-      IF(lev_histday.GE.3) THEN
-c
 cccccccccccccccccc  Tracers
 c
          if (iflag_trac.eq.1) THEN
-          if (microfi.eq.1) then
-           DO iq=1,nmicro
-         CALL histdef(nid_day, tname(iq), ttext(iq), "n/m2",
-     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
-     .                "ave(X)", zsto,zout)
-           ENDDO
+          if (microfi.ge.1) then
+c           DO iq=1,nmicro
+c             CALL histdef(nid_day, tname(iq), ttext(iq), "n/m2",
+c     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+c     .                "ave(X)", zsto,zout)
+c           ENDDO
+             CALL histdef(nid_day, "qaer","nb tot aer" , "n/m2",
+     .                    iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                    "ave(X)", zsto,zout)
+             CALL histdef(nid_day, "qnoy","nb tot noy" , "n/m2",
+     .                    iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                    "ave(X)", zsto,zout)
+             CALL histdef(nid_day, "qgl1","V tot gl1" , "m3/m2",
+     .                    iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                    "ave(X)", zsto,zout)
+             CALL histdef(nid_day, "qgl2","V tot gl2" , "m3/m2",
+     .                    iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                    "ave(X)", zsto,zout)
+             CALL histdef(nid_day, "qgl3","V tot gl3" , "m3/m2",
+     .                    iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                    "ave(X)", zsto,zout)
+c--------------
+c ----- SATURATION ESP NUAGES
+             if (clouds.eq.1) then
+               CALL histdef(nid_day,"ch4sat", "saturation CH4", "--",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+               CALL histdef(nid_day,"c2h6sat", "saturation C2H6", "--",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+               CALL histdef(nid_day,"c2h2sat", "saturation C2H2", "--",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c --------------
+c ----- RESERVOIR DE SURFACE
+               CALL histdef(nid_day, "reserv", "Reservoir surface","m",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c --------------
+c ----- PRECIPITATIONS (precipitations cumulatives)
+               CALL histdef(nid_day,"prech4","Precip CH4","m",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+               CALL histdef(nid_day,"prec2h6","Precip C2H6",
+     .                "m",iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+               CALL histdef(nid_day,"prec2h2","Precip C2H2",
+     .                "m",iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c --------------
+c ----- FLUX GLACE
+               CALL histdef(nid_day,"flxgl1", "flux gl CH4",
+     .              "kg/m2/s",iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .              "ave(X)", zsto,zout)
+               CALL histdef(nid_day,"flxgl2", "flux gl C2H6",
+     .              "kg/m2/s",iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .              "ave(X)", zsto,zout)
+               CALL histdef(nid_day,"flxgl3", "flux gl C2H2",
+     .              "kg/m2/s",iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .              "ave(X)", zsto,zout)
+c --------------
+c ----- RAYON DES GOUTTES
+               CALL histdef(nid_day,"rcldbar", "rayon moyen goutte",
+     .                "m",iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+             endif
 	  endif
+c --------------
+c ----- TRACEURS CHIMIQUES
 	  if (nmicro.lt.nqmax) then
            DO iq=nmicro+1,nqmax
@@ -128,4 +182,9 @@
          endif
 c
+      ENDIF !lev_histday.GE.2
+c
+c-------------------------------------------------------
+      IF(lev_histday.GE.3) THEN
+c
 cccccccccccccccccc  Radiative transfer
 c
@@ -154,4 +213,6 @@
      .                32, "ave(X)", zsto1,zout)
 c
+c --------------
+c ----- OPACITE BRUME
          DO k=7,NSPECV,10
            write(str1,'(i2.2)') k
@@ -161,4 +222,13 @@
          ENDDO
 c
+         DO k=8,NSPECI,10
+           write(str1,'(i2.2)') k
+         CALL histdef(nid_day,"thi"//str1,"Haze Opa IR",
+     .                "--",iim,jjmp1,nhori,klev,1,klev,nvert,32,
+     .                "ave(X)",zsto1,zout)
+         ENDDO
+c
+c --------------
+c ----- EXTINCTION BRUME
          DO k=7,NSPECV,10
            write(str1,'(i2.2)') k
@@ -168,14 +238,32 @@
          ENDDO
 c
+         DO k=8,NSPECI,10
+           write(str1,'(i2.2)') k
+         CALL histdef(nid_day,"khi"//str1,"Haze ext IR ",
+     .                "m-1",iim,jjmp1,nhori,klev,1,klev,nvert,32,
+     .                "ave(X)",zsto1,zout)
+         ENDDO
+c
+c --------------
+c ----- OPACITE GAZ
          DO k=7,NSPECV,10
            write(str1,'(i2.2)') k
-         CALL histdef(nid_day,"tgv"//str1,"Haze Opa Vis",
-     .                "--",iim,jjmp1,nhori,klev,1,klev,nvert,32,
-     .                "ave(X)",zsto1,zout)
-         ENDDO
-c
+         CALL histdef(nid_day,"tgv"//str1,"Gas Opa Vis",
+     .                "--",iim,jjmp1,nhori,klev,1,klev,nvert,32,
+     .                "ave(X)",zsto1,zout)
+         ENDDO
+c
+         DO k=8,NSPECI,10
+           write(str1,'(i2.2)') k
+         CALL histdef(nid_day,"tgi"//str1,"Gas Opa IR",
+     .                "--",iim,jjmp1,nhori,klev,1,klev,nvert,32,
+     .                "ave(X)",zsto1,zout)
+         ENDDO
+c
+c --------------
+c ----- EXTINCTION GAZ
          DO k=7,NSPECV,10
            write(str1,'(i2.2)') k
-         CALL histdef(nid_day,"kgv"//str1,"Haze ext Vis ",
+         CALL histdef(nid_day,"kgv"//str1,"Gas ext Vis ",
      .                "m-1",iim,jjmp1,nhori,klev,1,klev,nvert,32,
      .                "ave(X)",zsto1,zout)
@@ -184,29 +272,22 @@
          DO k=8,NSPECI,10
            write(str1,'(i2.2)') k
-         CALL histdef(nid_day,"thi"//str1,"Haze Opa IR",
-     .                "--",iim,jjmp1,nhori,klev,1,klev,nvert,32,
-     .                "ave(X)",zsto1,zout)
-         ENDDO
-c
-         DO k=8,NSPECI,10
-           write(str1,'(i2.2)') k
-         CALL histdef(nid_day,"khi"//str1,"Haze ext IR ",
-     .                "m-1",iim,jjmp1,nhori,klev,1,klev,nvert,32,
-     .                "ave(X)",zsto1,zout)
-         ENDDO
-c
-         DO k=8,NSPECI,10
-           write(str1,'(i2.2)') k
-         CALL histdef(nid_day,"tgi"//str1,"Haze Opa IR",
-     .                "--",iim,jjmp1,nhori,klev,1,klev,nvert,32,
-     .                "ave(X)",zsto1,zout)
-         ENDDO
-c
-         DO k=8,NSPECI,10
-           write(str1,'(i2.2)') k
-         CALL histdef(nid_day,"kgi"//str1,"Haze ext IR ",
-     .                "m-1",iim,jjmp1,nhori,klev,1,klev,nvert,32,
-     .                "ave(X)",zsto1,zout)
-         ENDDO
+         CALL histdef(nid_day,"kgi"//str1,"Gas ext IR ",
+     .                "m-1",iim,jjmp1,nhori,klev,1,klev,nvert,32,
+     .                "ave(X)",zsto1,zout)
+         ENDDO
+c
+c --------------
+c ----- OPACITE NUAGES
+         if (clouds.eq.1) then
+           CALL histdef(nid_day,"tcld","Cld Opa proxy",
+     .                "--",iim,jjmp1,nhori,klev,1,klev,nvert,32,
+     .                "ave(X)",zsto,zout)
+c
+c --------------
+c ----- EXTINCTION NUAGES
+           CALL histdef(nid_day,"kcld","Cld Ext proxy",
+     .                "m-1",iim,jjmp1,nhori,klev,1,klev,nvert,32,
+     .                "ave(X)",zsto,zout)
+         endif
 c
       ENDIF !lev_histday.GE.3
Index: trunk/LMDZ.TITAN/libf/phytitan/ini_histins.h
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/ini_histins.h	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/ini_histins.h	(revision 175)
@@ -1,5 +1,2 @@
-!
-! $Header: /home/cvsroot/LMDZ4/libf/phylmd/ini_histins.h,v 1.1.1.1 2004/05/19 12:53:08 lmdzadmin Exp $
-!
       IF (ok_instan) THEN
 c
@@ -112,9 +109,9 @@
 c
          if (iflag_trac.eq.1) THEN
-          if (microfi.eq.1) then
+          if (microfi.ge.1) then
            DO iq=1,nmicro
          CALL histdef(nid_ins, tname(iq), ttext(iq), "n/m2",
      .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
-     .                "ins(X)", zsto,zout)
+     .                "inst(X)", zsto,zout)
            ENDDO
 	  endif
@@ -123,5 +120,5 @@
          CALL histdef(nid_ins, tname(iq), ttext(iq), "ppm",
      .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
-     .                "ins(X)", zsto,zout)
+     .                "inst(X)", zsto,zout)
            ENDDO
 	  endif
@@ -154,4 +151,6 @@
      .                32, "inst(X)", zsto,zout)
 c
+c --------------
+c ----- OPACITE BRUME
          DO k=7,NSPECV,10
            write(str1,'(i2.2)') k
@@ -161,4 +160,13 @@
          ENDDO
 c
+         DO k=8,NSPECI,10
+           write(str1,'(i2.2)') k
+         CALL histdef(nid_ins,"thi"//str1,"Haze Opa IR",
+     .                "--",iim,jjmp1,nhori,klev,1,klev,nvert,32,
+     .                "ins(X)",zsto,zout)
+         ENDDO
+c
+c --------------
+c ----- EXTINCTION BRUME
          DO k=7,NSPECV,10
            write(str1,'(i2.2)') k
@@ -168,4 +176,13 @@
          ENDDO
 c
+         DO k=8,NSPECI,10
+           write(str1,'(i2.2)') k
+         CALL histdef(nid_ins,"khi"//str1,"Haze ext IR ",
+     .                "m-1",iim,jjmp1,nhori,klev,1,klev,nvert,32,
+     .                "ins(X)",zsto,zout)
+         ENDDO
+c
+c --------------
+c ----- OPACITE GAZ
          DO k=7,NSPECV,10
            write(str1,'(i2.2)') k
@@ -175,29 +192,17 @@
          ENDDO
 c
+         DO k=8,NSPECI,10
+           write(str1,'(i2.2)') k
+         CALL histdef(nid_ins,"tgi"//str1,"Haze Opa IR",
+     .                "--",iim,jjmp1,nhori,klev,1,klev,nvert,32,
+     .                "ins(X)",zsto,zout)
+         ENDDO
+c
+c --------------
+c ----- EXTINCTION GAZ
          DO k=7,NSPECV,10
            write(str1,'(i2.2)') k
          CALL histdef(nid_ins,"kgv"//str1,"Haze ext Vis ",
      .                "m-1",iim,jjmp1,nhori,klev,1,klev,nvert,32,
-     .                "ins(X)",zsto,zout)
-         ENDDO
-c
-         DO k=8,NSPECI,10
-           write(str1,'(i2.2)') k
-         CALL histdef(nid_ins,"thi"//str1,"Haze Opa IR",
-     .                "--",iim,jjmp1,nhori,klev,1,klev,nvert,32,
-     .                "ins(X)",zsto,zout)
-         ENDDO
-c
-         DO k=8,NSPECI,10
-           write(str1,'(i2.2)') k
-         CALL histdef(nid_ins,"khi"//str1,"Haze ext IR ",
-     .                "m-1",iim,jjmp1,nhori,klev,1,klev,nvert,32,
-     .                "ins(X)",zsto,zout)
-         ENDDO
-c
-         DO k=8,NSPECI,10
-           write(str1,'(i2.2)') k
-         CALL histdef(nid_ins,"tgi"//str1,"Haze Opa IR",
-     .                "--",iim,jjmp1,nhori,klev,1,klev,nvert,32,
      .                "ins(X)",zsto,zout)
          ENDDO
Index: trunk/LMDZ.TITAN/libf/phytitan/ini_histmth.h
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/ini_histmth.h	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/ini_histmth.h	(revision 175)
@@ -105,13 +105,83 @@
      .                "ave(X)", zsto1,zout)
 c
+cccccccccccccccccc  Tracers
+c
          if (iflag_trac.eq.1) THEN
-c         if (microfi.eq.1) then
-c          DO iq=1,nmicro
-c        CALL histdef(nid_mth, tname(iq), ttext(iq), "n/m2",
-c    .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
-c    .                "ave(X)", zsto,zout)
-c          ENDDO
-c         endif
-          if (nmicro.lt.nqmax) then
+          if (microfi.ge.1) then
+c           DO iq=1,nmicro
+c             CALL histdef(nid_mth, tname(iq), ttext(iq), "n/m2",
+c     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+c     .                "ave(X)", zsto,zout)
+c           ENDDO
+             CALL histdef(nid_mth, "qaer","nb tot aer" , "n/m2",
+     .                    iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                    "ave(X)", zsto,zout)
+             CALL histdef(nid_mth, "qnoy","nb tot noy" , "n/m2",
+     .                    iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                    "ave(X)", zsto,zout)
+             CALL histdef(nid_mth, "qgl1","V tot gl1" , "m3/m2",
+     .                    iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                    "ave(X)", zsto,zout)
+             CALL histdef(nid_mth, "qgl2","V tot gl2" , "m3/m2",
+     .                    iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                    "ave(X)", zsto,zout)
+             CALL histdef(nid_mth, "qgl3","V tot gl3" , "m3/m2",
+     .                    iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                    "ave(X)", zsto,zout)
+c--------------
+c ----- SATURATION ESP NUAGES
+             if (clouds.eq.1) then
+               CALL histdef(nid_mth,"ch4sat", "saturation CH4", "--",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+               CALL histdef(nid_mth,"c2h6sat", "saturation C2H6", "--",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+               CALL histdef(nid_mth,"c2h2sat", "saturation C2H2", "--",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c --------------
+c ----- RESERVOIR DE SURFACE
+               CALL histdef(nid_mth, "reserv", "Reservoir surface","m",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c --------------
+c ----- PRECIPITATIONS (precipitations cumulatives)
+               CALL histdef(nid_mth,"prech4","Precip CH4","m",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+               CALL histdef(nid_mth,"prec2h6","Precip C2H6",
+     .                "m",iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+               CALL histdef(nid_mth,"prec2h2","Precip C2H2",
+     .                "m",iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+               CALL histdef(nid_mth,"prenoy","Precip NOY",
+     .                "m",iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+               CALL histdef(nid_mth,"preaer","Precip AER",
+     .                "m",iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c --------------
+c ----- FLUX GLACE
+               CALL histdef(nid_mth,"flxgl1", "flux gl CH4",
+     .              "kg/m2/s",iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .              "ave(X)", zsto,zout)
+               CALL histdef(nid_mth,"flxgl2", "flux gl C2H6",
+     .              "kg/m2/s",iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .              "ave(X)", zsto,zout)
+               CALL histdef(nid_mth,"flxgl3", "flux gl C2H2",
+     .              "kg/m2/s",iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .              "ave(X)", zsto,zout)
+c --------------
+c ----- RAYON DES GOUTTES
+               CALL histdef(nid_mth,"rcldbar", "rayon moyen goutte",
+     .                "m",iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+             endif
+	  endif
+c --------------
+c ----- TRACEURS CHIMIQUES
+	  if (nmicro.lt.nqmax) then
            DO iq=nmicro+1,nqmax
          CALL histdef(nid_mth, tname(iq), ttext(iq), "ppm",
@@ -125,5 +195,5 @@
 c    .                "ave(X)", zsto,zout)
 c          ENDDO
-          endif
+	  endif
          endif
 c
@@ -159,4 +229,6 @@
      .                32, "ave(X)", zsto1,zout)
 c
+c --------------
+c ----- OPACITE BRUME
          DO k=7,NSPECV,10
            write(str1,'(i2.2)') k
@@ -166,4 +238,13 @@
          ENDDO
 c
+         DO k=8,NSPECI,10
+           write(str1,'(i2.2)') k
+         CALL histdef(nid_mth,"thi"//str1,"Haze Opa IR",
+     .                "--",iim,jjmp1,nhori,klev,1,klev,nvert,32,
+     .                "ave(X)",zsto1,zout)
+         ENDDO
+c
+c --------------
+c ----- EXTINCTION BRUME
          DO k=7,NSPECV,10
            write(str1,'(i2.2)') k
@@ -173,14 +254,32 @@
          ENDDO
 c
+         DO k=8,NSPECI,10
+           write(str1,'(i2.2)') k
+         CALL histdef(nid_mth,"khi"//str1,"Haze ext IR ",
+     .                "m-1",iim,jjmp1,nhori,klev,1,klev,nvert,32,
+     .                "ave(X)",zsto1,zout)
+         ENDDO
+c
+c --------------
+c ----- OPACITE GAZ
          DO k=7,NSPECV,10
            write(str1,'(i2.2)') k
-         CALL histdef(nid_mth,"tgv"//str1,"Haze Opa Vis",
-     .                "--",iim,jjmp1,nhori,klev,1,klev,nvert,32,
-     .                "ave(X)",zsto1,zout)
-         ENDDO
-c
+         CALL histdef(nid_mth,"tgv"//str1,"Gas Opa Vis",
+     .                "--",iim,jjmp1,nhori,klev,1,klev,nvert,32,
+     .                "ave(X)",zsto1,zout)
+         ENDDO
+c
+         DO k=8,NSPECI,10
+           write(str1,'(i2.2)') k
+         CALL histdef(nid_mth,"tgi"//str1,"Haze Opa IR",
+     .                "--",iim,jjmp1,nhori,klev,1,klev,nvert,32,
+     .                "ave(X)",zsto1,zout)
+         ENDDO
+c
+c --------------
+c ----- EXTINCTION GAZ
          DO k=7,NSPECV,10
            write(str1,'(i2.2)') k
-         CALL histdef(nid_mth,"kgv"//str1,"Haze ext Vis ",
+         CALL histdef(nid_mth,"kgv"//str1,"Gas ext Vis ",
      .                "m-1",iim,jjmp1,nhori,klev,1,klev,nvert,32,
      .                "ave(X)",zsto1,zout)
@@ -189,29 +288,31 @@
          DO k=8,NSPECI,10
            write(str1,'(i2.2)') k
-         CALL histdef(nid_mth,"thi"//str1,"Haze Opa IR",
-     .                "--",iim,jjmp1,nhori,klev,1,klev,nvert,32,
-     .                "ave(X)",zsto1,zout)
-         ENDDO
-c
-         DO k=8,NSPECI,10
-           write(str1,'(i2.2)') k
-         CALL histdef(nid_mth,"khi"//str1,"Haze ext IR ",
-     .                "m-1",iim,jjmp1,nhori,klev,1,klev,nvert,32,
-     .                "ave(X)",zsto1,zout)
-         ENDDO
-c
-         DO k=8,NSPECI,10
-           write(str1,'(i2.2)') k
-         CALL histdef(nid_mth,"tgi"//str1,"Haze Opa IR",
-     .                "--",iim,jjmp1,nhori,klev,1,klev,nvert,32,
-     .                "ave(X)",zsto1,zout)
-         ENDDO
-c
-         DO k=8,NSPECI,10
-           write(str1,'(i2.2)') k
-         CALL histdef(nid_mth,"kgi"//str1,"Haze ext IR ",
-     .                "m-1",iim,jjmp1,nhori,klev,1,klev,nvert,32,
-     .                "ave(X)",zsto1,zout)
-         ENDDO
+         CALL histdef(nid_mth,"kgi"//str1,"Gas ext IR ",
+     .                "m-1",iim,jjmp1,nhori,klev,1,klev,nvert,32,
+     .                "ave(X)",zsto1,zout)
+         ENDDO
+c
+c --------------
+c ----- OPACITE NUAGES
+         if (clouds.eq.1) then
+           CALL histdef(nid_mth,"tcld","Cld Opa proxy",
+     .                "--",iim,jjmp1,nhori,klev,1,klev,nvert,32,
+     .                "ave(X)",zsto,zout)
+c
+c --------------
+c ----- EXTINCTION NUAGES
+           CALL histdef(nid_mth,"kcld","Cld Ext proxy",
+     .                "m-1",iim,jjmp1,nhori,klev,1,klev,nvert,32,
+     .                "ave(X)",zsto,zout)
+         endif
+c
+c --------------
+c ----- OCCURENCE NUAGES
+           do k=1,12
+             write(str1,'(i2.2)') k
+             CALL histdef(nid_mth,"occcld"//str1,"occ cld",
+     .       "--",iim,jjmp1,nhori,klev,1,klev,nvert,32,
+     .       "ave(X)",zsto,zout)
+           enddo
 c
       ENDIF !lev_histmth.GE.3
Index: trunk/LMDZ.TITAN/libf/phytitan/inimuphy3D.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/inimuphy3D.F	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/inimuphy3D.F	(revision 175)
@@ -0,0 +1,118 @@
+
+************************************************************************
+*      inimphycst()
+*      initialise les constante utilisée dans la microphysique.
+*
+*      Oui je sais certaine constantes, voir toutes les definitions
+*      faites ici devraient etre dans YOMCST.h mais la j'ai pas le 
+*      courage pour le moment !
+************************************************************************
+       subroutine inimphycst()
+       implicit none
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+#include "YOMCST.h"
+
+         pi = RPI
+
+         nav = RNAVO
+         rgp = R
+         kbz = RKBOL
+
+         rtit = RA
+         g0   = RG
+
+         mch4  = 16.e-3      ! kg/mol !!!!
+         mc2h6 = 30.e-3
+         mc2h2 = 26.e-3
+         mar   = 36.4e-3
+         mn2   = 28.e-3
+         mair  = 28.e-3      ! l'air c'est du N2 ^^
+  
+         rhol      = 1.e+3     ! rho aerosols
+         rhoi_ch4  = 425.
+         rhoi_c2h6 = 544.6
+         rhoi_c2h2 = 615.0 
+
+         mtetach4  = 0.92
+         mtetac2h6 = 0.92
+         mtetac2h2 = 0.92
+
+         return
+       end
+************************************************************************
+*      Routine calculant/initialisant la grille verticale
+*      ainsi que tous les variables communes aux routines microphysique.
+*
+*      CONVENTION :
+*      suffixe b    : bord des couches.
+*      SANS suffixe : centre des couches.
+************************************************************************
+       subroutine inimuphy(ihor,tplev,tplay,tzlev,tzlay,tpt)
+       implicit none
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+*
+*      INPUT :
+*
+       integer ihor
+       real tplev(nz+1),tplay(nz),tzlev(nz+1),tzlay(nz),tpt(nz)
+*
+*      LOCAL
+*
+       integer i,j
+       real plev(nz+1),play(nz),zlev(nz+1),zlay(nz),pt(nz)
+
+
+       if (nz.ne.llm) then
+         print*,"<nz.ne.llm> dans inimuphys !"
+         STOP
+       endif
+
+*-----------------------
+*      INVERSION DES TABLEAUX
+*-----------------------
+
+      do j=1,nz+1 
+        plev(j)=tplev(nz-j+2)
+        zlev(j)=tzlev(nz-j+2)
+      enddo
+      do j=1,nz
+        play(j)=tplay(nz-j+1)
+        zlay(j)=tzlay(nz-j+1)
+        pt(j) = tpt(nz-j+1)
+      enddo
+*
+*      Calcul de la grille verticale :
+*      z,dz,zb,dzb
+*      
+       do i=1,nz-1         
+         dz(i)=zlay(i)-zlay(i+1)
+         dzb(i)=zlev(i)-zlev(i+1)
+       enddo
+       dz(nz)=dz(nz-1)                 ! ARBITRAIRE  
+       dzb(nz)=zlev(nz)-zlev(nz+1)
+       z=zlay
+       zb=zlev
+       p=play
+       pb=plev
+
+*
+*      conditions speciale pour le dernier niveau de pression
+*      on crée un niveau tres tres tres fin mais qui existe quand meme !)
+       pb(1) = plev(2)*1.e-7
+
+
+c Interpolation de tb a partir de t
+c*******************************************************
+       t=pt
+       do i=1,nz-1
+         tb(i+1)=(t(i)+t(i+1))/2.  
+       enddo
+       tb(1)=t(1)
+       tb(nz+1)=(t(nz)-t(nz-1))*.5+t(nz)
+
+         return
+       end
Index: trunk/LMDZ.TITAN/libf/phytitan/itemps.h
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/itemps.h	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/itemps.h	(revision 175)
@@ -0,0 +1,25 @@
+!--------------------------------------------------------------------c
+!      itemps.h : variable de temps d'executions.                    c
+!--------------------------------------------------------------------c
+       real ttphys           ! tps exec de la physique 
+       real ttmuphys         ! tps exec de la microphysique
+       real tthaze           ! tps exec de la brume
+       real ttcclds          ! tps exec CONDENSATION nuages
+       real ttsclds          ! tps exec SEDIMENTATION nuages
+       real ttdynt           ! tps exec dyn tout confondu (comprend physique)
+       real ttphytra         ! tps exec phytrac
+       real ttrad            ! tps exec TR
+       real ttadvtr          ! tps exec advection des traceurs dans la dynamique
+
+       common /itimes/ttdynt,ttphys,ttphytra,ttrad,                     &
+     &                ttmuphys,tthaze,ttcclds,ttsclds,ttadvtr
+
+
+! ---- variables locales a chaque routines utilisant itemps.h
+       real tt0        ! tps de demarage de la routine 
+       real ttt0       ! tps de demarage de la routine 
+       real tttt0       ! tps de demarage de la routine 
+       real tt1        ! tps d'EXECUTION de la routine.
+       real ttt1       ! tps d'EXECUTION de la routine.
+       real tttt1       ! tps d'EXECUTION de la routine.
+   
Index: trunk/LMDZ.TITAN/libf/phytitan/liqc2h6.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/liqc2h6.F	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/liqc2h6.F	(revision 175)
@@ -0,0 +1,103 @@
+      SUBROUTINE LIQC2H6(WAVELN,XNR,XNI)
+
+*
+*
+* PERS. COMM E. QUIRICO ; eric.quirico@obs.ujf-grenoble.fr
+*
+*
+      DIMENSION W(154),XN(154),XK(154)
+        data W/
+     & 1000.  ,13.7832,12.5514,11.7883,11.1533,10.5841,10.0702,
+     & 9.6039, 9.1789, 8.7899, 8.4325, 8.1031, 7.7984, 7.5158,
+     & 7.2530, 7.0079, 6.7789, 6.5643, 6.3629, 6.1383, 5.8776,
+     & 5.6862, 5.3808, 4.4945, 3.8012, 3.6938, 3.6004, 3.5311,
+     & 3.4720, 3.4149, 3.3595, 3.3060, 3.2541, 3.2038, 3.1551,
+     & 3.1078, 3.0620, 3.0167, 2.9724, 2.9286, 2.8869, 2.8469,
+     & 2.8075, 2.7699, 2.7360, 2.7037, 2.6689, 2.6345, 2.5991,
+     & 2.5653, 2.5339, 2.5033, 2.4734, 2.4443, 2.4158, 2.3880,
+     & 2.3608, 2.3343, 2.3083, 2.2829, 2.2580, 2.2337, 2.2099,
+     & 2.1866, 2.1638, 2.1373, 2.1135, 2.0920, 2.0707, 2.0502,
+     & 2.0301, 2.0105, 1.9912, 1.9722, 1.9537, 1.9354, 1.9175,
+     & 1.9000, 1.8827, 1.8658, 1.8492, 1.8328, 1.8168, 1.8010,
+     & 1.7855, 1.7702, 1.7553, 1.7405, 1.7261, 1.7118, 1.6978,
+     & 1.6840, 1.6704, 1.6571, 1.6440, 1.6310, 1.6183, 1.6058,
+     & 1.5934, 1.5813, 1.5693, 1.5575, 1.5457, 1.5342, 1.5229,
+     & 1.5118, 1.5009, 1.4901, 1.4795, 1.4690, 1.4586, 1.4485,
+     & 1.4384, 1.4285, 1.4187, 1.4091, 1.3996, 1.3902, 1.3809,
+     & 1.3718, 1.3628, 1.3539, 1.3451, 1.3365, 1.3279, 1.3195,
+     & 1.3111, 1.3029, 1.2947, 1.2867, 1.2788, 1.2709, 1.2632,
+     & 1.2556, 1.2480, 1.2405, 1.2332, 1.2259, 1.2187, 1.2116,
+     & 1.2045, 1.1976, 1.1907, 1.1839, 1.1772, 1.1705, 1.1640,
+     & 1.1575, 1.1510, 1.1447, 1.1384, 1.1322, 1.1282, 0.0100
+     &/
+        data XN/
+     & 1.3267, 1.3272, 1.3294, 1.2944, 1.3174, 1.3197, 1.3211,
+     & 1.3217, 1.3225, 1.3229, 1.3235, 1.3242, 1.3255, 1.3286,
+     & 1.3266, 1.3408, 1.3029, 1.3101, 1.3149, 1.3171, 1.3188,
+     & 1.3196, 1.3203, 1.3226, 1.3273, 1.3298, 1.3334, 1.3432,
+     & 1.3569, 1.3637, 1.3311, 1.2866, 1.3017, 1.3067, 1.3099,
+     & 1.3120, 1.3133, 1.3139, 1.3148, 1.3153, 1.3159, 1.3162,
+     & 1.3167, 1.3170, 1.3371, 1.3600, 1.3600, 1.3600, 1.3600,
+     & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600,
+     & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600,
+     & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600,
+     & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600,
+     & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600,
+     & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600,
+     & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600,
+     & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600,
+     & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600,
+     & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600,
+     & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600,
+     & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600,
+     & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600,
+     & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600,
+     & 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600, 1.3600
+     &/
+        data XK/
+     &.131E-02,.394E-03,.452E-03,.987E-03,.109E-02,.118E-02,.106E-02,
+     &.107E-02,.102E-02,.992E-03,.997E-03,.855E-03,.849E-03,.751E-03,
+     &.149E-02,.125E-02,.713E-02,.148E-02,.815E-03,.213E-03,.642E-04,
+     &.965E-04,.375E-04,.468E-04,.863E-04,.186E-05,.451E-04,.136E-02,
+     &.428E-02,.237E-01,.162E-01,.273E-02,.144E-02,.416E-03,.155E-03,
+     &.227E-03,.361E-03,.692E-04,.509E-04,.548E-04,.105E-03,.662E-04,
+     &.144E-03,.133E-03,.945E-04,.395E-04,.148E-03,.455E-05,.559E-04,
+     &.187E-04,.929E-04,.348E-04,.896E-04,.480E-03,.471E-03,.285E-03,
+     &.126E-03,.446E-03,.886E-03,.843E-03,.281E-03,.625E-04,.487E-04,
+     &.118E-04,.437E-04,.186E-05,.336E-04,.223E-05,.101E-04,.182E-04,
+     &.436E-04,.171E-04,.127E-04,.186E-04,.181E-04,.243E-04,.252E-04,
+     &.330E-04,.294E-04,.302E-04,.258E-04,.276E-04,.335E-04,.295E-04,
+     &.373E-04,.351E-04,.322E-04,.653E-04,.670E-04,.882E-04,.124E-03,
+     &.261E-04,.973E-05,.144E-04,.356E-05,.228E-05,.475E-05,.414E-05,
+     &.103E-05,.980E-06,.413E-06,.283E-06,.312E-06,.996E-06,.188E-05,
+     &.262E-05,.282E-05,.537E-05,.262E-05,.169E-05,.314E-05,.627E-05,
+     &.147E-04,.975E-05,.866E-05,.161E-04,.225E-04,.315E-04,.206E-04,
+     &.248E-04,.157E-04,.850E-05,.155E-05,.833E-06,.523E-06,.461E-06,
+     &.638E-06,.959E-06,.112E-05,.130E-05,.119E-05,.120E-05,.149E-05,
+     &.180E-05,.183E-05,.157E-05,.190E-05,.264E-05,.178E-05,.339E-05,
+     &.119E-04,.117E-04,.218E-04,.345E-04,.150E-04,.159E-04,.969E-05,
+     &.748E-05,.879E-05,.872E-05,.444E-05,.269E-05,.241E-05,.212E-05
+     &/
+*234567890123456789012345678901234567890123456789012345678901234567890
+*
+*
+      XNR=XN(1)
+      XNI=XK(1)
+      IF (WAVELN .GT. W(1))  RETURN
+      XNR=XN(154)
+      XNI=XK(154)
+      IF (WAVELN .LT. W(154)) RETURN
+      DO 100 I=2,154
+      IF (WAVELN .GT. W(I) ) GO TO 101
+ 100  CONTINUE
+ 101  CONTINUE
+C ALL INTERPOLATION IS IN LOG LAMBDA
+      FACTOR= (alog(WAVELN) - alog(W(I)) ) / (alog(W(I-1)) - alog(W(I)))
+C REAL PART IS LINEARLY INTERPOLATED
+      XNR=XN(I) + FACTOR*(XN(I-1) - XN(I))
+C IMAGINARY PART IS LOG INTERPOLATED
+      XNI=alog(XK(I)) + FACTOR*(alog(XK(I-1)) - alog(XK(I)))
+      XNI=exp(XNI)
+          iF(XNI.lt.1.e-7) XNI=1.e-7
+      RETURN
+      END
Index: trunk/LMDZ.TITAN/libf/phytitan/liqch4.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/liqch4.F	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/liqch4.F	(revision 175)
@@ -0,0 +1,51 @@
+      SUBROUTINE LIQCH4(WAVELN,XNR,XNI)
+*
+* /DATA FROM MARTONCHIK AND ORTON, 1994, Vol 33, no 36. Applied Optics/
+*   Table 2, (90 K)
+*
+      DIMENSION W(44),XN(44),XK(44)
+      DATA W/
+     &1000.00,  71.4300, 41.6700,  8.2600,  8.1300,  7.8000,  7.6900,
+     &  7.5900,  3.5700,  3.4300,  3.3700,  3.3300,  3.2900,  1.9530,  
+     &  1.9320,  1.2410,  1.2350,  1.0140,  1.0000,  0.9872,  0.9742,  
+     &  0.8885,  0.8673,  0.8418,  0.7994,  0.7849,  0.7299,  0.7174,  
+     &  0.7057,  0.6856,  0.6696,  0.6215,  0.5983,  0.5831,  0.4000,  
+     &  0.1337,  0.1200,  0.1162,  0.1087,  0.1012,  0.1000,  0.0900,  
+     &  0.0545,  0.0020/
+      DATA XN/
+     &  1.2930,  1.2910,  1.2900,  1.3310,  1.3250,  1.3650,  1.2750,
+     &  1.1950,  1.3030,  1.3000,  1.3100,  1.2780,  1.2420,  1.2850, 
+     &  1.2850,  1.2860,  1.2860,  1.2870,  1.2870,  1.2870,  1.2870,
+     &  1.2880,  1.2880,  1.2880,  1.2880,  1.2890,  1.2890,  1.2890,
+     &  1.2890,  1.2900,  1.2900,  1.2910,  1.2910,  1.2910,  1.2990,
+     &  1.7030,  1.4860,  1.4710,  1.5080,  1.4450,  1.4480,  1.2090, 
+     &  0.8560,  1.0000/
+      DATA XK/
+     &5.302e-05, 1.442e-03, 6.645e-04, 1.067e-02, 2.135e-02, 7.994e-02, 
+     &1.706e-02, 7.728e-02, 1.066e-02, 2.132e-02, 4.264e-02, 7.462e-02,
+     &3.198e-02, 8.947e-07, 1.574e-06, 8.425e-08, 1.677e-07, 1.000e-06, 
+     &8.313e-07, 6.281e-07, 4.958e-07, 1.899e-06, 3.311e-07, 4.998e-08,
+     &6.103e-08, 3.995e-08, 9.907e-08, 1.156e-07, 8.381e-09, 2.675e-09, 
+     &4.771e-09, 1.951e-07, 1.167e-09, 1.237e-09, 1.000e-10, 1.814e-01, 
+     &3.336e-01, 3.225e-01, 3.761e-01, 4.768e-01, 4.853e-01, 6.501e-01, 
+     &2.137e-01, 1.137e-01/  
+      XNR=XN(1)
+      XNI=XK(1)
+      IF (WAVELN .GT. W(1))  RETURN
+      XNR=XN(44)
+      XNI=XK(44)
+      IF (WAVELN .LT. W(44)) RETURN
+      DO 100 I=2,44
+      IF (WAVELN .GT. W(I) ) GO TO 101
+ 100  CONTINUE
+ 101  CONTINUE
+C ALL INTERPOLATION IS IN LOG LAMBDA
+      FACTOR= (alog(WAVELN) - alog(W(I)) ) / (alog(W(I-1)) - alog(W(I)))
+C REAL PART IS LINEARLY INTERPOLATED
+      XNR=XN(I) + FACTOR*(XN(I-1) - XN(I))
+C IMAGINARY PART IS LOG INTERPOLATED
+      XNI=alog(XK(I)) + FACTOR*(alog(XK(I-1)) - alog(XK(I)))
+      XNI=exp(XNI)
+          iF(XNI.lt.1.e-7) XNI=1.e-7
+      RETURN
+      END
Index: trunk/LMDZ.TITAN/libf/phytitan/microtab.h
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/microtab.h	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/microtab.h	(revision 175)
@@ -1,34 +1,35 @@
-*-------------------------------------------------------------------
-* INCLUDE microtab.h
-*
+!-------------------------------------------------------------------
+! INCLUDE microtab.h
+!
 	 REAL wco,df_GP
-         INTEGER nz,nrad,nztop
+         INTEGER nz,nrad,imono,nztop,ntype
 
-         parameter(nz=llm,nrad=10,nztop=1)  !VERSION X
+         parameter(nz=llm,ntype=5,nrad=10,imono=5,nztop=1)  !VERSION X
+!        parameter(nz=llm,ntype=1,nrad=10,imono=5,nztop=1)  !VERSION X
 
          parameter(wco=177.,df_GP=2.)      !FOR FRACTAL PARTCICLES
-c        parameter(wco=1.E+6,df_GP=3.)     !FOR SPHERE PARTICLES
+!        parameter(wco=1.E+6,df_GP=3.)     !FOR SPHERE PARTICLES
 
       real rf(nrad),df(nrad),zf,aknc
       common/frac/rf,df,zf,aknc
 
-*********************************************************************
-* tcorrect, tx, microfi, cutoff: definis dans physiq.def (clesphys.h)
-*------------
+!********************************************************************
+! tcorrect, tx, microfi, cutoff: definis dans physiq.def (clesphys.h)
+!------------
          ! WARNING: tx=production rate
          !          tcorrect is readjustment factor: =1 is continiuty
          !                                           =X is q()*X 
-*------------
-*(*1): si microfi=1, optcv et optci sont appeles a chaque appels de la 
-*	physique  pour reactualiser les TAU's. De meme, pg2.F est 
-*	active a chaque appel de la physique....
-*      si microfi=0., optcv et optci, ainsi que pg2, ne sont appele qu'une
-*       fois au debut, comme dans la version originale....
-*------------
-*       dans optci et optcv:
-*      si cutoff=1, brume coupee facon Pascal -> T ok au sol et dans la strato
-*                                             -> T tropopause mauvaise
-*                                             -> albedo ok
-*      si cutoff=2, brume coupee sous 100mbar -> T ok sol/tropopause/strato
-*                                             -> mais albedo mauvais
+!------------
+!(*1): si microfi=1, optcv et optci sont appeles a chaque appels de la 
+!	physique  pour reactualiser les TAU's. De meme, pg2.F est 
+!	active a chaque appel de la physique....
+!      si microfi=0., optcv et optci, ainsi que pg2, ne sont appele qu'une
+!       fois au debut, comme dans la version originale....
+!------------
+!       dans optci et optcv:
+!      si cutoff=1, brume coupee facon Pascal -> T ok au sol et dans la strato
+!                                             -> T tropopause mauvaise
+!                                             -> albedo ok
+!      si cutoff=2, brume coupee sous 100mbar -> T ok sol/tropopause/strato
+!                                             -> mais albedo mauvais
 
Index: trunk/LMDZ.TITAN/libf/phytitan/muphys3D.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/muphys3D.F	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/muphys3D.F	(revision 175)
@@ -0,0 +1,491 @@
+         subroutine muphys(ngrid,
+     &   plev,play,zlev,zlay,
+     &   tpt,tq,gaz1,gaz2,gaz3,
+     &   nmicro,ptimestep,
+     &   pmu0,pfract,     
+*    Sorties diagnostiques
+     &   flxesp_i,
+     &   tau_drop,tau_aer,
+     &   solesp,prec)
+
+c
+c
+c  CETTE NOUVELLE ROUTINE DE MICROPHYSIQUE GERE 
+c  LA MICROPHYSIQUE DES AEROSOLS ET CELLE DES NUAGES 
+c  EN UN SEUL APPEL...
+c
+c  TOUS LES TRACEURS AEROSOL+NOYAUX+2*GLACES SONT CONTENUS DANS
+c  LE TABLEAU TQ ET LEUR TENDANCES DANS TDQ. CES TABLEAUX
+c  SONT COMPOSES DE TROIS PARTIES:
+c
+c       TQ(         1,    nmicro/4      pour les aerosols
+c        +   nmicro/4+1,  2*nmicro/4      pour les noyaux  
+c        + 2*nmicro/4+1,  3*nmicro/4      pour la glace 1
+c        + 3*nmicro/4+1,    nmicro   )    pour la glace 2
+c
+c  pour les aerosols, les noyaux, la glace 1 et la glace 2. la separation
+c  puis la concatenation de fait juste avant l'appel aux routines
+c  dans lesquels la separation est necessaire. 
+c
+c                                            _______
+c                                            |     |  ____
+c  EX:         -------->    QAER()    ---->  | M   |      \
+c            /                               | I   |       \
+c           /                                | C   |        \
+c      TQ()  ---------->    QGLACE1()  --->  | R   |  ------  TDQ()
+c           \                                | O   |        /
+c            \                               | P   |       /
+c              -------->    QGLACE2() ---->  | H   |  ----/
+c              \                             | Y   |     /
+c               \                            |     |    /
+c                 ----->    QNOYAUX()        |     |  _/
+c                                            |     |
+c                                            -------
+c
+c
+c
+c  DANS LA MICROPHYSIQUE, SE TROUVENT IMBRIQUES LES PROCESSUS SUIVANTS 
+c
+c
+c
+c
+c
+c   NUCLEATION/SEDIMENTATION   ---> n_ethane.F / n_methane.F
+c
+c   MICROPHYSIQUE AEROSOLS     ---> brume.F 
+c
+c   SEDIMENTATION DES GOUTTES  ---> snuages.F 
+c
+c
+c
+c
+c
+c
+c------------------------------------------------------
+         use dimphy
+         IMPLICIT NONE
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+#include "clesphys.h"
+#include "itemps.h"
+
+         integer ngrid
+
+         integer iq,nmicro
+
+         common/part/vaer,raer,vrat,draer,dvaer
+         real   vaer(nrad),raer(nrad),vrat,
+     &          draer(nrad),dvaer(nrad)
+
+         real   ptimestep
+ 
+         real  pdpsrf(ngrid)
+
+c*************************************
+c declaration des variables internes *
+c*************************************
+ 
+c      sources     *
+c------------------*
+
+         REAL plev(ngrid,klev+1)
+         REAL play(ngrid,klev)
+         REAL zlev(ngrid,klev+1)
+         REAL zlay(ngrid,klev) 
+         REAL pu(ngrid),pv(ngrid)
+         REAL pmu0(ngrid),pfract(ngrid)
+         REAL tpt(ngrid,klev)
+         REAL tq(ngrid,klev,nmicro), 
+     &        gaz1(ngrid,klev),
+     &        gaz2(ngrid,klev),
+     &        gaz3(ngrid,klev)
+
+c       OUTPUT !!!!! c
+c  note : gaz1,...,gazN sont aussi des outputs, ils ont modifié tout au long de muphys.
+c--------------------c
+         REAL pdq(ngrid,klev,nmicro)
+         REAL flxesp_i(ngrid,klev,3)    ! flx esp GLACE
+         REAL solesp(ngrid,klev+1,3)    ! tx prod glace (puit/source)  ! ind klev+1 = surface ?
+         REAL tau_drop(ngrid,klev)
+         REAL tau_aer(ngrid,klev,nrad)
+         REAL prec(ngrid,5)
+
+c       LOCAL
+c--------------------c
+         real  q(ngrid,klev,nmicro)
+         REAL taused(klev,nrad)
+         integer jsup,jinf,h,jalt,ihor,k
+
+c    microphysique    *
+c---------------------*
+         real c(klev,nrad),  cni(klev,nrad)
+         real c1i(klev,nrad),c2i(klev,nrad),c3i(klev,nrad)
+         real gazc1(klev),gazc2(klev),gazc3(klev)
+         real ddt
+ 
+         real vcl,nuc,r,xgsn,xmsn
+         real zz,effg,xlog,rapport
+
+         integer IPREM,i,n,j,l
+         integer ibid
+         save IPREM 
+         data IPREM/0/
+
+
+         real ttq(ngrid,klev,nmicro,2)
+         real tttq(ngrid,klev,nmicro,2)
+
+
+c      			**************************
+c        		INITIALISATION DE TABLEAUX
+c    		 	**************************
+c                         A NE FAIRE QU'UNE FOIS
+c     		        **************************
+c
+         IF (IPREM.eq.0) THEN
+ 
+           IF (microfi.eq.1) THEN
+             IF (ngrid.ne.jjm+1) THEN
+               print*,"aLeRte :"
+               print*,"microfi en 2D mais ngrid.ne.jjm+1"
+               print*,ngrid,jjm+1
+               stop "je m'arrete..."
+             ENDIF
+           ELSEIF (microfi.eq.2) THEN
+             IF (ngrid.ne.klon) THEN
+               print*,"aLeRte :"
+               print*,"microfi en 3D mais ngrid.ne.klon"
+               print*,ngrid,klon
+               stop "je m'arrete..."
+             ENDIF
+           ENDIF
+
+c initialisation des constantes de la microphysique :
+c ----------------------------------------------
+           call inimphycst()
+           
+
+c initialisation des c(z,r), c1i(z,r), c2i(z,r)
+c ----------------------------------------------
+ 
+           do i=1,nmicro 
+             do n=1,ngrid
+               do j=klev,1,-1
+                 q(n,klev+1-j,i)=tq(n,j,i)                           ! glaces...
+                 if(i.le.2*nrad) q(n,klev+1-j,i)=tq(n,j,i)*tcorrect  ! noyaux+aerosol 
+                 pdq(n,j,i)=0.
+               enddo 
+             enddo 
+           enddo
+c ici, les tableaux definissant la structure des aerosols sont
+c remplis: rf,df(nmicro),r(nmicro),v(nmicro)......
+           call rdf()
+c   ici on recopie la grille dans un common specifique a la microfi... 
+           v_e    = vaer
+           r_e    = raer
+           vrat_e = vrat
+           dr_e   = draer
+           dv_e   = dvaer 
+c
+         ELSE   
+  
+c les tq() doivent etre en nombre d'aerosols / cases 
+
+           do j=1,klev                        ! j de 1 a 119 
+             do n=1,ngrid
+               do  i=1,nmicro
+                 q(n,j,i)=tq(n,klev-j+1,i)
+                 pdq(n,j,i)=0.
+               enddo
+             enddo
+           enddo
+
+         ENDIF  ! FIN IPREM
+
+
+c-----------------------------------------------------
+c      !! La premiere fois, on ne passe pas par 
+c      !! q--->c et par pg3.F
+c      !! on passe directement au remplissage c-->q
+         IF (IPREM.eq.0) goto 102 
+c-----------------------------------------------------
+
+c****************************************
+c                                       *
+c         ADAPTATION GCM > micro        *
+c                                       *
+c****************************************
+
+
+c correpondance des couches / sens GCM > microphysique 
+c-----------------------------------------------------
+c
+         do IHOR=1,NGRID ! GRANDE BOUCLE HORIZONTALE / SEPARATION DES COLONNES
+
+  
+c  Ici, on initialise la grille verticale et les 
+c  variables communes aux routines de microphysique.
+c*******************************************************
+           call inimuphy(ihor,plev(ihor,:),play(ihor,:),
+     &                   zlev(ihor,:),zlay(ihor,:),
+     &                   tpt(ihor,:))
+
+c  Ici, on scinde les tableaux aerosols et glaces 
+c*******************************************************
+
+           if(nrad .ne. nmicro/ntype) then 
+             print*,"aLeRte : nrad != nmicro/ntype"
+             print*,'nmicro= ',nmicro 
+             print*,'ntype=',ntype
+             print*,'nmicro/ntype= ',nmicro/ntype
+             print*,'nrad= ',nrad 
+             stop "je m'arrete..." 
+           endif
+
+           do i=1,nrad
+             do j=1,klev
+               c(j,i)  =q(IHOR,j,i       )/dzb(j) ! concentration aerosols/m^3
+               if (clouds.eq.1) then
+                 cni(j,i)=q(IHOR,j,i+  nrad)/dzb(j) ! concentration noyaux /m^3
+                 c1i(j,i)=q(IHOR,j,i+2*nrad)/dzb(j) ! concentration volume glace/m^3
+                 c2i(j,i)=q(IHOR,j,i+3*nrad)/dzb(j) ! concentration volume glace /m^3
+                 c3i(j,i)=q(IHOR,j,i+4*nrad)/dzb(j) ! concentration volume glace /m^3
+               endif
+             enddo
+           enddo 
+           if (clouds.eq.1) then
+             do j=1,klev
+               gazc1(j)  =gaz1(IHOR,klev-j+1)   ! fraction molaire CH4
+               gazc2(j)  =gaz2(IHOR,klev-j+1)   ! fraction molaire C2H6
+               gazc3(j)  =gaz3(IHOR,klev-j+1)   ! fraction molaire C2H2
+             enddo
+           endif
+
+c****************************************
+c 
+c  FIN DE LA PREPARATION:
+c
+c
+c  ON  APPELLE LES MODELES MICROPHYSIQUES
+c
+c         - brume (coagulation + sedimentation)
+c         - nuages (nucleation + condensation)
+c         - sedimentation nuages
+c
+c
+c****************************************
+
+
+           do j=1,klev
+             solesp(ihor,klev+1-j,:) = 0.
+             do i=1,nrad
+               tau_aer(ihor,klev+1-j,i)=0.
+             enddo
+           enddo
+
+           ddt=ptimestep
+
+* concerne les aerosols (tableau c):
+c           call begintime(tt0)
+           call brume(ngrid,c,ddt,klev,nrad,taused,ihor,
+     &                pmu0(ihor),pfract(ihor),
+     &                prec)
+c           call endtime(tt0,tt1)
+c           tthaze=tthaze+tt1
+
+* concerne aerosols +  gouttes (tableaux c,cn,c1,c2):
+
+           do j=1,klev
+             do i=1,nrad
+               tau_aer(ihor,klev+1-j,i)=tau_aer(ihor,klev+1-j,i)
+     &                                 +taused(j,i)
+             enddo
+           enddo
+
+           IF (clouds.eq.1) THEN
+          
+c             do j=1,klev
+c             do i=1,nrad
+c               ttq(ihor,klev-j+1,i,1) = c(j,i)*dzb(j)
+c               ttq(ihor,klev-j+1,i+nrad,1) = cni(j,i)*dzb(j)
+c               ttq(ihor,klev-j+1,i+2*nrad,1) = c1i(j,i)*dzb(j)
+c               ttq(ihor,klev-j+1,i+3*nrad,1) = c2i(j,i)*dzb(j)
+c               ttq(ihor,klev-j+1,i+4*nrad,1) = c3i(j,i)*dzb(j)
+c             enddo
+c             enddo
+
+c             call begintime(tt0)
+             call cnuages(c,c1i,c2i,c3i,cni,
+     &                      gazc1,gazc2,gazc3,ddt)
+c             call endtime(tt0,tt1)
+c             ttcclds=ttcclds+tt1
+
+c  verification des valeurs de c,cni,c1i,c2i et c3i.
+c  Lorsque l'on vide completement une case, on peut avoir des chiffres negatifs :s
+           do j=1,klev
+             do i=1,nrad
+               c(j,i)= MAX(c(j,i),0.)
+               cni(j,i)= MAX(cni(j,i),0.)
+               c1i(j,i)= MAX(c1i(j,i),0.)
+               c2i(j,i)= MAX(c2i(j,i),0.)
+               c3i(j,i)= MAX(c3i(j,i),0.)
+c               ttq(ihor,klev-j+1,i,2) = c(j,i)*dzb(j)
+c               ttq(ihor,klev-j+1,i+nrad,2) = cni(j,i)*dzb(j)
+c               ttq(ihor,klev-j+1,i+2*nrad,2) = c1i(j,i)*dzb(j)
+c               ttq(ihor,klev-j+1,i+3*nrad,2) = c2i(j,i)*dzb(j)
+c               ttq(ihor,klev-j+1,i+4*nrad,2) = c3i(j,i)*dzb(j)
+             enddo
+           enddo
+     
+
+           do j=1,klev
+             do i=1,nrad
+               solesp(ihor,klev+1-j,1)=solesp(ihor,klev+1-j,1) +
+     &         (c1i(j,i)-q(IHOR,j,i+2*nrad)/dzb(j))
+               solesp(ihor,klev+1-j,2)=solesp(ihor,klev+1-j,2) +
+     &         (c2i(j,i)-q(IHOR,j,i+3*nrad)/dzb(j))
+               solesp(ihor,klev+1-j,3)=solesp(ihor,klev+1-j,3) +
+     &         (c3i(j,i)-q(IHOR,j,i+4*nrad)/dzb(j))
+             enddo
+           enddo
+
+* concerne les gouttes (tableaux cn,c1,c2):
+
+c             do j=1,klev
+c             do i=1,nrad
+c               tttq(ihor,klev-j+1,i,1) = c(j,i)*dzb(j)
+c               tttq(ihor,klev-j+1,i+nrad,1) = cni(j,i)*dzb(j)
+c               tttq(ihor,klev-j+1,i+2*nrad,1) = c1i(j,i)*dzb(j)
+c               tttq(ihor,klev-j+1,i+3*nrad,1) = c2i(j,i)*dzb(j)
+c               tttq(ihor,klev-j+1,i+4*nrad,1) = c3i(j,i)*dzb(j)
+c             enddo
+c             enddo
+
+c             call begintime(tt0)
+             call snuages(ngrid,cni,c1i,c2i,c3i,c,ddt,
+     &                    klev,nrad,ihor,
+     &                    flxesp_i,tau_drop,prec)
+c             call endtime(tt0,tt1)
+c             ttsclds=ttsclds+tt1
+
+c           do j=1,klev
+c             do i=1,nrad
+c               tttq(ihor,klev-j+1,i,2) = c(j,i)*dzb(j)
+c               tttq(ihor,klev-j+1,i+nrad,2) = cni(j,i)*dzb(j)
+c               tttq(ihor,klev-j+1,i+2*nrad,2) = c1i(j,i)*dzb(j)
+c               tttq(ihor,klev-j+1,i+3*nrad,2) = c2i(j,i)*dzb(j)
+c               tttq(ihor,klev-j+1,i+4*nrad,2) = c3i(j,i)*dzb(j)
+c             enddo
+c           enddo
+           ENDIF    ! flag nuages :)
+
+
+* on recompose le tableau de traceurs ici.
+*--------------------------------------------------
+ 
+           do i=1,nrad
+             do j=1,klev
+               q(IHOR,j,i)        =   c(j,i)*dzb(j) ! nombre  aerosols /m^2
+               if (clouds.eq.1) then
+                 q(IHOR,j,i+  nrad) = cni(j,i)*dzb(j) ! nombre noyaux /m^2
+                 q(IHOR,j,i+2*nrad) = c1i(j,i)*dzb(j) ! concentration volume glace/m^2
+                 q(IHOR,j,i+3*nrad) = c2i(j,i)*dzb(j) ! concentration volume glace/m^2
+                 q(IHOR,j,i+4*nrad) = c3i(j,i)*dzb(j) ! concentration volume glace/m^2
+               endif
+             enddo
+           enddo 
+           if (clouds.eq.1) then
+             do j=1,klev
+               gaz1(IHOR,klev-j+1) = gazc1(j)   ! fraction molaire 
+               gaz2(IHOR,klev-j+1) = gazc2(j)   ! fraction molaire
+               gaz3(IHOR,klev-j+1) = gazc3(j)   ! fraction molaire
+             enddo
+           endif
+
+         ENDDO             ! Fin de la boucle IHOR
+
+102      CONTINUE           ! la premiere fois, c'est une boucle vide!
+
+
+c***************************************************************
+c FIN: on renvoie les nouvelles valeurs q(t+dt)=q(t) + dq(t)
+c
+c Pour les aerosols, les noyaux, les glaces et les vapeurs modifiees...
+c
+c***************************************************************
+
+         do n=1,ngrid
+           do i=1,nmicro
+             do j=1,klev                ! j de 1 a 54 
+               tq(n,j,i) = q(n,klev+1-j,i)
+             enddo
+           enddo
+         enddo
+
+ 
+c      do j=1,15
+cc       CH4 -- cnuages
+c        write(210,'(I4,3(ES24.16,1X))') j,
+c     &  sum(ttq(40,j,2*nrad+1:3*nrad,1)),
+c     &  sum(ttq(40,j,2*nrad+1:3*nrad,2)),
+c     &  sum(ttq(40,j,2*nrad+1:3*nrad,2))-
+c     &  sum(ttq(40,j,2*nrad+1:3*nrad,1))
+cc       C2H6 -- cnuages
+c        write(211,'(I4,3(ES24.16,1X))') j,
+c     &  sum(ttq(40,j,3*nrad+1:4*nrad,1)),
+c     &  sum(ttq(40,j,3*nrad+1:4*nrad,2)),
+c     &  sum(ttq(40,j,3*nrad+1:4*nrad,2))-
+c     &  sum(ttq(40,j,3*nrad+1:4*nrad,1))
+cc       C2H2 -- cnuages
+c        write(212,'(I4,3(ES24.16,1X))') j,
+c     &  sum(ttq(40,j,4*nrad+1:5*nrad,1)),
+c     &  sum(ttq(40,j,4*nrad+1:5*nrad,2)),
+c     &  sum(ttq(40,j,4*nrad+1:5*nrad,2))-
+c     & sum(ttq(40,j,4*nrad+1:5*nrad,1))
+c  
+cc       CH4 -- snuages
+c        write(310,'(I4,3(ES24.16,1X))') j,
+c     &  sum(tttq(40,j,2*nrad+1:3*nrad,1)),
+c     &  sum(tttq(40,j,2*nrad+1:3*nrad,2)),
+c     &  sum(tttq(40,j,2*nrad+1:3*nrad,2))-
+c     &  sum(tttq(40,j,2*nrad+1:3*nrad,1))
+cc       C2H6 -- snuages
+c        write(311,'(I4,3(ES24.16,1X))') j,
+c     &  sum(tttq(40,j,3*nrad+1:4*nrad,1)),
+c     &  sum(tttq(40,j,3*nrad+1:4*nrad,2)),
+c     &  sum(tttq(40,j,3*nrad+1:4*nrad,2))-
+c     &  sum(tttq(40,j,3*nrad+1:4*nrad,1))
+cc       C2H2 -- snuages
+c        write(312,'(I4,3(ES24.16,1X))') j,
+c     &  sum(tttq(40,j,4*nrad+1:5*nrad,1)),
+c     &  sum(tttq(40,j,4*nrad+1:5*nrad,2)),
+c     &  sum(tttq(40,j,4*nrad+1:5*nrad,2))-
+c     &  sum(tttq(40,j,4*nrad+1:5*nrad,1))
+c      enddo
+c      write(210,*) "NEWLINE"
+c      write(211,*) "NEWLINE"
+c      write(212,*) "NEWLINE"
+c      write(310,*) "NEWLINE"
+c      write(311,*) "NEWLINE"
+c      write(312,*) "NEWLINE"
+
+
+c       do j=1,20
+c         write(410,'(I4,3(ES24.16,1X))') j,
+c     &   flxesp_i(40,j,1),flxesp_i(40,j,2),flxesp_i(40,j,3)  
+c         write(510,'(I4,3(ES24.16,1X))') j,
+c     &   solesp(40,j,1),solesp(40,j,2),solesp(40,j,3)  
+c       enddo
+c       write(410,*) "NEWLINE"
+c       write(510,*) "NEWLINE"
+
+         IPREM=1       ! LA PROCHAINE FOIS NE SERA PLUS LA 1ERE 
+
+
+ 16      return  
+
+         end 
+
+
+c---------------------------------------------------------------------
Index: trunk/LMDZ.TITAN/libf/phytitan/n_acethylene.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/n_acethylene.F	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/n_acethylene.F	(revision 175)
@@ -0,0 +1,600 @@
+      subroutine n_acethylene(ngrid,nq,nbin,
+     *                     dt,pl,tl,aerad,
+     *                     q,qprime)
+
+      implicit none
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+
+c  Arguments
+c  ---------
+
+      integer ngrid,nq,nbin
+
+      REAL dt              ! physical time step (s)
+      REAL pl(ngrid,nz)    ! pressure at each level (mbar)
+      REAL tl(ngrid,nz)    ! temperature at each level (K)
+      REAL aerad(nbin)     ! Radius array
+
+c    Tracers :
+      REAL q(ngrid,nz,nq)         ! tracer (kg/kg)
+      REAL qprime(ngrid,nz,nbin)  ! tracer (kg/kg)
+
+
+c     Local variables
+c     ---------------
+
+      integer ntyp
+      parameter (ntyp=3)
+
+      real n_aer(nz,nbin,ntyp)
+      real c2h2vap(nz)
+
+      integer itrac
+      integer ig,i,j,k,l,n   ! Loop integers
+      integer ilay,iq
+
+c  Treatment 
+c  ---------
+
+      DO ig = 1 , NGRID
+
+c     Set up the aerosol array
+        do j = 1, ntyp
+          do k = 1, nbin
+            itrac = (j-1) * nbin + k
+            do l = 1, nz
+              n_aer(l,k,j) = max(q(ig,l,itrac),0.)
+            enddo 
+          enddo
+        enddo
+
+c     Set up the methane vapor array
+        do l = 1, nz
+          c2h2vap(l) = q(ig,l,nq)
+        enddo
+
+        call nucleacond3(ngrid,nbin,dt,ig,pl,tl,aerad,
+     &                             n_aer,qprime,c2h2vap)
+
+c       Update q arrays
+        do j = 1, ntyp
+          do k = 1, nbin
+            itrac = (j-1) * nbin + k
+            do l = 1, nz
+              q(ig,l,itrac) = n_aer(l,k,j)
+            enddo 
+          enddo
+        enddo
+
+c     Update methane vapor array
+        do l = 1, nz
+          q(ig,l,nq) = c2h2vap(l)
+        enddo
+
+      ENDDO
+
+      return
+      END
+
+****************************************************************
+      subroutine nucleacond3(ngrid,nbin,dt,ig,
+     *                      pl,tl,aerad,n_aer,qprime,c2h2vap)
+*                                                              *
+*     This routine updates species concentrations due          *
+*     to both nucleation and condensation-induced variations.  *
+*     Gain and loss rates associated to each one of these      *
+*     processes are computed separately in other routines.     *
+*                                                              *
+****************************************************************
+
+      implicit none
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+
+
+      integer ng,nalt
+      parameter(ng=1,nalt=llm)
+
+
+      real lv
+
+      common/lheat/lv
+
+
+
+c  Arguments
+c  ---------
+
+      integer ngrid,nbin
+      integer ig
+      integer ntyp
+      parameter (ntyp=3)
+
+      real dt                    ! Global time step
+      real pl(ngrid,nz),tl(ngrid,nz)
+      real aerad(nbin)
+      real c2h2vap(nz)            ! Methane vapor mass mixing ratio (kg/m3)
+      real c2h2vap_old
+      real n_aer(nz,nbin,ntyp)  ! number concentrations of particle/each size bin 
+      real qprime(ngrid,nz,nbin)  ! tracer (kg/kg)
+      REAL total1(nz),total11(nz),total2(nz),total22(nz)
+      REAL dmsm,mtot
+
+
+
+
+
+c  Local
+c  -----
+
+      integer i,j,k,l,n,iindice,iselec
+
+      real dQc           ! Amount of condensed methane (kg/m3) during timestep
+      real*8 sat_ratio     ! Methane saturation ratio over liquid
+      real*8 sat_ratmix  ! Methane saturation ratio over liquid
+      real*8 pc2h2         ! Methane partial pressure (Pa) 
+      real qsat          ! Methane mass mixing ratio at saturation (kg/kg of air)
+      real qsatmix          ! Methane mass mixing ratio at saturation (kg/kg of air)
+      real*8 rate(nbin)    ! Heterogeneous Nucleation rate (s-1)
+      real*8 elim          
+
+      real nsav(nbin,ntyp)
+      real dn(nbin,ntyp)
+      real rad(nbin)     ! Radius of droplets in each size bin
+      real*8 gr(nbin)      ! Growth rate in each bin
+      real radius        ! Radius of droplets after growth
+      real Qs            ! Mass of condensate required to reach saturation
+      real newsat
+      real vol(nbin)
+
+      real press
+      real sig3,temp,seq(nbin)
+      real Ctot,up,dwn,newvap,gltot
+
+      real temp0,temp1,temp2,last_temp
+      real qsat1,sat_ratio1,tempf(0:10),sat_ratiof(0:10)
+      real rho_a,cap
+      real tempref
+      real xtime,xtime_prime
+
+
+c     Variables for latent heat release
+      real lw,cpp
+      data lw / 581.e+3/
+      data cpp/1050./ ! pour etre cohérent avec le reste...
+      save lw,cpp
+
+
+c  Treatment
+c  ---------
+      do i = 1, nbin
+        vol(i) = 4./3. * pi * aerad(i)**3.
+      enddo
+
+      do l = 1, nz
+      total1(l)=0. !solide
+      do k = 1, nbin
+      total1(l)=total1(l)+n_aer(l,k,2)*rhoi_c2h2
+      enddo
+      total2(l)=c2h2vap(l)
+      enddo
+
+
+c     Start loop over heights
+      DO 100 l = 1, nz
+
+        iindice=0                ! mettre l'indice à 0
+
+        temp   = tl(ig,l)
+        press  = pl(ig,l)
+        tempref=temp
+
+c       Save the values of the particle arrays before condensation
+        do j = 1, ntyp
+          do i = 1, nbin
+             nsav(i,j) = n_aer(l,i,j)
+          enddo
+        enddo
+
+
+ 99     continue 
+
+
+        call c2h2sat(temp,press,qsat)
+        qsatmix=qsat
+ 
+c  quantité  pmixc2h2(l) déjà calculé dans cnuages.F et passé dans un common
+ 
+c       Get the partial presure of methane vapor and its saturation ratio
+        pc2h2      = c2h2vap(l) * (Mn2/Mc2h2) * press
+        sat_ratio  = c2h2vap(l) / qsat
+        sat_ratmix = c2h2vap(l) / qsatmix
+
+c       Get the rates of nucleation
+        call nuclea3(nbin,aerad,pc2h2,temp,sat_ratio,rate)
+
+c       Get the growth rates of condensation/sublimation
+        up   = c2h2vap(l)
+        dwn  = 1.
+        Ctot = c2h2vap(l)
+        DO i = 1, nbin
+
+        if (n_aer(l,i,3).eq.0) then
+         rad(i) = aerad(i)
+        else
+         rad(i) = ((n_aer(l,i,2)/n_aer(l,i,3) + 
+     &   qprime(ig,l,i)/n_aer(l,i,3)
+     &   +vol(i))*0.75/pi)**(1./3.)
+        endif
+
+
+*       Equilibrium saturation ratio (due to curvature effect)
+        seq(i) = exp( 2.*sig3(temp)*Mc2h2 /(rhoi_c2h2*rgp*temp*rad(i)))
+
+        call growthrate3(dt,temp,press,pc2h2,
+     &                   sat_ratmix,seq(i),rad(i),gr(i))
+
+        up = up + dt * gr(i) * 4. * pi * rhoi_c2h2 * rad(i) * seq(i)
+     *                 * nsav(i,3) 
+        dwn= dwn+ dt * gr(i) * 4. * pi * rhoi_c2h2 * rad(i) / qsat
+     *                 * nsav(i,3) 
+        Ctot= Ctot + rhoi_c2h2 * nsav(i,2)
+
+        ENDDO
+
+        newvap = min(up/dwn,Ctot)
+        newvap = max(newvap,0.)
+
+        gltot = 0.
+        DO i = 1, nbin
+          gr(i)  = gr(i) * ( newvap/qsat - seq(i) )
+          if(nsav(i,2).le.0. .and. gr(i).le.0.) then
+              n_aer(l,i,2) = 0.
+          else
+          n_aer(l,i,2) = nsav(i,2) + dt * gr(i) * 4. * pi * rad(i)
+     *                               * n_aer(l,i,3)
+          if (n_aer(l,i,2).le.0.) then
+            n_aer(l,i,1) = n_aer(l,i,1) + n_aer(l,i,3)
+            n_aer(l,i,2) = 0.
+            n_aer(l,i,3) = 0.
+          endif
+          gltot=n_aer(l,i,2)*rhoi_c2h2+gltot
+          endif
+
+        ENDDO
+   
+c       Determine the mass of exchanged methane
+
+        dQc = 0.
+        DO i = 1, nbin
+          dQc = dQc - rhoi_c2h2 * ( n_aer(l,i,2) - nsav(i,2) )
+        ENDDO
+
+c       Update the methane vapor mixing ratio implied by 
+c       the cond/eva processes.
+
+
+c       Arrays resetted to their initial value before condensation
+        do j = 1, ntyp
+          do i = 1, nbin
+            dn(i,j)      = n_aer(l,i,j) - nsav(i,j)
+            n_aer(l,i,j) = nsav(i,j)
+          enddo
+        enddo
+
+c       Update the c arrays.
+c       nucleation & cond/eva tendencies added together.
+
+        do i=1,nbin
+          elim         = dt * rate(i)
+          n_aer(l,i,1) = n_aer(l,i,1) / (1.+elim)
+          n_aer(l,i,3) = n_aer(l,i,3) + elim * n_aer(l,i,1) + dn(i,3)
+          n_aer(l,i,1) = n_aer(l,i,1) + dn(i,1)
+          n_aer(l,i,2) = n_aer(l,i,2) + dn(i,2)
+          if(n_aer(l,i,2).lt.0.) n_aer(l,i,2)=0.
+        enddo
+
+        dQc = 0.
+        DO i = 1, nbin
+          dQc = dQc - rhoi_c2h2 * ( n_aer(l,i,2) - nsav(i,2) )
+        ENDDO
+
+
+        c2h2vap(l)  = c2h2vap(l) + dQc
+
+100   CONTINUE
+
+      do l = 1, nz
+      total11(l)=0. 
+      do k = 1, nbin
+      total11(l)=total11(l)+n_aer(l,k,2)*rhoi_c2h2
+      enddo
+      total22(l)=c2h2vap(l)
+      enddo
+
+      return
+      end
+
+
+*******************************************************
+* 						      *
+      subroutine nuclea3(nbin,aerad,pc2h2,temp,sat,nucrate)
+*   This subroutine computes the nucleation rate      *
+*   as given in Pruppacher & Klett (1978) in the      *
+*   case of water ice forming on a solid substrate.   *
+*     Definition refined by Keese (jgr,1989)	      *
+*						      *
+*******************************************************
+
+      implicit none
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+
+      integer nbin
+      real aerad(nbin)
+
+      real*8 nucrate(nbin)
+      real*8 pc2h2
+      real   temp
+      real*8 sat
+
+      integer l,i
+      real*8 nc2h2
+      real sig3            ! Water-ice/air surface tension  (N.m)
+      real*8 rstar        ! Radius of the critical germ (m)
+      real*8 gstar        ! # of molecules forming a critical embryo
+      real*8 x            ! Ratio rstar/radius of the nucleating dust particle
+      real fistar         ! Activation energy required to form a critical embryo (J)
+      real*8 zeldov       ! Zeldovitch factor (no dim)
+      real*8 fshape3       ! function defined at the end of the file
+      real*8 deltaf
+
+      real nus
+      data nus/1.e+13/       ! Jump frequency of a molecule (s-1)
+      real m0
+      data m0/4.31894e-26/     ! Weight of a methane molecule (kg)
+      real vo1
+      data vo1/4.22764e-5/    ! Volume molaire (masse molaire/masse volumique = MolWt/LDEN)
+      real desorp
+      data desorp/0.288e-19/ ! Activation energy for desorption of water on a dust-like substrate (J/molecule)
+      real surfdif
+      data surfdif/0.288e-20/! Estimated activation energy for surface diffusion of water molecules (J/molecule)
+
+      IF (sat .GT. 1.) then    ! minimum condition to activate nucleation
+
+        nc2h2    = pc2h2 / kbz / temp
+        rstar  = 2. * sig3(temp) * vo1 / (rgp*temp*log(sat))
+        gstar  = 4. * nav * pi * (rstar**3) / (3.*vo1)
+c       Loop over size bins
+        do i=1,nbin
+          x      = aerad(i) / rstar
+          x      = aerad(imono) / rstar  ! r(5)=monomere
+          fistar = (4./3.*pi) * sig3(temp) * (rstar**2.) 
+     &     *fshape3(mtetac2h2,x)
+          deltaf = min( max((2.*desorp-surfdif-fistar)/(kbz*temp)
+     &           , -100.), 100.)
+          if (deltaf.eq.-100.) then 
+            nucrate(i) = 0. 
+          else
+            zeldov = sqrt ( fistar / (3.*pi*kbz*temp*(gstar**2.)) )
+            nucrate(i)  = zeldov * kbz* temp * rstar**2.
+     &                  * 4. * pi * ( nc2h2*aerad(i) )**2.
+     &                  / ( fshape3(mtetac2h2,x) * nus * m0 )
+     &                  * dexp(deltaf)
+
+
+            if(i.gt.imono)  nucrate(i)= zeldov * kbz* temp * rstar**2.
+     &          * 4. * pi * vrat_e**(i-imono)*(nc2h2*aerad(imono) )**2.
+     &                  / (fshape3(mtetac2h2,x) * nus * m0 )
+     &                  * dexp(deltaf)
+
+          endif
+        enddo
+      ELSE
+        do i=1,nbin
+          nucrate(i) = 0.
+        enddo
+
+      ENDIF
+
+      return
+      end
+
+******************************************************************
+        subroutine c2h2sat(t,p,qsat)
+*                                                                 *
+* cette fonction calcule la pression de vapeur saturante de l'    *
+* ethane a une altitude donnee z par Reid et al., p657            *
+*                                                                 *
+* Compatible avec Barth et al., dans l'intervalle 30-90K          *
+*                                                                 *
+*                                                                 *
+******************************************************************
+
+        real rgp
+        data rgp/8.3143/
+
+* declaration des variables internes
+* ----------------------------------
+
+        real qsat,t,p
+         
+
+        a=-6.90128
+        b=1.26873
+        c=-2.09113
+        d=-2.75601
+        pc=61.4*1.013e5
+        tc=308.3
+
+        x=(1.-t/tc)
+        if(x.gt. 0.) qsat=(1-x)**(-1)*(a*x+b*x**1.5+c*x**3.+d*x**6.)
+        if(x.le. 0.) qsat=a*x/abs(1.-x)     ! approx pour  t > tc
+        qsat=pc*exp(qsat)
+
+        qsat=qsat* 26.0 / (28.0*p)  ! kg/kg
+
+        return
+        end
+
+c=======================================================================
+      subroutine growthrate3(timestep,temp,press,pc2h2,sat,seq,r,Cste)
+c
+c     Determination of the droplet growth rate
+c
+c=======================================================================
+
+      IMPLICIT NONE
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+
+c-----------------------------------------------------------------------
+C   DECLARATIONS:
+c   -------------
+
+      common/lheat/Lv
+
+c
+c   arguments:
+c   ----------
+
+      REAL timestep
+      REAL temp    ! temperature in the middle of the layer (K)
+      REAL press    ! pressure in the middle of the layer (K)
+      REAL*8 pc2h2 ! Methane vapor partial pressure (Pa)
+      REAL*8 sat  ! saturation ratio 
+      REAL r    ! crystal radius before condensation (m)
+      REAL seq  ! Equilibrium saturation ratio
+
+c   local:
+c   ------
+
+      REAL psat
+      REAL moln2,molc2h2
+      REAL To,tc2h2,wc2h2       ! Reid et al., (eq 7-9.4 + Appendix compound  [168])
+      REAL fte
+
+c     Effective gas molecular radius (m)
+      data moln2/1.75e-10/   ! N2
+c     Effective gas molecular radius (m)
+      data molc2h2/2.015e-10/   ! C2H2
+c     Temperature critique  + omega
+      data tc2h2/308.3/
+      data wc2h2/19.0e-2/
+
+      REAL k,Lv                 
+      REAL knudsen           ! Knudsen number (gas mean free path/particle radius)
+      REAL a,Dv,lambda,Rk,Rd ! Intermediate computations for growth rate
+      REAL*8 Cste
+
+c-----------------------------------------------------------------------
+c      Ice particle growth rate by diffusion/impegement of 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----------------------------------------------------------------------- 
+
+      psat = pc2h2 / sat
+
+c     - Thermal conductibility of N2
+      
+      k = ( 2.857e-2 * temp - 0.5428  ) * 4.184e-3
+      
+      
+c     - Latent heat of c2h2 (J.kg-1)
+      Lv =581.e3                      ! eq (7-9.4) Reid et al. 
+      fte=(1.-temp/tc2h2)
+      if (fte.le.1.e-3)  fte=1.e-3
+      Lv=8.314*tc2h2*(7.08*fte**0.354+10.95*wc2h2*fte**0.456)/26.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* (moln2*1.e10)**2  * (nav*1.e-20))
+
+c     - Compute Dv, methane 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*rgp*temp/(pi*Mc2h2) )* (kbz*1.e20) * temp/
+     & (pi*press*(moln2*1.e10+molc2h2*1.e10)**2 * sqrt(1.+Mc2h2/Mn2))
+
+      knudsen = temp / press * a / r
+      lambda  = (1.333+0.71/knudsen) / (1.+1./knudsen)
+      Dv      = Dv / (1. + lambda * knudsen)
+
+c     - Compute Rk
+      Rk = Lv**2 * rhoi_c2h2 * Mc2h2 / (k*rgp*temp**2.)
+*     print*,'Cste Rk :',Lv,k,rgp,t
+
+c     - Compute Rd
+      Rd = rgp * temp *rhoi_c2h2 / (Dv*psat*Mc2h2)
+*     print*,'Cste Rd :',Dv,psat,Mc2h2
+
+c     - Compute:      rdr/dt = Cste * (S-Seq)
+      Cste = 1. / (seq*Rk+Rd)
+*     print*,'Cste Cste :',seq,Rk,Rd
+
+
+      RETURN
+      END
+
+
+*********************************************************
+      real function sig3(t)
+*   this function computes the surface tension (N.m)   *
+*   between acethylene and air as a function of temp.    *
+*********************************************************
+
+      real t
+      pc=61.4*1.01325e5
+      tc=308.3
+      tb=188.4
+      tr=t/tc
+      tbr=tb/tc
+      if(t.gt.308.0) then
+         tr=308./tc
+      endif
+
+
+
+      sig3=0.1196*(1.+(tbr*alog(pc/1.01325))/(1.-tbr))-0.279
+      sig3=pc**(2./3.)*tc**(1./3.)*sig3*(1.-tr)**(11./9.)
+      sig3=sig3*1.e-8
+
+      return
+      end
+
+*********************************************************
+      real*8 function fshape3(cost,rap)
+*        function computing the f(m,x) factor           *
+* related to energy required to form a critical embryo  *
+*********************************************************
+
+      implicit none
+
+      real cost
+      real*8 rap
+      real*8 phi
+      real*8 a,b,c
+
+
+      phi = sqrt( 1. - 2.*cost*rap + rap**2 )
+      a = 1. + ( (1.-cost*rap)/phi )**3
+      b = (rap**3) * (2.-3.*(rap-cost)/phi+((rap-cost)/phi)**3)
+      c = 3. * cost * (rap**2) * ((rap-cost)/phi-1.)
+
+      fshape3 = 0.5*(a+b+c)
+
+      if (rap.gt.3000.) fshape3 = ((2.+cost)*(1.-cost)**2)/4.
+
+      return
+      end
+
Index: trunk/LMDZ.TITAN/libf/phytitan/n_ethane.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/n_ethane.F	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/n_ethane.F	(revision 175)
@@ -0,0 +1,628 @@
+      subroutine n_ethane(ngrid,nq,nbin,
+     *                     dt,pl,tl,aerad,
+     *                     q,qprime)
+
+      implicit none
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+
+c  Arguments
+c  ---------
+
+      integer ngrid,nq,nbin
+
+      REAL dt              ! physical time step (s)
+      REAL pl(ngrid,nz)    ! pressure at each level (mbar)
+      REAL tl(ngrid,nz)    ! temperature at each level (K)
+      REAL aerad(nbin)     ! Radius array
+
+c    Tracers :
+      REAL q(ngrid,nz,nq)         ! tracer (kg/kg)
+      REAL qprime(ngrid,nz,nbin)  ! tracer (kg/kg)
+
+
+c     Local variables
+c     ---------------
+
+      integer ntyp
+      parameter (ntyp=3)
+
+      real n_aer(nz,nbin,ntyp)
+      real c2h6vap(nz)
+
+      integer itrac
+      integer ig,i,j,k,l,n   ! Loop integers
+      integer ilay,iq
+
+c  Treatment 
+c  ---------
+
+      DO ig = 1 , NGRID
+
+c     Set up the aerosol array
+        do j = 1, ntyp
+          do k = 1, nbin
+            itrac = (j-1) * nbin + k
+            do l = 1, nz
+              n_aer(l,k,j) = max(q(ig,l,itrac),0.)
+            enddo 
+          enddo
+        enddo
+
+c     Set up the methane vapor array
+        do l = 1, nz
+          c2h6vap(l) = q(ig,l,nq)
+        enddo
+
+        call nucleacond2(ngrid,nbin,dt,ig,pl,tl,aerad,
+     &                             n_aer,qprime,c2h6vap)
+
+c       Update q arrays
+        do j = 1, ntyp
+          do k = 1, nbin
+            itrac = (j-1) * nbin + k
+            do l = 1, nz
+              q(ig,l,itrac) = n_aer(l,k,j)
+            enddo 
+          enddo
+        enddo
+
+c     Update methane vapor array
+      do l = 1, nz
+      q(ig,l,nq) = c2h6vap(l)
+
+c     if(q(ig,l,nq).le.0.) print*,'in nuc2h6',ig,l, q(ig,l,nq) 
+
+      enddo
+
+      ENDDO
+
+      return
+      END
+
+****************************************************************
+      subroutine nucleacond2(ngrid,nbin,dt,ig,
+     *                      pl,tl,aerad,n_aer,qprime,c2h6vap)
+*                                                              *
+*     This routine updates species concentrations due          *
+*     to both nucleation and condensation-induced variations.  *
+*     Gain and loss rates associated to each one of these      *
+*     processes are computed separately in other routines.     *
+*                                                              *
+****************************************************************
+
+      implicit none
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+
+
+      integer ng,nalt
+      parameter(ng=1,nalt=llm)
+
+      real lv
+
+* dejà évalué dans n_methane !
+      REAL x1(nalt)
+      REAL x2(nalt)
+      REAL x3(nalt)
+      REAL icefrac(nalt)
+      REAL pmixch4(nalt)
+      REAL pmixc2h6(nalt)
+      REAL pmixn2(nalt)
+
+      common/lheat/lv
+      common/mixing/x1,x2,x3,icefrac,
+     &         pmixch4,pmixc2h6,pmixn2
+
+
+
+c  Arguments
+c  ---------
+
+      integer ngrid,nbin
+      integer ig
+      integer ntyp
+      parameter (ntyp=3)
+
+      real dt                    ! Global time step
+      real pl(ngrid,nz),tl(ngrid,nz)
+      real aerad(nbin)
+      real c2h6vap(nz)            ! Methane vapor mass mixing ratio (kg/m3)
+      real c2h6vap_old
+      real n_aer(nz,nbin,ntyp)  ! number concentrations of particle/each size bin 
+      real qprime(ngrid,nz,nbin)  ! tracer (kg/kg)
+      REAL total1(nz),total11(nz),total2(nz),total22(nz)
+      REAL dmsm,mtot
+
+
+
+
+
+c  Local
+c  -----
+
+      integer i,j,k,l,n,iindice,iselec
+
+      real dQc           ! Amount of condensed methane (kg/m3) during timestep
+      real*8 sat_ratio     ! Methane saturation ratio over liquid
+      real*8 sat_ratmix  ! Methane saturation ratio over liquid
+      real*8 pc2h6         ! Methane partial pressure (Pa) 
+      real qsat          ! Methane mass mixing ratio at saturation (kg/kg of air)
+      real qsatmix          ! Methane mass mixing ratio at saturation (kg/kg of air)
+      real*8 rate(nbin)    ! Heterogeneous Nucleation rate (s-1)
+      real*8 elim          
+
+      real nsav(nbin,ntyp)
+      real dn(nbin,ntyp)
+      real rad(nbin)     ! Radius of droplets in each size bin
+      real*8 gr(nbin)      ! Growth rate in each bin
+      real radius        ! Radius of droplets after growth
+      real Qs            ! Mass of condensate required to reach saturation
+      real newsat
+      real vol(nbin)
+
+      real press
+      real sig2,temp,seq(nbin)
+      real Ctot,up,dwn,newvap,gltot
+
+      real temp0,temp1,temp2,last_temp
+      real qsat1,sat_ratio1,tempf(0:10),sat_ratiof(0:10)
+      real rho_a,cap
+      real tempref
+      real xtime,xtime_prime
+
+
+
+c     Variables for latent heat release
+      real lw,cpp
+      data lw / 581.e+3/
+c     data cpp/1044./
+      data cpp/1050./ ! pour etre cohérent avec le reste...
+      save lw,cpp
+
+
+c  Treatment
+c  ---------
+      do i = 1, nbin
+        vol(i) = 4./3. * pi * aerad(i)**3.
+      enddo
+
+      do l = 1, nz
+      total1(l)=0. !solide
+      do k = 1, nbin
+      total1(l)=total1(l)+n_aer(l,k,2)*rhoi_c2h6
+      enddo
+      total2(l)=c2h6vap(l)
+      enddo
+
+
+c     Start loop over heights
+      DO 100 l = 1, nz
+
+        iindice=0                ! mettre l'indice à 0
+
+        temp   = tl(ig,l)
+        press  = pl(ig,l)
+        tempref=temp
+
+c       Save the values of the particle arrays before condensation
+        do j = 1, ntyp
+          do i = 1, nbin
+             nsav(i,j) = n_aer(l,i,j)
+          enddo
+        enddo
+
+
+ 99     continue 
+
+
+        call c2h6sat(temp,press,qsat)
+        qsatmix=qsat
+ 
+c  quantité  pmixc2h6(l) déjà calculé dans cnuages.F et passé dans un common
+c       qsat=pmixc2h6(l)*30.0 / (28.0*p)
+c       qsatmix=pmixc2h6(l)*30.0 / (28.0*p)
+ 
+c       Get the partial presure of methane vapor and its saturation ratio
+        pc2h6      = c2h6vap(l) * (Mn2/Mc2h6) * press
+        sat_ratio  = c2h6vap(l) / qsat
+        sat_ratmix = c2h6vap(l) / qsatmix
+
+c       Get the rates of nucleation
+        call nuclea2(nbin,aerad,pc2h6,temp,sat_ratio,rate)
+
+c       Get the growth rates of condensation/sublimation
+        up   = c2h6vap(l)
+        dwn  = 1.
+        Ctot = c2h6vap(l)
+        DO i = 1, nbin
+
+        if (n_aer(l,i,3).eq.0) then
+         rad(i) = aerad(i)
+        else
+         rad(i) = ((n_aer(l,i,2)/n_aer(l,i,3) + 
+     &   qprime(ig,l,i)/n_aer(l,i,3)
+     &   +vol(i))*0.75/pi)**(1./3.)
+        endif
+
+
+*       Equilibrium saturation ratio (due to curvature effect)
+        seq(i) = exp( 2.*sig2(temp)*Mc2h6 /(rhoi_c2h6*rgp*temp*rad(i)))
+
+        call growthrate2(dt,temp,press,pc2h6,
+     &                   sat_ratmix,seq(i),rad(i),gr(i))
+        up = up + dt * gr(i) * 4. * pi * rhoi_c2h6 * rad(i) * seq(i)
+     *                 * nsav(i,3) 
+        dwn= dwn+ dt * gr(i) * 4. * pi * rhoi_c2h6 * rad(i) / qsat
+     *                 * nsav(i,3) 
+        Ctot= Ctot + rhoi_c2h6 * nsav(i,2)
+
+        ENDDO
+
+        newvap = min(up/dwn,Ctot)
+        newvap = max(newvap,0.)
+
+        gltot = 0.
+        DO i = 1, nbin
+          gr(i)  = gr(i) * ( newvap/qsat - seq(i) )
+          if(nsav(i,2).le.0. .and. gr(i).le.0.) then
+              n_aer(l,i,2) = 0.
+          else
+          n_aer(l,i,2) = nsav(i,2) + dt * gr(i) * 4. * pi * rad(i)
+     *                               * n_aer(l,i,3)
+          if (n_aer(l,i,2).le.0.) then
+            n_aer(l,i,1) = n_aer(l,i,1) + n_aer(l,i,3)
+            n_aer(l,i,2) = 0.
+            n_aer(l,i,3) = 0.
+          endif
+          gltot=n_aer(l,i,2)*rhoi_c2h6+gltot
+          endif
+
+        ENDDO
+   
+c       Determine the mass of exchanged methane
+
+        dQc = 0.
+        DO i = 1, nbin
+          dQc = dQc - rhoi_c2h6 * ( n_aer(l,i,2) - nsav(i,2) )
+        ENDDO
+
+c       Update the methane vapor mixing ratio implied by 
+c       the cond/eva processes.
+
+
+c       Arrays resetted to their initial value before condensation
+        do j = 1, ntyp
+          do i = 1, nbin
+            dn(i,j)      = n_aer(l,i,j) - nsav(i,j)
+            n_aer(l,i,j) = nsav(i,j)
+          enddo
+        enddo
+
+c       Update the c arrays.
+c       nucleation & cond/eva tendencies added together.
+
+        do i=1,nbin
+          elim         = dt * rate(i)
+          n_aer(l,i,1) = n_aer(l,i,1) / (1.+elim)
+          n_aer(l,i,3) = n_aer(l,i,3) + elim * n_aer(l,i,1) + dn(i,3)
+          n_aer(l,i,1) = n_aer(l,i,1) + dn(i,1)
+          n_aer(l,i,2) = n_aer(l,i,2) + dn(i,2)
+          if(n_aer(l,i,2).lt.0.) n_aer(l,i,2)=0.
+        enddo
+
+        dQc = 0.
+        DO i = 1, nbin
+          dQc = dQc - rhoi_c2h6 * ( n_aer(l,i,2) - nsav(i,2) )
+        ENDDO
+
+
+        c2h6vap(l)  = c2h6vap(l) + dQc
+
+100   CONTINUE
+
+      do l = 1, nz
+      total11(l)=0. 
+      do k = 1, nbin
+      total11(l)=total11(l)+n_aer(l,k,2)*rhoi_c2h6
+      enddo
+      total22(l)=c2h6vap(l)
+      enddo
+
+      return
+      end
+
+
+*******************************************************
+* 						      *
+      subroutine nuclea2(nbin,aerad,pc2h6,temp,sat,nucrate)
+*   This subroutine computes the nucleation rate      *
+*   as given in Pruppacher & Klett (1978) in the      *
+*   case of water ice forming on a solid substrate.   *
+*     Definition refined by Keese (jgr,1989)	      *
+*						      *
+*******************************************************
+
+      implicit none
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+
+      integer nbin
+      real aerad(nbin)
+
+      real*8 nucrate(nbin)
+      real*8 pc2h6
+      real   temp
+      real*8 sat
+
+      integer l,i
+      real*8 nc2h6
+      real sig2            ! Water-ice/air surface tension  (N.m)
+      real*8 rstar        ! Radius of the critical germ (m)
+      real*8 gstar        ! # of molecules forming a critical embryo
+      real*8 x            ! Ratio rstar/radius of the nucleating dust particle
+      real fistar         ! Activation energy required to form a critical embryo (J)
+      real*8 zeldov       ! Zeldovitch factor (no dim)
+      real*8 fshape2       ! function defined at the end of the file
+      real*8 deltaf
+
+      real nus
+      data nus/1.e+13/       ! Jump frequency of a molecule (s-1)
+      real m0
+      data m0/4.983e-26/     ! Weight of a methane molecule (kg)
+      real vo1
+c     data vo1/9.094e-29/
+      data vo1/5.4746e-5/    ! Volume of 1 mole
+      real desorp
+      data desorp/0.288e-19/ ! Activation energy for desorption of water on a dust-like substrate (J/molecule)
+      real surfdif
+      data surfdif/0.288e-20/! Estimated activation energy for surface diffusion of water molecules (J/molecule)
+
+      IF (sat .GT. 1.) then    ! minimum condition to activate nucleation
+
+        nc2h6    = pc2h6 / kbz / temp
+        rstar  = 2. * sig2(temp) * vo1 / (rgp*temp*log(sat))
+        gstar  = 4. * nav * pi * (rstar**3) / (3.*vo1)
+c       Loop over size bins
+        do i=1,nbin
+          x      = aerad(i) / rstar
+          x      = aerad(imono) / rstar  ! r(5)=monomere
+          fistar = (4./3.*pi) * sig2(temp) * (rstar**2.) 
+     &     *fshape2(mtetac2h6,x)
+          deltaf = min( max((2.*desorp-surfdif-fistar)/(kbz*temp)
+     &           , -100.), 100.)
+          if (deltaf.eq.-100.) then 
+            nucrate(i) = 0. 
+          else
+            zeldov = sqrt ( fistar / (3.*pi*kbz*temp*(gstar**2.)) )
+            nucrate(i)  = zeldov * kbz* temp * rstar**2.
+     &                  * 4. * pi * ( nc2h6*aerad(i) )**2.
+     &                  / ( fshape2(mtetac2h6,x) * nus * m0 )
+     &                  * dexp(deltaf)
+            if(i.gt.imono)  nucrate(i)= zeldov * kbz* temp * rstar**2.
+     &          * 4. * pi * vrat_e**(i-imono)*(nc2h6*aerad(imono) )**2.
+     &          / (fshape2(mtetac2h6,x) * nus * m0 )
+     &          * dexp(deltaf)
+
+          endif
+        enddo
+      ELSE
+        do i=1,nbin
+          nucrate(i) = 0.
+        enddo
+
+      ENDIF
+
+      return
+      end
+
+******************************************************************
+        subroutine c2h6sat(t,p,qsat)
+*                                                                 *
+* cette fonction calcule la pression de vapeur saturante de l'    *
+* ethane a une altitude donnee z par Reid et al., p657            *
+*                                                                 *
+* Compatible avec Barth et al., dans l'intervalle 30-90K          *
+*                                                                 *
+*                                                                 *
+******************************************************************
+
+        real rgp
+        data rgp/8.3143/
+
+* declaration des variables internes
+* ----------------------------------
+
+        real qsat,t,p
+         
+c       qsat=10.01-1085.0/(t-0.561)
+c       qsat=10.**qsat/760.*1.e5
+
+
+        a=-6.34307
+        b=1.011630
+        c=-1.19116
+        d=-2.03539
+        pc=48.8*1.e5
+        tc=305.4
+
+        x=(1.-t/tc)
+        if(x.gt. 0.) qsat=(1-x)**(-1)*(a*x+b*x**1.5+c*x**3.+d*x**6.)
+        if(x.le. 0.) qsat=a*x/abs(1.-x)     ! approx pour  t > tc
+        qsat=pc*exp(qsat)
+
+        qsat=qsat* 30.0 / (28.0*p)  ! kg/kg
+
+        return
+        end
+
+c=======================================================================
+      subroutine growthrate2(timestep,temp,press,pc2h6,sat,seq,r,Cste)
+c
+c     Determination of the droplet growth rate
+c
+c=======================================================================
+
+      IMPLICIT NONE
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+
+c-----------------------------------------------------------------------
+C   DECLARATIONS:
+c   -------------
+
+      common/lheat/Lv
+
+
+c
+c   arguments:
+c   ----------
+
+      REAL timestep
+      REAL temp    ! temperature in the middle of the layer (K)
+      REAL press   ! pressure in the middle of the layer (K)
+      REAL*8 pc2h6 ! Methane vapor partial pressure (Pa)
+      REAL*8 sat  ! saturation ratio 
+      REAL r    ! crystal radius before condensation (m)
+      REAL seq  ! Equilibrium saturation ratio
+
+c   local:
+c   ------
+
+      REAL psat
+      REAL moln2,molc2h6
+      REAL To,tc2h6,wc2h6       ! Reid et al., (eq 7-9.4 + Appendix compound  [168])
+      REAL fte
+
+c     Effective gas molecular radius (m)
+      data moln2/1.75e-10/   ! N2
+c     Effective gas molecular radius (m)
+      data molc2h6/2.22e-10/   ! C2H6
+c     Temperature critique  + omega
+      data tc2h6/305.4/
+      data wc2h6/9.9e-2/
+
+      REAL k,Lv                 
+      REAL knudsen           ! Knudsen number (gas mean free path/particle radius)
+      REAL a,Dv,lambda,Rk,Rd ! Intermediate computations for growth rate
+      REAL*8 Cste
+
+c-----------------------------------------------------------------------
+c      Ice particle growth rate by diffusion/impegement of 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----------------------------------------------------------------------- 
+
+      psat = pc2h6 / sat
+
+c     - Thermal conductibility of N2
+      
+      k = ( 2.857e-2 * temp - 0.5428  ) * 4.184e-3
+      
+      
+c     - Latent heat of c2h6 (J.kg-1)
+      Lv =581.e3                      ! eq (7-9.4) Reid et al. 
+      fte=(1.-temp/tc2h6)
+      if (fte.le.1.e-3)  fte=1.e-3
+      Lv=8.314*tc2h6*(7.08*fte**0.354+10.95*wc2h6*fte**0.456)/30.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* (moln2*1.e10)**2  * (nav*1.e-20))
+
+c     - Compute Dv, methane 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*rgp*temp/(pi*Mc2h6) )* (kbz*1.e20) * temp / 
+     & (pi*press*(moln2*1.e10+molc2h6*1.e10)**2 * sqrt(1.+Mc2h6/Mn2) )
+
+      knudsen = temp / press * a / r
+      lambda  = (1.333+0.71/knudsen) / (1.+1./knudsen)
+      Dv      = Dv / (1. + lambda * knudsen)
+
+c     - Compute Rk
+      Rk = Lv**2 * rhoi_c2h6 * Mc2h6 / (k*rgp*temp**2.)
+c     - Compute Rd
+      Rd = rgp * temp *rhoi_c2h6 / (Dv*psat*Mc2h6)
+
+c     - Compute:      rdr/dt = Cste * (S-Seq)
+      Cste = 1. / (seq*Rk+Rd)
+
+      RETURN
+      END
+
+
+*********************************************************
+      real function sig2(t)
+*    this function computes the surface tension (N.m)   *
+*   between methane and air as a function of temp.    *
+*   Eq (12-3-6 et 12-3-7 Reid et al.)
+*
+*********************************************************
+
+      real t
+
+      pc=48.8*1.01325e5
+      tc=305.4
+      tb=184.6
+      tr=t/tc
+      tbr=tb/tc
+      if(t.gt.305.0) then 
+         tr=305./tc
+      endif
+
+      sig2=0.1196*(1.+(tbr*alog(pc/1.01325))/(1.-tbr))-0.279
+      sig2=pc**(2./3.)*tc**(1./3.)*sig2*(1.-tr)**(11./9.)
+      sig2=sig2*1.e-8
+
+
+
+
+c     sig2 = 21.157*((305.4-t)/(305.4-153.2))**(11./9.)
+c     sig2=sig2*1.e-4
+c
+c       if(t.gt.305.0) then 
+c         sig2 = 21.157*((305.4-305.)/(305.4-153.2))**(11./9.)
+c         sig2=sig2*1.e-4
+c       endif
+c
+c     print*,t,sig2,sig3
+
+      return
+      end
+
+*********************************************************
+      real*8 function fshape2(cost,rap)
+*        function computing the f(m,x) factor           *
+* related to energy required to form a critical embryo  *
+*********************************************************
+
+      implicit none
+
+      real cost
+      real*8 rap
+      real*8 phi
+      real*8 a,b,c
+
+
+      phi = sqrt( 1. - 2.*cost*rap + rap**2 )
+      a = 1. + ( (1.-cost*rap)/phi )**3
+      b = (rap**3) * (2.-3.*(rap-cost)/phi+((rap-cost)/phi)**3)
+      c = 3. * cost * (rap**2) * ((rap-cost)/phi-1.)
+
+      fshape2 = 0.5*(a+b+c)
+
+      if (rap.gt.3000.) fshape2 = ((2.+cost)*(1.-cost)**2)/4.
+
+      return
+      end
+
Index: trunk/LMDZ.TITAN/libf/phytitan/n_methane.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/n_methane.F	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/n_methane.F	(revision 175)
@@ -0,0 +1,580 @@
+      subroutine n_methane(ngrid,nq,nbin,
+     *                     dt,pl,tl,aerad,
+     *                     q,qprime)
+
+      implicit none
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+
+c  Arguments
+c  ---------
+
+      integer ngrid,nq,nbin
+
+      REAL dt              ! physical time step (s)
+      REAL pl(ngrid,nz)    ! pressure at each level (mbar)
+      REAL tl(ngrid,nz)    ! temperature at each level (K)
+      REAL aerad(nbin)     ! Radius array
+
+c    Tracers :
+      REAL q(ngrid,nz,nq)         ! tracer (kg/kg)
+      REAL qprime(ngrid,nz,nbin)  ! tracer (kg/kg)
+
+
+c     Local variables
+c     ---------------
+
+      integer ntyp
+      parameter (ntyp=3)   ! 3 = 1 aerosol + 1 noyau + 1 glace 
+
+      real n_aer(nz,nbin,ntyp)
+      real ch4vap(nz)
+
+      integer itrac
+      integer ig,i,j,k,l,n   ! Loop integers
+      integer ilay,iq
+
+c  Treatment 
+c  ---------
+
+      DO ig = 1 , NGRID
+
+c     Set up the aerosol array
+        do j = 1, ntyp
+          do k = 1, nbin
+            itrac = (j-1) * nbin + k
+            do l = 1, nz
+              n_aer(l,k,j) = max(q(ig,l,itrac),0.)
+            enddo 
+          enddo
+        enddo
+
+c     Set up the methane vapor array
+        do l = 1, nz
+          ch4vap(l) = q(ig,l,nq)
+        enddo
+
+
+
+        call nucleacond(ngrid,nbin,dt,ig,pl,tl,aerad,
+     &                 n_aer,qprime,ch4vap)
+
+
+c       Update q arrays
+        do j = 1, ntyp
+          do k = 1, nbin
+            itrac = (j-1) * nbin + k
+            do l = 1, nz
+              q(ig,l,itrac) = n_aer(l,k,j)
+            enddo 
+          enddo
+        enddo
+
+c     Update methane vapor array
+        do l = 1, nz
+          q(ig,l,nq) = ch4vap(l)
+        enddo
+
+      ENDDO
+
+      return
+      END
+
+****************************************************************
+      subroutine nucleacond(ngrid,nbin,dt,ig,
+     &                      pl,tl,aerad,n_aer,qprime,ch4vap)
+*                                                              *
+*     This routine updates species concentrations due          *
+*     to both nucleation and condensation-induced variations.  *
+*     Gain and loss rates associated to each one of these      *
+*     processes are computed separately in other routines.     *
+*                                                              *
+****************************************************************
+
+      implicit none
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+
+      integer ng,nalt
+      parameter(ng=1,nalt=llm)
+
+      real lv
+      common/lheat/lv
+
+c  Arguments
+c  ---------
+
+      integer ngrid,nbin
+      integer ig
+      integer ntyp
+      parameter (ntyp=3)
+
+      real dt                    ! Global time step
+      real pl(ngrid,nz),tl(ngrid,nz)
+      real aerad(nbin)
+      real ch4vap(nz)            ! Methane vapor mass mixing ratio (kg/m3)
+      real ch4vap_old
+      real n_aer(nz,nbin,ntyp)  ! number concentrations of particle/each size bin 
+      real qprime(ngrid,nz,nbin)  ! tracer (kg/kg)
+      REAL total1(nz),total11(nz),total2(nz),total22(nz)
+      REAL dmsm,mtot
+
+
+c  Local
+c  -----
+
+      integer i,j,k,l,n,iindice,iselec
+
+      real dQc           ! Amount of condensed methane (kg/m3) during timestep
+      real*8 sat_ratio   ! Methane saturation ratio over liquid
+      real*8 sat_ratmix   ! Methane saturation ratio over liquid
+      real*8 pch4        ! Methane partial pressure (Pa) 
+      real qsat          ! Methane mass mixing ratio at saturation (kg/kg of air)
+      real qsatmix          ! Methane mass mixing ratio at saturation (kg/kg of air)
+      real*8 rate(nbin)    ! Heterogeneous Nucleation rate (s-1)
+      real*8 elim          
+
+      real nsav(nbin,ntyp)
+      real dn(nbin,ntyp) 
+      real rad(nbin)     ! Radius of droplets in each size bin
+      real*8 gr(nbin)      ! Growth rate in each bin
+      real radius        ! Radius of droplets after growth
+      real Qs            ! Mass of condensate required to reach saturation
+      real newsat
+      real vol(nbin)
+
+      real press
+      real sig,temp,seq(nbin)
+      real Ctot,up,dwn,newvap,gltot
+
+      real rho_a,cap
+      real tempref
+      real frac
+      real xtime,xtime_prime
+      real dQc2
+
+c     Variables for latent heat release
+      real lw,cpp
+      data lw / 510.e+3/
+c     data cpp/1044./
+      data cpp/1050./ ! pour etre cohérent avec le reste...
+      save lw,cpp
+
+
+c  Treatment
+c  ---------
+
+c  Treatment
+c  ---------
+      do i = 1, nbin
+        vol(i) = 4./3. * pi * aerad(i)**3.
+      enddo
+
+        do l = 1, nz
+        total1(l)=0. !solide
+        do k = 1, nbin
+        total1(l)=total1(l)+n_aer(l,k,2)*rhoi_ch4
+        enddo
+        total2(l)=ch4vap(l)
+        enddo
+
+c     Start loop over heights
+      DO 100 l = 1, nz
+   
+        iindice=0                ! mettre l'indice à 0
+
+        temp   = tl(ig,l)
+        press  = pl(ig,l)
+        tempref=temp
+
+c       Save the values of the particle arrays before condensation
+        do j = 1, ntyp
+          do i = 1, nbin
+            nsav(i,j) = n_aer(l,i,j)
+          enddo
+        enddo
+
+
+ 99     continue   ! DEBUT DE LA BOUCLE CONDITONNELLE
+
+        call ch4sat(temp,press,qsat)
+        qsat=qsat*0.85
+        qsatmix=qsat*0.85
+
+c       Get the partial presure of methane vapor and its saturation ratio
+        pch4       = ch4vap(l) * (Mn2/Mch4) * press
+        sat_ratio  = ch4vap(l) / qsat
+        sat_ratmix = ch4vap(l) / qsatmix
+
+c       Get the rates of nucleation
+        call nuclea(nbin,aerad,pch4,temp,sat_ratio,rate)
+
+c       Get the growth rates of condensation/sublimation
+        up   = ch4vap(l)
+        dwn  = 1.
+        Ctot = ch4vap(l)
+        DO i = 1, nbin
+
+        if (n_aer(l,i,3).eq.0) then
+          rad(i) = aerad(i)
+        else
+          rad(i) = ((n_aer(l,i,2)/n_aer(l,i,3) +
+     &     qprime(ig,l,i)/n_aer(l,i,3)
+     &    +vol(i))*0.75/pi)**(1./3.)
+        endif
+       
+
+*       Equilibrium saturation ratio (due to curvature effect)
+        seq(i) = exp( 2.*sig(temp)*Mch4 / (rhoi_ch4*rgp*temp*rad(i)) )
+
+        call growthrate(dt,temp,press,pch4,
+     &                  sat_ratmix,seq(i),rad(i),gr(i))
+        up = up + dt * gr(i) * 4. * pi * rhoi_ch4 * rad(i) * seq(i)
+     *                 * nsav(i,3) 
+        dwn= dwn+ dt * gr(i) * 4. * pi * rhoi_ch4 * rad(i) / qsat
+     *                 * nsav(i,3) 
+        Ctot= Ctot + rhoi_ch4 * nsav(i,2)
+
+        ENDDO
+
+        newvap = min(up/dwn,Ctot)  
+        newvap = max(newvap,0.)  
+
+        gltot=0.
+        DO i = 1, nbin
+          gr(i)  = gr(i) * ( newvap/qsat - seq(i) )
+          if(nsav(i,2).le.0. .and. gr(i).le.0.) then
+              n_aer(l,i,2) = 0.
+          else
+          n_aer(l,i,2) = nsav(i,2) + dt * gr(i) * 4. * pi * rad(i)
+     *                               * n_aer(l,i,3)
+          if (n_aer(l,i,2).le.0.) then
+            n_aer(l,i,1) = n_aer(l,i,1) + n_aer(l,i,3)
+            n_aer(l,i,2) = 0.
+            n_aer(l,i,3) = 0.
+          endif
+          gltot=n_aer(l,i,2)*rhoi_ch4+gltot
+          endif 
+
+        ENDDO
+    
+c       Determine the mass of exchanged methane
+
+        dQc = 0.
+        DO i = 1, nbin
+          dQc = dQc - rhoi_ch4 * ( n_aer(l,i,2) - nsav(i,2) )
+        ENDDO
+
+
+c       Arrays resetted to their initial value before condensation
+
+        do j = 1, ntyp
+          do i = 1, nbin
+            dn(i,j)      = n_aer(l,i,j) - nsav(i,j)
+            n_aer(l,i,j) = nsav(i,j)
+          enddo
+        enddo
+
+
+c       Update the c arrays.
+c       nucleation & cond/eva tendencies added together.
+
+        do i=1,nbin
+          elim         = dt * rate(i)
+          n_aer(l,i,1) = n_aer(l,i,1) / (1.+elim)
+          n_aer(l,i,3) = n_aer(l,i,3) + elim * n_aer(l,i,1) + dn(i,3)
+          n_aer(l,i,1) = n_aer(l,i,1) + dn(i,1)
+          n_aer(l,i,2) = n_aer(l,i,2) + dn(i,2)
+         if(n_aer(l,i,2).lt.0.) n_aer(l,i,2)=0.
+
+        enddo
+
+        dQc = 0.
+        DO i = 1, nbin    ! dQc <0 si glace produite !!
+          dQc = dQc - rhoi_ch4 * ( n_aer(l,i,2) - nsav(i,2) )
+        ENDDO
+
+
+       ch4vap(l)    = ch4vap(l) + dQc
+
+100   CONTINUE
+
+        do l = 1, nz
+        total11(l)=0.
+        do k = 1, nbin
+          total11(l)=total11(l)+n_aer(l,k,2)*rhoi_ch4
+        enddo
+        total22(l)=ch4vap(l) 
+        enddo
+
+
+      return
+      end
+
+
+*******************************************************
+* 						      *
+      subroutine nuclea(nbin,aerad,pch4,temp,sat,nucrate)
+*   This subroutine computes the nucleation rate      *
+*   as given in Pruppacher & Klett (1978) in the      *
+*   case of water ice forming on a solid substrate.   *
+*     Definition refined by Keese (jgr,1989)	      *
+*						      *
+*******************************************************
+
+      implicit none
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+
+      integer nbin
+      real aerad(nbin)
+
+      real*8 nucrate(nbin)
+      real*8 pch4
+      real   temp
+      real*8 sat
+
+      integer l,i
+      real*8 nch4
+      real sig            ! Water-ice/air surface tension  (N.m)
+      real*8 rstar        ! Radius of the critical germ (m)
+      real*8 gstar        ! # of molecules forming a critical embryo
+      real*8 x            ! Ratio rstar/radius of the nucleating dust particle
+      real fistar         ! Activation energy required to form a critical embryo (J)
+      real*8 zeldov       ! Zeldovitch factor (no dim)
+      real*8 fshape       ! function defined at the end of the file
+      real*8 deltaf
+
+      real nus
+      data nus/1.e+13/       ! Jump frequency of a molecule (s-1)
+      real m0
+      data m0/2.6578e-26/     ! Weight of a methane molecule (kg)
+      real vo1
+c     data vo1/6.254e-29/     ! Volume of a methane molecule (m3)
+      data vo1/3.7649e-5/     ! Volume of a methane molecule (m3)
+
+      real desorp
+      data desorp/0.288e-19/ ! Activation energy for desorption of water on a dust-like substrate (J/molecule)
+      real surfdif
+      data surfdif/0.288e-20/! Estimated activation energy for surface diffusion of water molecules (J/molecule)
+
+      IF (sat .GT. 1.) THEN    ! minimum condition to activate nucleation
+
+        nch4    = pch4 / kbz / temp
+        rstar  = 2. * sig(temp) * vo1 / (rgp*temp*log(sat))
+        gstar  = 4. * nav * pi * (rstar**3) / (3.*vo1)
+c       Loop over size bins
+        do i=1,nbin
+          x      = aerad(i) / rstar
+          x      = aerad(imono) / rstar  ! attention r(5)=monomeres
+
+          fistar = (4./3.*pi) * sig(temp) * (rstar**2.) *
+     &             fshape(mtetach4,x)
+          deltaf = min( max((2.*desorp-surfdif-fistar)/(kbz*temp)
+     &           , -100.), 100.)
+          if (deltaf.eq.-100.) then 
+            nucrate(i) = 0. 
+          else
+            zeldov = sqrt ( fistar / (3.*pi*kbz*temp*(gstar**2.)) )
+            nucrate(i)  = zeldov * kbz* temp * rstar**2.
+     &                  * 4. * pi * ( nch4*aerad(i) )**2.
+     &                  / ( fshape(mtetach4,x) * nus * m0 )
+     &                  * dexp(deltaf)
+ 
+             if(i.gt.imono)  nucrate(i)= zeldov * kbz* temp * rstar**2.
+     &           * 4. * pi * vrat_e**(i-imono)*(nch4*aerad(imono) )**2.
+     &            / (fshape(mtetach4,x) * nus * m0 )
+     &            * dexp(deltaf)
+
+
+          endif
+        enddo
+      ELSE
+        do i=1,nbin
+          nucrate(i) = 0.
+        enddo
+
+      ENDIF
+
+      return
+      end
+
+******************************************************************
+        subroutine ch4sat(t,p,qsat)
+* cette fonction calcule la pression de vapeur saturante du      *
+* methane a une altitude donnee z par l'equation de Thek-Stiel   *
+******************************************************************
+
+        real rgp
+        data rgp/8.3143/
+
+* declaration des variables internes
+* ----------------------------------
+        real p,tc,pc,tr,tb,tbr,phib,ac,hbr,hvb,avb,a,b
+        real qsat
+
+        tc = 190.53
+        pc = 45.96 * 0.986923
+        tr = t / tc
+        tb = 111.63
+        tbr= tb / tc
+        phib = -35. + 36./tbr + 42.*log(tbr)-tbr**6
+        ac   = (0.315*phib + log(pc))/(0.0838*phib-log(tbr))
+        hbr  = tbr * log(pc) / (1.-tbr)
+        hvb  = rgp*tb*(0.4343*log(pc)-0.68859+0.89584*tbr)/(0.37691-
+     s      0.37306*tbr+0.14878/(pc*tbr**2))
+        avb  = hvb / (rgp*tc*(1.-tbr)**(0.375))
+        a    = 5.2691 + 2.0753*avb - 3.1738*hbr
+        b    = 1.042 * ac - 0.46284 * avb
+
+        qsat=pc*exp(avb*(1.14893-1./tr-0.11719*tr-0.03174*tr**2
+     s        -0.375*log(tr))+b*((tr**a-1.)/a+0.04*(1./tr-1.)))
+        qsat=qsat*1e+5/0.986923
+        !  ---> qsat en Pa
+
+        qsat=qsat* 16.0 / (28.0*p)   ! kg/kg
+        
+
+
+        return
+        end
+
+c=======================================================================
+      subroutine growthrate(timestep,temp,press,pch4,sat,seq,r,Cste)
+c
+c     Determination of the droplet growth rate
+c
+c=======================================================================
+
+      IMPLICIT NONE
+#include "dimensions.h"
+#include "microtab.h"
+#include "varmuphy.h"
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+      common/lheat/Lv
+
+c
+c   arguments:
+c   ----------
+
+      REAL timestep
+      REAL temp    ! temperature in the middle of the layer (K)
+      REAL press    ! pressure in the middle of the layer (K)
+      REAL*8 pch4 ! Methane vapor partial pressure (Pa)
+      REAL*8 sat  ! saturation ratio 
+      REAL r    ! crystal radius before condensation (m)
+      REAL seq  ! Equilibrium saturation ratio
+
+c   local:
+c   ------
+
+      REAL psat
+      REAL moln2,molch4
+      REAL To,wch4,tch4,ftm
+
+c     Effective gas molecular radius (m)
+      data moln2/1.75e-10/   ! N2
+c     Effective gas molecular radius (m)
+      data molch4/2.e-10/   ! CH4
+
+      data tch4/190.4/
+      data wch4/1.1e-2/    ! Reid et al (Eq 7-9.4 + Appendix Compound [116])
+
+      REAL k,Lv                 
+      REAL knudsen           ! Knudsen number (gas mean free path/particle radius)
+      REAL a,Dv,lambda,Rk,Rd ! Intermediate computations for growth rate
+      REAL*8 Cste
+
+c-----------------------------------------------------------------------
+c      Ice particle growth rate by diffusion/impegement of 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----------------------------------------------------------------------- 
+
+      psat = pch4 / sat
+
+c     - Thermal conductibility of N2
+      k = ( 2.857e-2 * temp - 0.5428  ) * 4.184e-3
+c     - Latent heat of ch4 (J.kg-1)
+      Lv = 510.e+3
+      ftm=1.-temp/tch4
+      if (ftm.le.1.e-3)  ftm=1.e-3
+      Lv=8.314*tch4*(7.08*ftm**0.354+10.95*wch4*ftm**0.456)/16.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* (moln2*1.e10)**2  * (nav*1.e-20))
+
+c     - Compute Dv, methane 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*rgp*temp/(pi*Mch4) )* (kbz*1.e20) * temp / 
+     &   (pi*press*(moln2*1.e10+molch4*1.e10)**2 * sqrt(1.+Mch4/Mn2) )
+
+      knudsen = temp / press * a / r
+      lambda  = (1.333+0.71/knudsen) / (1.+1./knudsen)
+      Dv      = Dv / (1. + lambda * knudsen)
+
+c     - Compute Rk
+      Rk = Lv**2 * rhoi_ch4 * Mch4 / (k*rgp*temp**2.)
+c     - Compute Rd
+      Rd = rgp * temp *rhoi_ch4 / (Dv*psat*Mch4)
+
+c     - Compute:      rdr/dt = Cste * (S-Seq)
+      Cste = 1. / (seq*Rk+Rd)
+
+      RETURN
+      END
+
+
+*********************************************************
+      real function sig(t)
+*    this function computes the surface tension (N.m)   *
+*   between methane and air as a function of temp.    *
+*********************************************************
+
+      real t
+
+      sig = ( t/4. + 41.) * 1e-3
+
+      return
+      end
+
+*********************************************************
+      real*8 function fshape(cost,rap)
+*        function computing the f(m,x) factor           *
+* related to energy required to form a critical embryo  *
+*********************************************************
+
+      implicit none
+
+      real cost
+      real*8 rap
+      real*8 phi
+      real*8 a,b,c
+
+      phi = sqrt( 1. - 2.*cost*rap + rap**2 )
+
+      a = 1. + ( (1.-cost*rap)/phi )**3
+      b = (rap**3) * (2.-3.*(rap-cost)/phi+((rap-cost)/phi)**3)
+      c = 3. * cost * (rap**2) * ((rap-cost)/phi-1.)
+
+      fshape = 0.5*(a+b+c)
+
+      if (rap.gt.3000.) fshape = ((2.+cost)*(1.-cost)**2)/4.
+
+
+      return
+      end
+
Index: trunk/LMDZ.TITAN/libf/phytitan/optci.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/optci.F	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/optci.F	(revision 175)
@@ -32,6 +32,9 @@
      & , REALI(NSPECI), XIMGI(NSPECI), REALV(NSPECV), XIMGV(NSPECV)
 
-      COMMON /CLOUD/ RADCLD(NLAYER), XNCLD(NLAYER)
-     & , RCLDI(NSPECI), XICLDI(NSPECI), RCLDV(NSPECV), XICLDV(NSPECV)
+      COMMON /CLOUD/
+     &               RCLDI(NSPECI), XICLDI(NSPECI)
+     &             , RCLDV(NSPECV), XICLDV(NSPECV)
+     &             , RCLDI2(NSPECI), XICLDI2(NSPECI)
+     &             , RCLDV2(NSPECV), XICLDV2(NSPECV)
 
       COMMON /TAUS/   TAUHI(ngrid,NSPECI),TAUCI(ngrid,NSPECI),
@@ -41,6 +44,8 @@
 
       COMMON /TAUD/   TAUHID(ngrid,NLAYER,NSPECI)
+     &               ,TAUCID(ngrid,NLAYER,NSPECI)
      &               ,TAUGID(ngrid,NLAYER,NSPECI)
      &               ,TAUHVD(ngrid,NLAYER,NSPECV)
+     &               ,TAUCVD(ngrid,NLAYER,NSPECV)
      &               ,TAUGVD(ngrid,NLAYER,NSPECV)
 
@@ -50,7 +55,14 @@
      &               ,WBARI(ngrid,NLAYER,NSPECI)
      &               ,COSBI(ngrid,NLAYER,NSPECI)
+     &               ,DTAUIP(ngrid,NLAYER,NSPECI)
+     &               ,TAUIP(ngrid,NLEVEL,NSPECI)
+     &               ,WBARIP(ngrid,NLAYER,NSPECI)
+     &               ,COSBIP(ngrid,NLAYER,NSPECI)
 
       COMMON /SPECTI/ BWNI(NSPC1I), WNOI(NSPECI),
      &                DWNI(NSPECI), WLNI(NSPECI)
+
+      REAL DTAUP(ngrid,NLAYER,NSPECI),DTAUPP(ngrid,NLAYER,NSPECI)
+      COMMON /IRTAUS/ DTAUP,DTAUPP
 
       COMMON /PLANT/ CSUBP,RSFI,RSFV,F0PI
@@ -58,4 +70,11 @@
       COMMON /CONST/RGAS,RHOP,PI,SIGMA
       COMMON /part/v,rayon,vrat,dr,dv
+
+c-----Rayons nuages et "composition" de la goutte
+c     sur la grille ...
+      integer ncount(ngrid,NLAYER)
+      real    rmcbar(ngrid,NLAYER)
+      real    xfbar(ngrid,NLAYER,4)
+      COMMON/rnuabar/ncount,rmcbar,xfbar
 
       DIMENSION PROD(NLEVEL)
@@ -78,12 +97,7 @@
       data iopti,iwarning,seulmtunpt/0,0,0/
 
-      real   zqaer_1pt(NLAYER,nrad)
-      real   TAUHID_1pt(NLAYER,NSPECI)
-      real   TAUGID_1pt(NLAYER,NSPECI)
-      real   TAUHI_1pt(NSPECI),TAUCI_1pt(NSPECI)
-      real   TAUGI_1pt(NSPECI)
-      real   DTAUI_1pt(NLAYER,NSPECI),TAUI_1pt(NLEVEL,NSPECI)
-      real   WBARI_1pt(NLAYER,NSPECI)
-      real   COSBI_1pt(NLAYER,NSPECI)
+      real   zqaer_1pt(NLAYER,2*nrad)
+#include "optci_1pt.h"
+
       character*100 dummy
       real   dummy2,dummy3
@@ -128,11 +142,24 @@
 c il faut quand meme qu on lise la look-up table de dim nrad=10
 c et si microfi=1, on doit avoir nmicro=nrad (dans microtab.h)
-       if ((nmicro.ne.nrad).and.(microfi.eq.1)) then
-          print*,"nmicro.ne.nrad",nmicro,nrad
-	  print*,"PROBLEME pour zqaer_1pt dans optci !!"
-	  stop
+c
+c Nouvelle verif pour nuages : 
+c La condition ci-dessus n'est plus realisable !
+c nmicro comprend maintenant aussi des glaces
+c Donc on teste juste que nmicro soit > 2*nrad (ou nrad si on ne fait pas de nuages)
+       if (microfi.ge.1) then
+         if ((clouds.eq.1).and.(nmicro.lt.2*nrad)) then
+           print*,"OPTCI :"
+           print*,"clouds = 1 MAIS nmicro < 2*nrad"
+           print*,"Probleme pour zqaer_1pt dans optci."
+           stop
+         endif
+         if ((clouds.eq.0).and.(nmicro.lt.nrad)) then
+           print*,"OPTCI :"
+           print*,"nmicro < nrad"
+           print*,"Probleme pour zqaer_1pt dans optci."
+           stop
+         endif
        endif
 
-      
       DO 420 K=1,NSPECI
 C LETS USE THE THOLIN OPTICAL CONSTANTS FOR THE HAZE.
@@ -141,6 +168,10 @@
           XIMGI(K)=TNI*FHIR
 C SET UP THE OPTICAL CONSTANTS FOR THE CLOUD
-          RCLDI(K)=1.27
-          XICLDI(K)=REFLIQ(WNOI(K))
+          CALL LIQCH4(WLNI(K),TNR,TNI)
+          RCLDI(K)=TNR
+          XICLDI(K)=TNI
+          CALL LIQC2H6(WLNI(K),TNR,TNI)
+          RCLDI2(K)=TNR
+          XICLDI2(K)=TNI
  420  CONTINUE
 
@@ -197,12 +228,18 @@
 c     endif   
 
-        if (microfi.eq.1) then
-           do iq=1,nrad
-             do j=1,NLAYER
-                 zqaer_1pt(j,iq)=qaer(ig,j,iq)
-             enddo
-           enddo
+        if (microfi.ge.1) then
+          do iq=1,2*nrad
+c           si on ne fait pas de nuages on ne copie que les nrad premieres valeurs.
+            if (clouds.eq.0.and.iq.gt.nrad) then
+              zqaer_1pt(:,iq)=0.
+            else
+              do j=1,NLAYER
+                zqaer_1pt(j,iq)=qaer(ig,j,iq)
+              enddo
+            endif
+          enddo
         else
          if (ig.eq.1)  then
+           zqaer_1pt = 0.
 c initialisation zqaer_1pt a partir d une look-up table (uniforme en ig)
 c boucle sur nrad=10 (dans microtab.h)
@@ -217,5 +254,5 @@
 c ici, les tableaux definissant la structure des aerosols sont
 c remplis: rf,df(nq),rayon(nq,)v(nq)......
-       call rdf()
+           call rdf()
          endif
         endif
@@ -229,7 +266,6 @@
 	
         if (seulmtunpt.eq.0) then
-	   call optci_1pt(zqaer_1pt,iopti,
-     .            COSBI_1pt,DTAUI_1pt,TAUHI_1pt,TAUHID_1pt,TAUCI_1pt,
-     .            TAUGI_1pt,TAUGID_1pt,WBARI_1pt,TAUI_1pt,IPRINT)
+          call optci_1pt2(zqaer_1pt,rmcbar(ig,:),xfbar(ig,:,:),
+     &                   iopti,IPRINT)
            iopti = 1
 	endif
@@ -241,13 +277,21 @@
 	endif
 	
-	COSBI(ig,:,:)  = COSBI_1pt(:,:) 
-	WBARI(ig,:,:)  = WBARI_1pt(:,:) 
-	DTAUI(ig,:,:)  = DTAUI_1pt(:,:) 
-	TAUHI(ig,:)    = TAUHI_1pt(:) 
-	TAUCI(ig,:)    = TAUCI_1pt(:) 
-	TAUGI(ig,:)    = TAUGI_1pt(:) 
-	TAUI(ig,:,:)   = TAUI_1pt(:,:) 
-	TAUHID(ig,:,:) = TAUHID_1pt(:,:) 
-	TAUGID(ig,:,:) = TAUGID_1pt(:,:) 
+        COSBI(ig,:,:)  = COSBI_1pt(:,:) 
+        WBARI(ig,:,:)  = WBARI_1pt(:,:) 
+        DTAUI(ig,:,:)  = DTAUI_1pt(:,:) 
+        TAUI(ig,:,:)   = TAUI_1pt(:,:) 
+
+        COSBIP(ig,:,:)  = COSBIP_1pt(:,:) 
+        WBARIP(ig,:,:)  = WBARIP_1pt(:,:) 
+        DTAUIP(ig,:,:)  = DTAUIP_1pt(:,:) 
+        TAUIP(ig,:,:)   = TAUIP_1pt(:,:) 
+
+        TAUHI(ig,:)    = TAUHI_1pt(:) 
+        TAUCI(ig,:)    = TAUCI_1pt(:) 
+        TAUGI(ig,:)    = TAUGI_1pt(:) 
+
+        TAUHID(ig,:,:) = TAUHID_1pt(:,:) 
+        TAUCID(ig,:,:) = TAUCID_1pt(:,:) 
+        TAUGID(ig,:,:) = TAUGID_1pt(:,:) 
 
 c************************************************************************
@@ -256,4 +300,13 @@
 c************************************************************************
 c************************************************************************
+C THIS ROUTINE HAS ALREADY SET THE DTAUI(J,K) VALUES BUT MUST BE PASSED
+        DO 225 IG=1,klon
+         DO 220 J=1,NLAYER
+          DO 230 K=1,NSPECI
+              DTAUP(IG,J,K)=DTAUI(IG,J,K)
+              DTAUPP(IG,J,K)=DTAUIP(IG,J,K)
+230       CONTINUE
+220      CONTINUE
+225     CONTINUE
 
       print*, 'FIN OPTCI'
Index: trunk/LMDZ.TITAN/libf/phytitan/optci_1pt.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/optci_1pt.F	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/optci_1pt.F	(revision 175)
@@ -1,5 +1,3 @@
-      SUBROUTINE optci_1pt(zqaer_1pt,iopti,
-     .            COSBI_1pt,DTAUI_1pt,TAUHI_1pt,TAUHID_1pt,TAUCI_1pt,
-     .            TAUGI_1pt,TAUGID_1pt,WBARI_1pt,TAUI_1pt,IPRINT)
+      SUBROUTINE optci_1pt(zqaer_1pt,rcdb,xfrb,iopti,IPRINT)
       use dimphy
 #include "dimensions.h"
@@ -16,12 +14,6 @@
 C iopti: premier appel, on ne calcule qu'une fois les QM et QF
 * nrad dans microtab.h
-      real   zqaer_1pt(NLAYER,nrad)
-      real   TAUHID_1pt(NLAYER,NSPECI)
-      real   TAUGID_1pt(NLAYER,NSPECI)
-      real   TAUHI_1pt(NSPECI),TAUCI_1pt(NSPECI)
-      real   TAUGI_1pt(NSPECI)
-      real   DTAUI_1pt(NLAYER,NSPECI),TAUI_1pt(NLEVEL,NSPECI)
-      real   WBARI_1pt(NLAYER,NSPECI)
-      real   COSBI_1pt(NLAYER,NSPECI)
+      real   zqaer_1pt(NLAYER,2*nrad)
+#include "optci_1pt.h"
 c   ---------
 
@@ -37,6 +29,9 @@
      & , REALI(NSPECI), XIMGI(NSPECI), REALV(NSPECV), XIMGV(NSPECV)
 
-      COMMON /CLOUD/ RADCLD(NLAYER), XNCLD(NLAYER)
-     & , RCLDI(NSPECI), XICLDI(NSPECI), RCLDV(NSPECV), XICLDV(NSPECV)
+      COMMON /CLOUD/
+     &               RCLDI(NSPECI), XICLDI(NSPECI)
+     &             , RCLDV(NSPECV), XICLDV(NSPECV)
+     &             , RCLDI2(NSPECI), XICLDI2(NSPECI)
+     &             , RCLDV2(NSPECV), XICLDV2(NSPECV)
 
       COMMON /SPECTI/ BWNI(NSPC1I), WNOI(NSPECI),
@@ -57,7 +52,13 @@
       REAL QM1(nrad,NSPECI),QM2(nrad,NSPECI)
       REAL QM3(nrad,NSPECI),QM4(nrad,NSPECI)
+      REAL QC1(nrad,NSPECI),QC2(nrad,NSPECI)
+      REAL QC3(nrad,NSPECI),QC4(nrad,NSPECI)
       real emu
       REAL TAEROSM1(NSPECI),TAEROSCATM1(NSPECI),DELTAZM1(NSPECI)
       
+c ---- nuages      
+      REAL TNUAGE,TNUAGESCAT
+      REAL rcdb(nlayer),xfrb(nlayer,4)
+
       save qf1,qf2,qf3,qf4,qm1,qm2,qm3,qm4
 
@@ -192,10 +193,10 @@
              if (iopti.eq.0) then
 
-       CALL OPTFRAC(XMONO,10000./WNOI(K)
-     &                         ,QEXT,QSCT,QABS,QBAR)
-
-
-c      CALL CFFFV11(1.e-2/WNOI(K),REALI(K),XIMGI(K),RF(inq),2.
-c    &                ,XMONO,QSCT,QEXT,QABS,QBAR)
+c       CALL OPTFRAC(XMONO,10000./WNOI(K)
+c     &                         ,QEXT,QSCT,QABS,QBAR)
+
+
+       CALL CFFFV11(1.e-2/WNOI(K),REALI(K),XIMGI(K),RF(inq),2.
+     &                ,XMONO,QSCT,QEXT,QABS,QBAR)
 
 
@@ -213,5 +214,4 @@
 
                IF(TAEROS.LT.1.e-10) TAEROS=1.e-10                                              
-
          ENDIF
        ENDDO             ! FIN DE LA BOUCLE SUR nrad
@@ -279,12 +279,82 @@
 
 C NEXT COMPUTE TAU CLOUD
-      TAUCLD=0.0
-      CBARC =0.0
-       IF ( XNCLD(J) .GT. 0..and .taufac.gt.0.) THEN
-         print*,'Appel a xmie avec radcld=',radcld(j)
-                CALL XMIE(RADCLD(J),RCLDI(K),XICLDI(K),
-     &                         QEXTC,QSCTC,QABSC,CBARC,WNOI(K))
-                TAUCLD=QEXTC*XNCLD(J)
+      IF (clouds.eq.0) THEN
+        TNUAGE=0.
+        TNUAGESCAT=0.
+        CNBAR=0.
+      ELSE
+        TNUAGE=0.
+        TNUAGESCAT=0.
+        CNBAR=0.
+        QEXTC=0.
+        QSCTC=0.
+        QABSC=0.
+        CBARC=0.
+
+        DO inq=1,nrad         !BOUCLE SUR LES NQMX TAILLE D"AEROSOLS
+          QC1(inq,K)=0.
+          QC2(inq,K)=0.
+          QC3(inq,K)=0.
+          QC4(inq,K)=0.
+        ENDDO
+
+** OPTICAL CONSTANT : MIXING RULES
+
+        IF (rcdb(nlayer+1-J).gt.1.1e-10) THEN
+
+          XNR=xfrb(nlayer+1-J,1) *REALI(K)
+     &    +xfrb(nlayer+1-J,2) *RCLDI(K)
+     &    +xfrb(nlayer+1-J,3) *RCLDI2(K)
+     &    +xfrb(nlayer+1-J,4) *RCLDI2(K)
+
+          XNI=xfrb(nlayer+1-J,1) *XIMGI(K)
+     &    +xfrb(nlayer+1-J,2) *XICLDI(K)
+     &    +xfrb(nlayer+1-J,3) *XICLDI2(K)
+     &    +xfrb(nlayer+1-J,4) *XICLDI2(K)
+
+** OPTICAL CONSTANT : LIQUID DROP = THOLIN
+
+          IF(xfrb(nlayer+1-J,1).ge.0.1) THEN
+            XNI=XIMGI(K)
+            XNR=REALI(K)
+          ENDIF
+
+          IF (XNI.gt.1.e-10  .and. XNR.gt.1.00) THEN
+            CALL CMIE(1.E-2/WNOI(K),XNR,XNI,
+     &      rcdb(nlayer+1-J),
+     &      QEXTC,QSCTC,QABSC,CBARC)
+          ELSE
+            PRINT*,' WARNING XNR/XNI in optci: ',XNR,XNI
+            QEXTC=0.
+            QSCTC=0.
+            QABSC=0.
+            CBARC=0.
+          ENDIF
+        ELSE
+          QEXTC=0.
+          QSCTC=0.
+          QABSC=0.
+          CBARC=0.
         ENDIF
+
+        DO inq=1,nrad         !BOUCLE SUR LES NQMX TAILLE D"AEROSOLS
+          QC1(inq,K)=QEXTC/xnuf
+          QC2(inq,K)=QSCTC/xnuf
+          QC3(inq,K)=QABSC/xnuf
+          QC4(inq,K)=CBARC
+          TNUAGE=QC1(inq,K)*zqaer_1pt(nlayer+1-J,inq+nrad)*1.e-4
+     &          +TNUAGE
+          TNUAGESCAT=QC2(inq,K)*zqaer_1pt(nlayer+1-J,inq+nrad)*1.e-4
+     &              +TNUAGESCAT
+          CNBAR=QC4(inq,K)*QC2(inq,K)
+     &         *zqaer_1pt(nlayer+1-J,inq+nrad)*1.e-4+CNBAR
+        ENDDO
+
+        IF(TNUAGESCAT.EQ.0.) THEN
+             CNBAR=0.
+        ELSE
+             CNBAR=CNBAR/TNUAGESCAT
+        ENDIF
+      ENDIF    ! Cond CLD
 
 
@@ -329,54 +399,51 @@
 C
 
-      IF (TAEROS + TAUCLD .GT. 0.) THEN
-         COSBI_1pt(J,K)=(CBAR*TAEROSCAT + CBARC*TAUCLD )
-     &                     /(TAEROSCAT + TAUCLD)
+      DTAUI_1pt(J,K)=TAUGAS+TAEROS+TNUAGE
+      DTAUIP_1pt(J,K)=TAUGAS+TAEROS
+
+      TAUHI_1pt(K)=TAUHI_1pt(K) + TAEROS
+      TAUHID_1pt(J,K)=TAUHI_1pt(K)
+
+      TAUGI_1pt(K)=TAUGI_1pt(K) + TAUGAS
+      TAUGID_1pt(J,K)=TAUGI_1pt(K)
+
+      TAUCI_1pt(K)=TAUCI_1pt(K) + TNUAGE
+      TAUCID_1pt(J,K)=TAUCI_1pt(K)
+ 
+C ??FLAG? SERIOUS PROBLEM WITH THE CODE HERE!
+
+      TLIMIT=1.E-16
+
+
+      IF (TAEROSCAT + TNUAGESCAT .GT. 0.) THEN
+         COSBI_1pt(J,K)=(CBAR*TAEROSCAT + CNBAR*TNUAGESCAT )
+     &                     /(TAEROSCAT + TNUAGESCAT)
       ELSE
          COSBI_1pt(J,K)=0.0
       ENDIF
 
-      DTAUI_1pt(J,K)=TAUGAS+TAEROS+TAUCLD
-
-      TAUHI_1pt(K)=TAUHI_1pt(K) + TAEROS
-      TAUHID_1pt(J,K)=TAUHI_1pt(K)
-
-      TAUGI_1pt(K)=TAUGI_1pt(K) + TAUGAS
-      TAUGID_1pt(J,K)=TAUGI_1pt(K)
-
-      TAUCI_1pt(K)=TAUCI_1pt(K) + TAUCLD
- 
-c     if (ig.eq.1) then
-c     if (k.eq.NSPECI/2.or.k.eq.1.or.k.eq.NSPECI) then
-c      print*,'@IR',K,J,DTAUI_1pt(J,K),TAUGAS,TAEROS,TAUCLD         
-c     endif
-c     endif
-
-
-C ??FLAG? SERIOUS PROBLEM WITH THE CODE HERE!
-
-      TLIMIT=1.E-16
-
-      IF (DTAUI_1pt(J,K) .GT. TLIMIT) THEN
-
-c***************** ECHANGE 
-c        WBARI(J,K)=(QSCT*XNUMB(J) + QSCTC*XNCLD(J))
-c****************
-CFC        WBARI_1pt(J,K)=(TAEROSCAT + QSCTC*XNCLD(J))
-c****************
-           WBARI_1pt(J,K)=TAEROSCAT
-     &   /DTAUI_1pt(J,K)
-c        if(iwarning.eq.0) 
-c     s   print*,'WARNING!!! dans optci xncld non initialise'
-c        iwarning=1
-
+      IF (TAEROSCAT  .GT. 0.) THEN
+         COSBIP_1pt(J,K)=(CBAR*TAEROSCAT)
+     &                     /(TAEROSCAT)
       ELSE
-
+         COSBIP_1pt(J,K)=0.0
+      ENDIF
+
+*---------
+
+      IF (DTAUI_1pt(J,K) .GT.  TLIMIT) THEN
+          WBARI_1pt(J,K)=(TAEROSCAT+TNUAGESCAT) /DTAUI_1pt(J,K)
+      ELSE
          WBARI_1pt(J,K)=0.0
-c        PRINT*,'gaz ',taugas,'aerosols',taeros,'nuages',taucld
-c        WRITE (6,999) J,K,DTAUI_1pt(J,K)
- 999     FORMAT ('  WARNING TAU MINIMUM AT J,K,DTAU:',2I3,1PE10.3)
          DTAUI_1pt(J,K)=TLIMIT
-
       ENDIF
+
+      IF (DTAUIP_1pt(J,K) .GT.  TLIMIT) THEN
+          WBARIP_1pt(J,K)=(TAEROSCAT) /DTAUIP_1pt(J,K)
+      ELSE
+         WBARIP_1pt(J,K)=0.0
+         DTAUIP_1pt(J,K)=TLIMIT
+      ENDIF
+
 
 c     IF (IPRINT .GT. 9)
@@ -397,6 +464,8 @@
         DO 119 K=1,NSPECI
            TAUI_1pt(1,K)=0.0
+           TAUIP_1pt(1,K)=0.0
         DO 119 J=1,NLAYER
            TAUI_1pt(J+1,K)=TAUI_1pt(J,K)+DTAUI_1pt(J,K)
+           TAUIP_1pt(J+1,K)=TAUIP_1pt(J,K)+DTAUIP_1pt(J,K)
  119    CONTINUE
 
Index: trunk/LMDZ.TITAN/libf/phytitan/optci_1pt.h
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/optci_1pt.h	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/optci_1pt.h	(revision 175)
@@ -0,0 +1,47 @@
+!----------------------------------------------
+! fichier optci_1p.h
+!
+!  regroupe les sorties du fichier optci_1pt
+!  les nuages oblige a quasiment doubler
+!  le nombre de variables c'est juste pour
+!  la lisibilite.
+!----------------------------------------------
+
+! ----DIAGNOSTIQUES
+      real   TAUHID_1pt(NLAYER,NSPECI)
+      real   TAUCID_1pt(NLAYER,NSPECI)
+      real   TAUGID_1pt(NLAYER,NSPECI)
+! ----OPACITES TOTALES
+      real   TAUHI_1pt(NSPECI)
+      real   TAUCI_1pt(NSPECI)
+      real   TAUGI_1pt(NSPECI)
+! ----COLONNE NUAGEUSE
+      real   DTAUI_1pt(NLAYER,NSPECI)
+      real   TAUI_1pt(NLEVEL,NSPECI)
+      real   WBARI_1pt(NLAYER,NSPECI)
+      real   COSBI_1pt(NLAYER,NSPECI)
+! ----COLONNE "CLAIRE"
+      real   DTAUIP_1pt(NLAYER,NSPECI)
+      real   TAUIP_1pt(NLEVEL,NSPECI)
+      real   WBARIP_1pt(NLAYER,NSPECI)
+      real   COSBIP_1pt(NLAYER,NSPECI)
+
+
+      common/opti_1pt/                                                  &
+     &        TAUHID_1pt                                                &
+     &       ,TAUCID_1pt                                                &
+     &       ,TAUGID_1pt                                                &
+! ----OPACITES TOTALES
+     &       ,TAUHI_1pt                                                 &
+     &       ,TAUCI_1pt                                                 &
+     &       ,TAUGI_1pt                                                 &
+! ----COLONNE NUAGEUSE
+     &       ,DTAUI_1pt                                                 &
+     &       ,TAUI_1pt                                                  &
+     &       ,WBARI_1pt                                                 &
+     &       ,COSBI_1pt                                                 &
+! ----COLONNE "CLAIRE"
+     &       ,DTAUIP_1pt                                                &
+     &       ,TAUIP_1pt                                                 &
+     &       ,WBARIP_1pt                                                &
+     &       ,COSBIP_1pt
Index: trunk/LMDZ.TITAN/libf/phytitan/optci_1pt_2.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/optci_1pt_2.F	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/optci_1pt_2.F	(revision 175)
@@ -0,0 +1,480 @@
+      SUBROUTINE optci_1pt2(zqaer_1pt,rcdb,xfrb,iopti,IPRINT)
+
+      use dimphy
+#include "dimensions.h"
+#include "microtab.h"
+#include "numchimrad.h"
+#include "clesphys.h"
+
+      PARAMETER(NLAYER=llm,NLEVEL=NLAYER+1)
+      PARAMETER (NSPECI=46,NSPC1I=47,NSPECV=24,NSPC1V=25)
+
+c   Arguments:
+c   ---------
+      integer IPRINT,iopti
+C iopti: premier appel, on ne calcule qu'une fois les QM et QF
+* nrad dans microtab.h
+      real   zqaer_1pt(NLAYER,2*nrad)
+#include "optci_1pt.h"
+c   ---------
+
+      COMMON /ATM/ Z(NLEVEL),PRESS(NLEVEL),DEN(NLEVEL),TEMP(NLEVEL)
+
+      COMMON /GASS/ CH4(NLEVEL),XN2(NLEVEL),H2(NLEVEL),AR(NLEVEL)
+     & ,XMU(NLEVEL),GAS1(NLAYER),COLDEN(NLAYER)
+
+      COMMON /STRATO/ C2H2(NLAYER),C2H6(NLAYER)
+      COMMON /STRAT2/ HCN(NLAYER)
+
+      COMMON /AERSOL/ RADIUS(NLAYER), XNUMB(NLAYER)
+     & , REALI(NSPECI), XIMGI(NSPECI), REALV(NSPECV), XIMGV(NSPECV)
+
+      COMMON /CLOUD/
+     &               RCLDI(NSPECI), XICLDI(NSPECI)
+     &             , RCLDV(NSPECV), XICLDV(NSPECV)
+     &             , RCLDI2(NSPECI), XICLDI2(NSPECI)
+     &             , RCLDV2(NSPECV), XICLDV2(NSPECV)
+
+      COMMON /SPECTI/ BWNI(NSPC1I), WNOI(NSPECI),
+     &                DWNI(NSPECI), WLNI(NSPECI)
+
+      COMMON /PLANT/ CSUBP,RSFI,RSFV,F0PI
+      COMMON /ADJUST/ RHCH4,FH2,FHAZE,FHVIS,FHIR,TAUFAC,RCLOUD,FARGON
+      COMMON /CONST/RGAS,RHOP,PI,SIGMA
+      COMMON /part/v,rayon,vrat,dr,dv
+
+      DIMENSION PROD(NLEVEL)
+* nrad dans microtab.h
+      real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad)
+      real xv1(klev,nspeci),xv2(klev,nspeci)
+      real xv3(klev,nspeci)
+      REAL QF1(nrad,NSPECI),QF2(nrad,NSPECI)
+      REAL QF3(nrad,NSPECI),QF4(nrad,NSPECI)
+      REAL QM1(nrad,NSPECI),QM2(nrad,NSPECI)
+      REAL QM3(nrad,NSPECI),QM4(nrad,NSPECI)
+      REAL QC1(nrad,NSPECI),QC2(nrad,NSPECI)
+      REAL QC3(nrad,NSPECI),QC4(nrad,NSPECI)
+      real emu
+      REAL TAEROSM1(NSPECI),TAEROSCATM1(NSPECI),DELTAZM1(NSPECI)
+
+c ---- nuages      
+      REAL TNUAGE,TNUAGESCAT
+      REAL rcdb(nlayer),xfrb(nlayer,4)
+
+      save qf1,qf2,qf3,qf4,qm1,qm2,qm3,qm4,qc1,qc2,qc3,qc4
+
+
+C THE PRESSURE INDUCED TRANSITIONS ARE FROM REGIS
+C THE LAST SEVENTEEN INTERVALS ARE THE BANDS FROM GNF.
+C
+C THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE INFRARED
+C IT CALCUALTES FOR EACH LAYER, FOR EACH SPECRAL INTERVAL IN THE IR
+C LAYER: WBAR, DTAU, COSBAR
+C LEVEL: TAU
+C
+
+        DO 80 K=1,NSPECI
+           TAUHI_1pt(K)=0.
+           TAUCI_1pt(K)=0.
+           TAUGI_1pt(K)=0.
+ 80     CONTINUE
+
+c************************************************************************
+          DO 100 J=1,NLAYER    ! BOUCLE SUR L'ALTITUDE
+c************************************************************************
+
+C SET UP THE COEFFICIENT TO REDUCE MASS PATH TO STP ...SEE NOTES
+C T0 =273.15   PO=1.01325 BAR
+
+        TBAR=0.5*(TEMP(J)+TEMP(J+1))
+        PBAR=SQRT(PRESS(J)*PRESS(J+1))
+        BMU=0.5*(XMU(J+1)+XMU(J))
+        COEF1=RGAS*273.15**2*.5E5* (PRESS(J+1)**2 - PRESS(J)**2)
+     & /(1.01325**2 *EFFG(Z(J))*TBAR*BMU)
+
+      IF (IPRINT .GT. 9) WRITE(6,21) J,EFFG(Z(J)),TBAR,BMU,COEF1
+ 21   FORMAT(' J, EFFG, TBAR, BMU, COEF1,: ',I3,1P6E10.3)
+
+c------------------------------------------------------------------------
+         DO 101 K=1,NSPECI     ! BOUCLE SUR LES L.D'O
+c------------------------------------------------------------------------
+
+
+C #1:             HAZE
+C---------------------
+
+C FIRST COMPUTE TAU AEROSOL
+
+
+c
+c                    /\
+c                   /  \
+c                  /    \
+c                 / _O   \
+c                / |/     \
+c               /  / \     \
+c              /   |\ \/\   \
+c             /    || /  \   \
+c             ----------------
+c            |     WARNING    |
+c            |    SLOW DOWN   |
+c             ---------------- 
+
+
+
+
+c*********** EN TRAVAUX ***************************
+
+         TAEROS=0.
+         TAEROSCAT=0.
+         CBAR=0.
+
+
+      DO inq=1,nrad         !BOUCLE SUR LES TAILLE D"AEROSOLS
+
+
+      IF (WNOI(K).lt.wco) THEN    ! lamda > 56 um
+
+           if (iopti.eq.0) then
+
+c          CALL XMIE(rayon(inq)*1.e6,REALI(K),XIMGI(K),
+c    &     QEXT,QSCT,QABS,QBAR,WNOI(K))
+
+           CALL CMIE(1.E-2/WNOI(K),REALI(K),XIMGI(K),rayon(inq),
+     &     QEXT,QSCT,QABS,QBAR)
+
+
+           QM1(inq,K)=QEXT
+           QM2(inq,K)=QSCT
+           QM3(inq,K)=QABS
+           QM4(inq,K)=QBAR
+
+          endif         ! end iopti
+
+
+      TAEROS=QM1(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4+TAEROS
+      TAEROSCAT=QM2(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4+TAEROSCAT
+      CBAR=CBAR+QM4(inq,K)*QM2(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4
+
+
+         ELSE                           ! 0.2 < lambda < 56 um
+
+
+            if(rayon(inq).lt.RF(inq)) THEN
+
+              if (iopti.eq.0) then
+
+                   CALL XMIE(rayon(inq)*1.e6,REALI(K),XIMGI(K),
+     &             QEXT,QSCT,QABS,QBAR,WNOI(K))
+
+              QM1(inq,K)=QEXT
+              QM2(inq,K)=QSCT
+              QM3(inq,K)=QABS
+              QM4(inq,K)=QBAR
+              endif         ! end iopti
+
+
+        TAEROS=QM1(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4+TAEROS
+        TAEROSCAT=QM2(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4+TAEROSCAT
+        CBAR=CBAR+QM4(inq,K)*QM2(inq,K)*zqaer_1pt(nlayer+1-J,inq)*1.e-4
+
+           else
+
+               XMONO=(rayon(inq)/RF(inq))**3.
+               XRULE=1.
+
+            if(XMONO.gt.16384./1.5) then
+             XRULE=(XMONO/16384.)
+             XMONO=16384.
+            endif
+
+
+             if (iopti.eq.0) then
+
+c       CALL OPTFRAC(XMONO,10000./WNOI(K)
+c     &                         ,QEXT,QSCT,QABS,QBAR)
+
+
+       CALL CFFFV11(1.e-2/WNOI(K),REALI(K),XIMGI(K),RF(inq),2.
+     &                ,XMONO,QSCT,QEXT,QABS,QBAR)
+
+
+              QF1(inq,K)=QEXT*XRULE
+              QF2(inq,K)=QSCT*XRULE
+              QF3(inq,K)=QABS*XRULE
+              QF4(inq,K)=QBAR
+             endif         ! end iopti
+
+        TAEROS=QF1(inq,K)*zqaer_1pt(nlayer+1-J,inq)+TAEROS
+        TAEROSCAT=QF2(inq,K)*zqaer_1pt(nlayer+1-J,inq)+TAEROSCAT
+        CBAR=CBAR+QF4(inq,K)*QF2(inq,K)*zqaer_1pt(nlayer+1-J,inq)
+
+           endif
+
+               IF(TAEROS.LT.1.e-10) TAEROS=1.e-10
+
+         ENDIF
+       ENDDO             ! FIN DE LA BOUCLE SUR nrad
+
+       IF(TAEROSCAT.le.0.) then
+        CBAR=0.
+       ELSE
+        CBAR=CBAR/TAEROSCAT
+       ENDIF
+
+        DELTAZ=Z(J)-Z(J+1)
+
+c --------------------------------------------------------------------
+c profil brume Pascal: fit T (sauf tropopause) et albedo
+c -------------------
+        if( cutoff.eq.1) then
+         IF(PRESS(J).gt.9.e-3) THEN
+          TAEROS=TAEROSM1(K)*DELTAZ/DELTAZM1(K)*0.85
+          TAEROSCAT=TAEROSCATM1(K)*DELTAZ/DELTAZM1(K)*0.85
+c         TAEROS=0.
+c         TAEROSCAT=0.
+         ENDIF
+
+         IF(PRESS(J).gt.1.e-1) THEN
+          TAEROS=TAEROSM1(K)*DELTAZ/DELTAZM1(K)*1.15
+          TAEROSCAT=TAEROSCATM1(K)*DELTAZ/DELTAZM1(K)*1.15
+c         TAEROS=0.
+c         TAEROSCAT=0.
+         ENDIF
+        endif !cutoff=1
+
+c profil brume pour fit T (y compris tropopause), mais ne fit plus albedo...
+c -----------------------
+        if( cutoff.eq.2) then
+         IF(PRESS(J).gt.1.e-1) THEN
+          TAEROS=0.
+          TAEROSCAT=0.
+         ENDIF
+        endif !cutoff=2
+c --------------------------------------------------------------------
+
+         TAEROSM1(K)=TAEROS
+         TAEROSCATM1(K)=TAEROSCAT
+         DELTAZM1(K)=DELTAZ
+
+
+      IF(TAEROSCAT.le.0.) CBAR=0.
+
+c     print*,'HERE, MCKAY AEROSOLS IR'
+c     TAEROS=xv1(j,k)
+c     TAEROSCAT=xv2(j,k)
+c     CBAR=xv3(j,k)
+
+c*********** EN TRAVAUX ***************************
+
+C #2:         CLOUD
+C------------------
+C NEXT COMPUTE TAU CLOUD
+c
+c  Menu special :
+c  Afin d'eviter la surcharge de calcul on ne calcule les 
+c  propriétes optiques des nuages qu'une seule fois
+c  avec un rayon de particule effectif de 3um et une composition
+c  de goutte : 90% CH4 / 10% NOYAUX
+c  Puis on ajute les section efficace par la surface reelle de 
+c  la goutte.
+c
+c  ---> A TESTER !!!!
+c
+        TNUAGE=0.
+        TNUAGESCAT=0.
+        CNBAR=0.
+        IF (clouds.eq.1) THEN
+          IF (iopti.eq.0) THEN !--> au premier appel
+            QEXTC=0.
+            QSCTC=0.
+            QABSC=0.
+            CBARC=0.
+            DO inq=1,nrad         !BOUCLE SUR LES NQMX TAILLE D"AEROSOLS
+              QC1(inq,K)=0.
+              QC2(inq,K)=0.
+              QC3(inq,K)=0.
+              QC4(inq,K)=0.
+            ENDDO
+** OPTICAL CONSTANT : MIXING RULES
+** Fraction volumique fixe :
+** 10% noyaux.
+** 90% methane.
+            XNR = 0.5 * REALI(K)
+     &          + 0.5 * RCLDI(K)
+            XNI = 0.5 * XIMGI(K)
+     &          + 0.5 * XICLDI(K)
+**
+**   Efficacite : particule de 3um de rayon
+            CALL CMIE(1.E-2/WNOI(K),XNR,XNI,3.e-6,
+     &                QEXTC,QSCTC,QABSC,CBARC)
+**
+**   ATTENTION CE SONT DES EFFICACITES : il faut les x par la surface REELLE de la goutte.
+            DO inq=1,nrad
+              QC1(inq,K)=QEXTC/xnuf
+              QC2(inq,K)=QSCTC/xnuf
+              QC3(inq,K)=QABSC/xnuf
+              QC4(inq,K)=CBARC
+            ENDDO
+          ENDIF   ! iopti = 0
+
+c ----- On ne calcule les constante optiques que si Rgoutte > 1e-10
+          IF (rcdb(nlayer+1-J).gt.1.1e-10) THEN
+            DO inq=1,nrad        
+              TNUAGE=QC1(inq,K)*(rcdb(nlayer+1-J)/3.e-6)**2.*1.e-4*
+     &               zqaer_1pt(nlayer+1-J,inq+nrad) +
+     &               TNUAGE
+              TNUAGESCAT=QC2(inq,K)*(rcdb(nlayer+1-J)/3.e-6)**2.*
+     &                   1.e-4*zqaer_1pt(nlayer+1-J,inq+nrad) +
+     &                   TNUAGESCAT
+              CNBAR=QC4(inq,K)*QC2(inq,K)*
+     &              (rcdb(nlayer+1-J)/3.e-6)**2.*
+     &              1.e-4*zqaer_1pt(nlayer+1-J,inq+nrad) +
+     &              CNBAR
+            ENDDO
+          ENDIF
+
+          IF(TNUAGESCAT.EQ.0.) THEN
+            CNBAR=0.
+          ELSE
+            CNBAR=CNBAR/TNUAGESCAT
+          ENDIF
+
+        ENDIF    ! Cond CLD
+c
+C #3:          GAZ
+C------------------
+
+C NOW COMPUTE TAUGAS DUE TO THE PIA TERM ONLY FOR LAMDA LT 940
+       TAUGAS=0.0
+       IF (WNOI(K) .LT. 940. ) THEN
+                 CALL PIA(K,TBAR,PNN,PCC,PCN,PHN)
+C HERE IS WHERE WE COULD SCALE THE PIA COEFFICEINTS TO FIT DATA
+C BASED ON REGIS' NOTES. ---TGM HAS THIS ADJUST IN IT AS DEFAULT
+                 PCN=PCN*MIN(1.75 , AMAX1(1.0,WNOI(K)/200.))
+C***REPLACE ABOVE WITH: PCN=PCN*1.25*MIN(1.75 , AMAX1(1.0,WNOI(K)/200.))
+C 1.25 FACTOR (NOT FROM DATA) SUGGESTED BY TOON et al. (1988)
+                 TAUGAS=COEF1*
+     &           (XN2(J)*XN2(J)*PNN + CH4(J)*CH4(J)*PCC
+     &           + XN2(J)*CH4(J)*PCN + XN2(J)*H2(J)*PHN)
+            IF (J .EQ. NLAYER .AND. IPRINT .GT. 9)
+     &          WRITE (6,22) WNOI(K),TAUGAS,XN2(J),CH4(J),H2(J),
+     &          TBAR, PNN,PCC,PCN, PHN,
+     &          XN2(J)*XN2(J)*PNN , CH4(J)*CH4(J)*PCC ,
+     &          XN2(J)*CH4(J)*PCN , XN2(J)*H2(J)*PHN
+ 22             FORMAT(1X,1P8E10.2)
+       ENDIF
+
+       IF (K .GT. 28) THEN
+                KGAS=K-28
+C     ??FLAG? HERE MUST BE WATCHED CAREFULLY
+                     U=COLDEN(J)*6.02204E23/BMU
+                     if((ylellouch).or.(.not.hcnrad)) then
+                       CALL GAS2_NOHCN(J, KGAS,TBAR,PBAR,U,TAU2)
+                     else
+                       CALL GAS2(J, KGAS,TBAR,PBAR,U,TAU2)
+                     endif
+                     TAUGAS=TAUGAS+TAU2
+       ENDIF
+C
+
+      DTAUI_1pt(J,K)=TAUGAS+TAEROS+TNUAGE
+      DTAUIP_1pt(J,K)=TAUGAS+TAEROS
+
+      TAUHI_1pt(K)=TAUHI_1pt(K) + TAEROS
+      TAUHID_1pt(J,K)=TAUHI_1pt(K)
+
+      TAUGI_1pt(K)=TAUGI_1pt(K) + TAUGAS
+      TAUGID_1pt(J,K)=TAUGI_1pt(K)
+
+      TAUCI_1pt(K)=TAUCI_1pt(K) + TNUAGE
+      TAUCID_1pt(J,K)=TAUCI_1pt(K)
+ 
+C ??FLAG? SERIOUS PROBLEM WITH THE CODE HERE!
+
+      TLIMIT=1.E-16
+
+
+      IF (TAEROSCAT + TNUAGESCAT .GT. 0.) THEN
+         COSBI_1pt(J,K)=(CBAR*TAEROSCAT + CNBAR*TNUAGESCAT )
+     &                     /(TAEROSCAT + TNUAGESCAT)
+      ELSE
+         COSBI_1pt(J,K)=0.0
+      ENDIF
+
+      IF (TAEROSCAT  .GT. 0.) THEN
+         COSBIP_1pt(J,K)=(CBAR*TAEROSCAT)
+     &                     /(TAEROSCAT)
+      ELSE
+         COSBIP_1pt(J,K)=0.0
+      ENDIF
+
+*---------
+
+      IF (DTAUI_1pt(J,K) .GT.  TLIMIT) THEN
+          WBARI_1pt(J,K)=(TAEROSCAT+TNUAGESCAT) /DTAUI_1pt(J,K)
+      ELSE
+         WBARI_1pt(J,K)=0.0
+         DTAUI_1pt(J,K)=TLIMIT
+      ENDIF
+
+      IF (DTAUIP_1pt(J,K) .GT.  TLIMIT) THEN
+          WBARIP_1pt(J,K)=(TAEROSCAT) /DTAUIP_1pt(J,K)
+      ELSE
+         WBARIP_1pt(J,K)=0.0
+         DTAUIP_1pt(J,K)=TLIMIT
+      ENDIF
+
+
+c     IF (IPRINT .GT. 9)
+c    & WRITE(6,73)J,K,TAUGAS,TAEROS,QEXT,QSCT
+  73           FORMAT(2I3,1P8E10.3)
+ 
+
+c------------------------------------------------------------------------
+ 101  CONTINUE   ! FIN BOUCLE L D'O
+c------------------------------------------------------------------------
+ 
+      iopti=1
+
+c************************************************************************
+ 100  CONTINUE   ! FIN BOUCLE ALTITUDE
+c************************************************************************
+ 
+        DO 119 K=1,NSPECI
+           TAUI_1pt(1,K)=0.0
+           TAUIP_1pt(1,K)=0.0
+        DO 119 J=1,NLAYER
+           TAUI_1pt(J+1,K)=TAUI_1pt(J,K)+DTAUI_1pt(J,K)
+           TAUIP_1pt(J+1,K)=TAUIP_1pt(J,K)+DTAUIP_1pt(J,K)
+ 119    CONTINUE
+
+c      IF (IPRINT .GT. 2) THEN
+c          WRITE (6,120)
+c  120      FORMAT(///'  OPTICAL CONSTANTS IN THE INFRARED')
+
+c        DO 200 K=1,NSPECI           ! #2
+c          WRITE (6,190)
+c          WRITE (6,210)K,WLNI(K),WNOI(K),BWNI(K)
+c    &    ,BWNI(K)+DWNI(K),DWNI(K)
+c          WRITE (6,230)REALI(K),XIMGI(K)
+
+c        DO 195 J=1,NLAYER         !   #3
+c          WRITE (6,220)XNUMB(J), WBARI_1pt(J,K),COSBI_1pt(J,K)
+c    &                          , DTAUI_1pt(J,K),TAUI_1pt(J,K)
+c 195    CONTINUE
+
+c 200    CONTINUE
+
+c          END IF
+
+
+c  210 FORMAT(1X,I3,F10.3,F10.2,F10.2,'-',F8.2,F10.3)
+c  190 FORMAT(1X//'  SNUM  MICRONS   WAVENU   INTERVAL    DELTA-WN')
+c  230 FORMAT(1X,'NREAL(LAYER)= ',1PE10.3,' NIMG(LAYER)= ',E10.3/
+c     &' #AEROSOLS   WBAR  COSBAR DTAU TAU')
+c  220 FORMAT(5(1X,G9.3))
+c  240 FORMAT(41X,G9.3)
+
+      RETURN
+      END
Index: trunk/LMDZ.TITAN/libf/phytitan/optcv.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/optcv.F	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/optcv.F	(revision 175)
@@ -31,7 +31,9 @@
      & , REALI(NSPECI), XIMGI(NSPECI), REALV(NSPECV), XIMGV(NSPECV)
 
-      COMMON /CLOUD/ RADCLD(NLAYER), XNCLD(NLAYER)
-     &             , RCLDI(NSPECI), XICLDI(NSPECI)
+      COMMON /CLOUD/ 
+     &               RCLDI(NSPECI), XICLDI(NSPECI)
      &             , RCLDV(NSPECV), XICLDV(NSPECV)
+     &             , RCLDI2(NSPECI), XICLDI2(NSPECI)
+     &             , RCLDV2(NSPECV), XICLDV2(NSPECV)
 
       COMMON /TAUS/   TAUHI(ngrid,NSPECI), TAUCI(ngrid,NSPECI)
@@ -41,6 +43,8 @@
 
       COMMON /TAUD/   TAUHID(ngrid,NLAYER,NSPECI)
+     &               ,TAUCID(ngrid,NLAYER,NSPECI)
      &               ,TAUGID(ngrid,NLAYER,NSPECI)
      &               ,TAUHVD(ngrid,NLAYER,NSPECV)
+     &               ,TAUCVD(ngrid,NLAYER,NSPECV)
      &               ,TAUGVD(ngrid,NLAYER,NSPECV)
 
@@ -49,4 +53,8 @@
      &               ,WBARV(ngrid,NLAYER,NSPECV,4)
      &               ,COSBV(ngrid,NLAYER,NSPECV,4)
+     &               ,DTAUVP(ngrid,NLAYER,NSPECV,4)
+     &               ,TAUVP(ngrid,NLEVEL,NSPECV,4)
+     &               ,WBARVP(ngrid,NLAYER,NSPECV,4)
+     &               ,COSBVP(ngrid,NLAYER,NSPECV,4)
 
       COMMON /SPECTV/ BWNV(NSPC1V),WNOV(NSPECV) 
@@ -57,4 +65,11 @@
       COMMON /CONST/ RGAS,RHOP,PI,SIGMA
       COMMON /part/ v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad)
+
+c-----Rayons nuages et "composition" de la goutte
+c     sur la grille ...
+      integer ncount(ngrid,NLAYER)
+      real    rmcbar(ngrid,NLAYER)
+      real    xfbar(ngrid,NLAYER,4)
+      COMMON/rnuabar/ncount,rmcbar,xfbar
 
       REAL xv1(klev,NSPECV)
@@ -74,12 +89,7 @@
       data ioptv,iwarning,seulmtunpt/0,0,0/
 
-      real   zqaer_1pt(NLAYER,nrad)
-      real   TAUHVD_1pt(NLAYER,NSPECV)
-      real   TAUGVD_1pt(NLAYER,NSPECV)
-      real   TAUHV_1pt(NSPECV),TAUCV_1pt(NSPECV)
-      real   TAURV_1pt(NSPECV),TAUGV_1pt(NSPECV)
-      real   DTAUV_1pt(NLAYER,NSPECV,4),TAUV_1pt(NLEVEL,NSPECV,4)
-      real   WBARV_1pt(NLAYER,NSPECV,4)
-      real   COSBV_1pt(NLAYER,NSPECV,4)
+      real   zqaer_1pt(NLAYER,2*nrad)
+#include "optcv_1pt.h"
+
       character*100 dummy
       real   dummy2,dummy3
@@ -87,5 +97,5 @@
 C*
 C THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE VISIBLE
-C IT CALCUALTES FOR EACH LAYER, FOR EACH SPECRAL INTERVAL IN THE VIS
+C IT CALCULATES FOR EACH LAYER, FOR EACH SPECRAL INTERVAL IN THE VIS
 C LAYER: WBAR, DTAU, COSBAR
 C LEVEL: TAU
@@ -95,14 +105,4 @@
        print*,'ATTENTION, TAU UNIFORME DANS OPTCV'
 
-c      do nng=2,klon
-c       do i=1,klev           
-c        do j=1,nqtot
-c          sum=sum+qaer(nng,i,j)*rayon(j)**3.*1.3333*3.1415*1000.
-c        enddo
-c       enddo
-c       enddo
-c       print*,sum/(klon-1),'SOMME COLONNE/OPTCV'
-
-             
 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 c INITIALISATIONS UNE SEULE FOIS
@@ -114,10 +114,23 @@
 c il faut quand meme qu'on lise la look-up table de dim nrad=10
 c et si microfi=1, on doit avoir nmicro=nrad (dans microtab.h)
-       if ((nmicro.ne.nrad).and.(microfi.eq.1)) then
-          print*,"nmicro.ne.nrad",nmicro,nrad
-	  print*,"PROBLEME pour zqaer_1pt dans optcv !!"
-	  stop
+c 
+c Nouvelle verif pour nuages : 
+c La condition ci-dessus n'est plus realisable !
+c nmicro comprend maintenant aussi des glaces
+c Donc on teste juste que nmicro soit > 2*nrad (ou nrad si on ne fait pas de nuages)
+       if (microfi.ge.1) then
+         if ((clouds.eq.1).and.(nmicro.lt.2*nrad)) then
+           print*,"OPTCV :"
+           print*,"clouds = 1 MAIS nmicro < 2*nrad"
+           print*,"Probleme pour zqaer_1pt dans optcv."
+           stop
+         endif
+         if ((clouds.eq.0).and.(nmicro.lt.nrad)) then
+           print*,"OPTCV :"
+           print*,"nmicro < nrad"
+           print*,"Probleme pour zqaer_1pt dans optcv."
+           stop
+         endif
        endif
-
       
       DO 130 K=1,NSPECV
@@ -130,6 +143,10 @@
 C      XIMGV(K)=FITEDN(WLNV(K))
 C THE CLOUD IS CLEAR IN THE VISIBLE
-      RCLDV(K)=1.27
-      XICLDV(K)=1.E-7
+      CALL LIQCH4(WLNV(K),TNR,TNI)
+      RCLDV(K)=TNR
+      XICLDV(K)=TNI
+      CALL LIQC2H6(WLNV(K),TNR,TNI)
+      RCLDV2(K)=TNR
+      XICLDV2(K)=TNI
  130  CONTINUE
 C
@@ -150,10 +167,14 @@
       DO 101 ig=1,klon       !c! BOUCLE SUR GRILLE HORIZONTALE
 
-        if (microfi.eq.1) then
-           do iq=1,nrad
-	      do j=1,NLAYER
-	         zqaer_1pt(j,iq)=qaer(ig,j,iq)
-	      enddo
-	   enddo
+        if (microfi.ge.1) then
+           do iq=1,2*nrad
+             if (clouds.eq.0.and.iq.gt.nrad) then
+                zqaer_1pt(:,iq)=0.
+             else
+               do j=1,NLAYER
+                  zqaer_1pt(j,iq)=qaer(ig,j,iq)
+               enddo
+             endif
+           enddo
         else
          if (ig.eq.1)  then
@@ -181,26 +202,33 @@
 c       if ((microfi.eq.0).or.(ig.eq.klon/2)) iout=1
         if (seulmtunpt.eq.0) then
-	   call optcv_1pt(zqaer_1pt,ioptv,
-     .            COSBV_1pt,DTAUV_1pt,TAUHV_1pt,TAUHVD_1pt,TAUCV_1pt,
-     .       TAURV_1pt,TAUGV_1pt,TAUGVD_1pt,WBARV_1pt,TAUV_1pt,iout)
+          call optcv_1pt2(zqaer_1pt,rmcbar(ig,:),xfbar(ig,:,:),
+     &                   ioptv,IPRINT)
            ioptv = 1
 	endif
 
 c Pas de microphysique, ni de composition variable: un seul passage
-c dans optci_1pt.
+c dans optcv_1pt.
         if ((microfi.eq.0).and.(ylellouch)) then
 	   seulmtunpt = 1
 	endif
 	
-	COSBV(ig,:,:,:)= COSBV_1pt(:,:,:) 
-	WBARV(ig,:,:,:)= WBARV_1pt(:,:,:) 
-	DTAUV(ig,:,:,:)= DTAUV_1pt(:,:,:) 
-	TAUHV(ig,:)    = TAUHV_1pt(:) 
-	TAUCV(ig,:)    = TAUCV_1pt(:) 
-	TAURV(ig,:)    = TAURV_1pt(:) 
-	TAUGV(ig,:)    = TAUGV_1pt(:) 
-	TAUV(ig,:,:,:) = TAUV_1pt(:,:,:) 
-	TAUHVD(ig,:,:) = TAUHVD_1pt(:,:) 
-	TAUGVD(ig,:,:) = TAUGVD_1pt(:,:) 
+        COSBV(ig,:,:,:)= COSBV_1pt(:,:,:) 
+        WBARV(ig,:,:,:)= WBARV_1pt(:,:,:) 
+        DTAUV(ig,:,:,:)= DTAUV_1pt(:,:,:) 
+        TAUV(ig,:,:,:) = TAUV_1pt(:,:,:) 
+
+        COSBVP(ig,:,:,:)= COSBVP_1pt(:,:,:) 
+        WBARVP(ig,:,:,:)= WBARVP_1pt(:,:,:) 
+        DTAUVP(ig,:,:,:)= DTAUVP_1pt(:,:,:) 
+        TAUVP(ig,:,:,:) = TAUVP_1pt(:,:,:) 
+
+        TAUHV(ig,:)    = TAUHV_1pt(:) 
+        TAUCV(ig,:)    = TAUCV_1pt(:) 
+        TAURV(ig,:)    = TAURV_1pt(:) 
+        TAUGV(ig,:)    = TAUGV_1pt(:) 
+
+        TAUHVD(ig,:,:) = TAUHVD_1pt(:,:) 
+        TAUCVD(ig,:,:) = TAUCVD_1pt(:,:) 
+        TAUGVD(ig,:,:) = TAUGVD_1pt(:,:) 
 
  101  CONTINUE
Index: trunk/LMDZ.TITAN/libf/phytitan/optcv_1pt.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/optcv_1pt.F	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/optcv_1pt.F	(revision 175)
@@ -1,5 +1,3 @@
-      SUBROUTINE optcv_1pt(zqaer_1pt,ioptv,
-     .            COSBV_1pt,DTAUV_1pt,TAUHV_1pt,TAUHVD_1pt,TAUCV_1pt,
-     .       TAURV_1pt,TAUGV_1pt,TAUGVD_1pt,WBARV_1pt,TAUV_1pt,IPRINT)
+      SUBROUTINE optcv_1pt(zqaer_1pt,rcdb,xfrb,ioptv,IPRINT)
 
 
@@ -17,12 +15,6 @@
 C ioptv: premier appel, on ne calcule qu'une fois les QM et QF
 * nrad dans microtab.h
-      real   zqaer_1pt(NLAYER,nrad)
-      real   TAUHVD_1pt(NLAYER,NSPECV)
-      real   TAUGVD_1pt(NLAYER,NSPECV)
-      real   TAUHV_1pt(NSPECV),TAUCV_1pt(NSPECV)
-      real   TAURV_1pt(NSPECV),TAUGV_1pt(NSPECV)
-      real   DTAUV_1pt(NLAYER,NSPECV,4),TAUV_1pt(NLEVEL,NSPECV,4)
-      real   WBARV_1pt(NLAYER,NSPECV,4)
-      real   COSBV_1pt(NLAYER,NSPECV,4)
+      real   zqaer_1pt(NLAYER,2*nrad)
+#include "optcv_1pt.h"
 c   ---------
 
@@ -38,7 +30,9 @@
      & , REALI(NSPECI), XIMGI(NSPECI), REALV(NSPECV), XIMGV(NSPECV)
 
-      COMMON /CLOUD/ RADCLD(NLAYER), XNCLD(NLAYER)
-     &             , RCLDI(NSPECI), XICLDI(NSPECI)
+      COMMON /CLOUD/ 
+     &               RCLDI(NSPECI), XICLDI(NSPECI)
      &             , RCLDV(NSPECV), XICLDV(NSPECV)
+     &             , RCLDI2(NSPECI), XICLDI2(NSPECI)
+     &             , RCLDV2(NSPECV), XICLDV2(NSPECV)
 
       COMMON /SPECTV/ BWNV(NSPC1V),WNOV(NSPECV) 
@@ -55,7 +49,17 @@
       REAL QM1(nrad,NSPECV),QM2(nrad,NSPECV)
       REAL QM3(nrad,NSPECV),QM4(nrad,NSPECV)
+      REAL QC1(nrad,NSPECV),QC2(nrad,NSPECV)
+      REAL QC3(nrad,NSPECV),QC4(nrad,NSPECV)
+
+c---- NUAGES
+      real TNUABS,TNUSCAT
+      real   rcdb(NLAYER)
+      real     xfrb(NLAYER,4)
 
       save qf1,qf2,qf3,qf4,qm1,qm2,qm3,qm4
  
+      integer ilat,jalt
+      common/toto/ilat,jalt
+
 C*
 C THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE VISIBLE
@@ -77,5 +81,5 @@
 
       DO 100 J=1,NLAYER         !a! BOUCLE SUR L"ALTITUDE
-
+        jalt=j
 C #1:                   HAZE
 c---------------------------
@@ -149,9 +153,9 @@
             if(ioptv.eq.0.and.J.eq.1) then
 
-        CALL OPTFRAC(XMONO,10000./WNOV(K)
-     &                        ,QEXT,QSCT,QABS,QBAR)
-
-c       CALL CFFFV11(1.e-2/WNOV(K),REALV(K),XIMGV(K),RF(inq),2.
-c    &   ,XMONO,QSCT,QEXT,QABS,QBAR)
+c        CALL OPTFRAC(XMONO,10000./WNOV(K)
+c     &                        ,QEXT,QSCT,QABS,QBAR)
+
+        CALL CFFFV11(1.e-2/WNOV(K),REALV(K),XIMGV(K),RF(inq),2.
+     &   ,XMONO,QSCT,QEXT,QABS,QBAR)
 
 
@@ -215,17 +219,17 @@
        IF (TAEROSCAT.le.0.) CBAR=0. 
 
-      if (IPRINT.eq.1) then
-      if (k.eq.NSPECV/2) then   
-       print*,'@VI',K,J,TAEROS,TAEROSCAT,CBAR
-       print*,'@  ',K,J,QF1(1,K),QF2(1,K),zqaer_1pt(NLAYER+1-J,1)
-       print*,'@  ',K,J,QF1(3,K),QF2(3,K),zqaer_1pt(NLAYER+1-J,3)
-       print*,'@  ',K,J,QF1(5,K),QF2(5,K),zqaer_1pt(NLAYER+1-J,5)
-       print*,'@  ',K,J,QF1(7,K),QF2(7,K),zqaer_1pt(NLAYER+1-J,7)
-       print*,'@  ',K,J,QF1(9,K),QF2(9,K),zqaer_1pt(NLAYER+1-J,9)
-       print*
-      endif
-      endif
-
-
+c      if (IPRINT.eq.1) then
+c      if (k.eq.NSPECV/2) then   
+c       write(*,1699) '@VI',K,J,TAEROS,TAEROSCAT,CBAR
+c       write(*,1699) '@  ',K,J,QF1(1,K),QF2(1,K),zqaer_1pt(NLAYER+1-J,1)
+c       write(*,1699) '@  ',K,J,QF1(3,K),QF2(3,K),zqaer_1pt(NLAYER+1-J,3)
+c       write(*,1699) '@  ',K,J,QF1(5,K),QF2(5,K),zqaer_1pt(NLAYER+1-J,5)
+c       write(*,1699) '@  ',K,J,QF1(7,K),QF2(7,K),zqaer_1pt(NLAYER+1-J,7)
+c       write(*,1699) '@  ',K,J,QF1(9,K),QF2(9,K),zqaer_1pt(NLAYER+1-J,9)
+c       print*
+c      endif
+c      endif
+
+1699  FORMAT(a3,2I3,3(ES15.7,1X))
 
 c*********** EN TRAVAUX ***************************
@@ -280,22 +284,98 @@
 C NEXT COMPUTE TAU CLOUD
 
-      TAUCLD=0.0
-      CBARC =0.0
-      QEXTC =0.0
-      QSCTC =0.0
-c             XNCLD(J)=0.
-      IF ( XNCLD(J) .GT. 0. .and .taufac.gt.0.) THEN
-                CALL XMIE(RADCLD(J),RCLDV(K),XICLDV(K),
-     &                         QEXTC,QSCTC,QABSC,CBARC,WNOV(K))
-                TAUCLD=QEXTC*XNCLD(J)         
-      ENDIF
-C
-      TAURV_1pt(K)=TAURV_1pt(K)+TAURAY
-      TAUGVD_1pt(J,K)=TAURV_1pt(K)
-
-      TAUHV_1pt(K)=TAUHV_1pt(K)+TAEROS          ! INTEGRATED Quant.
-      TAUHVD_1pt(J,K)=TAUHV_1pt(K)
-
-      TAUCV_1pt(K)=TAUCV_1pt(K)+TAUCLD
+       IF (clouds.eq.0) THEN
+         CNBAR=0.
+         TNUSCAT=0.
+         TNUABS=0.
+         TBNUABS=0.
+       ELSE
+         CNBAR=0.
+         TNUSCAT=0.
+         TNUABS=0.
+         TBNUABS=0.
+         QEXTC=0.
+         QSCTC=0.
+         QABSC=0.
+         CBARC=0.
+
+         do inq=1,nrad
+           QC1(INQ,k)=0.
+           QC2(INQ,k)=0.
+           QC3(INQ,k)=0.
+           QC4(INQ,k)=0.
+         enddo
+
+         IF (rcdb(nlayer+1-J).gt.1.1e-10) THEN
+
+** OPTICAL CONSTANT : MIXING RULES
+
+           XNR=xfrb(nlayer+1-J,1)*REALV(K)                   !
+     &        +xfrb(nlayer+1-J,2)*RCLDV(K)                   !
+     &        +xfrb(nlayer+1-J,3)*RCLDV2(K)                  !
+     &        +xfrb(nlayer+1-J,4)*RCLDV2(K)                  !
+
+           XNI=xfrb(nlayer+1-J,1)*XIMGV(K)
+     &        +xfrb(nlayer+1-J,2)*XICLDV(K)
+     &        +xfrb(nlayer+1-J,3)*XICLDV2(K)
+     &        +xfrb(nlayer+1-J,4)*XICLDV2(K)
+
+** OPTICAL CONSTANT : LIQUID DROP = THOLIN
+           IF(xfrb(nlayer+1-J,1).ge.0.01) THEN
+             XNI=XIMGV(K)
+             XNR=REALV(K)
+           ENDIF
+
+           IF (XNI.gt.1.e-10  .and. XNR.gt.1.00) THEN
+             CALL CMIE(1.E-2/WNOV(K),XNR,XNI,
+     &       rcdb(nlayer+1-J),
+     &       QEXTC,QSCTC,QABSC,CBARC)
+           ELSE
+             PRINT*,' WARNING XNR/XNI in optcv: ',XNR,XNI
+             QEXTC=0.
+             QSCTC=0.
+             QABSC=0.
+             CBARC=0.
+             STOP
+           ENDIF
+         ELSE
+           QEXTC=0.
+           QSCTC=0.
+           QABSC=0.
+           CBARC=0.
+         ENDIF
+
+         DO inq=1,nrad
+
+           QC1(INQ,k)=QEXTC/xnuf
+           QC2(INQ,k)=QSCTC/xnuf
+           QC3(INQ,k)=QABSC/xnuf
+           QC4(INQ,k)=CBARC
+
+           TNUABS=QC1(inq,K)*zqaer_1pt(NLAYER+1-J,inq+nrad)*1.e-4
+     &           +TNUABS
+
+           TNUSCAT=QC2(inq,K)*zqaer_1pt(NLAYER+1-J,inq+nrad)*1.e-4
+     &            +TNUSCAT
+
+           CNBAR=QC4(inq,K)*QC2(inq,K)*
+     &           zqaer_1pt(NLAYER+1-J,inq+nrad)*1.e-4 + CNBAR
+
+         ENDDO
+
+         IF(TNUSCAT.EQ.0) CNBAR=0.
+         IF(TNUSCAT.NE.0.) CNBAR=CNBAR/TNUSCAT
+
+
+       ENDIF  ! Cond. CLD
+
+       TAURV_1pt(K)=TAURV_1pt(K)+TAURAY
+       TAUGVD_1pt(J,K)=TAURV_1pt(K)
+
+       TAUHV_1pt(K)=TAUHV_1pt(K)+TAEROS ! INTEGRATED Quant.
+       TAUHVD_1pt(J,K)=TAUHV_1pt(K)
+
+       TAUCV_1pt(K)=TAUCV_1pt(K)+TNUABS
+       TAUCVD_1pt(J,K)=TAUCV_1pt(K)
+
 
 C #4:                  TAUGAS
@@ -311,37 +391,45 @@
 
 
-C COMPUTE THE AVERAGE COSBAR AND WBAR
-C&&
-
-c     CBAR=MIN(1.0,1.05*CBAR)       ! THE HAZE FORWARD SCATTERING 5%(WHY?)
-      COSBV_1pt(J,K,NT)=(CBAR*TAEROSCAT + CBARC*TAUCLD)
-     &  /(TAEROSCAT+TAUCLD+TAURAY)     !CBAR_RAY=0.
-c        print*,'CBV',J,K,NT,CBAR,TAEROSCAT,CBARC,TAUCLD       
-
-      DTAUV_1pt(J,K,NT)=TAUGAS+TAEROS+TAURAY+TAUCLD       !TOTAL TAU_EXT
-      TAUGV_1pt(K)=TAUGV_1pt(K)+TAUGAS*ATERM(NT,K)         !TAU_ABS_METH INTEG.
-
-C WE LET W RAYLEIGH BE .999 OR W=1 WHEN ONLY RAYLEIGH=PROBLEM FOR TRID
-c WE HAVE ASSUMED ABOVE THAT COSBAR FOR RAYLEIGH IS ZERO.
-      if (IPRINT.eq.1) then
-      if (k.eq.NSPECV/2) then   
-       print*,'@VI',K,J,DTAUV_1pt(J,K,1),TAUGAS,TAEROS,TAUCLD
-      endif
-      endif
-
-
-c***************** ECHANGE 
-c     WBARV(J,K,NT)=(QSCT*XNUMB(J)+TAURAY*0.9999999 + QSCTC*XNCLD(J) )
-c****************
-      WBARV_1pt(J,K,NT)=(TAEROSCAT+TAURAY*0.9999999 + QSCTC*XNCLD(J) )
-c     WBARV_1pt(J,K,NT)=(TAEROSCAT+TAURAY*0.9999999 )
-     &            /(TAUGAS+TAEROS+TAURAY+TAUCLD)
-c**************** 
-      IF((TAEROS+TAUCLD+TAURAY+TAUCLD).le.0.) WBARV_1pt(J,K,NT)=0.
-      IF((TAEROS+TAUCLD+TAURAY).le.0.) COSBV_1pt(J,K,NT)=0.
-
-c     print*,'WBV',J,K,NT,TAEROSCAT,TAURAY,QSCTC*XNCLD(J)
-c     print*,'WBV',J,K,NT,TAEROS,TAUGAS,TAURAY,TAUCLD
-c     print*,Z(j),J,K,NT,TAUV(1,j,K,NT),WBARV(1,j,K,NT),COSBV(1,j,K,NT)
+*  COSBV ET COSBVP
+*-----------------
+
+      IF(TAEROSCAT+TNUSCAT+TAURAY .ne. 0.) THEN
+         COSBV_1pt(J,K,NT)=(CBAR*TAEROSCAT + CNBAR*TNUSCAT)
+     &  /(TAEROSCAT+TNUSCAT+TAURAY) !CBAR_RAY=0.
+      ELSE
+         COSBV_1pt(J,K,NT)=0.
+      ENDIF
+
+      IF(TAEROSCAT+TAURAY .ne. 0.) THEN
+         COSBVP_1pt(J,K,NT)=(CBAR*TAEROSCAT)
+     &  /(TAEROSCAT+TAURAY) !CBAR_RAY=0.
+      ELSE
+         COSBVP_1pt(J,K,NT)=0.
+      ENDIF
+
+*  DTAUV ET DTAUVP
+*-----------------
+
+      DTAUV_1pt(J,K,NT) =TAUGAS+TAEROS+TAURAY+TNUABS !TAU_ABS_METH
+      DTAUVP_1pt(J,K,NT)=TAUGAS+TAEROS+TAURAY       !TAU_ABS_METH
+
+      TAUGV_1pt(K)=TAUGV_1pt(K)+TAUGAS*ATERM(NT,K) !INTEG.
+
+*  WBARV ET WBARVP
+*-----------------
+
+      IF(TAUGAS+TAEROS+TAURAY+TNUABS .ne.  0.) THEN
+         WBARV_1pt(J,K,NT)=(TAEROSCAT+TAURAY*0.9999999 + TNUSCAT)
+     & /(TAUGAS+TAEROS+TAURAY+TNUABS)
+      ELSE
+         WBARV_1pt(J,K,NT)=0.
+      ENDIF
+
+      IF(TAUGAS+TAEROS+TAURAY .ne.  0.) THEN
+         WBARVP_1pt(J,K,NT)=(TAEROSCAT+TAURAY*0.9999999 )
+     & /(TAUGAS+TAEROS+TAURAY)
+      ELSE
+         WBARVP_1pt(J,K,NT)=0.
+      ENDIF
 
  909  CONTINUE
@@ -358,6 +446,8 @@
            DO 119 NT=1,NTERM(K)
            TAUV_1pt(1,K,NT)=0.0
+           TAUVP_1pt(1,K,NT)=0.0
              DO 119 J=1,NLAYER
              TAUV_1pt(J+1,K,NT)=TAUV_1pt(J,K,NT)+DTAUV_1pt(J,K,NT)
+             TAUVP_1pt(J+1,K,NT)=TAUVP_1pt(J,K,NT)+DTAUVP_1pt(J,K,NT)
  119     CONTINUE
 
Index: trunk/LMDZ.TITAN/libf/phytitan/optcv_1pt.h
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/optcv_1pt.h	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/optcv_1pt.h	(revision 175)
@@ -0,0 +1,48 @@
+!----------------------------------------------
+! fichier optcv_1p.h
+!
+!  regroupe les sorties du fichier optcv_1pt
+!  les nuages oblige a quasiment doubler
+!  le nombre de variables c'est juste pour
+!  la lisibilite.
+!----------------------------------------------
+
+! ----DIAGNOSTIQUES 
+      real   TAUHVD_1pt(NLAYER,NSPECV)
+      real   TAUCVD_1pt(NLAYER,NSPECV)
+      real   TAUGVD_1pt(NLAYER,NSPECV)
+! ----OPACITES TOTALES
+      real   TAUHV_1pt(NSPECV)
+      real   TAUCV_1pt(NSPECV)
+      real   TAURV_1pt(NSPECV)
+      real   TAUGV_1pt(NSPECV)
+! ----COLONNE NUAGEUSE
+      real   TAUV_1pt(NLEVEL,NSPECV,4)
+      real   DTAUV_1pt(NLAYER,NSPECV,4)
+      real   WBARV_1pt(NLAYER,NSPECV,4)
+      real   COSBV_1pt(NLAYER,NSPECV,4)
+! ----COLONNE "CLAIRE"
+      real   TAUVP_1pt(NLEVEL,NSPECV,4)
+      real   DTAUVP_1pt(NLAYER,NSPECV,4)
+      real   WBARVP_1pt(NLAYER,NSPECV,4)
+      real   COSBVP_1pt(NLAYER,NSPECV,4) 
+
+      common/optv_1pt/                                                  &
+     &        TAUHVD_1pt                                                &
+     &       ,TAUCVD_1pt                                                &
+     &       ,TAUGVD_1pt                                                &
+! ----OPACITES TOTALES
+     &       ,TAUHV_1pt                                                 &
+     &       ,TAUCV_1pt                                                 &
+     &       ,TAUGV_1pt                                                 &
+! ----COLONNE NUAGEUSE
+     &       ,DTAUV_1pt                                                 &
+     &       ,TAUV_1pt                                                  &
+     &       ,WBARV_1pt                                                 &
+     &       ,COSBV_1pt                                                 &
+! ----COLONNE "CLAIRE"
+     &       ,DTAUVP_1pt                                                &
+     &       ,TAUVP_1pt                                                 &
+     &       ,WBARVP_1pt                                                &
+     &       ,COSBVP_1pt
+
Index: trunk/LMDZ.TITAN/libf/phytitan/optcv_1pt_2.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/optcv_1pt_2.F	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/optcv_1pt_2.F	(revision 175)
@@ -0,0 +1,434 @@
+      SUBROUTINE optcv_1pt2(zqaer_1pt,rcdb,xfrb,ioptv,IPRINT)
+
+      use dimphy
+#include "dimensions.h"
+#include "microtab.h"
+#include "clesphys.h"
+
+      PARAMETER(NLAYER=llm,NLEVEL=NLAYER+1)
+      PARAMETER (NSPECI=46,NSPC1I=47,NSPECV=24,NSPC1V=25)
+
+c   Arguments:
+c   ---------
+      integer IPRINT,ioptv
+C ioptv: premier appel, on ne calcule qu'une fois les QM et QF
+* nrad dans microtab.h
+      real   zqaer_1pt(NLAYER,2*nrad)
+#include "optcv_1pt.h"
+c   ---------
+
+      COMMON /ATM/ Z(NLEVEL),PRESS(NLEVEL),DEN(NLEVEL),TEMP(NLEVEL)
+
+      COMMON /GASS/ CH4(NLEVEL),XN2(NLEVEL),H2(NLEVEL),AR(NLEVEL)
+     & ,XMU(NLEVEL),GAS1(NLAYER),COLDEN(NLAYER)
+
+      COMMON /VISGAS/SOLARF(NSPECV),NTERM(NSPECV),PEXPON(NSPECV),
+     &         ATERM(4,NSPECV),BTERM(4,NSPECV)
+
+      COMMON /AERSOL/ RADIUS(NLAYER), XNUMB(NLAYER)
+     & , REALI(NSPECI), XIMGI(NSPECI), REALV(NSPECV), XIMGV(NSPECV)
+
+      COMMON /CLOUD/ 
+     &               RCLDI(NSPECI), XICLDI(NSPECI)
+     &             , RCLDV(NSPECV), XICLDV(NSPECV)
+     &             , RCLDI2(NSPECI), XICLDI2(NSPECI)
+     &             , RCLDV2(NSPECV), XICLDV2(NSPECV)
+
+      COMMON /SPECTV/ BWNV(NSPC1V),WNOV(NSPECV) 
+     &               ,DWNV(NSPECV),WLNV(NSPECV)
+
+      COMMON /PLANT/ CSUBP,RSFI,RSFV,F0PI
+      COMMON /ADJUST/ RHCH4,FH2,FHAZE,FHVIS,FHIR,TAUFAC,RCLOUD,FARGON
+      COMMON /CONST/ RGAS,RHOP,PI,SIGMA
+* nrad dans microtab.h
+      COMMON /part/ v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad)
+
+      REAL QF1(nrad,NSPECV),QF2(nrad,NSPECV)
+      REAL QF3(nrad,NSPECV),QF4(nrad,NSPECV)
+      REAL QM1(nrad,NSPECV),QM2(nrad,NSPECV)
+      REAL QM3(nrad,NSPECV),QM4(nrad,NSPECV)
+      REAL QC1(nrad,NSPECV),QC2(nrad,NSPECV)
+      REAL QC3(nrad,NSPECV),QC4(nrad,NSPECV)
+
+c---- NUAGES
+      real TNUABS,TNUSCAT
+      real   rcdb(NLAYER), xfrb(NLAYER,4)
+
+      save qf1,qf2,qf3,qf4,qm1,qm2,qm3,qm4,qc1,qc2,qc3,qc4
+
+
+C*
+C THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE VISIBLE
+C IT CALCUALTES FOR EACH LAYER, FOR EACH SPECRAL INTERVAL IN THE VIS
+C LAYER: WBAR, DTAU, COSBAR
+C LEVEL: TAU
+C
+C ZERO THE COLUMN OPTICAL DEPTHS OF EACH TYPE
+C ??FLAG? THE OPTICAL DEPTH OF THE TOP OF THE MODEL
+C MAY NOT BE ZERO.
+
+c******* DEBUT DES BOUCLES ************************
+      DO 100 K=1,NSPECV         !b! BOUCLE SUR LAMBDA
+
+      TAURV_1pt(K)=0.
+      TAUHV_1pt(K)=0.            ! INTEGRATED TAU.......INITIALIZATION.
+      TAUCV_1pt(K)=0.            ! Rayleigh, Haze, Cloud, Gas
+      TAUGV_1pt(K)=0.            !   sca,    abs,  abs  , abs
+
+      DO 100 J=1,NLAYER         !a! BOUCLE SUR L"ALTITUDE
+
+C #1:                   HAZE
+c---------------------------
+
+c     CALL THE MIE CODE TO GIVE THE AEROSOL PROPERTIES
+c     USE XFRAC FOR FRACTAL AEROSOLS PROPERTIES AT LAMBDA < 2. um 
+
+
+
+
+c                    /\
+c                   /  \
+c                  /    \
+c                 / _O   \
+c                / |/     \
+c               /  / \     \
+c              /   |\ \/\   \
+c             /    || /  \   \
+c             ----------------
+c            |     WARNING    |
+c            |    SLOW DOWN   |
+c             ---------------- 
+
+
+
+
+c*********** EN TRAVAUX ***************************
+ 
+         TAEROS=0.
+         TAEROSCAT=0.
+         CBAR=0.
+
+c       print*,"rayon=",rayon
+c       print*,"RF=",RF
+
+      DO inq=1,nrad         !BOUCLE SUR LES TAILLE D"AEROSOLS
+
+
+            IF (rayon(inq).lt.RF(inq)) THEN    ! aerosols spheriques
+
+              
+            if(ioptv.eq.0.and.J.eq.1) then
+c                  CALL XMIE(rayon(inq)*1.e6,REALV(K),XIMGV(K),
+c    &             QEXT,QSCT,QABS,QBAR,WNOV(K))
+
+                CALL CMIE(1.E-2/WNOV(K),REALV(K),XIMGV(K),rayon(inq),
+     &          QEXT,QSCT,QABS,QBAR)
+
+c       print*,'inq=',inq,' QM1=',QM1(inq,K),' QEXT=',QEXT
+
+              QM1(inq,K)=QEXT
+              QM2(inq,K)=QSCT
+              QM3(inq,K)=QABS
+              QM4(inq,K)=QBAR
+            endif
+
+       TAEROS=QM1(inq,K)*zqaer_1pt(NLAYER+1-J,inq)*1.e-4+TAEROS
+       TAEROSCAT=QM2(inq,K)*zqaer_1pt(NLAYER+1-J,inq)*1.e-4+TAEROSCAT
+       CBAR=CBAR+QM4(inq,K)*QM2(inq,K)*zqaer_1pt(NLAYER+1-J,inq)*1.e-4
+
+            ELSE                        ! aerosols fractals
+
+               XMONO=(rayon(inq)/RF(inq))**3.
+               XRULE=1. 
+
+            if(XMONO.gt.16384./1.5) then 
+             XRULE=(XMONO/16384.) 
+             XMONO=16384.
+            endif 
+
+            if(ioptv.eq.0.and.J.eq.1) then
+
+c        CALL OPTFRAC(XMONO,10000./WNOV(K)
+c     &                        ,QEXT,QSCT,QABS,QBAR)
+
+        CALL CFFFV11(1.e-2/WNOV(K),REALV(K),XIMGV(K),RF(inq),2.
+     &   ,XMONO,QSCT,QEXT,QABS,QBAR)
+
+
+              QF1(inq,K)=QEXT*XRULE
+              QF2(inq,K)=QSCT*XRULE
+              QF3(inq,K)=QABS*XRULE
+              QF4(inq,K)=QBAR
+
+c       print*,'inq=',inq,' QF1=',QF1(inq,K),' QEXT=',QEXT,' XRULE=',XRULE
+                   
+            endif
+
+        TAEROS=QF1(inq,K)*zqaer_1pt(NLAYER+1-J,inq)+TAEROS
+        TAEROSCAT=QF2(inq,K)*zqaer_1pt(NLAYER+1-J,inq)+TAEROSCAT
+        CBAR=CBAR+QF4(inq,K)*QF2(inq,K)*zqaer_1pt(NLAYER+1-J,inq)
+
+           ENDIF 
+
+       ENDDO    ! nrad
+
+       IF(TAEROSCAT.le.0.) then
+        CBAR=0.
+       ELSE
+        CBAR=CBAR/TAEROSCAT
+       ENDIF
+
+        DELTAZ=Z(J)-Z(J+1)
+
+c --------------------------------------------------------------------
+c profil brume Pascal: fit T (sauf tropopause) et albedo
+c -------------------
+        if( cutoff.eq.1) then
+         IF(PRESS(J).gt.9.e-3) THEN
+          TAEROS=TAEROSM1*DELTAZ/DELTAZM1*0.85
+          TAEROSCAT=TAEROSCATM1*DELTAZ/DELTAZM1*0.85
+c         TAEROS=0.
+c         TAEROSCAT=0.
+         ENDIF
+
+         IF(PRESS(J).gt.1.e-1) THEN
+          TAEROS=TAEROSM1*DELTAZ/DELTAZM1*1.15
+          TAEROSCAT=TAEROSCATM1*DELTAZ/DELTAZM1*1.15
+c         TAEROS=0.
+c         TAEROSCAT=0.
+         ENDIF
+        endif !cutoff=1
+
+c profil brume pour fit T (y compris tropopause), mais ne fit plus albedo...
+c -----------------------
+        if( cutoff.eq.2) then
+         IF(PRESS(J).gt.1.e-1) THEN
+          TAEROS=0.
+          TAEROSCAT=0.
+         ENDIF
+        endif !cutoff=2
+c --------------------------------------------------------------------
+
+         TAEROSM1=TAEROS
+         TAEROSCATM1=TAEROSCAT
+         DELTAZM1=DELTAZ
+
+
+       IF (TAEROSCAT.le.0.) CBAR=0. 
+
+1699  FORMAT(a3,2I3,3(ES15.7,1X))
+
+c*********** EN TRAVAUX ***************************
+
+C #2:                   RAYLEIGH
+c-------------------------------
+
+C RAYLEIGH SCATTERING STRAIGHT FROM HANSEN AND TRAVIS...SEE NOTES
+C RATIOED BY THE LAYER COLUMN NUMBER TO THE TOTAL
+C COLUMN NUMBER ON EARTH. CM-2
+C THIS IS THE SCATTERING BY THE ATMOSPHERE
+
+      TAURAY=(COLDEN(J)*28.9/(XMU(J)*1013.25))*
+     &(.008569/WLNV(K)**4)*(1.+.0113/WLNV(K)**2+.00013/WLNV(K)**4)
+
+
+C #3:                   CLOUD
+c----------------------------
+C NEXT COMPUTE TAU CLOUD
+c 
+c  Menu special :
+c  Afin d'eviter la surcharge de calcul on ne calcule les 
+c  propriétes optiques des nuages qu'une seule fois
+c  avec un rayon de particule effectif de 3um et une composition
+c  de goutte : 90% CH4 / 10% NOYAUX
+c  Puis on ajute les section efficace par la surface reelle de 
+c  la goutte.
+c
+c  ---> A TESTER !!!!
+c
+       IF (clouds.eq.0) THEN
+         CNBAR=0.
+         TNUSCAT=0.
+         TNUABS=0.
+       ELSE
+         IF (ioptv.eq.0.and.j.eq.1) THEN !--> au premier appel
+           QEXTC=0.
+           QSCTC=0.
+           QABSC=0.
+           CBARC=0.
+           DO inq=1,nrad         !BOUCLE SUR LES NQMX TAILLE D"AEROSOLS
+             QC1(inq,K)=0.
+             QC2(inq,K)=0.
+             QC3(inq,K)=0.
+             QC4(inq,K)=0.
+           ENDDO
+** OPTICAL CONSTANT : MIXING RULES
+** Fraction volumique fixe :
+** 10% noyaux.
+** 90% methane.
+           XNR = 0.5 * REALI(K)
+     &         + 0.5 * RCLDI(K)
+           XNI = 0.5 * XIMGI(K)
+     &         + 0.5 * XICLDI(K)
+**
+**   Efficacite : particule de 3um de rayon
+           CALL CMIE(1.E-2/WNOV(K),XNR,XNI,3.e-6,
+     &                QEXTC,QSCTC,QABSC,CBARC)
+
+           DO inq=1,nrad
+             QC1(inq,K)=QEXTC/xnuf
+             QC2(inq,K)=QSCTC/xnuf
+             QC3(inq,K)=QABSC/xnuf
+             QC4(inq,K)=CBARC
+           ENDDO
+         ENDIF   ! ioptv = 0
+         TNUABS=0.
+         TNUSCAT=0.
+         CNBAR=0.
+         IF (rcdb(nlayer+1-J).gt.1.1e-10) THEN
+           DO inq=1,nrad
+             TNUABS=QC1(inq,K)*(rcdb(nlayer+1-J)/3.e-6)**2.*1.e-4*
+     &              zqaer_1pt(NLAYER+1-J,inq+nrad) +
+     &              TNUABS
+             TNUSCAT=QC2(inq,K)*(rcdb(nlayer+1-J)/3.e-6)**2.*1.e-4*
+     &               zqaer_1pt(NLAYER+1-J,inq+nrad) +
+     &               TNUSCAT
+             CNBAR=QC4(inq,K)*QC2(inq,K)*(rcdb(nlayer+1-J)/3.e-6)**2.*
+     &             1.e-4*zqaer_1pt(NLAYER+1-J,inq+nrad) + 
+     &             CNBAR
+           ENDDO
+         ENDIF
+
+         IF(TNUSCAT.EQ.0.) THEN
+           CNBAR=0.
+         ELSE
+           CNBAR=CNBAR/TNUSCAT
+         ENDIF
+       ENDIF  ! Cond. CLD
+
+       TAUCV_1pt(K)=TAUCV_1pt(K)+TNUABS
+       TAUCVD_1pt(J,K)=TAUCV_1pt(K)
+
+       TAURV_1pt(K)=TAURV_1pt(K)+TAURAY
+       TAUGVD_1pt(J,K)=TAURV_1pt(K)
+
+       TAUHV_1pt(K)=TAUHV_1pt(K)+TAEROS ! INTEGRATED Quant.
+       TAUHVD_1pt(J,K)=TAUHV_1pt(K)
+
+
+
+C #4:                  TAUGAS
+C----------------------------
+
+C LOOP OVER THE NTERMS
+C THIS IS THE ABSORPTION BY THE ATMOSPHERE (METHANE)
+
+
+       DO 909 NT=1,NTERM(K)
+         TAUGAS=COLDEN(J)*GAS1(J)*BTERM(NT,K)*
+     &   (   (PRESS(J+1) + PRESS(J))*.5  )**PEXPON(K)
+
+
+*  COSBV ET COSBVP
+*-----------------
+
+         IF(TAEROSCAT+TNUSCAT+TAURAY .ne. 0.) THEN
+           COSBV_1pt(J,K,NT)=(CBAR*TAEROSCAT + CNBAR*TNUSCAT)
+     &     /(TAEROSCAT+TNUSCAT+TAURAY) !CBAR_RAY=0.
+         ELSE
+           COSBV_1pt(J,K,NT)=0.
+         ENDIF
+
+         IF(TAEROSCAT+TAURAY .ne. 0.) THEN
+           COSBVP_1pt(J,K,NT)=(CBAR*TAEROSCAT)
+     &     /(TAEROSCAT+TAURAY) !CBAR_RAY=0.
+         ELSE
+           COSBVP_1pt(J,K,NT)=0.
+         ENDIF
+
+*  DTAUV ET DTAUVP
+*-----------------
+
+         DTAUV_1pt(J,K,NT) =TAUGAS+TAEROS+TAURAY+TNUABS !TAU_ABS_METH
+         DTAUVP_1pt(J,K,NT)=TAUGAS+TAEROS+TAURAY       !TAU_ABS_METH
+
+         TAUGV_1pt(K)=TAUGV_1pt(K)+TAUGAS*ATERM(NT,K) !INTEG.
+
+*  WBARV ET WBARVP
+*-----------------
+
+         IF(TAUGAS+TAEROS+TAURAY+TNUABS .ne.  0.) THEN
+           WBARV_1pt(J,K,NT)=(TAEROSCAT+TAURAY*0.9999999 + TNUSCAT)
+     &     /(TAUGAS+TAEROS+TAURAY+TNUABS)
+         ELSE
+           WBARV_1pt(J,K,NT)=0.
+         ENDIF
+
+         IF(TAUGAS+TAEROS+TAURAY .ne.  0.) THEN
+           WBARVP_1pt(J,K,NT)=(TAEROSCAT+TAURAY*0.9999999 )
+     &     /(TAUGAS+TAEROS+TAURAY)
+         ELSE
+           WBARVP_1pt(J,K,NT)=0.
+         ENDIF
+    
+ 909   CONTINUE
+ 
+       TAUGVD_1pt(J,K)=TAUGVD_1pt(J,K)+TAUGV_1pt(K)
+
+ 100  CONTINUE
+
+       ioptv=1
+
+c HERE END OF THE LOOPS *******
+c******************************
+         
+C TOTAL EXTINCTION OPTICAL DEPTHS
+          DO 119 K=1,NSPECV
+C LOOP OVER NTERMS
+           DO 119 NT=1,NTERM(K)
+           TAUV_1pt(1,K,NT)=0.0
+           TAUVP_1pt(1,K,NT)=0.0
+             DO 119 J=1,NLAYER
+             TAUV_1pt(J+1,K,NT)=TAUV_1pt(J,K,NT)+DTAUV_1pt(J,K,NT)
+             TAUVP_1pt(J+1,K,NT)=TAUVP_1pt(J,K,NT)+DTAUVP_1pt(J,K,NT)
+ 119     CONTINUE
+
+
+c       print*,'SETUP'
+c      do i=1,NSPECV
+c      print*,WLNV(i)
+c       do j=1,NLAYER+1
+c       print*,Z(j),TAUV(1,j,i,1),WBARV(1,j,i,1),COSBV(1,j,i,1)
+c       enddo
+c      enddo
+c
+c     IF (IPRINT .GT. 1) THEN
+c           NT=1
+c     IF (2 .GT. 1) THEN
+c          WRITE (6,120)
+c 120      FORMAT(///'  OPTICAL CONSTANTS IN THE VISIBLE (@EQUATOR) ')
+c          WRITE(6,*) 'latitude:',ig
+c          DO 200 K=1,NSPECV
+c          WRITE (6,190)
+c          WRITE (6,210)K,WLNV(K),WNOV(K),BWNV(K)
+c    &    ,BWNV(K)+DWNV(K),DWNV(K)
+c          WRITE (6,230)REALV(K),XIMGV(K)
+c          DO 195 J=1,NLAYER,NLAYER
+C RECALCULATE FOR PRINT OUT ONLY, ONLY FIRST NTERM AT ig=12 (EQUATOR)
+c          WRITE (6,220)XNUMB(J), WBARV_1pt(J,K,NT),COSBV_1pt(J,K,NT)
+c    &      ,DTAUV_1pt(J,K,NT),TAUV_1pt(J,K,NT)
+c 195      CONTINUE
+c          WRITE (6,240) TAUV_1pt(NLEVEL,K,NT)
+c 200      CONTINUE
+c     END IF
+
+c  210 FORMAT(1X,I3,F10.3,F10.2,F10.2,'-',F8.2,F10.3)
+c  190 FORMAT(1X//'  SNUM  MICRONS   WAVENU   INTERVAL    DELTA-WN')
+c  230 FORMAT(1X,'NREAL(LAYER)= ',1PE10.3,' NIMG(LAYER)= ',E10.3/
+c     &' #AEROSOLS   WBAR  COSBAR       DTAU     TAU'
+c     & ,9X,'RAY     GAS    AEROSOL')
+c  220 FORMAT(8(1X,F9.3))
+c  240 FORMAT(41X,F9.3)
+
+      RETURN
+      END
Index: trunk/LMDZ.TITAN/libf/phytitan/pg2.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/pg2.F	(revision 174)
+++ 	(revision )
@@ -1,727 +1,0 @@
-            subroutine pg2(
-     &      tpplev,tpt,tq,tdq,nq,ptimestep,mu0,fract,last)
-c
-c
-c
-c
-c
-c
-c    &      tpplev,tpt,tq,tdq,nq,ptimestep,last)
-c                     /                    \
-c       |  PHYSIQUE  | AEROSOLS            |
-c
-c                     \|/
-c                    (o o)
-c-----------------oOo--O--oOo--------------------------
-c                      
-c Interface entre physiq.F et aerosols.F 
-c
-c Date: 5 Nov 96
-c
-c   -->(  )          q(x,nlayer,nq) 
-c
-c             q(x,nlayer,nq) <==>  c(nz,nrad)
-c
-c          c(nz,nrad)(t) -->  aerosol.F --> c(nz,nrad)(t+dt)
-c
-c             c(nz,nrad) <==> q(x,nlayer,nq)
-c     
-c              c(IHOR,NRAD,NRAD)  en aerosols
-c              c0(NZ,NRAD)        en aerosols/m^3  
-c
-c   L'ECHANGE N'EST POSSIBLE QUE SI LES QUANTITES SONT
-c   DES NOMBRES D'AEROSOLS.........
-c
-c   LES QUANTITES Q SONT EN AEROSOLS / CASE (BOUT DE COLONNE
-c   DE 1m^2 * DZ(J)..................ATTENTION AU PASSAGE 
-c      PHYSIQUE <---> DYNAMIQUE QUI A BESOINS DE ????
-c
-c   LE MODELE MICROPHYSIQUE A BESOIN DE CONCENTRATIONS
-c                     AEROSOLS/M^3
-c------------------------------------------------------
-
-      use dimphy
-      USE comgeomphy
-#include "dimensions.h"
-#include "microtab.h"
-#include "paramet.h"
-#include "aerprod.h"
-#include "clesphys.h"
-#include "YOMCST.h"
-
-     
-        parameter (NG=jjm+1)   ! NG: on travaille en moyenne zonale
- 
-c*************************************
-c declaration des variables internes *
-c*************************************
-	
-c       GCM        *
-c------------------*
-
-        real tzzlev(ng,klev+1)
-     &         ,tpplev(ng,klev+1)
-     &         ,tzzlay(ng,klev)
-     &         ,tpt(ng,klev)
-     &         ,tq(ng,klev,nq)
-     &         ,tdq(ng,klev,nq)
-        real   mu0(ng),fract(ng)
-
-        real    zzlev(NG,klev+1)
-     &         ,pplev(NG,klev+1)
-     &         ,zzlay(NG,klev)
-     &         ,pt(NG,klev)
-     &         ,q(NG,klev,nq)
-     &         ,qdel(NG,klev,nq)
-     &         ,qcumul(NG,0:200,nq)
-
-        integer jsup,jinf,h
- 
-        logical last
-
-
-c    microphysique    *
-c---------------------*
-
-        real aire(ng),airetot,lati(ng)
-	save aire,lati
-
-	real z(nz),zb(nz+1),alt(200)
-	real dz(nz),dzb(nz+1)
-        real pb(nz+1),p(nz)
-        real tb(nz+1),t(nz) 
- 
-	real c0(200,nrad),c(nz,nrad),ctp(nz,nrad)
-	double precision c0lu(200,nrad)
-        real cmemoire(nz,nrad)
-        real micropas,ddt
-
-      integer iprem
-      save iprem
-      data iprem/0/
-
-c          print*,'DEBUT DE PG2'
-
-
-         ngrid=ng
-         nlayer=klev
-         if(nrad.ne.nq) then
-             print*,'microphysique:nrad.ne.nq:',nrad,nq
-             stop 
-         endif
-
-* ici, on evalue les niveaux d'altitudes en fonction des niveaux de
-*  pressions.
-
-          do h=1,ngrid
-          tpplev(h,nlayer+1)=tpplev(h,nlayer)*.1
-          enddo
-
-        r=8.314*1000./28.
-
-* pour chaque point de grille
-
-       do h=1,ngrid
-         zz=0.
-         tzzlev(h,1)=zz
-
-* bord de couche
-
-        do l=1,nlayer
-         eff_g = 1.345*(2575./(2575.+zz/1000.))**2
-          zz=zz+r*2.*tpt(h,l)/
-     &    eff_g*(tpplev(h,l)-tpplev(h,l+1))/(tpplev(h,l)+tpplev(h,l+1))
-          tzzlev(h,l+1)=zz
-c         print*,l,eff_g,tpplev(h,l),tpplev(h,l+1),zz
-        enddo
-
-* milieu  de couche
-
-        do l=1,nlayer
-        xlog=( alog(tpplev(h,l+1)) + alog(tpplev(h,l)) )/2.
-        rapport=(tzzlev(h,l+1)-tzzlev(h,l))
-     &             /(alog(tpplev(h,l+1))-alog(tpplev(h,l)))
-        tzzlay(h,l)=rapport*(xlog-alog(tpplev(h,l+1)))
-     &              +tzzlev(h,l+1)
-        enddo
-       enddo
-
-
-c       PRINT*,'PROFILE #1'
-c       h=10
-c       do l=1,nlayer
-c        print*, tpplev(h,l),tpt(h,l),tq(h,1,1),tq(h,l,7)
-c       enddo
-c        print*, tpplev(h,nlayer+1)
-
-         do j=1,200
-           alt(j)=(j-1)*5000.     !0 5000 10000 15000 .......!
-         enddo
-         
-
-
-
-c      			**************************
-c        		INITIALISATION DE TABLEAUX
-c    		 	**************************
-c                         A NE FAIRE QU'UNE FOIS
-c     		        **************************
-
- 
-        IF (iprem.eq.0) THEN
-
-       qdel = 0.
-
-c initialisation de aire(ig)
-c --------------------------
-
-      airetot=0.
-      
-      lati(1)     = 0.5*RPI
-      DO ig=2,ngrid-1
-        lati(ig)  = rlatd(2+(ig-2)*iim)*RPI/180.
-      ENDDO
-      lati(ngrid) = -0.5*RPI
-      
-      DO ig=1,ngrid
-      if(ig.eq.1)
-     &   aire(ig)=2*RPI*(1.-sin(lati(ig)/2.+lati(ig+1)/2.))*RA*RA
-      if(ig.eq.ngrid)
-     &   aire(ig)=2*RPI*(1.+sin(lati(ig-1)/2.+lati(ig)/2.))*RA*RA
-       if(ig.ne.1. .and. ig.ne.ngrid) aire(ig)=2*RPI*RA*RA*
-     &      (sin(lati(ig-1)/2.+lati(ig)/2.)
-     &      -sin(lati(ig)/2.+lati(ig+1)/2.))
-
-      airetot=airetot+aire(ig)
-      ENDDO
-c     print*,"ENTREE PG2 PREMIER APPEL"
-c     print*,airetot,' airetot?= ',4.*RPI*RA*RA
-c     print*,1,rlatd(1),aire(1),aire(1)/airetot,' aires'
-c     DO ig=2,ngrid-1
-c     print*,ig,rlatd(2+(ig-2)*iim),aire(ig),aire(ig)/airetot,' aires'
-c     ENDDO
-c     print*,ngrid,rlatd(klon),aire(ngrid),aire(ngrid)/airetot,' aires'
-c     stop
-      
-c initialisation de c(z,r)
-c --------------------------
-
-
-        itype=2
-
-
-c remplissage type 1:            OBSOLETE !
-c----------------------
-
-
-        if(itype.eq.1) then !****************************
-
-        taer=tcorrect
-
-#ifdef CRAY
-        open (unit=32,file='aerosols',status='old',iostat=ii,
-     1  form='formatted')
-        if(ii.ne.0) then
-           print*,'WARNING!!! pas de reinitialisation des traceurs'
-           print*,'On part des traceurs contenus dans start'
-           return
-        endif
-        print*,'pg2 apres open version cray',ii
-        read(32,'(e8.3)') tt
-        read(32,'(5e10.3)') c0
-        close(32)
-#else
-        print*,'pg2 avant open'
-        open (unit=31,file='initfich',iostat=ii,
-     1  access='sequential',form='formatted')
-
-13      read(unit=31,fmt=1010,iostat=ii,end=15)tt,((c0lu(j,k),
-     1   k=1,nrad),j=1,200)
-1010    format(e8.3,2000(e8.3))
-
-15      continue
-
-c Conversion: lecture en double, variable utile en simple...
-        do j=1,200
-        do k=1,nrad
-          c0(j,k) = real(c0lu(j,k))
-c          print*,c0(j,k)
-        enddo
-        enddo
-#endif
- 
-c        print*,'fichier microphysique'
-c        do j=1,200
-c        print*,'L&0',j,c0(j,1),c0(j,3),c0(j,5),c0(j,7),c0(j,9)
-c        enddo
-
-         close (unit=31)
-        
-         do k=1,nrad 
-         do h=1,ngrid
-            qcumul(h,0,k)=0.
-            qcumul(h,1,k)=c0(200,k)*taer*5000.
-          do j=2,200
-            qcumul(h,j,k)=c0(200-j+1,k)*taer*5000.+qcumul(h,j-1,k)   
-          enddo 
-          do j=1,nlayer
-           qdel(h,j,k)=tq(h,j,k)   ! etat q provenant des starts a effacer!
-           tq(h,j,k)=0.
-          enddo
-         enddo 
-         enddo 
-c        do j=1,200
-c        print*,'L&1',j,qcumul(12,j,1),qcumul(12,j,3),qcumul(12,j,5)
-c        enddo
-         write(92,*) qdel
-
-c interpolation des q_cumules
-
-c         do j=1,nlayer
-c          print*,tzzlev(10,j),alt(j)
-c         enddo
-         do k=1,nrad 
-         do h=1,ngrid
-          jsup=int(tzzlev(h,2)/5000.+2.)
-          xfact=tzzlev(h,2)/alt(jsup)
-          tq(h,1,k)=xfact*qcumul(h,1,k)
-          do j=2,nlayer
-             jsup=int(tzzlev(h,j+1)/5000.+2.)
-             jinf=int(tzzlev(h,j+1)/5000.+1.)
-             xfact=(tzzlev(h,j+1)-alt(jinf))/(alt(jsup)-alt(jinf))
-             tq(h,j,k)=xfact*(qcumul(h,jsup-1,k)-qcumul(h,jinf-1,k))
-     &       +qcumul(h,jinf-1,k)
-          enddo
-         enddo 
-         enddo 
-
-c soustraction des q_cumules
-
-         do k=1,nrad 
-         do h=1,ngrid
-         do j=nlayer,2,-1
-          tq(h,j,k)=tq(h,j,k)-tq(h,j-1,k)
-         enddo 
-         enddo 
-         enddo 
-
-c on inverse q <--> tq, et tq=0 ====> dq=q-qt a la fin pour intitialiser. 
-
-         do k=1,nrad 
-         do h=1,ngrid
-         do j=nlayer,1,-1
-             q(h,j,k)=tq(h,nlayer-j+1,k)
-             tq(h,nlayer-j+1,k)=0.
-
-c        if (h.eq.12) then
-c         if (k.eq.nrad) then
-c            print*,'L&3',j,q(12,j,1),q(12,j,3),q(12,j,5)
-c          endif
-c        endif
-
-         enddo 
-         enddo 
-         enddo 
-           print*,'itype=1'
-
-         do h=1,ngrid 
-          somme=0.
-         do k=1,nrad 
-         do j=nlayer,1,-1
-         ref=1.63789E-09*(2.**.3333333333)**(4.*(k-1))
-           somme=somme+q(h,j,k)*4.1888*ref**3. 
-         enddo 
-         enddo 
-           print*,'bilan externe: m3/m2 grid#',h, somme
-         enddo 
-
-
-           else  !**********************************
-
-c remplissage type 2:
-c----------------------
-
-c       open (unit=31,file='finfich',iostat=ii,
-c    1  access='sequential',form='formatted')
-
-c       read(unit=31,fmt=1011,iostat=ii,end=18)tt,(((q(i,j,k),
-c    1  k=1,nrad),j=1,nlayer),i=1,ngrid)
-c8      continue
-c       close (unit=31)
-c----------------------
-
-
-          print*,'entre dans itype2'
-
-
-         do k=1,nrad 
-         do h=1,ngrid
-         do j=nlayer,1,-1
-
-          
-
-          q(h,nlayer+1-j,k)=tq(h,j,k)*tcorrect
-
-             tq(h,j,k)=0.  
-c
-c  Car les q initiaux sont lus dans la physiq, mais les dq doivent
-c  etre passes dans la dynamique via dqfi. C'est ici que les valeurs
-c  de dqfi=(q_lu*tcorrect - 0) sont definie
-
-         enddo 
-         enddo 
-         enddo
-
-
-           print*,'itype=2'
-         do h=1,ngrid 
-          somme=0.
-         do k=1,nrad 
-         do j=nlayer,1,-1
-         ref=1.63789E-09*(2.**.3333333333)**(4.*(k-1))
-           somme=somme+q(h,j,k)*4.1888*ref**3. 
-         enddo 
-         enddo 
-           print*,'bilan externe: m3/m2 grid#',h, somme
-         enddo 
-
-
-
-
-
-        endif 
-
-
-        ENDIF !FIN IPREM 
-  
-
-
-c	      ************************************
-c                FIN: A NE FAIRE QU'UNE FOIS 
-c	      ************************************
-c              
-
-
-
-c	   ************************************
-c            IL FAUT INVERSER LES TABLEAUX...            
-c	   ************************************
-
-
-
-
-       do n=1,ngrid
-         do j=1,NLAYER+1               ! j de 1 a 120
-           zzlev(n,j)=tzzlev(n,nlayer-j+2) ! indice de 120 a 1
-           pplev(n,j)=tpplev(n,nlayer-j+2)
-         enddo
-       enddo
-
-c les tq() doivent etre en nombre d'aerosols / cases 
-
-       do j=1,NLAYER                ! j de 1 a 119 
-         do n=1,ngrid
-           zzlay(n,j)=tzzlay(n,nlayer-j+1)  ! indice de 119 a 1
-           pt(n,j)=tpt(n,nlayer-j+1)
-         enddo
-       enddo
-
-        if (iprem.eq.0) goto 119  ! pour ne pas effacer les q()|t=0
-
-       do j=1,NLAYER                ! j de 1 a 119 
-         do n=1,ngrid
-           do i=1,nq
-             qdel(n,j,i)=0.
-             q(n,j,i)=tq(n,nlayer-j+1,i)
-           enddo
-         enddo
-       enddo
-
- 119    continue
-
-
-c               ******************************
-c                      BILAN DE MASSE
-c               ******************************
-
-       total=0.
-       do ihor=1,ngrid
-          do iq=1,nq
-           do JALT=1,nlayer
-            total=total+tq(ihor,JALT,iq)*(16.**(iq-5))*aire(ihor)
-           enddo
-          enddo
-       enddo
-c         print*,'Bilan entree masse des qaer (unite M_mono)',total   
-    
-
-c****************************************
-c                                       *
-c         ADAPTATION GCM > micro        *
-c                                       *
-c****************************************
-
-
-c correpondance des couches / sens GCM > microphysique 
-c-----------------------------------------------------
-c
-c But remplir les c(nz,i) avec les concentrations
-c Q(ng,NLAYER,i) d'aerosols calculee par gcm.F
-
-
- 
-      totalc1=0. 
-      totalc2=0. 
-      
-      if (iprem.eq.0) then 
-c ici, les tableaux definissant la structure des aerosols sont
-c remplis: rf,df(nq),rayon(nq,)v(nq)......
-       call rdf()
-      endif
-
-
-
-c---------------------------------------------
-
-       IF (iprem.eq.0) goto 102 
-
-c      !! La premiere fois, on ne passe pas par 
-c      !! q--->c et par pg3.F
-c      !! on passe directement au remplissage c-->q
-c---------------------------------------------
-
-       
-       do IHOR=1,NGRID      ! GRANDE BOUCLE HORIZONTALE
-
-         cpt=0.
-         cpx=0.
-         nzhau=0
-  
-
-       do JALT=1,nlayer-1         ! 1ere BOUCLE SUR Z (indice nz=1,120)
-         dz(jalt)=(zzlay(ihor,jalt)-zzlay(ihor,jalt+1))
-       enddo   
-         dz(nlayer)=dz(nlayer-1)  ! ARBITRAIRE ET SANS IMPORTANCE!!!!!
-
-       do JALT=1,nlayer         ! 1ere BOUCLE SUR Z (indice nz=1,120)
-         dzb(jalt)=(zzlev(ihor,jalt)-zzlev(ihor,jalt+1))
-         pb(jalt)=pplev(ihor,jalt)
-         t(jalt)=pt(ihor,jalt) 
-       enddo 
-         pb(nlayer+1)=pplev(ihor,nlayer+1)
- 
-
-
-c** T(>300km) = T(300km)
-
-
-         pb(nlayer+1)=pplev(IHOR,nlayer+1)
-
-         zb1=zzlev(ihor,1)
-         z1 =zzlay(ihor,1)
-
-
-c        if(ihor.eq.12) 
-c    &   print*,'nzhau pour la latitude # ',ihor,' : ',nzhau
-c        if(ihor.eq.1) 
-c    &   print*,'nzhau pour la latitude # ',ihor,' : ',nzhau
-c        if(ihor.eq.24) 
-c    &   print*,'nzhau pour la latitude # ',ihor,' : ',nzhau
-
-
-c Interpolation des tableaux tb et p a partir de t et pb
-c******************************************************
-
-        do i=1,nz-1
-         tb(i+1)=(t(i)+t(i+1))/2.  ! temperature au bord des couches
-        enddo
-
-         tb(1)=t(1)
-         tb(nz+1)=(t(nz)-t(nz-1))*.5+t(nz)
-         
-        do i=1,nz
-         p(i)=(alog(pb(i))+alog(pb(i+1)))/2. ! pression au centre des couches
-         p(i)=exp(p(i))
-        enddo
-
-
-        
-c****************************************
-c 
-c   APPEL DU MODEL MICROPHYSIQUE
-c
-c****************************************
-
-
-        do i=1,nrad
-         do j=1,nz
-          c(j,i)=q(IHOR,j,i)/dzb(j) ! concentration aerosols/m^3
-         enddo
-        enddo 
-
-c                                   -------
-101      continue
-
-
-       ddt=0.
-       micropas=min(36000.,ptimestep)        
-103    micropas=micropas/2.
-      ddt=ptimestep/(int(ptimestep/(2*micropas))*1.)/2.  
-      if (int(ptimestep/ddt/2.).lt.2) goto 103
-
-      call pg3(dz,dzb,tb,t,pb,p,c,z1,zb1,ptimestep,ddt
-     & ,nzhau,ihor,mu0(ihor),fract(ihor))
-
- 
-       do i=1,nrad
-         do j=1,nz
-            totalc2=totalc2+c(J,i)*dzb(j)
-     &      *2.**(i*7.-7.)
-          q(IHOR,j,i)=c(j,i)*dzb(j) ! nombre  aerosols
-         enddo
-       enddo 
-
-       ENDDO             ! Fin de la boucle IHOR
-
-
-102   CONTINUE           ! la premiere fois, c'est une boucle vide!
-
-
-
-c***************************************************************
-c FIN: on renvoie les nouvelles valeurs de dq=q(t+dt)-q(t)
-c***************************************************************
-
-
-
-
-       do n=1,ngrid
-       do i=1,nq
-       do j=1,NLAYER                ! j de 1 a 54 
-
-
-          tdq(n,nlayer+1-j,i)=0.
-
-          tdq(n,nlayer+1-j,i)=(q(n,j,i)
-     &                         -tq(n,nlayer+1-j,i))/ptimestep
-
-       if (tdq(n,nlayer+1-j,i).eq.0.)  tdq(n,nlayer+1-j,i)=1.e-20
-       enddo
-       enddo
-       enddo
-
-c Calcul de la surface des aerosols pour la chimie heterogene
-c-------------------------------------------------------------
-
-       do ihor=1,ngrid
-       do jalt=1,nlayer
-
-         dzb(jalt)=(zzlev(ihor,jalt)-zzlev(ihor,jalt+1))
-         psurfhaze(ihor,jalt)=0.
-
-         do iq=1,nq
-          if(iq .le. 6)
-     &       surf1=4.*3.1415926353*rf(6)**2./(2.519842**(6-iq))**2.
-          if(iq .gt. 6)
-     &       surf1=4.*3.1415926353*rf(6)**2. * (16.**(iq-6))
-
-            psurfhaze(ihor,jalt)=psurfhaze(ihor,jalt)+
-     &             q(ihor,nlayer+1-jalt,iq)/dzb(jalt)*surf1
-         enddo
-
-         psurfhaze(ihor,jalt)=psurfhaze(ihor,jalt)
-     &                        *1.e12/1.e6  !passage m^2/m^3 a um^2/cm^3
-c        print*,psurfhaze(ihor,jalt),dzb(jalt),q(ihor,nlayer+1-jalt,1)
-c    &         ,surf1,rf(6)
-
-         enddo
-       enddo
-
-c***** WARNING, SI IPREM=0 ON DOIT EGALEMENT SOUSTRAIRE QDEL
-c******* VOIR PLUS LOIN. DANS CE CAS, LA BOUCLE SI DESSUS
-c****** NE SRT QU'A FAIRE LE BIALN DQ=Q_FICHIER-0
-c**** LE DQ EFFECTIVEMENT PRIS EN COMPTE EST CALCULE APRES LE BILAN
-
-c      BILAN DE MASSE SORTIE
-
-
-       total=0.
-       tmass=0.
-       do ihor=1,ngrid
-          do iq=1,nq
-           do JALT=1,nlayer
-            total=total+tdq(ihor,JALT,iq)*(16.**(iq-5))
-     .                      *aire(ihor)*ptimestep
-            tmass=tmass+q(ihor,JALT,iq)*(16.**(iq-5))*aire(ihor)
-           enddo
-          enddo
-       enddo
-c         print*,'Bilan sortie masse des qaer (unite M_mono)',
-c    .                  tmass,total,total/tmass   
-
-
-c POUR LE PREMIER PASSAGE, IL FAUT ELIMINER L'ETAT DE Q
-c PROVENANT DE LA LECTURE DES FICHIERS STARTS
-c QD DOIT DONC CONTENIR -QDEL
-
-       if (iprem.eq.0) then
-
-       do n=1,ngrid
-       do i=1,nq
-       do j=1,NLAYER                ! j de 1 a 54 
-
-             tdq(n,nlayer+1-j,i)=0.
-
-             tdq(n,nlayer+1-j,i)=(q(n,j,i)
-     &                         -tq(n,nlayer+1-j,i)
-     &                       -qdel(n,nlayer+1-j,i))/ptimestep
-
-
-       tq(n,nlayer+1-j,i)=tq(n,nlayer+1-j,i)+qdel(n,nlayer+1-j,i)
-
-       if (tdq(n,nlayer+1-j,i).eq.0.)  tdq(n,nlayer+1-j,i)=1.e-20
-
-       enddo
-       enddo
-       enddo
-       endif
-
-c      print*,'ok1'
-c EN GENERAL, TDQ= (Q_FICHIER - Q_START)/PTIMESTEP
-
- 
-          iprem=1       ! LA PROCHAINE FOIS NE SERA PLUS LA 1ERE 
-c      print*,'************************************'
-c      print*,'***********TABLEAU APRES************'
-c      print*,'************************************'
-c      do h=12,12
-c      do j=1,NLAYER
-c         print*,'exit',h,j,tdq(h,j,7),q(h,j,7),tpt(h,j),tpplev(h,j)
-c      enddo
-c      enddo
-c      print*,'************************************'
-
-c Au dernier appel...on ecrit finfich
-
-          if (last) then
-        open (unit=31,file='finfich',iostat=ii,
-     1  access='sequential',form='formatted')
-
-
-         write(unit=31,fmt=1011,iostat=ii)tt,(((q(i,j,k),
-     1   k=1,nrad),j=1,nz),i=1,ngrid)
-         endif
-c        print*,'ok2'
-
-1011    format(e8.3,21000(e8.3))
-
- 
- 16      return  
- 500    print*,'erreur lecture initfich' 
-          stop
- 499    print*,'erreur ouverture initfich' 
-          stop
-          end 
-
-
-c---------------------------------------------------------------------
Index: trunk/LMDZ.TITAN/libf/phytitan/pg2.old
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/pg2.old	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/pg2.old	(revision 175)
@@ -0,0 +1,727 @@
+            subroutine pg2(
+     &      tpplev,tpt,tq,tdq,nq,ptimestep,mu0,fract,last)
+c
+c
+c
+c
+c
+c
+c    &      tpplev,tpt,tq,tdq,nq,ptimestep,last)
+c                     /                    \
+c       |  PHYSIQUE  | AEROSOLS            |
+c
+c                     \|/
+c                    (o o)
+c-----------------oOo--O--oOo--------------------------
+c                      
+c Interface entre physiq.F et aerosols.F 
+c
+c Date: 5 Nov 96
+c
+c   -->(  )          q(x,nlayer,nq) 
+c
+c             q(x,nlayer,nq) <==>  c(nz,nrad)
+c
+c          c(nz,nrad)(t) -->  aerosol.F --> c(nz,nrad)(t+dt)
+c
+c             c(nz,nrad) <==> q(x,nlayer,nq)
+c     
+c              c(IHOR,NRAD,NRAD)  en aerosols
+c              c0(NZ,NRAD)        en aerosols/m^3  
+c
+c   L'ECHANGE N'EST POSSIBLE QUE SI LES QUANTITES SONT
+c   DES NOMBRES D'AEROSOLS.........
+c
+c   LES QUANTITES Q SONT EN AEROSOLS / CASE (BOUT DE COLONNE
+c   DE 1m^2 * DZ(J)..................ATTENTION AU PASSAGE 
+c      PHYSIQUE <---> DYNAMIQUE QUI A BESOINS DE ????
+c
+c   LE MODELE MICROPHYSIQUE A BESOIN DE CONCENTRATIONS
+c                     AEROSOLS/M^3
+c------------------------------------------------------
+
+      use dimphy
+      USE comgeomphy
+#include "dimensions.h"
+#include "microtab.h"
+#include "paramet.h"
+#include "aerprod.h"
+#include "clesphys.h"
+#include "YOMCST.h"
+
+     
+        parameter (NG=jjm+1)   ! NG: on travaille en moyenne zonale
+ 
+c*************************************
+c declaration des variables internes *
+c*************************************
+	
+c       GCM        *
+c------------------*
+
+        real tzzlev(ng,klev+1)
+     &         ,tpplev(ng,klev+1)
+     &         ,tzzlay(ng,klev)
+     &         ,tpt(ng,klev)
+     &         ,tq(ng,klev,nq)
+     &         ,tdq(ng,klev,nq)
+        real   mu0(ng),fract(ng)
+
+        real    zzlev(NG,klev+1)
+     &         ,pplev(NG,klev+1)
+     &         ,zzlay(NG,klev)
+     &         ,pt(NG,klev)
+     &         ,q(NG,klev,nq)
+     &         ,qdel(NG,klev,nq)
+     &         ,qcumul(NG,0:200,nq)
+
+        integer jsup,jinf,h
+ 
+        logical last
+
+
+c    microphysique    *
+c---------------------*
+
+        real aire(ng),airetot,lati(ng)
+	save aire,lati
+
+	real z(nz),zb(nz+1),alt(200)
+	real dz(nz),dzb(nz+1)
+        real pb(nz+1),p(nz)
+        real tb(nz+1),t(nz) 
+ 
+	real c0(200,nrad),c(nz,nrad),ctp(nz,nrad)
+	double precision c0lu(200,nrad)
+        real cmemoire(nz,nrad)
+        real micropas,ddt
+
+      integer iprem
+      save iprem
+      data iprem/0/
+
+c          print*,'DEBUT DE PG2'
+
+
+         ngrid=ng
+         nlayer=klev
+         if(nrad.ne.nq) then
+             print*,'microphysique:nrad.ne.nq:',nrad,nq
+             stop 
+         endif
+
+* ici, on evalue les niveaux d'altitudes en fonction des niveaux de
+*  pressions.
+
+          do h=1,ngrid
+          tpplev(h,nlayer+1)=tpplev(h,nlayer)*.1
+          enddo
+
+        r=8.314*1000./28.
+
+* pour chaque point de grille
+
+       do h=1,ngrid
+         zz=0.
+         tzzlev(h,1)=zz
+
+* bord de couche
+
+        do l=1,nlayer
+         eff_g = 1.345*(2575./(2575.+zz/1000.))**2
+          zz=zz+r*2.*tpt(h,l)/
+     &    eff_g*(tpplev(h,l)-tpplev(h,l+1))/(tpplev(h,l)+tpplev(h,l+1))
+          tzzlev(h,l+1)=zz
+c         print*,l,eff_g,tpplev(h,l),tpplev(h,l+1),zz
+        enddo
+
+* milieu  de couche
+
+        do l=1,nlayer
+        xlog=( alog(tpplev(h,l+1)) + alog(tpplev(h,l)) )/2.
+        rapport=(tzzlev(h,l+1)-tzzlev(h,l))
+     &             /(alog(tpplev(h,l+1))-alog(tpplev(h,l)))
+        tzzlay(h,l)=rapport*(xlog-alog(tpplev(h,l+1)))
+     &              +tzzlev(h,l+1)
+        enddo
+       enddo
+
+
+c       PRINT*,'PROFILE #1'
+c       h=10
+c       do l=1,nlayer
+c        print*, tpplev(h,l),tpt(h,l),tq(h,1,1),tq(h,l,7)
+c       enddo
+c        print*, tpplev(h,nlayer+1)
+
+         do j=1,200
+           alt(j)=(j-1)*5000.     !0 5000 10000 15000 .......!
+         enddo
+         
+
+
+
+c      			**************************
+c        		INITIALISATION DE TABLEAUX
+c    		 	**************************
+c                         A NE FAIRE QU'UNE FOIS
+c     		        **************************
+
+ 
+        IF (iprem.eq.0) THEN
+
+       qdel = 0.
+
+c initialisation de aire(ig)
+c --------------------------
+
+      airetot=0.
+      
+      lati(1)     = 0.5*RPI
+      DO ig=2,ngrid-1
+        lati(ig)  = rlatd(2+(ig-2)*iim)*RPI/180.
+      ENDDO
+      lati(ngrid) = -0.5*RPI
+      
+      DO ig=1,ngrid
+      if(ig.eq.1)
+     &   aire(ig)=2*RPI*(1.-sin(lati(ig)/2.+lati(ig+1)/2.))*RA*RA
+      if(ig.eq.ngrid)
+     &   aire(ig)=2*RPI*(1.+sin(lati(ig-1)/2.+lati(ig)/2.))*RA*RA
+       if(ig.ne.1. .and. ig.ne.ngrid) aire(ig)=2*RPI*RA*RA*
+     &      (sin(lati(ig-1)/2.+lati(ig)/2.)
+     &      -sin(lati(ig)/2.+lati(ig+1)/2.))
+
+      airetot=airetot+aire(ig)
+      ENDDO
+c     print*,"ENTREE PG2 PREMIER APPEL"
+c     print*,airetot,' airetot?= ',4.*RPI*RA*RA
+c     print*,1,rlatd(1),aire(1),aire(1)/airetot,' aires'
+c     DO ig=2,ngrid-1
+c     print*,ig,rlatd(2+(ig-2)*iim),aire(ig),aire(ig)/airetot,' aires'
+c     ENDDO
+c     print*,ngrid,rlatd(klon),aire(ngrid),aire(ngrid)/airetot,' aires'
+c     stop
+      
+c initialisation de c(z,r)
+c --------------------------
+
+
+        itype=2
+
+
+c remplissage type 1:            OBSOLETE !
+c----------------------
+
+
+        if(itype.eq.1) then !****************************
+
+        taer=tcorrect
+
+#ifdef CRAY
+        open (unit=32,file='aerosols',status='old',iostat=ii,
+     1  form='formatted')
+        if(ii.ne.0) then
+           print*,'WARNING!!! pas de reinitialisation des traceurs'
+           print*,'On part des traceurs contenus dans start'
+           return
+        endif
+        print*,'pg2 apres open version cray',ii
+        read(32,'(e8.3)') tt
+        read(32,'(5e10.3)') c0
+        close(32)
+#else
+        print*,'pg2 avant open'
+        open (unit=31,file='initfich',iostat=ii,
+     1  access='sequential',form='formatted')
+
+13      read(unit=31,fmt=1010,iostat=ii,end=15)tt,((c0lu(j,k),
+     1   k=1,nrad),j=1,200)
+1010    format(e8.3,2000(e8.3))
+
+15      continue
+
+c Conversion: lecture en double, variable utile en simple...
+        do j=1,200
+        do k=1,nrad
+          c0(j,k) = real(c0lu(j,k))
+c          print*,c0(j,k)
+        enddo
+        enddo
+#endif
+ 
+c        print*,'fichier microphysique'
+c        do j=1,200
+c        print*,'L&0',j,c0(j,1),c0(j,3),c0(j,5),c0(j,7),c0(j,9)
+c        enddo
+
+         close (unit=31)
+        
+         do k=1,nrad 
+         do h=1,ngrid
+            qcumul(h,0,k)=0.
+            qcumul(h,1,k)=c0(200,k)*taer*5000.
+          do j=2,200
+            qcumul(h,j,k)=c0(200-j+1,k)*taer*5000.+qcumul(h,j-1,k)   
+          enddo 
+          do j=1,nlayer
+           qdel(h,j,k)=tq(h,j,k)   ! etat q provenant des starts a effacer!
+           tq(h,j,k)=0.
+          enddo
+         enddo 
+         enddo 
+c        do j=1,200
+c        print*,'L&1',j,qcumul(12,j,1),qcumul(12,j,3),qcumul(12,j,5)
+c        enddo
+         write(92,*) qdel
+
+c interpolation des q_cumules
+
+c         do j=1,nlayer
+c          print*,tzzlev(10,j),alt(j)
+c         enddo
+         do k=1,nrad 
+         do h=1,ngrid
+          jsup=int(tzzlev(h,2)/5000.+2.)
+          xfact=tzzlev(h,2)/alt(jsup)
+          tq(h,1,k)=xfact*qcumul(h,1,k)
+          do j=2,nlayer
+             jsup=int(tzzlev(h,j+1)/5000.+2.)
+             jinf=int(tzzlev(h,j+1)/5000.+1.)
+             xfact=(tzzlev(h,j+1)-alt(jinf))/(alt(jsup)-alt(jinf))
+             tq(h,j,k)=xfact*(qcumul(h,jsup-1,k)-qcumul(h,jinf-1,k))
+     &       +qcumul(h,jinf-1,k)
+          enddo
+         enddo 
+         enddo 
+
+c soustraction des q_cumules
+
+         do k=1,nrad 
+         do h=1,ngrid
+         do j=nlayer,2,-1
+          tq(h,j,k)=tq(h,j,k)-tq(h,j-1,k)
+         enddo 
+         enddo 
+         enddo 
+
+c on inverse q <--> tq, et tq=0 ====> dq=q-qt a la fin pour intitialiser. 
+
+         do k=1,nrad 
+         do h=1,ngrid
+         do j=nlayer,1,-1
+             q(h,j,k)=tq(h,nlayer-j+1,k)
+             tq(h,nlayer-j+1,k)=0.
+
+c        if (h.eq.12) then
+c         if (k.eq.nrad) then
+c            print*,'L&3',j,q(12,j,1),q(12,j,3),q(12,j,5)
+c          endif
+c        endif
+
+         enddo 
+         enddo 
+         enddo 
+           print*,'itype=1'
+
+         do h=1,ngrid 
+          somme=0.
+         do k=1,nrad 
+         do j=nlayer,1,-1
+         ref=1.63789E-09*(2.**.3333333333)**(4.*(k-1))
+           somme=somme+q(h,j,k)*4.1888*ref**3. 
+         enddo 
+         enddo 
+           print*,'bilan externe: m3/m2 grid#',h, somme
+         enddo 
+
+
+           else  !**********************************
+
+c remplissage type 2:
+c----------------------
+
+c       open (unit=31,file='finfich',iostat=ii,
+c    1  access='sequential',form='formatted')
+
+c       read(unit=31,fmt=1011,iostat=ii,end=18)tt,(((q(i,j,k),
+c    1  k=1,nrad),j=1,nlayer),i=1,ngrid)
+c8      continue
+c       close (unit=31)
+c----------------------
+
+
+          print*,'entre dans itype2'
+
+
+         do k=1,nrad 
+         do h=1,ngrid
+         do j=nlayer,1,-1
+
+          
+
+          q(h,nlayer+1-j,k)=tq(h,j,k)*tcorrect
+
+             tq(h,j,k)=0.  
+c
+c  Car les q initiaux sont lus dans la physiq, mais les dq doivent
+c  etre passes dans la dynamique via dqfi. C'est ici que les valeurs
+c  de dqfi=(q_lu*tcorrect - 0) sont definie
+
+         enddo 
+         enddo 
+         enddo
+
+
+           print*,'itype=2'
+         do h=1,ngrid 
+          somme=0.
+         do k=1,nrad 
+         do j=nlayer,1,-1
+         ref=1.63789E-09*(2.**.3333333333)**(4.*(k-1))
+           somme=somme+q(h,j,k)*4.1888*ref**3. 
+         enddo 
+         enddo 
+           print*,'bilan externe: m3/m2 grid#',h, somme
+         enddo 
+
+
+
+
+
+        endif 
+
+
+        ENDIF !FIN IPREM 
+  
+
+
+c	      ************************************
+c                FIN: A NE FAIRE QU'UNE FOIS 
+c	      ************************************
+c              
+
+
+
+c	   ************************************
+c            IL FAUT INVERSER LES TABLEAUX...            
+c	   ************************************
+
+
+
+
+       do n=1,ngrid
+         do j=1,NLAYER+1               ! j de 1 a 120
+           zzlev(n,j)=tzzlev(n,nlayer-j+2) ! indice de 120 a 1
+           pplev(n,j)=tpplev(n,nlayer-j+2)
+         enddo
+       enddo
+
+c les tq() doivent etre en nombre d'aerosols / cases 
+
+       do j=1,NLAYER                ! j de 1 a 119 
+         do n=1,ngrid
+           zzlay(n,j)=tzzlay(n,nlayer-j+1)  ! indice de 119 a 1
+           pt(n,j)=tpt(n,nlayer-j+1)
+         enddo
+       enddo
+
+        if (iprem.eq.0) goto 119  ! pour ne pas effacer les q()|t=0
+
+       do j=1,NLAYER                ! j de 1 a 119 
+         do n=1,ngrid
+           do i=1,nq
+             qdel(n,j,i)=0.
+             q(n,j,i)=tq(n,nlayer-j+1,i)
+           enddo
+         enddo
+       enddo
+
+ 119    continue
+
+
+c               ******************************
+c                      BILAN DE MASSE
+c               ******************************
+
+       total=0.
+       do ihor=1,ngrid
+          do iq=1,nq
+           do JALT=1,nlayer
+            total=total+tq(ihor,JALT,iq)*(16.**(iq-5))*aire(ihor)
+           enddo
+          enddo
+       enddo
+c         print*,'Bilan entree masse des qaer (unite M_mono)',total   
+    
+
+c****************************************
+c                                       *
+c         ADAPTATION GCM > micro        *
+c                                       *
+c****************************************
+
+
+c correpondance des couches / sens GCM > microphysique 
+c-----------------------------------------------------
+c
+c But remplir les c(nz,i) avec les concentrations
+c Q(ng,NLAYER,i) d'aerosols calculee par gcm.F
+
+
+ 
+      totalc1=0. 
+      totalc2=0. 
+      
+      if (iprem.eq.0) then 
+c ici, les tableaux definissant la structure des aerosols sont
+c remplis: rf,df(nq),rayon(nq,)v(nq)......
+       call rdf()
+      endif
+
+
+
+c---------------------------------------------
+
+       IF (iprem.eq.0) goto 102 
+
+c      !! La premiere fois, on ne passe pas par 
+c      !! q--->c et par pg3.F
+c      !! on passe directement au remplissage c-->q
+c---------------------------------------------
+
+       
+       do IHOR=1,NGRID      ! GRANDE BOUCLE HORIZONTALE
+
+         cpt=0.
+         cpx=0.
+         nzhau=0
+  
+
+       do JALT=1,nlayer-1         ! 1ere BOUCLE SUR Z (indice nz=1,120)
+         dz(jalt)=(zzlay(ihor,jalt)-zzlay(ihor,jalt+1))
+       enddo   
+         dz(nlayer)=dz(nlayer-1)  ! ARBITRAIRE ET SANS IMPORTANCE!!!!!
+
+       do JALT=1,nlayer         ! 1ere BOUCLE SUR Z (indice nz=1,120)
+         dzb(jalt)=(zzlev(ihor,jalt)-zzlev(ihor,jalt+1))
+         pb(jalt)=pplev(ihor,jalt)
+         t(jalt)=pt(ihor,jalt) 
+       enddo 
+         pb(nlayer+1)=pplev(ihor,nlayer+1)
+ 
+
+
+c** T(>300km) = T(300km)
+
+
+         pb(nlayer+1)=pplev(IHOR,nlayer+1)
+
+         zb1=zzlev(ihor,1)
+         z1 =zzlay(ihor,1)
+
+
+c        if(ihor.eq.12) 
+c    &   print*,'nzhau pour la latitude # ',ihor,' : ',nzhau
+c        if(ihor.eq.1) 
+c    &   print*,'nzhau pour la latitude # ',ihor,' : ',nzhau
+c        if(ihor.eq.24) 
+c    &   print*,'nzhau pour la latitude # ',ihor,' : ',nzhau
+
+
+c Interpolation des tableaux tb et p a partir de t et pb
+c******************************************************
+
+        do i=1,nz-1
+         tb(i+1)=(t(i)+t(i+1))/2.  ! temperature au bord des couches
+        enddo
+
+         tb(1)=t(1)
+         tb(nz+1)=(t(nz)-t(nz-1))*.5+t(nz)
+         
+        do i=1,nz
+         p(i)=(alog(pb(i))+alog(pb(i+1)))/2. ! pression au centre des couches
+         p(i)=exp(p(i))
+        enddo
+
+
+        
+c****************************************
+c 
+c   APPEL DU MODEL MICROPHYSIQUE
+c
+c****************************************
+
+
+        do i=1,nrad
+         do j=1,nz
+          c(j,i)=q(IHOR,j,i)/dzb(j) ! concentration aerosols/m^3
+         enddo
+        enddo 
+
+c                                   -------
+101      continue
+
+
+       ddt=0.
+       micropas=min(36000.,ptimestep)        
+103    micropas=micropas/2.
+      ddt=ptimestep/(int(ptimestep/(2*micropas))*1.)/2.  
+      if (int(ptimestep/ddt/2.).lt.2) goto 103
+
+      call pg3(dz,dzb,tb,t,pb,p,c,z1,zb1,ptimestep,ddt
+     & ,nzhau,ihor,mu0(ihor),fract(ihor))
+
+ 
+       do i=1,nrad
+         do j=1,nz
+            totalc2=totalc2+c(J,i)*dzb(j)
+     &      *2.**(i*7.-7.)
+          q(IHOR,j,i)=c(j,i)*dzb(j) ! nombre  aerosols
+         enddo
+       enddo 
+
+       ENDDO             ! Fin de la boucle IHOR
+
+
+102   CONTINUE           ! la premiere fois, c'est une boucle vide!
+
+
+
+c***************************************************************
+c FIN: on renvoie les nouvelles valeurs de dq=q(t+dt)-q(t)
+c***************************************************************
+
+
+
+
+       do n=1,ngrid
+       do i=1,nq
+       do j=1,NLAYER                ! j de 1 a 54 
+
+
+          tdq(n,nlayer+1-j,i)=0.
+
+          tdq(n,nlayer+1-j,i)=(q(n,j,i)
+     &                         -tq(n,nlayer+1-j,i))/ptimestep
+
+       if (tdq(n,nlayer+1-j,i).eq.0.)  tdq(n,nlayer+1-j,i)=1.e-20
+       enddo
+       enddo
+       enddo
+
+c Calcul de la surface des aerosols pour la chimie heterogene
+c-------------------------------------------------------------
+
+       do ihor=1,ngrid
+       do jalt=1,nlayer
+
+         dzb(jalt)=(zzlev(ihor,jalt)-zzlev(ihor,jalt+1))
+         psurfhaze(ihor,jalt)=0.
+
+         do iq=1,nq
+          if(iq .le. 6)
+     &       surf1=4.*3.1415926353*rf(6)**2./(2.519842**(6-iq))**2.
+          if(iq .gt. 6)
+     &       surf1=4.*3.1415926353*rf(6)**2. * (16.**(iq-6))
+
+            psurfhaze(ihor,jalt)=psurfhaze(ihor,jalt)+
+     &             q(ihor,nlayer+1-jalt,iq)/dzb(jalt)*surf1
+         enddo
+
+         psurfhaze(ihor,jalt)=psurfhaze(ihor,jalt)
+     &                        *1.e12/1.e6  !passage m^2/m^3 a um^2/cm^3
+c        print*,psurfhaze(ihor,jalt),dzb(jalt),q(ihor,nlayer+1-jalt,1)
+c    &         ,surf1,rf(6)
+
+         enddo
+       enddo
+
+c***** WARNING, SI IPREM=0 ON DOIT EGALEMENT SOUSTRAIRE QDEL
+c******* VOIR PLUS LOIN. DANS CE CAS, LA BOUCLE SI DESSUS
+c****** NE SRT QU'A FAIRE LE BIALN DQ=Q_FICHIER-0
+c**** LE DQ EFFECTIVEMENT PRIS EN COMPTE EST CALCULE APRES LE BILAN
+
+c      BILAN DE MASSE SORTIE
+
+
+       total=0.
+       tmass=0.
+       do ihor=1,ngrid
+          do iq=1,nq
+           do JALT=1,nlayer
+            total=total+tdq(ihor,JALT,iq)*(16.**(iq-5))
+     .                      *aire(ihor)*ptimestep
+            tmass=tmass+q(ihor,JALT,iq)*(16.**(iq-5))*aire(ihor)
+           enddo
+          enddo
+       enddo
+c         print*,'Bilan sortie masse des qaer (unite M_mono)',
+c    .                  tmass,total,total/tmass   
+
+
+c POUR LE PREMIER PASSAGE, IL FAUT ELIMINER L'ETAT DE Q
+c PROVENANT DE LA LECTURE DES FICHIERS STARTS
+c QD DOIT DONC CONTENIR -QDEL
+
+       if (iprem.eq.0) then
+
+       do n=1,ngrid
+       do i=1,nq
+       do j=1,NLAYER                ! j de 1 a 54 
+
+             tdq(n,nlayer+1-j,i)=0.
+
+             tdq(n,nlayer+1-j,i)=(q(n,j,i)
+     &                         -tq(n,nlayer+1-j,i)
+     &                       -qdel(n,nlayer+1-j,i))/ptimestep
+
+
+       tq(n,nlayer+1-j,i)=tq(n,nlayer+1-j,i)+qdel(n,nlayer+1-j,i)
+
+       if (tdq(n,nlayer+1-j,i).eq.0.)  tdq(n,nlayer+1-j,i)=1.e-20
+
+       enddo
+       enddo
+       enddo
+       endif
+
+c      print*,'ok1'
+c EN GENERAL, TDQ= (Q_FICHIER - Q_START)/PTIMESTEP
+
+ 
+          iprem=1       ! LA PROCHAINE FOIS NE SERA PLUS LA 1ERE 
+c      print*,'************************************'
+c      print*,'***********TABLEAU APRES************'
+c      print*,'************************************'
+c      do h=12,12
+c      do j=1,NLAYER
+c         print*,'exit',h,j,tdq(h,j,7),q(h,j,7),tpt(h,j),tpplev(h,j)
+c      enddo
+c      enddo
+c      print*,'************************************'
+
+c Au dernier appel...on ecrit finfich
+
+          if (last) then
+        open (unit=31,file='finfich',iostat=ii,
+     1  access='sequential',form='formatted')
+
+
+         write(unit=31,fmt=1011,iostat=ii)tt,(((q(i,j,k),
+     1   k=1,nrad),j=1,nz),i=1,ngrid)
+         endif
+c        print*,'ok2'
+
+1011    format(e8.3,21000(e8.3))
+
+ 
+ 16      return  
+ 500    print*,'erreur lecture initfich' 
+          stop
+ 499    print*,'erreur ouverture initfich' 
+          stop
+          end 
+
+
+c---------------------------------------------------------------------
Index: trunk/LMDZ.TITAN/libf/phytitan/pg3.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/pg3.F	(revision 174)
+++ 	(revision )
@@ -1,1530 +1,0 @@
-        subroutine pg3(tab1,tab2,tab3,tab4,tab5,tab6,tab7,
-     &  x1,x2,x3,x4,xnztop,ihor,xmu0,xfract)
-
-c     call pg3(dz,dzb,tb,t,pb,p,c,z1,zb1,ptimestep,ddt
-c    & ,nzhau,ihor)
-
-
-*1  dz, pas d'altitude pour les milieux de couches
-*2  dzb, pas d'altitude pour les limites superieures de couches
-*34 tb,t temperature a la limite superieure des couches et 
-*4         au milieu des couches  
-*56 pb,p pression a la limite superieure des couches et 
-*6         au milieu des couches  
-*7  c nombre de particules de la grille de rayon r a l'altitude z 
-*1  z1, altitude du milieu de la couche superieure de l'atmosphere. 
-*2  zb1, altitude de la limite superieure de la couche superieure
-*          de l'atmosphere
-*3  tmax, duree , en jour, de l'execution
-*4  dt, pas de temps, en heure.  
-
-*--------------------------------------------------------------*
-*                                                              *
-*            ENTRE 0 ET 1000 KILOMETRES                        *     
-*                                                              * 
-*    la dimension fractale est en tableau, attention au        *
-*    raccordement entre le regime moleculaire et le regime     *
-*    fluide                                                    *
-*                                                              *
-*    Modele microphysique:    Cabane et al.,1992 /             *
-*    Modele version fractale: Cabane et al.,1993 /             *
-*                                                              *
-*--------------------------------------------------------------*
-* VERSION DU 2 JUIN 1993  --- AUT 1994 --- 11/04/96
-*
-* changer: altitude de production zalt0=/taux de production ctot= 
-*        : la charge/micron, ne
-*        : df(h),rf... 
-* raccordement aknc 
-*
-* declaration des blocs communs
-*------------------------------
-
-#include "dimensions.h"
-#include "microtab.h"
-#include "clesphys.h"
-
-	common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
-        common/ini/z1,zb1,c0  
-	common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
-	common/grille/z,zb,dz,dzb 
-	common/ctps/li,lf,tt,dt
-        common/con/c
-	common/part/v,rayon,vrat,dr,dv
-	common/coag/k
-        common/effets/ xsaison
-
- 
-* declaration des variables communes
-* ----------------------------------
-
-	integer xnztop
-	integer li,lf
-	real dt,tt
-	real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz)
-     &  ,pb(nz),tb(nz),rhob(nz)
-	real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
-	real zb(nz),z(nz),dz(nz),dzb(nz) 
-	real c0(nz,nrad),c(nz,nrad,2)
-        real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad)
-	real k(nz,nrad,nrad),knu
-        real xmu0,xfract
-        
-
-*  variables internes
-*  ------------------
-
-	integer h,ti,tmax,itime
-        real tab1(nz),tab2(nz+1),tab3(nz+1),tab4(nz)
-        real tab5(nz+1),tab6(nz),tab7(nz,nrad)
-        real x1,x2,x3,x4 
-        real knd1,knd2,knd3,knd4,knd5,knd6
-
-       save itime
-       data itime/0/
-* initialisation
-* --------------
-
-c      print*,'Df aerosols /1 a nqtot/'
-c       write(*,*) (df(h),h=1,nrad)
-c       write(*,*) (rayon(h),h=1,nrad)
-c       write(*,*) (dr(h),h=1,nrad)
-c       write(*,*) (v(h),h=1,nrad)
-c       write(*,*) (dv(h),h=1,nrad)
-c       print*,vrat,rf,aknc
-
-* effet saisonnier
-* ----------------
-
-
-         xsaison=0.
-         xsaison=xmu0*4.*xfract  
-                              !=Pi si fract=1/2 (equinoxe) et 
-                              !    si mu0=1 sous le soleil
-                              !    exactement.
-
-c        xsaison=0.
-c        if (ihor.le.9.or.ihor.ge.41) xsaison=8.  ! rapport des surfaces
-c        xsaison=1.
-
-* controles
-* ---------
-
-        do i=1,nz	
-         dz(i)=tab1(i)
-         dzb(i)=tab2(i)
-         tb(i)=tab3(i) 
-         t(i)=tab4(i) 
-         pb(i)=tab5(i)  		
-         p(i)=tab6(i) 
-          do j=1,nrad 
-            c(i,j,1)=tab7(i,j)
-            c(i,j,2)=0.0 
-          enddo 
-        enddo 
-        z1=x1
-        zb1=x2
-        tmax=int(x3/x4)/2       ! 2. * tmax iterations 
-        dt=x4                    !  
-       
-
-        z(1)=z1  
-        zb(1)=zb1 
- 
-	do 12 i=2,nz
-	  z(i)=z(i-1)-dz(i-1)
-	  zb(i)=zb(i-1)-dzb(i-1)
-12	continue
-
-c        print*, tmax,dt,z1,zb1
-c       do i=1,nz
-c        print*,i,z(i),p(i),t(i),zb(i),pb(i),tb(i),c(i,1,1)
-c       enddo
- 
-c       stop 'profile'
-
-       if (itime.eq.0) then 
-
-        ITIME=1
-c        print*,'avant init'
-         call init
-c        print*,'apres init'
-c        print*,'avant calcoag'
-         call calcoag
-c        print*,'apres calcoag'
-
-c        print*,'***** TEST COAGULATION ********'
-c       do h=1,nz,20
-c        do i=1,3
-c         print*,'KOAG',h,i,k(h,1,i),k(h,2,i),k(h,3,i)
-c        enddo
-c       enddo
-
-       endif
-
-
-* iteration du modele sur le temps
-* ---------------------------------
-c      print*,'##############################################'
-c         print*,'debut microphysique'
-c       print*,'Df aerosols /1 a 6/'
-c       write(*,*) (df(h),h=1,6)
-c         call ecran(tt) 
-c
-c      print*,'CHECK BEFORE COMPUTATION'
-c      print*,'nrad=',nrad,' nqtot=',nqtot,' ctrl...'
-c      print*,'##############################################'
-c      print*,'1.0 - tableaux de bases:'
-c      print*,'i	rayon(i)	'
-c       do i=1,nrad
-c        print*,i,rayon(i)
-c       enddo
-c      print*,'temps appel	pas de temps:'
-c      print*,tmax, dt 
-c      print*,'##############################################'
-c      print*,'1.1 - Avec l altitude: '
-c      print*,' i       v1  v3 v5 v6 '
-c      print*, 'i	z(i)	c(i,1,1)	c(i,4,1)	c(i,6,1)'
-c      print*,'***	dz(i)	dzb(i)'
-c      print*,'***	pb(i)	p(i)	t(i)	tb(i)'
-c
-c      if(ihor.eq.25.or.IHOR.EQ.1.) THEN 
-c       do i=1,nz,1
-c         print*,i,z(i),c(i,1,1),c(i,4,1),c(i,6,1)
-c         print*,'pbpttb',pb(i),p(i),t(i),tb(i)
-c            v1=vitesse(i,7,0)
-c            v2=vitesse(i,8,0)
-c            v3=vitesse(i,9,0)
-c            v4=vitesse(i,10,0)
-c            print*,ihor,z(i),v1,v2,v3,v4
-c      enddo
-c      endif
-c      if(ihor.eq.25) STOP
-c
-c       if (ihor.eq.25.or.ihor.eq.48.or.ihor.eq.1) then
-c      print*,'##############################################'
-c       print*,'ihor=',ihor
-c       do i=1,nz,1
-c             knd1=knu(i,5,1)
-c             knd2=knu(i,6,1)
-c             knd3=knu(i,7,1)
-c             knd4=knu(i,8,1)
-c             knd5=knu(i,9,1)
-c             knd6=knu(i,10,1)
-c         print*,i,z(i),knd2,knd4,knd6
-c      enddo
-c 
-c      if(ihor.eq.49) STOP
-c
-c      endif
-c
-c      print*,'1.2 - Avec les rayons:'
-c      print*,'h	i	j	k(h,i,j)'
-c        do j=1,nqtot
-c         print*,h,i,j,k(h,i,j)
-c      enddo
-c      print*,'##############################################'
-c       stop 'end check'
-
-
-c       somme=0.
-c       do i=1,nz
-c        do j=1,nrad
-c         somme=somme+c(i,j,1)*dzb(i)*4.1888*rayon(j)**3.
-c        enddo
-c       enddo
- 
-c       print*,'bilan interne: ',somme,'  volume/m^2'
-
-
-					    ! 1,tmax,2*dt : 
-	do 10 ti=1,tmax                     ! a chaque passage, deux pas
-					    ! de temps sont franchis.... 
-*  1ere iteration
-
-           tt=tt+dt
-
-            call coagul
-
-            call production(ihor)
-
-c           call nuages
-
-	   li=3-li
-	   lf=3-lf
-
-            call sedif
-
-
-
-
-*  2ieme iteration
-
-	tt=tt+dt
-
-	li=3-li
-	lf=3-lf
-
-
-        call sedif
-
-	li=3-li
-	lf=3-lf
-
-        call coagul
-
-        call production(ihor)
-
-c       call nuages
-
-	    li=3-li
-	    lf=3-lf
-
-
-
-10	continue
-
-379      continue
-
-          do i=1,nz
-           do j=1,nrad
-              tab7(i,j)=c(i,j,li)     ! li=1
-           enddo
-          enddo 
-         
-c        total=0. 
-c         do i=1,nz
-c          do j=1,nrad
-c             total=total+tab7(i,j)*dzb(j)*rayon(j)**3.
-c    &        *(1.333333*3.1415926)*1000.
-c          enddo
-c         enddo 
-c          print*,'bilan colonne kg/m^2:',total
-
-
-777      return  
-
-         end 
-*________________________________________________________________________ 
-                     subroutine ecran(tt)
-
-#include "dimensions.h"
-#include "microtab.h"
-cparameter(nz=200,nrad=nqtot,nztop=135)
-        common/con/c
-        real c(nz,nrad,2)
-          print*,'--------------------'
-          print*,'ecriture micro:'
-         do i=140,200,20
-         print*, c(i,1,1),c(i,4,1),c(i,6,1)
-         enddo
-
-        return
-        end
-
-
-
-
-                    subroutine coagul
-
-
-*********************************************************
-* ce programme calcule la nouvelle concentration dans   *
-* le a ieme intervalle de rayon, a l'altitude h, a      *
-* l'instant t+dt                                        *
-*********************************************************
-
-#include "dimensions.h"
-#include "microtab.h"
-
-* declaration des blocs communs
-*------------------------------
-
-	common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
-	common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
-	common/grille/z,zb,dz,dzb 
-	common/ctps/li,lf,tt,dt
-        common/con/c
-	common/part/v,rayon,vrat,dr,dv
-
-* declaration des variables
-* --------------------------
-
-	integer li,lf
-	real tt,dt
-cparameter(nz=200,nrad=nqtot,nztop=135)
-	real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz),pi,nav
-	real pb(nz),tb(nz),rhob(nz)
-	real rgp,kbz,rtit,g0,mch4,mar,mn2,rhol,dz(nz)
-	real vrat,dr(nrad),dv(nrad)
-	real c(nz,nrad,2),v(nrad),rayon(nrad),z(nz),zb(nz),dzb(nz) 
-
-* declaration des variables propres au ss-programme
-* -------------------------------------------------
-
-	integer h,a
-	real pr,pe
-
-*  traitement
-*  ----------
-
-
-        do 10 h=nztop,nz
-	   do 11 a=1,nrad
-	       call pertpro(h,a,pe,pr)
-c           if((1+dt*pe).lt.0.) stop 'denom.eq.0'
-            c(h,a,lf)=(c(h,a,li)+pr*dt)/(1+dt*pe)
-	  
-11         continue
-10	continue
-
-	if (nztop.ne.1) then
-	  do 12 h=1,nztop-1
-	     do 12 a=1,nrad
-	       c(h,a,lf)=c(h,a,li)
-12	  continue
-	endif
-
-	return
-	end
-      
-      
-*__________________________________________________________________________
-
-	     subroutine  calcoag
-
-***************************************************************
-*                                                             *
-*  Ce programme calcule les coefficients de collection  d'une *
-* particule de rayon x avec une particule de rayon b a une    *
-* altitude donnee h                                           *
-*************************************************************** 
-
-* declaration des blocs communs
-*------------------------------
-#include "dimensions.h"
-#include "microtab.h"
-
-        common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
-        common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
-        common/grille/z,zb,dz,dzb 
-        common/ctps/li,lf,tt,dt
-        common/con/c
-        common/part/v,rayon,vrat,dr,dv
-        common/coag/k
-
-* declaration des variables
-* --------------------------
-
-        integer li,lf
-        real tt,dt
-cparameter(nz=200,nrad=nqtot)
-        real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz),pi,nav
-        real pb(nz),tb(nz),rhob(nz)
-        real rgp,kbz,rtit,g0,mch4,mar,mn2,rhol,dz(nz)
-        real vrat,dr(nrad),dv(nrad)
-        real c(nz,nrad,2),v(nrad),rayon(nrad),z(nz),zb(nz),dzb(nz) 
-        real knu,nud,k(nz,nrad,nrad)
-
-* declaration des variables propres au ss-programme
-* -------------------------------------------------
-
-        integer h,b,x
-        real nua,lambb,lambx,knb,knx,alphab,alphax,d,e,f,kcg
-        real db,dx,rm,dm,deltab,deltax,del,g,beta,gx,gb
-         real*8 ne,qe,epso
-         real*8 corelec,yy
-
-        real kco,vx,vb,vitesse,sto,ee,a,dd,bb,p0,t0,l0,ccol
-        real st(37),ef(37)
-
-* initialisation
-* --------------
-c        print*,'**** calcoag'
-
-*  -nombres de STOCKES
-
-        data(st(i),i=1,37)/1.35,1.5,1.65,1.85,2.05,2.25,2.5,2.8,3.1,
-     s    3.35,3.6,3.95,4.3,4.7,5.05,5.45,5.9,6.4,7.,7.6,8.3,9.05,9.9,
-     s       10.9,11.1,13.5,15.3,17.25,20.5,24.5,30.4,39.3,48,57,86.,
-     s       187.,600./
-
-*  -coef. d'efficacite de collection
-
-        ef(1)=3.75
-        ef(2)=8.75
-        do 11 i=3,37
-        ef(i)=ef(i-1)+2.5
-11	continue
-
-        do 2 i=1,37
-        ef(i)=ef(i)*1e-2
-2	continue
-
-        qe=1.6e-19
-        ne=-30e+6
-        epso=1e-9/(36*pi)
-
-        d=1.257
-        e=0.4
-        f=-1.1
-
-*  iteration sur z
- 
-        do 1 h=1,nz
-        nua=nud(h,1)      
-
-*  iteration sur les rayons
-
-         do 1 b=1,nrad
-
-        knb=knu(h,b,1)
-        vb=vitesse(h,b,1)
-
-           do 1 x=1,b
-
-        knx=knu(h,x,1)
-        vx=vitesse(h,x,1)
-
-
-
-**  COAGULATION  ****************************************************
-** --------------****************************************************
-* calcul du terme correcteur 'slip-flow'
-
-        alphab=d+e*exp(f/knb)
-        alphax=d+e*exp(f/knx)
-
-* calcul du coefficient de diffusion
-
-        rfb=(rayon(b)**(3./df(b)))*((rf(b))**(1.-3./df(b)))
-        rfx=(rayon(x)**(3./df(x)))*((rf(x))**(1.-3./df(x)))
-        db=kbz*t(h)*(1+alphab*knb)/(6*pi*nua*rfb)
-        dx=kbz*t(h)*(1+alphax*knx)/(6*pi*nua*rfx)
-
-* calcul du coefficient de coagulation
-
-
-        rpr=rfb+rfx
-        kcg=4*pi*rpr*(db+dx)
-
-* calcul de la vitesse thermique
-
-        gx=sqrt(6*kbz*t(h)/(rhol*pi**2*rayon(x)**3))
-        gb=sqrt(6*kbz*t(h)/(rhol*pi**2*rayon(b)**3))
-
-* calcul du libre parcours apparent des aerosols
-
-        lambb=8*db/(pi*gb)
-        lambx=8*dx/(pi*gx)
-
-*calcul du terme correcteur beta
-
-        rm=rpr/2.
-        dm=(dx+db)/2.
-        g=sqrt(gx**2+gb**2)
-        deltab=(((2*rfb+lambb)**3-(4*rfb**2+lambb**2)**1.5)
-     s  /(6*rfb*lambb)-2*rfb)*sqrt(2.)
-        deltax=(((2*rfx+lambx)**3-(4*rfx**2+lambx**2)**1.5)
-     s  /(6*rfx*lambx)-2*rfx)*sqrt(2.)
-        del=sqrt(deltab**2+deltax**2)
-        beta=1/((rm/(rm+del/2))+(4*dm/(g*rm)))
-
-* calcul du coefficient de coagulation corrige
-
-        kcg=kcg*beta
-
-
-
-
-
-**  COALESCENCE  **************************************************
-**  -------------**************************************************
-
-
-        kco=0.
-
-        if ( b.eq. x) goto 9
-
-
-* calcul du nombre de Stockes de la petite particule
-
-        sto=2*rhol*rfx**2*abs(vx-vb)/(9*nua*rfb)
-
-* calcul du coef. de Cunningham-Millikan
-
-        a=1.246
-        bb=0.42
-        dd=0.87
-        l0=0.653e-7
-        p0=101325.
-        t0=288.
-
-        ee=1+(l0*t(h)*p0*(a+bb*exp(-dd*rfx*t0*p(h)/(l0*t(h)*p0))))
-     s    /(rfx*t0*p(h))
-
-* calcul du nombre de Stockes corrige
-
-        sto=sto*ee
-
-        if (sto .le. 1.2) goto 9
-
-        if (sto .ge. 600.) then 
-           ccol=1.
-           goto 8
-        endif
-
-*  recherche du coefficient de collection
-
-        do 3 i=1,37
-          if (sto .gt. st(i)) then
-             goto 3
-          endif
-
-          if (sto .eq. st(i)) then
-                ccol=ef(i+1)
-          else
-                ccol=ef(i)
-          endif
-          goto 8
-3       continue
-
-*  calcul du coefficient de coalescence
-
-8        kco=pi*(rfb+rfx)**2*ccol*abs(vb-vx)
-
-9	continue
-
-**  CORRECTION ELECTRICITE *******************************
-**  ------------------------******************************
-
-
-        yy=1.d0*ne**2*rayon(x)*rayon(b)*qe**2
-     &  /(1.d0*kbz*t(h)*(rayon(b)+rayon(x))*4*pi*epso)
-
-        corovo=1
-        corcoll=1.                    ! efficacite de collage 
-
-        corelec=0.
-        if (yy.lt.50.) corelec=yy/(exp(yy)-1.)
-
-        k(h,b,x)=(kcg+kco)*corelec*corovo*corcoll
-        k(h,x,b)=k(h,b,x)
- 
-
-1	continue
-        return
-        end
-
-*______________________________________________________________________
-
-            real function lambda(j,indic)
-*
-*------------------------------------------------------------------*
-*  fonction calculant le libre parcours moyen des molecules        *
-*  atmospheriques( rayon =ra) se trouvant dans la couche no j.     *
-*  pour indic=0  ...... la particule se trouve a la frontiere entre*
-*                        les couches j et j-1                      *
-*  pour indic=1  ...... la particule se trouve au milieu de la     *
-*                         la couche j                              *
-*------------------------------------------------------------------*
-*
-* declaration des blocs communs
-*------------------------------
-#include "dimensions.h"
-#include "microtab.h"
-
-        common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
-        common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
-        common/grille/z,zb,dz,dzb 
-
-* declaration des variables communes
-* ----------------------------------
-
-cparameter(nz=200,nrad=nqtot)
-        real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz),pb(nz),tb(nz),
-     s     rhob(nz)
-        real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
-        real zb(nz),z(nz),dz(nz),dzb(nz) 
-
-*  declaration des variables internes
-*  ----------------------------------
-
-        integer indic
-        real pp,ra
-
-        ra=1.75e-10
-
-* traitement
-* ----------
-
-        if (indic.eq.0) then
-           pp=pb(j)
-        else
-             if (indic.ne.1) then
-               print*,'erreur argument fonction lambda'
-               return
-             endif
-          pp=p(j)
-        endif
-
-        lambda=kbz*t(j)/(4*sqrt(2.)*pi*(ra**2)*pp)
-        end
-
-*******************************************************************************
-
-            real function knu(j,k,indic)
-*
-*--------------------------------------------------------------*
-*  fonction calculant le nombre de knudsen d'une particule     *
-*  d'aerosol de rayon rayon(k) se trouvant dans la couche no j *
-*  indic ......  idem function lambda                          *
-*--------------------------------------------------------------*
-*
-* declaration des blocs communs
-*------------------------------
-#include "dimensions.h"
-#include "microtab.h"
-
-        common/part/v,rayon,vrat,dr,dv
-
-* declaration des variables communes
-* ----------------------------------
-
-cparameter(nz=200,nrad=nqtot)
-        real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad)
-
-*  declaration des variables internes
-*  ----------------------------------
-
-        integer indic
-        real lambda
-
-* traitement
-* ----------
-
-        if (indic.ne.0 .and.indic.ne.1) then
-               print*,'erreur argument fonction knu'
-               return
-        endif
-
-        rfk=(rayon(k)**(3./df(k)))*((rf(k))**(1.-3./df(k)))
-        knu=lambda(j,indic)/rfk
-        end
-
-*****************************************************************************
-
-             real function nud(j,indic)
-*
-*--------------------------------------------------------------*
-*  fonction calculant la viscosite dynamique (en USI) de l'air *
-*  d'apres la formule de Sutherlant a l'altitude j             *
-*  indic  ......... idem fonction lambda                       *
-*--------------------------------------------------------------*
-*
-#include "dimensions.h"
-#include "microtab.h"
-        integer indic
-cparameter (nz=200)
-        real nud0,c,tt
-        real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz),pb(nz),tb(nz),
-     s     rhob(nz)
-        common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
-*
-        nud0=1.74e-5
-        c=109.
-
-        if(indic.ne.0.and.indic.ne.1) then
-           print*,'erreur argument fonction nud'
-           return
-        endif
-
-        if(indic.eq.0) tt=tb(j)
-        if (indic.eq.1) tt=t(j)
-
-        nud=nud0*sqrt(tt/293)*(1+c/293)/(1+c/tt)
-        end
-
-****************************************************************************
-
-            real function vitesse(j,k,indic)
-*
-*-----------------------------------------------------------------*
-*  fonction calculant la vitesse de chute d'une particule de rayon*
-*  k se trouvant a l'altitude j  suivant la valeur du nombre de   *
-*   Knudsen                                                       *
-*  indic ....... idem function lambda                             *
-*-----------------------------------------------------------------*
-*
-
-* declaration des blocs communs
-*------------------------------
-#include "dimensions.h"
-#include "microtab.h"
-
-        common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
-        common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
-        common/grille/z,zb,dz,dzb 
-        common/part/v,rayon,vrat,dr,dv
-
-* declaration des variables communes
-* ----------------------------------
-
-cparameter(nz=200,nrad=nqtot)
-        real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz)
-     s  ,pb(nz),tb(nz),rhob(nz)
-        real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
-        real zb(nz),z(nz),dz(nz),dzb(nz) 
-        real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad)
-
-*  declaration des variables internes
-*  ----------------------------------
-
-        integer indic
-        real w,g,m,a0,zz,knu,nud,knud,tt,rhoh
-
-*  traitement
-*  ----------
-
-        if (indic.ne.0.and.indic.ne.1) then
-            print*,'erreur argument fonction vitesse'
-            return
-        endif
-
-        if(indic.eq.0) then
-            zz=z(j)+dz(j)/2.
-            tt=tb(j)
-            rhoh=rhob(j)
-        endif
-        if(indic.eq.1) then
-           zz=z(j)
-           tt=t(j)
-           rhoh=rho(j)
-        endif
-
-        g=g0*(rtit/(rtit+zz))**2
-        a0=0.74
-        m=(ach4(j)*mch4+aar(j)*mar+an2(j)*mn2)/nav
-        knud=knu(j,k,indic)
-
-
-        akncx=aknc
-        if(df(k).gt.2.5) akncx=2.7
-
-        if(knud.ge.akncx) then
-
-        rbis=(rayon(k)**(3.-6./df(k)))*((rf(k))**(-2.+6./df(k)))
-          w=a0*g*rbis*rhol/(rhoh*sqrt(8*kbz*tt/(pi*m)))
-        endif
-
-        if(knud.lt.akncx) then
-
-        rfk=(rayon(k)**(3./df(k)))*((rf(k))**(1.-3./df(k)))
-          w=2./9.*rfk**(df(k)-1.)*rf(k)**(3.-df(k))*g*rhol/nud(j,indic)
-
-           if(knud.gt.0.01)  w=w*(1+knud)
-        endif
-
-c       if (p(j).lt.500..and.k.eq.nrad) then
-c          w=0.
-c       endif
-
-
-
-        vitesse=w
-        end
-***********************************************************************
-        
-              real function kd(h)
-*
-*--------------------------------------------------------------------*
-*  cette fonction calcule le coefficient du terme de 'eddy diffusion'*
-*  a l'altitude j						     *
-*--------------------------------------------------------------------*
-*
-
-#include "dimensions.h"
-#include "microtab.h"
-	common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
-	common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
-	common/grille/z,zb,dz,dzb 
-
-
-cparameter(nz=200,nrad=nqtot)
-	real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz),pb(nz),tb(nz),
-     s   rhob(nz)
-	real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
-	real zb(nz),z(nz),dz(nz),dzb(nz) 
-
-        integer h
-
-	 zbx=z(h)+dz(h)/2.
-	if(zbx.le.42000.) then
-              kd=4.
-              kd=1.64e+12*(pb(h)/(kbz*tb(h)))**(-1./2.)
-        else
-c             kd=1.e+15*(pb(h)/(kbz*tb(h)))**(-2./3.)
-              kd=1.64e+12*(pb(h)/(kbz*tb(h)))**(-1./2.)
-	endif
-
-         kd=0.0*kd
-
-	return
-	end
-
-
-*____________________________________________________________________________
-
-	   subroutine init
-*
-*--------------------------------------------------------------------*
-*  cette routine effectue  :                                         *
-*		1) interpolation a partir des donnees initiales des  *
-*                   valeurs de p,t,rho,ach4,aar,an2  sur la grille   *
-*               2) initialisation des constantes (common/phys/)      *
-*	        3) initialisation des variables temporelles (common  *
-*                    /temps/)                                        *
-*               4) definition des grilles en rayon et verticale      *
-*               5)  initialisation de c(z,r,t) avec les donnees du   *
-*                     fichier unit=1                                 *
-*                                                                    *
-*  les donnees sont des valeurs caracterisques de l'atmosphere de    *
-*    TITAN  ( voir Lelouch and co )                                  *
-*--------------------------------------------------------------------*
-
-* declaration des blocs communs
-*------------------------------
-#include "dimensions.h"
-#include "microtab.h"
-
-	common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
-        common/ini/z1,zb1,c0  
-	common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
-	common/grille/z,zb,dz,dzb 
-	common/ctps/li,lf,tt,dt
-        common/con/c
-	common/part/v,rayon,vrat,dr,dv
-
-* declaration des variables communes
-* ----------------------------------
-
-cparameter(nz=200,nrad=nqtot)
-	integer li,lf
-	real dt,tt
-	real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz),pb(nz),tb(nz),
-     s   rhob(nz)
-	real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
-	real zb(nz),z(nz),dz(nz),dzb(nz)  
-	real c(nz,nrad,2),c0(nz,nrad) 
-        real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad)
-
-* declaration des variables internes
-* ----------------------------------
-	
-	integer nzd
-	parameter (nzd=254)
-	integer limsup,liminf,j1,j2
-	real zd(nzd),ach4d(nzd),rap
-        real m	
-
-
-* initialisation des constantes physiques
-* ---------------------------------------
-
-	pi=4.*atan(1.)
-	nav=6.022e+23
-	rgp=8.3143
-	kbz=rgp/nav
-	rtit=2.8e+6
-	g0=1.35
-	mch4=16.043e-3
-	mar=36.4e-3
-	mn2=28.016e-3
-	rhol=1e+3
-
-
-* initialisation des variables temporelles
-* ----------------------------------------
-
-	li=1
-	lf=2
-
-  
-
-
-
-* interpolation de xch4,xar et xn2 sur la grille
-* ----------------------------------------------
-
-* donnees initiales (Lellouch et al,87) 
-* ------------------------------------- 
-
-c       print*,'****** init'
-	do 1 i=1,168
-	  zd(i)=(1000.-5*(i-1))*1000.
-1	continue
-	do 2 i=1,78
-	  zd(168+i)=(160.-2*(i-1))*1000.
-2	continue
-	do 3 i=1,4
-	  zd(246+i)=(5.-(i-1))*1000.
-3	continue
-	do 4 i=1,4
-	  zd(250+i)=(1.5-(i-1)*0.5)*1000.
-4	continue
-
-	data (ach4d(i),i=1,168)/168*1.5e-2/
-	data (ach4d(i),i=169,254)/63*1.5e-2,1.6e-2,1.8e-2,1.8e-2,
-     1  1.9e-2,2.e-2,2.1e-2,2.3e-2,2.5e-2,2.8e-2,3.1e-2,3.6e-2,
-     2  4.1e-2,4.7e-2,5.7e-2,6.7e-2,7.5e-2,7*8.e-2/
-
-	liminf=0
-	limsup=0
-
-* interpolation des taux de melange de ch4,ar,n2  
-*-----------------------------------------------  
-
-	do 20 j1=1,nz
-	   do 21 j2=1,nzd
-              if( zd(j2).le.z(j1)) goto 22
-21	   continue
-22            liminf=j2
-	  if (zd(liminf).eq.z(j1) )then
-	    ach4(j1)=ach4d(liminf)
-	    goto20
-	  endif
-	      if (j2.ne.1) then
-	         limsup=j2-1
-	      else
-	         limsup=j2
-	      endif
-
-	  if (limsup.eq.liminf) then
-	    ach4(j1)=ach4(limsup)
-	  else
-	    ach4(j1)=ach4d(liminf)-(ach4d(limsup)-ach4d(liminf))/
-     s       (zd(limsup)-zd(liminf))*(zd(liminf)-z(j1))
-	  endif
-20	continue
-
-*  rap= aar/an2  cst sur l'altitude
-
-	rap=0.191
-	do 23 i=1,nz
-	  an2(i)=(1.-ach4(i))/(1.+rap)
-	  aar(i)=rap*an2(i)
-23	continue
-
-	do 24 i=1,nz
-	  m=ach4(i)*mch4+an2(i)*mn2+aar(i)*mar
-	  rho(i)=p(i)*m/(rgp*t(i))
-24	continue
-
-	do 34 i=1,nz
-	  m=ach4(i)*mch4+an2(i)*mn2+aar(i)*mar
-	  rhob(i)=pb(i)*m/(rgp*tb(i))
-c         print*,pb(i),m,rgp,tb(i),rhob(i),rho(i)
-34	continue
-
-* fin d'interpolation des taux de melange
-*---------------------------------------- 
-
-c       print*,'**** fin init'
-540     continue
-	return
-
-500      print*,'erreur lecture initialisation de c...erreur=',ii
-	 stop
-
-	end
-
-*____________________________________________________________________________
-
-	 subroutine pertpro(h,a,l_,pr_)
-
-*****************************************************************************
-*                                                                          *
-* ce programme permet le calcul du terme de production (pr) et de perte (l)*
-* pour le phenomene de coagulation                                         *
-* dans le a ieme intervalle de rayon a une altitude h                      *
-****************************************************************************
-
-
-
-* declaration des blocs communs
-*------------------------------
-#include "dimensions.h"
-#include "microtab.h"
-
-	common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
-	common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
-	common/grille/z,zb,dz,dzb 
-	common/ctps/li,lf,tt,dt
-        common/con/c
-	common/part/v,rayon,vrat,dr,dv
-	common/coag/k
-
-* declaration des variables
-* --------------------------
-
-	integer li,lf
-	real tt,dt
-cparameter(nz=200,nrad=nqtot)
-	real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz),pi,nav
-	real pb(nz),tb(nz),rhob(nz)
-	real rgp,kbz,rtit,g0,mch4,mar,mn2,rhol,dz(nz)
-	real vrat,dr(nrad),dv(nrad)
-	real c(nz,nrad,2),v(nrad),rayon(nrad),z(nz),k(nz,nrad,nrad)
-        real dzb(nz),zb(nz) 
-
-* declaration des variables propres au ss-programme
-* -------------------------------------------------
-
-	integer h,b,a,x
-	real*8 pr,ss,s,l
-	real pr_,l_,vol,del
-
-* traitement
-* -----------
-
-*  production
-*+++++++++++++
-	s=0.d0
-	ss=0.d0
-	pr=0.
-
-	if (a .eq. 1) goto 2
-	  
-	  b=a-1
-
-	if (c(h,b,lf) .eq. 0 .and. c(h,b,li) .eq. 0) goto 2
- 
-        do 1 i=1,b
-
-	 if(c(h,i,li) .eq. 0 .and. c(h,i,lf) .eq. 0) goto 1
-	  
-	    if (i .ne. b)del=1.
-	    if (i .eq. b) del=.5
-
-	   s=(v(i)*1.d0)*del*(k(h,b,i)*1.d0)*(c(h,i,li)*1.d0)+s
-	   ss=(v(i)*1.d0)*del*(k(h,b,i)*1.d0)*(c(h,i,lf)*1.d0)+ss
-c       if (a.eq.2) print*,'SS>',v(i),k(h,b,i),c(h,b,lf)
-c       if (a.eq.2) print*,'SS>',del*v(i)*k(h,b,i)*c(h,b,lf)
-
-
-1	 continue
-
-*  calcul du terme de production
-
-	  pr=(c(h,b,lf)*s/(vrat-1.)+c(h,b,li)*ss)/v(a)
-c        if (a.eq.2) print*,'PR>',s,ss,c(h,b,lf),v(a)
-
-2        continue
-
-
-*  perte
-*- - - - -
-
-	l=0
-
-
-*    condition limite : pas de perte dans le dernier intervalle
-
-	if (a .eq. nrad) goto 9
-
-	do 10 x=1,nrad
-
-	  if (c(h,x,li) .eq. 0) goto 10
-
-	  if (a .lt. x) vol=1.
-	  if (a .eq. x) vol=.5*vrat/(vrat-1)
-	  if (a .gt. x) vol=v(x)/(v(a)*(vrat-1))
-
-	  l=l+k(h,a,x)*c(h,x,li)*vol*1.d0
-
-	    
-10	continue
-9       continue
-
-#ifdef CRAY
-        l_=l
-        pr_=pr
-#else
-        l_=sngl(l)
-        pr_=sngl(pr)
-#endif
-c       l_=sngl(l)
-c       pr_=sngl(pr)
-c         if (a.eq.2) print*,'pr_,l_',h,a,pr_,l_
-c         if (a.eq.2) print*,'-----------------------'
-
-
-
-	return
-
-	end
-
-*_____________________________________________________________________________
-
-	   subroutine production(ihor)
-*
-*--------------------------------------------------------------------*
-*  routine calculant le terme de production des molecules organiques *
-*  composant les aerosols . rini= rayon des aerosols initiaux        *
-*--------------------------------------------------------------------*
-*
-#include "dimensions.h"
-#include "microtab.h"
-#include "clesphys.h"
-
-
-	integer ndz
-cparameter (nrad=nqtot,nz=200,nztop=135)
-	real zb(nz),z(nz),dz(nz),dzb(nz) 
-	real c(nz,nrad,2)
-	real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad)
-	integer li,lf
-	real tt,dt
-        real fonction,fonction1,fonction2,fonction3,fonction4
-        real xlargeur1,xlargeur2,xlargeur3,xlargeur4,xlargeur5
-	real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
-	real zalt0,zy,c0,ctot,prod,rini,rfron
-	real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz)
-     &  ,pb(nz),tb(nz),rhob(nz)
-	common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
-	common /grille/ z,zb,dz,dzb 
-	common/ctps/li,lf,tt,dt
-	common /con/c
-	common/part/v,rayon,vrat,dr,dv
-	common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
-
-        common/effets/ xsaison
-
-         
-         
-
-c        p0=0.3
-         p0=1.
-         do i=1,nz-1
-          if (pb(i).lt.p0.and.pb(i+1).gt.p0) zalt0=(z(i)+z(i+1))/2.
-         enddo
-	
-	ctot=3.5e-13*tx ! ATTENTION, ??COHERENT AVEC INITPAR??
-        ctot=ctot*xsaison  ! 
-
-c       zalt0=385.e+3
-	zy=20.e+3
-	rini=1.3e-9
-	rini=rayon(1)   
-	ndz=50
-*
-	do 10 i=1,nrad 
-	   if(rini.lt.rayon(i)) goto 100
-10	continue
-100	continue
-	if (i.eq.1) then
-	  rini=rayon(1)
-	else
-	  rfron=(rayon(i)+rayon(i-1))/2
-	  if (rini .lt.rfron) then 
-                rini=rayon(i-1)
-	       i=i-1
-	  else
-	        rini=rayon(i)
-          endif
-	endif
-*
-	 c0=ctot/(sqrt(2.*pi)*zy)
-         c0=c0*3./(4.*pi*rhol*rini**3)
-*
-	do 20 k=nztop,nz
-c        zmid=(zb(k)+zb(k+1))/2.
-	 prod=0.
-        do 201 k1=1,ndz
-       prod=prod+c0*exp(-0.5*(((z(k)+dz(k)/2.-k1*dz(k)/(2.*ndz)
-     s -zalt0)/zy)**2))*dt/ndz
-201     continue
-
-	    if (prod .le. 1) prod=0.
-	    c(k,i,lf)=c(k,i,lf)+prod
-20	continue
-
-
-	return
-	end
-
-*-------------------------------------------------------------------*
-
-
-	   subroutine nuages
-*
-*--------------------------------------------------------------------  *
-* Cete routine transforme les aerosols fractals (i=1..9) en particules *
-* spheriques (i=nrad) lors du passage en dessous de la pression de     *
-* condensation (P=42 Pa) avec une constante de temps de                *
-* de 10 jours-Titan                                                    *
-*--------------------------------------------------------------------  *
-*
-#include "dimensions.h"
-#include "microtab.h"
-
-
-	integer ndz
-cparameter (nrad=nqtot,nz=200,nztop=135)
-	real zb(nz),z(nz),dz(nz),dzb(nz) 
-	real c(nz,nrad,2)
-	real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad)
-	integer li,lf
-	real tt,dt
-	real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
-	real zalt0,zy,c0,ctot,prod,rini,rfron
-	real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz)
-     &  ,pb(nz),tb(nz),rhob(nz)
-	common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
-	common /grille/ z,zb,dz,dzb 
-	common/ctps/li,lf,tt,dt
-	common /con/c
-	common/part/v,rayon,vrat,dr,dv
-	common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
-        common/effets/ xsaison
-
-          xnuage=0.01
-
-        P_0=900.
-        P_0=3162.
-
-	do 20 k=nztop,nz
-
-c transfert i={1...9} vers i=10 au dessous de P_0.
-
-         if (p(k).gt.P_0) then 
-          do 10 i=1,nrad-1
-            c(k,nrad,lf)=c(k,nrad,lf)+c(k,i,lf)*xnuage
-     &               *(1.-exp(-dt/1.3824e+06/10.))
-	    c(k,i,lf)=c(k,i,lf)*exp(-dt/1.3824e+06/10.)
- 10       continue
-         endif
-
-c transfert i=10 vers i=5 au dessus de P_0 Pascals
-
-         if (p(k).le.P_0) then 
-            c(k,5,lf)=c(k,5,lf)+c(k,nrad,lf)
-     &               *(1.-exp(-dt/1.3824e+06/30.))
-         c(k,nrad,lf)=c(k,nrad,lf)*exp(-dt/1.3824e+06/30.)
-         endif
-
- 20     continue
-
-	return
-	end
-
-
-*__________________________________________________________________________
-
-	   subroutine sedif
-*
-*------------------------------------------------------------------*
-*  cette routine calcule l'evolution de la fonction de distribution*
-*  c(z,r,t) pour les phenomenes de sedimentation et de diffusion   *
-*------------------------------------------------------------------*
-*
-*
-* declaration des blocs communs
-*------------------------------
-#include "dimensions.h"
-#include "microtab.h"
-
-	common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
-	common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
-	common/grille/z,zb,dz,dzb 
-	common/ctps/li,lf,tt,dt
-        common/con/c
-	common/part/v,rayon,vrat,dr,dv
-
-* declaration des variables communes
-* ----------------------------------
-
-cparameter(nz=200,nrad=nqtot,nztop=135)
-	integer li,lf
-	real tt,dt
-	real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz)
-	real pb(nz),tb(nz),rhob(nz)
-	real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
-	real zb(nz),z(nz),dz(nz),dzb(nz) 
-	real c(nz,nrad,2)
-        real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad)
-
-* declaration des variables internes
-* ----------------------------------
-
-	real w,w1,dzbX,dc
-	double precision sigma,theta,hc,l,rap,cmp,wp 
-	double precision fs(nz+1),ft(nz+1)
-	real as(nz),bs(nz),cs(nz),ds(nz)
-	double precision asi(nztop:nz),bsi(nztop:nz),csi(nztop:nz)
-        double precision dsi(nztop:nz),xsol(nztop:nz)
-	real vitesse,kd
-
-        external dtridgl
-* resolution
-*------------
-
-c        print*,'ECHANTILLON.SEDIF.li'
-c        print*,c(100,1,li),c(100,3,lf),c(100,5,lf)
-c        print*,c(10,1,li),c(50,3,lf),c(50,5,lf)
-c        print*,c(10,1,li),c(10,3,lf),c(10,5,lf)
-
-           do 10 k=1,nrad  
-	   do 20 j=nztop,nz
-
-	    if (j.eq.1) goto 20
-
-* calcul de la vitesse corrigee
-
-	     dzbX=(dz(j)+dz(j-1))/2.
-	     w=-1*vitesse(j,k,0)
-	       if (kd(j).ne.0.) then
-	         theta=0.5*(w*dzbX/kd(j)+log(rho(j-1)/rho(j)))
-	            if (theta.ne.0) then
-	               sigma=1./dtanh(theta)-1./theta
-	            else
-	               sigma=1.
-	            endif
-	       else
-	         sigma=1.
-	       endif
-	       if(c(j,k,li).eq.0.) then
-	         rap=10.
-	       else
-	         rap=c(j-1,k,li)/c(j,k,li)
-	          if( rap.gt.10.) rap=10.
-	          if( rap.lt.0.1) rap=0.1
-	       endif
-	       if (rap.gt.0.9 .and. rap.lt.1.1) then
-	          w1=w
-	       else
-	          if(w.ne.0) then
-	              hc=dzbX/dlog(rap)
-	              l=dzbX/(w*dt)*(dexp(-w*dt/hc)-1.)/(1.-rap)
-                      wp=w*1.d0
-                      cmp=dlog(-wp)+abs(sigma)*dlog(l)
-                      if (cmp.gt.38) then
-                               goto 20
-                      endif
-                      w1=-dexp(cmp)
-
-	          else
-                      w1=0.
-	          endif
-	       endif
-
-*  calcul des flux aux interfaces
-
-
-	  if (kd(j).ne.0.) then
-              if (theta.ne.0.) then
-	        ft(j)=(w1+log(rho(j-1)/rho(j))*kd(j)/dzbX)/(dexp(2.*
-     s           theta)-1.)
-                fs(j)=ft(j)*dexp(2.*theta)
-	      else
-	        ft(j)=kd(j)/dzbX
-	        fs(j)=kd(j)/dzbX
-              endif
-	 else
-	   if (w1.lt.0.)then
-	     ft(j)=-w1
-	     fs(j)=0.
-	   else
-	     ft(j)=0.
-	     fs(j)=w1
-	   endif
-	endif
-
-20	   continue
-
-* conditions aux limites pour les flux aux interfaces
-
-	   fs(1)=0.
-	   ft(1)=0.
-	   fs(nz+1)=0.
-	   ft(nz+1)=-w1
-
-* calcul des coefficients de l'equation discrete
-
-	   do 21 j=nztop,nz
-	     as(j)=-dz(j)/dt
-	     bs(j)=-ft(j)
-	     cs(j)=ft(j+1)+fs(j)-dz(j)/dt
-	     ds(j)=-fs(j+1)
-
-	         if ( cs(j).gt.0) goto100
-21        continue
-
-* cas explicite (mu=0) : calcul de la fonction c(z,r,t+1)
-
-	  do 22 j=nztop,nz-1
-
-	   if (j.eq.nztop) then
-	     dc=(cs(nztop)*c(nztop,k,li)+ds(nztop)
-     &                    *c(nztop+1,k,li))/as(nztop)
-	     c(nztop,k,lf)=dc
-
-
-	     goto 22
-	   endif
-
-	      dc=(bs(j)*c(j-1,k,li)+cs(j)*c(j,k,li)+ds(j)*c(j+1,k,li))
-     s        /as(j)
-	     c(j,k,lf)=dc
-
-
-22	  continue
-
-	     dc=(bs(nz)*c(nz-1,k,li)+cs(nz)*c(nz,k,li))/as(nz)
-	     c(nz,k,lf)=dc
-
-
-	  if (nztop.ne.1) then
-	  do 32 j=1,nztop-1
-	    c(j,k,lf)=c(j,k,li)
-32	  continue
-	  endif
-
-	goto 10
-
-100      continue
-
-* cas implicite (mu=1) : calcul de la fonction c(z,r,t+1)
-
-	 do 101 j=nztop,nz
-	    asi(j)=ft(j)
-	    bsi(j)=-(ft(j+1)+fs(j)+dz(j)/dt)
-	    csi(j)=fs(j+1)
-	    dsi(j)=-dz(j)/dt*c(j,k,li)
-101	 continue
-
-* inversion de la matrice tridiagonale 
-
-	nb=nz-nztop+1
-
-        call dtridgl(nb,asi,bsi,csi,dsi,xsol) 
-
-
-        do 102 j=nztop,nz
-         c(j,k,lf)=xsol(j)
-102     continue
-
-	if (nztop.ne.1) then
-	  do 110 j=1,nztop-1
-	   c(j,k,lf)=c(j,k,li)
-110	  continue
-	 endif
-
-
-
-10	continue
-
-        return
-
-	end
-
Index: trunk/LMDZ.TITAN/libf/phytitan/pg3.old
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/pg3.old	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/pg3.old	(revision 175)
@@ -0,0 +1,1530 @@
+        subroutine pg3(tab1,tab2,tab3,tab4,tab5,tab6,tab7,
+     &  x1,x2,x3,x4,xnztop,ihor,xmu0,xfract)
+
+c     call pg3(dz,dzb,tb,t,pb,p,c,z1,zb1,ptimestep,ddt
+c    & ,nzhau,ihor)
+
+
+*1  dz, pas d'altitude pour les milieux de couches
+*2  dzb, pas d'altitude pour les limites superieures de couches
+*34 tb,t temperature a la limite superieure des couches et 
+*4         au milieu des couches  
+*56 pb,p pression a la limite superieure des couches et 
+*6         au milieu des couches  
+*7  c nombre de particules de la grille de rayon r a l'altitude z 
+*1  z1, altitude du milieu de la couche superieure de l'atmosphere. 
+*2  zb1, altitude de la limite superieure de la couche superieure
+*          de l'atmosphere
+*3  tmax, duree , en jour, de l'execution
+*4  dt, pas de temps, en heure.  
+
+*--------------------------------------------------------------*
+*                                                              *
+*            ENTRE 0 ET 1000 KILOMETRES                        *     
+*                                                              * 
+*    la dimension fractale est en tableau, attention au        *
+*    raccordement entre le regime moleculaire et le regime     *
+*    fluide                                                    *
+*                                                              *
+*    Modele microphysique:    Cabane et al.,1992 /             *
+*    Modele version fractale: Cabane et al.,1993 /             *
+*                                                              *
+*--------------------------------------------------------------*
+* VERSION DU 2 JUIN 1993  --- AUT 1994 --- 11/04/96
+*
+* changer: altitude de production zalt0=/taux de production ctot= 
+*        : la charge/micron, ne
+*        : df(h),rf... 
+* raccordement aknc 
+*
+* declaration des blocs communs
+*------------------------------
+
+#include "dimensions.h"
+#include "microtab.h"
+#include "clesphys.h"
+
+	common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
+        common/ini/z1,zb1,c0  
+	common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
+	common/grille/z,zb,dz,dzb 
+	common/ctps/li,lf,tt,dt
+        common/con/c
+	common/part/v,rayon,vrat,dr,dv
+	common/coag/k
+        common/effets/ xsaison
+
+ 
+* declaration des variables communes
+* ----------------------------------
+
+	integer xnztop
+	integer li,lf
+	real dt,tt
+	real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz)
+     &  ,pb(nz),tb(nz),rhob(nz)
+	real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
+	real zb(nz),z(nz),dz(nz),dzb(nz) 
+	real c0(nz,nrad),c(nz,nrad,2)
+        real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad)
+	real k(nz,nrad,nrad),knu
+        real xmu0,xfract
+        
+
+*  variables internes
+*  ------------------
+
+	integer h,ti,tmax,itime
+        real tab1(nz),tab2(nz+1),tab3(nz+1),tab4(nz)
+        real tab5(nz+1),tab6(nz),tab7(nz,nrad)
+        real x1,x2,x3,x4 
+        real knd1,knd2,knd3,knd4,knd5,knd6
+
+       save itime
+       data itime/0/
+* initialisation
+* --------------
+
+c      print*,'Df aerosols /1 a nqtot/'
+c       write(*,*) (df(h),h=1,nrad)
+c       write(*,*) (rayon(h),h=1,nrad)
+c       write(*,*) (dr(h),h=1,nrad)
+c       write(*,*) (v(h),h=1,nrad)
+c       write(*,*) (dv(h),h=1,nrad)
+c       print*,vrat,rf,aknc
+
+* effet saisonnier
+* ----------------
+
+
+         xsaison=0.
+         xsaison=xmu0*4.*xfract  
+                              !=Pi si fract=1/2 (equinoxe) et 
+                              !    si mu0=1 sous le soleil
+                              !    exactement.
+
+c        xsaison=0.
+c        if (ihor.le.9.or.ihor.ge.41) xsaison=8.  ! rapport des surfaces
+c        xsaison=1.
+
+* controles
+* ---------
+
+        do i=1,nz	
+         dz(i)=tab1(i)
+         dzb(i)=tab2(i)
+         tb(i)=tab3(i) 
+         t(i)=tab4(i) 
+         pb(i)=tab5(i)  		
+         p(i)=tab6(i) 
+          do j=1,nrad 
+            c(i,j,1)=tab7(i,j)
+            c(i,j,2)=0.0 
+          enddo 
+        enddo 
+        z1=x1
+        zb1=x2
+        tmax=int(x3/x4)/2       ! 2. * tmax iterations 
+        dt=x4                    !  
+       
+
+        z(1)=z1  
+        zb(1)=zb1 
+ 
+	do 12 i=2,nz
+	  z(i)=z(i-1)-dz(i-1)
+	  zb(i)=zb(i-1)-dzb(i-1)
+12	continue
+
+c        print*, tmax,dt,z1,zb1
+c       do i=1,nz
+c        print*,i,z(i),p(i),t(i),zb(i),pb(i),tb(i),c(i,1,1)
+c       enddo
+ 
+c       stop 'profile'
+
+       if (itime.eq.0) then 
+
+        ITIME=1
+c        print*,'avant init'
+         call init
+c        print*,'apres init'
+c        print*,'avant calcoag'
+         call calcoag
+c        print*,'apres calcoag'
+
+c        print*,'***** TEST COAGULATION ********'
+c       do h=1,nz,20
+c        do i=1,3
+c         print*,'KOAG',h,i,k(h,1,i),k(h,2,i),k(h,3,i)
+c        enddo
+c       enddo
+
+       endif
+
+
+* iteration du modele sur le temps
+* ---------------------------------
+c      print*,'##############################################'
+c         print*,'debut microphysique'
+c       print*,'Df aerosols /1 a 6/'
+c       write(*,*) (df(h),h=1,6)
+c         call ecran(tt) 
+c
+c      print*,'CHECK BEFORE COMPUTATION'
+c      print*,'nrad=',nrad,' nqtot=',nqtot,' ctrl...'
+c      print*,'##############################################'
+c      print*,'1.0 - tableaux de bases:'
+c      print*,'i	rayon(i)	'
+c       do i=1,nrad
+c        print*,i,rayon(i)
+c       enddo
+c      print*,'temps appel	pas de temps:'
+c      print*,tmax, dt 
+c      print*,'##############################################'
+c      print*,'1.1 - Avec l altitude: '
+c      print*,' i       v1  v3 v5 v6 '
+c      print*, 'i	z(i)	c(i,1,1)	c(i,4,1)	c(i,6,1)'
+c      print*,'***	dz(i)	dzb(i)'
+c      print*,'***	pb(i)	p(i)	t(i)	tb(i)'
+c
+c      if(ihor.eq.25.or.IHOR.EQ.1.) THEN 
+c       do i=1,nz,1
+c         print*,i,z(i),c(i,1,1),c(i,4,1),c(i,6,1)
+c         print*,'pbpttb',pb(i),p(i),t(i),tb(i)
+c            v1=vitesse(i,7,0)
+c            v2=vitesse(i,8,0)
+c            v3=vitesse(i,9,0)
+c            v4=vitesse(i,10,0)
+c            print*,ihor,z(i),v1,v2,v3,v4
+c      enddo
+c      endif
+c      if(ihor.eq.25) STOP
+c
+c       if (ihor.eq.25.or.ihor.eq.48.or.ihor.eq.1) then
+c      print*,'##############################################'
+c       print*,'ihor=',ihor
+c       do i=1,nz,1
+c             knd1=knu(i,5,1)
+c             knd2=knu(i,6,1)
+c             knd3=knu(i,7,1)
+c             knd4=knu(i,8,1)
+c             knd5=knu(i,9,1)
+c             knd6=knu(i,10,1)
+c         print*,i,z(i),knd2,knd4,knd6
+c      enddo
+c 
+c      if(ihor.eq.49) STOP
+c
+c      endif
+c
+c      print*,'1.2 - Avec les rayons:'
+c      print*,'h	i	j	k(h,i,j)'
+c        do j=1,nqtot
+c         print*,h,i,j,k(h,i,j)
+c      enddo
+c      print*,'##############################################'
+c       stop 'end check'
+
+
+c       somme=0.
+c       do i=1,nz
+c        do j=1,nrad
+c         somme=somme+c(i,j,1)*dzb(i)*4.1888*rayon(j)**3.
+c        enddo
+c       enddo
+ 
+c       print*,'bilan interne: ',somme,'  volume/m^2'
+
+
+					    ! 1,tmax,2*dt : 
+	do 10 ti=1,tmax                     ! a chaque passage, deux pas
+					    ! de temps sont franchis.... 
+*  1ere iteration
+
+           tt=tt+dt
+
+            call coagul
+
+            call production(ihor)
+
+c           call nuages
+
+	   li=3-li
+	   lf=3-lf
+
+            call sedif
+
+
+
+
+*  2ieme iteration
+
+	tt=tt+dt
+
+	li=3-li
+	lf=3-lf
+
+
+        call sedif
+
+	li=3-li
+	lf=3-lf
+
+        call coagul
+
+        call production(ihor)
+
+c       call nuages
+
+	    li=3-li
+	    lf=3-lf
+
+
+
+10	continue
+
+379      continue
+
+          do i=1,nz
+           do j=1,nrad
+              tab7(i,j)=c(i,j,li)     ! li=1
+           enddo
+          enddo 
+         
+c        total=0. 
+c         do i=1,nz
+c          do j=1,nrad
+c             total=total+tab7(i,j)*dzb(j)*rayon(j)**3.
+c    &        *(1.333333*3.1415926)*1000.
+c          enddo
+c         enddo 
+c          print*,'bilan colonne kg/m^2:',total
+
+
+777      return  
+
+         end 
+*________________________________________________________________________ 
+                     subroutine ecran(tt)
+
+#include "dimensions.h"
+#include "microtab.h"
+cparameter(nz=200,nrad=nqtot,nztop=135)
+        common/con/c
+        real c(nz,nrad,2)
+          print*,'--------------------'
+          print*,'ecriture micro:'
+         do i=140,200,20
+         print*, c(i,1,1),c(i,4,1),c(i,6,1)
+         enddo
+
+        return
+        end
+
+
+
+
+                    subroutine coagul
+
+
+*********************************************************
+* ce programme calcule la nouvelle concentration dans   *
+* le a ieme intervalle de rayon, a l'altitude h, a      *
+* l'instant t+dt                                        *
+*********************************************************
+
+#include "dimensions.h"
+#include "microtab.h"
+
+* declaration des blocs communs
+*------------------------------
+
+	common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
+	common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
+	common/grille/z,zb,dz,dzb 
+	common/ctps/li,lf,tt,dt
+        common/con/c
+	common/part/v,rayon,vrat,dr,dv
+
+* declaration des variables
+* --------------------------
+
+	integer li,lf
+	real tt,dt
+cparameter(nz=200,nrad=nqtot,nztop=135)
+	real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz),pi,nav
+	real pb(nz),tb(nz),rhob(nz)
+	real rgp,kbz,rtit,g0,mch4,mar,mn2,rhol,dz(nz)
+	real vrat,dr(nrad),dv(nrad)
+	real c(nz,nrad,2),v(nrad),rayon(nrad),z(nz),zb(nz),dzb(nz) 
+
+* declaration des variables propres au ss-programme
+* -------------------------------------------------
+
+	integer h,a
+	real pr,pe
+
+*  traitement
+*  ----------
+
+
+        do 10 h=nztop,nz
+	   do 11 a=1,nrad
+	       call pertpro(h,a,pe,pr)
+c           if((1+dt*pe).lt.0.) stop 'denom.eq.0'
+            c(h,a,lf)=(c(h,a,li)+pr*dt)/(1+dt*pe)
+	  
+11         continue
+10	continue
+
+	if (nztop.ne.1) then
+	  do 12 h=1,nztop-1
+	     do 12 a=1,nrad
+	       c(h,a,lf)=c(h,a,li)
+12	  continue
+	endif
+
+	return
+	end
+      
+      
+*__________________________________________________________________________
+
+	     subroutine  calcoag
+
+***************************************************************
+*                                                             *
+*  Ce programme calcule les coefficients de collection  d'une *
+* particule de rayon x avec une particule de rayon b a une    *
+* altitude donnee h                                           *
+*************************************************************** 
+
+* declaration des blocs communs
+*------------------------------
+#include "dimensions.h"
+#include "microtab.h"
+
+        common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
+        common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
+        common/grille/z,zb,dz,dzb 
+        common/ctps/li,lf,tt,dt
+        common/con/c
+        common/part/v,rayon,vrat,dr,dv
+        common/coag/k
+
+* declaration des variables
+* --------------------------
+
+        integer li,lf
+        real tt,dt
+cparameter(nz=200,nrad=nqtot)
+        real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz),pi,nav
+        real pb(nz),tb(nz),rhob(nz)
+        real rgp,kbz,rtit,g0,mch4,mar,mn2,rhol,dz(nz)
+        real vrat,dr(nrad),dv(nrad)
+        real c(nz,nrad,2),v(nrad),rayon(nrad),z(nz),zb(nz),dzb(nz) 
+        real knu,nud,k(nz,nrad,nrad)
+
+* declaration des variables propres au ss-programme
+* -------------------------------------------------
+
+        integer h,b,x
+        real nua,lambb,lambx,knb,knx,alphab,alphax,d,e,f,kcg
+        real db,dx,rm,dm,deltab,deltax,del,g,beta,gx,gb
+         real*8 ne,qe,epso
+         real*8 corelec,yy
+
+        real kco,vx,vb,vitesse,sto,ee,a,dd,bb,p0,t0,l0,ccol
+        real st(37),ef(37)
+
+* initialisation
+* --------------
+c        print*,'**** calcoag'
+
+*  -nombres de STOCKES
+
+        data(st(i),i=1,37)/1.35,1.5,1.65,1.85,2.05,2.25,2.5,2.8,3.1,
+     s    3.35,3.6,3.95,4.3,4.7,5.05,5.45,5.9,6.4,7.,7.6,8.3,9.05,9.9,
+     s       10.9,11.1,13.5,15.3,17.25,20.5,24.5,30.4,39.3,48,57,86.,
+     s       187.,600./
+
+*  -coef. d'efficacite de collection
+
+        ef(1)=3.75
+        ef(2)=8.75
+        do 11 i=3,37
+        ef(i)=ef(i-1)+2.5
+11	continue
+
+        do 2 i=1,37
+        ef(i)=ef(i)*1e-2
+2	continue
+
+        qe=1.6e-19
+        ne=-30e+6
+        epso=1e-9/(36*pi)
+
+        d=1.257
+        e=0.4
+        f=-1.1
+
+*  iteration sur z
+ 
+        do 1 h=1,nz
+        nua=nud(h,1)      
+
+*  iteration sur les rayons
+
+         do 1 b=1,nrad
+
+        knb=knu(h,b,1)
+        vb=vitesse(h,b,1)
+
+           do 1 x=1,b
+
+        knx=knu(h,x,1)
+        vx=vitesse(h,x,1)
+
+
+
+**  COAGULATION  ****************************************************
+** --------------****************************************************
+* calcul du terme correcteur 'slip-flow'
+
+        alphab=d+e*exp(f/knb)
+        alphax=d+e*exp(f/knx)
+
+* calcul du coefficient de diffusion
+
+        rfb=(rayon(b)**(3./df(b)))*((rf(b))**(1.-3./df(b)))
+        rfx=(rayon(x)**(3./df(x)))*((rf(x))**(1.-3./df(x)))
+        db=kbz*t(h)*(1+alphab*knb)/(6*pi*nua*rfb)
+        dx=kbz*t(h)*(1+alphax*knx)/(6*pi*nua*rfx)
+
+* calcul du coefficient de coagulation
+
+
+        rpr=rfb+rfx
+        kcg=4*pi*rpr*(db+dx)
+
+* calcul de la vitesse thermique
+
+        gx=sqrt(6*kbz*t(h)/(rhol*pi**2*rayon(x)**3))
+        gb=sqrt(6*kbz*t(h)/(rhol*pi**2*rayon(b)**3))
+
+* calcul du libre parcours apparent des aerosols
+
+        lambb=8*db/(pi*gb)
+        lambx=8*dx/(pi*gx)
+
+*calcul du terme correcteur beta
+
+        rm=rpr/2.
+        dm=(dx+db)/2.
+        g=sqrt(gx**2+gb**2)
+        deltab=(((2*rfb+lambb)**3-(4*rfb**2+lambb**2)**1.5)
+     s  /(6*rfb*lambb)-2*rfb)*sqrt(2.)
+        deltax=(((2*rfx+lambx)**3-(4*rfx**2+lambx**2)**1.5)
+     s  /(6*rfx*lambx)-2*rfx)*sqrt(2.)
+        del=sqrt(deltab**2+deltax**2)
+        beta=1/((rm/(rm+del/2))+(4*dm/(g*rm)))
+
+* calcul du coefficient de coagulation corrige
+
+        kcg=kcg*beta
+
+
+
+
+
+**  COALESCENCE  **************************************************
+**  -------------**************************************************
+
+
+        kco=0.
+
+        if ( b.eq. x) goto 9
+
+
+* calcul du nombre de Stockes de la petite particule
+
+        sto=2*rhol*rfx**2*abs(vx-vb)/(9*nua*rfb)
+
+* calcul du coef. de Cunningham-Millikan
+
+        a=1.246
+        bb=0.42
+        dd=0.87
+        l0=0.653e-7
+        p0=101325.
+        t0=288.
+
+        ee=1+(l0*t(h)*p0*(a+bb*exp(-dd*rfx*t0*p(h)/(l0*t(h)*p0))))
+     s    /(rfx*t0*p(h))
+
+* calcul du nombre de Stockes corrige
+
+        sto=sto*ee
+
+        if (sto .le. 1.2) goto 9
+
+        if (sto .ge. 600.) then 
+           ccol=1.
+           goto 8
+        endif
+
+*  recherche du coefficient de collection
+
+        do 3 i=1,37
+          if (sto .gt. st(i)) then
+             goto 3
+          endif
+
+          if (sto .eq. st(i)) then
+                ccol=ef(i+1)
+          else
+                ccol=ef(i)
+          endif
+          goto 8
+3       continue
+
+*  calcul du coefficient de coalescence
+
+8        kco=pi*(rfb+rfx)**2*ccol*abs(vb-vx)
+
+9	continue
+
+**  CORRECTION ELECTRICITE *******************************
+**  ------------------------******************************
+
+
+        yy=1.d0*ne**2*rayon(x)*rayon(b)*qe**2
+     &  /(1.d0*kbz*t(h)*(rayon(b)+rayon(x))*4*pi*epso)
+
+        corovo=1
+        corcoll=1.                    ! efficacite de collage 
+
+        corelec=0.
+        if (yy.lt.50.) corelec=yy/(exp(yy)-1.)
+
+        k(h,b,x)=(kcg+kco)*corelec*corovo*corcoll
+        k(h,x,b)=k(h,b,x)
+ 
+
+1	continue
+        return
+        end
+
+*______________________________________________________________________
+
+            real function lambda(j,indic)
+*
+*------------------------------------------------------------------*
+*  fonction calculant le libre parcours moyen des molecules        *
+*  atmospheriques( rayon =ra) se trouvant dans la couche no j.     *
+*  pour indic=0  ...... la particule se trouve a la frontiere entre*
+*                        les couches j et j-1                      *
+*  pour indic=1  ...... la particule se trouve au milieu de la     *
+*                         la couche j                              *
+*------------------------------------------------------------------*
+*
+* declaration des blocs communs
+*------------------------------
+#include "dimensions.h"
+#include "microtab.h"
+
+        common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
+        common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
+        common/grille/z,zb,dz,dzb 
+
+* declaration des variables communes
+* ----------------------------------
+
+cparameter(nz=200,nrad=nqtot)
+        real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz),pb(nz),tb(nz),
+     s     rhob(nz)
+        real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
+        real zb(nz),z(nz),dz(nz),dzb(nz) 
+
+*  declaration des variables internes
+*  ----------------------------------
+
+        integer indic
+        real pp,ra
+
+        ra=1.75e-10
+
+* traitement
+* ----------
+
+        if (indic.eq.0) then
+           pp=pb(j)
+        else
+             if (indic.ne.1) then
+               print*,'erreur argument fonction lambda'
+               return
+             endif
+          pp=p(j)
+        endif
+
+        lambda=kbz*t(j)/(4*sqrt(2.)*pi*(ra**2)*pp)
+        end
+
+*******************************************************************************
+
+            real function knu(j,k,indic)
+*
+*--------------------------------------------------------------*
+*  fonction calculant le nombre de knudsen d'une particule     *
+*  d'aerosol de rayon rayon(k) se trouvant dans la couche no j *
+*  indic ......  idem function lambda                          *
+*--------------------------------------------------------------*
+*
+* declaration des blocs communs
+*------------------------------
+#include "dimensions.h"
+#include "microtab.h"
+
+        common/part/v,rayon,vrat,dr,dv
+
+* declaration des variables communes
+* ----------------------------------
+
+cparameter(nz=200,nrad=nqtot)
+        real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad)
+
+*  declaration des variables internes
+*  ----------------------------------
+
+        integer indic
+        real lambda
+
+* traitement
+* ----------
+
+        if (indic.ne.0 .and.indic.ne.1) then
+               print*,'erreur argument fonction knu'
+               return
+        endif
+
+        rfk=(rayon(k)**(3./df(k)))*((rf(k))**(1.-3./df(k)))
+        knu=lambda(j,indic)/rfk
+        end
+
+*****************************************************************************
+
+             real function nud(j,indic)
+*
+*--------------------------------------------------------------*
+*  fonction calculant la viscosite dynamique (en USI) de l'air *
+*  d'apres la formule de Sutherlant a l'altitude j             *
+*  indic  ......... idem fonction lambda                       *
+*--------------------------------------------------------------*
+*
+#include "dimensions.h"
+#include "microtab.h"
+        integer indic
+cparameter (nz=200)
+        real nud0,c,tt
+        real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz),pb(nz),tb(nz),
+     s     rhob(nz)
+        common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
+*
+        nud0=1.74e-5
+        c=109.
+
+        if(indic.ne.0.and.indic.ne.1) then
+           print*,'erreur argument fonction nud'
+           return
+        endif
+
+        if(indic.eq.0) tt=tb(j)
+        if (indic.eq.1) tt=t(j)
+
+        nud=nud0*sqrt(tt/293)*(1+c/293)/(1+c/tt)
+        end
+
+****************************************************************************
+
+            real function vitesse(j,k,indic)
+*
+*-----------------------------------------------------------------*
+*  fonction calculant la vitesse de chute d'une particule de rayon*
+*  k se trouvant a l'altitude j  suivant la valeur du nombre de   *
+*   Knudsen                                                       *
+*  indic ....... idem function lambda                             *
+*-----------------------------------------------------------------*
+*
+
+* declaration des blocs communs
+*------------------------------
+#include "dimensions.h"
+#include "microtab.h"
+
+        common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
+        common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
+        common/grille/z,zb,dz,dzb 
+        common/part/v,rayon,vrat,dr,dv
+
+* declaration des variables communes
+* ----------------------------------
+
+cparameter(nz=200,nrad=nqtot)
+        real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz)
+     s  ,pb(nz),tb(nz),rhob(nz)
+        real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
+        real zb(nz),z(nz),dz(nz),dzb(nz) 
+        real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad)
+
+*  declaration des variables internes
+*  ----------------------------------
+
+        integer indic
+        real w,g,m,a0,zz,knu,nud,knud,tt,rhoh
+
+*  traitement
+*  ----------
+
+        if (indic.ne.0.and.indic.ne.1) then
+            print*,'erreur argument fonction vitesse'
+            return
+        endif
+
+        if(indic.eq.0) then
+            zz=z(j)+dz(j)/2.
+            tt=tb(j)
+            rhoh=rhob(j)
+        endif
+        if(indic.eq.1) then
+           zz=z(j)
+           tt=t(j)
+           rhoh=rho(j)
+        endif
+
+        g=g0*(rtit/(rtit+zz))**2
+        a0=0.74
+        m=(ach4(j)*mch4+aar(j)*mar+an2(j)*mn2)/nav
+        knud=knu(j,k,indic)
+
+
+        akncx=aknc
+        if(df(k).gt.2.5) akncx=2.7
+
+        if(knud.ge.akncx) then
+
+        rbis=(rayon(k)**(3.-6./df(k)))*((rf(k))**(-2.+6./df(k)))
+          w=a0*g*rbis*rhol/(rhoh*sqrt(8*kbz*tt/(pi*m)))
+        endif
+
+        if(knud.lt.akncx) then
+
+        rfk=(rayon(k)**(3./df(k)))*((rf(k))**(1.-3./df(k)))
+          w=2./9.*rfk**(df(k)-1.)*rf(k)**(3.-df(k))*g*rhol/nud(j,indic)
+
+           if(knud.gt.0.01)  w=w*(1+knud)
+        endif
+
+c       if (p(j).lt.500..and.k.eq.nrad) then
+c          w=0.
+c       endif
+
+
+
+        vitesse=w
+        end
+***********************************************************************
+        
+              real function kd(h)
+*
+*--------------------------------------------------------------------*
+*  cette fonction calcule le coefficient du terme de 'eddy diffusion'*
+*  a l'altitude j						     *
+*--------------------------------------------------------------------*
+*
+
+#include "dimensions.h"
+#include "microtab.h"
+	common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
+	common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
+	common/grille/z,zb,dz,dzb 
+
+
+cparameter(nz=200,nrad=nqtot)
+	real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz),pb(nz),tb(nz),
+     s   rhob(nz)
+	real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
+	real zb(nz),z(nz),dz(nz),dzb(nz) 
+
+        integer h
+
+	 zbx=z(h)+dz(h)/2.
+	if(zbx.le.42000.) then
+              kd=4.
+              kd=1.64e+12*(pb(h)/(kbz*tb(h)))**(-1./2.)
+        else
+c             kd=1.e+15*(pb(h)/(kbz*tb(h)))**(-2./3.)
+              kd=1.64e+12*(pb(h)/(kbz*tb(h)))**(-1./2.)
+	endif
+
+         kd=0.0*kd
+
+	return
+	end
+
+
+*____________________________________________________________________________
+
+	   subroutine init
+*
+*--------------------------------------------------------------------*
+*  cette routine effectue  :                                         *
+*		1) interpolation a partir des donnees initiales des  *
+*                   valeurs de p,t,rho,ach4,aar,an2  sur la grille   *
+*               2) initialisation des constantes (common/phys/)      *
+*	        3) initialisation des variables temporelles (common  *
+*                    /temps/)                                        *
+*               4) definition des grilles en rayon et verticale      *
+*               5)  initialisation de c(z,r,t) avec les donnees du   *
+*                     fichier unit=1                                 *
+*                                                                    *
+*  les donnees sont des valeurs caracterisques de l'atmosphere de    *
+*    TITAN  ( voir Lelouch and co )                                  *
+*--------------------------------------------------------------------*
+
+* declaration des blocs communs
+*------------------------------
+#include "dimensions.h"
+#include "microtab.h"
+
+	common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
+        common/ini/z1,zb1,c0  
+	common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
+	common/grille/z,zb,dz,dzb 
+	common/ctps/li,lf,tt,dt
+        common/con/c
+	common/part/v,rayon,vrat,dr,dv
+
+* declaration des variables communes
+* ----------------------------------
+
+cparameter(nz=200,nrad=nqtot)
+	integer li,lf
+	real dt,tt
+	real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz),pb(nz),tb(nz),
+     s   rhob(nz)
+	real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
+	real zb(nz),z(nz),dz(nz),dzb(nz)  
+	real c(nz,nrad,2),c0(nz,nrad) 
+        real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad)
+
+* declaration des variables internes
+* ----------------------------------
+	
+	integer nzd
+	parameter (nzd=254)
+	integer limsup,liminf,j1,j2
+	real zd(nzd),ach4d(nzd),rap
+        real m	
+
+
+* initialisation des constantes physiques
+* ---------------------------------------
+
+	pi=4.*atan(1.)
+	nav=6.022e+23
+	rgp=8.3143
+	kbz=rgp/nav
+	rtit=2.8e+6
+	g0=1.35
+	mch4=16.043e-3
+	mar=36.4e-3
+	mn2=28.016e-3
+	rhol=1e+3
+
+
+* initialisation des variables temporelles
+* ----------------------------------------
+
+	li=1
+	lf=2
+
+  
+
+
+
+* interpolation de xch4,xar et xn2 sur la grille
+* ----------------------------------------------
+
+* donnees initiales (Lellouch et al,87) 
+* ------------------------------------- 
+
+c       print*,'****** init'
+	do 1 i=1,168
+	  zd(i)=(1000.-5*(i-1))*1000.
+1	continue
+	do 2 i=1,78
+	  zd(168+i)=(160.-2*(i-1))*1000.
+2	continue
+	do 3 i=1,4
+	  zd(246+i)=(5.-(i-1))*1000.
+3	continue
+	do 4 i=1,4
+	  zd(250+i)=(1.5-(i-1)*0.5)*1000.
+4	continue
+
+	data (ach4d(i),i=1,168)/168*1.5e-2/
+	data (ach4d(i),i=169,254)/63*1.5e-2,1.6e-2,1.8e-2,1.8e-2,
+     1  1.9e-2,2.e-2,2.1e-2,2.3e-2,2.5e-2,2.8e-2,3.1e-2,3.6e-2,
+     2  4.1e-2,4.7e-2,5.7e-2,6.7e-2,7.5e-2,7*8.e-2/
+
+	liminf=0
+	limsup=0
+
+* interpolation des taux de melange de ch4,ar,n2  
+*-----------------------------------------------  
+
+	do 20 j1=1,nz
+	   do 21 j2=1,nzd
+              if( zd(j2).le.z(j1)) goto 22
+21	   continue
+22            liminf=j2
+	  if (zd(liminf).eq.z(j1) )then
+	    ach4(j1)=ach4d(liminf)
+	    goto20
+	  endif
+	      if (j2.ne.1) then
+	         limsup=j2-1
+	      else
+	         limsup=j2
+	      endif
+
+	  if (limsup.eq.liminf) then
+	    ach4(j1)=ach4(limsup)
+	  else
+	    ach4(j1)=ach4d(liminf)-(ach4d(limsup)-ach4d(liminf))/
+     s       (zd(limsup)-zd(liminf))*(zd(liminf)-z(j1))
+	  endif
+20	continue
+
+*  rap= aar/an2  cst sur l'altitude
+
+	rap=0.191
+	do 23 i=1,nz
+	  an2(i)=(1.-ach4(i))/(1.+rap)
+	  aar(i)=rap*an2(i)
+23	continue
+
+	do 24 i=1,nz
+	  m=ach4(i)*mch4+an2(i)*mn2+aar(i)*mar
+	  rho(i)=p(i)*m/(rgp*t(i))
+24	continue
+
+	do 34 i=1,nz
+	  m=ach4(i)*mch4+an2(i)*mn2+aar(i)*mar
+	  rhob(i)=pb(i)*m/(rgp*tb(i))
+c         print*,pb(i),m,rgp,tb(i),rhob(i),rho(i)
+34	continue
+
+* fin d'interpolation des taux de melange
+*---------------------------------------- 
+
+c       print*,'**** fin init'
+540     continue
+	return
+
+500      print*,'erreur lecture initialisation de c...erreur=',ii
+	 stop
+
+	end
+
+*____________________________________________________________________________
+
+	 subroutine pertpro(h,a,l_,pr_)
+
+*****************************************************************************
+*                                                                          *
+* ce programme permet le calcul du terme de production (pr) et de perte (l)*
+* pour le phenomene de coagulation                                         *
+* dans le a ieme intervalle de rayon a une altitude h                      *
+****************************************************************************
+
+
+
+* declaration des blocs communs
+*------------------------------
+#include "dimensions.h"
+#include "microtab.h"
+
+	common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
+	common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
+	common/grille/z,zb,dz,dzb 
+	common/ctps/li,lf,tt,dt
+        common/con/c
+	common/part/v,rayon,vrat,dr,dv
+	common/coag/k
+
+* declaration des variables
+* --------------------------
+
+	integer li,lf
+	real tt,dt
+cparameter(nz=200,nrad=nqtot)
+	real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz),pi,nav
+	real pb(nz),tb(nz),rhob(nz)
+	real rgp,kbz,rtit,g0,mch4,mar,mn2,rhol,dz(nz)
+	real vrat,dr(nrad),dv(nrad)
+	real c(nz,nrad,2),v(nrad),rayon(nrad),z(nz),k(nz,nrad,nrad)
+        real dzb(nz),zb(nz) 
+
+* declaration des variables propres au ss-programme
+* -------------------------------------------------
+
+	integer h,b,a,x
+	real*8 pr,ss,s,l
+	real pr_,l_,vol,del
+
+* traitement
+* -----------
+
+*  production
+*+++++++++++++
+	s=0.d0
+	ss=0.d0
+	pr=0.
+
+	if (a .eq. 1) goto 2
+	  
+	  b=a-1
+
+	if (c(h,b,lf) .eq. 0 .and. c(h,b,li) .eq. 0) goto 2
+ 
+        do 1 i=1,b
+
+	 if(c(h,i,li) .eq. 0 .and. c(h,i,lf) .eq. 0) goto 1
+	  
+	    if (i .ne. b)del=1.
+	    if (i .eq. b) del=.5
+
+	   s=(v(i)*1.d0)*del*(k(h,b,i)*1.d0)*(c(h,i,li)*1.d0)+s
+	   ss=(v(i)*1.d0)*del*(k(h,b,i)*1.d0)*(c(h,i,lf)*1.d0)+ss
+c       if (a.eq.2) print*,'SS>',v(i),k(h,b,i),c(h,b,lf)
+c       if (a.eq.2) print*,'SS>',del*v(i)*k(h,b,i)*c(h,b,lf)
+
+
+1	 continue
+
+*  calcul du terme de production
+
+	  pr=(c(h,b,lf)*s/(vrat-1.)+c(h,b,li)*ss)/v(a)
+c        if (a.eq.2) print*,'PR>',s,ss,c(h,b,lf),v(a)
+
+2        continue
+
+
+*  perte
+*- - - - -
+
+	l=0
+
+
+*    condition limite : pas de perte dans le dernier intervalle
+
+	if (a .eq. nrad) goto 9
+
+	do 10 x=1,nrad
+
+	  if (c(h,x,li) .eq. 0) goto 10
+
+	  if (a .lt. x) vol=1.
+	  if (a .eq. x) vol=.5*vrat/(vrat-1)
+	  if (a .gt. x) vol=v(x)/(v(a)*(vrat-1))
+
+	  l=l+k(h,a,x)*c(h,x,li)*vol*1.d0
+
+	    
+10	continue
+9       continue
+
+#ifdef CRAY
+        l_=l
+        pr_=pr
+#else
+        l_=sngl(l)
+        pr_=sngl(pr)
+#endif
+c       l_=sngl(l)
+c       pr_=sngl(pr)
+c         if (a.eq.2) print*,'pr_,l_',h,a,pr_,l_
+c         if (a.eq.2) print*,'-----------------------'
+
+
+
+	return
+
+	end
+
+*_____________________________________________________________________________
+
+	   subroutine production(ihor)
+*
+*--------------------------------------------------------------------*
+*  routine calculant le terme de production des molecules organiques *
+*  composant les aerosols . rini= rayon des aerosols initiaux        *
+*--------------------------------------------------------------------*
+*
+#include "dimensions.h"
+#include "microtab.h"
+#include "clesphys.h"
+
+
+	integer ndz
+cparameter (nrad=nqtot,nz=200,nztop=135)
+	real zb(nz),z(nz),dz(nz),dzb(nz) 
+	real c(nz,nrad,2)
+	real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad)
+	integer li,lf
+	real tt,dt
+        real fonction,fonction1,fonction2,fonction3,fonction4
+        real xlargeur1,xlargeur2,xlargeur3,xlargeur4,xlargeur5
+	real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
+	real zalt0,zy,c0,ctot,prod,rini,rfron
+	real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz)
+     &  ,pb(nz),tb(nz),rhob(nz)
+	common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
+	common /grille/ z,zb,dz,dzb 
+	common/ctps/li,lf,tt,dt
+	common /con/c
+	common/part/v,rayon,vrat,dr,dv
+	common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
+
+        common/effets/ xsaison
+
+         
+         
+
+c        p0=0.3
+         p0=1.
+         do i=1,nz-1
+          if (pb(i).lt.p0.and.pb(i+1).gt.p0) zalt0=(z(i)+z(i+1))/2.
+         enddo
+	
+	ctot=3.5e-13*tx ! ATTENTION, ??COHERENT AVEC INITPAR??
+        ctot=ctot*xsaison  ! 
+
+c       zalt0=385.e+3
+	zy=20.e+3
+	rini=1.3e-9
+	rini=rayon(1)   
+	ndz=50
+*
+	do 10 i=1,nrad 
+	   if(rini.lt.rayon(i)) goto 100
+10	continue
+100	continue
+	if (i.eq.1) then
+	  rini=rayon(1)
+	else
+	  rfron=(rayon(i)+rayon(i-1))/2
+	  if (rini .lt.rfron) then 
+                rini=rayon(i-1)
+	       i=i-1
+	  else
+	        rini=rayon(i)
+          endif
+	endif
+*
+	 c0=ctot/(sqrt(2.*pi)*zy)
+         c0=c0*3./(4.*pi*rhol*rini**3)
+*
+	do 20 k=nztop,nz
+c        zmid=(zb(k)+zb(k+1))/2.
+	 prod=0.
+        do 201 k1=1,ndz
+       prod=prod+c0*exp(-0.5*(((z(k)+dz(k)/2.-k1*dz(k)/(2.*ndz)
+     s -zalt0)/zy)**2))*dt/ndz
+201     continue
+
+	    if (prod .le. 1) prod=0.
+	    c(k,i,lf)=c(k,i,lf)+prod
+20	continue
+
+
+	return
+	end
+
+*-------------------------------------------------------------------*
+
+
+	   subroutine nuages
+*
+*--------------------------------------------------------------------  *
+* Cete routine transforme les aerosols fractals (i=1..9) en particules *
+* spheriques (i=nrad) lors du passage en dessous de la pression de     *
+* condensation (P=42 Pa) avec une constante de temps de                *
+* de 10 jours-Titan                                                    *
+*--------------------------------------------------------------------  *
+*
+#include "dimensions.h"
+#include "microtab.h"
+
+
+	integer ndz
+cparameter (nrad=nqtot,nz=200,nztop=135)
+	real zb(nz),z(nz),dz(nz),dzb(nz) 
+	real c(nz,nrad,2)
+	real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad)
+	integer li,lf
+	real tt,dt
+	real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
+	real zalt0,zy,c0,ctot,prod,rini,rfron
+	real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz)
+     &  ,pb(nz),tb(nz),rhob(nz)
+	common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
+	common /grille/ z,zb,dz,dzb 
+	common/ctps/li,lf,tt,dt
+	common /con/c
+	common/part/v,rayon,vrat,dr,dv
+	common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
+        common/effets/ xsaison
+
+          xnuage=0.01
+
+        P_0=900.
+        P_0=3162.
+
+	do 20 k=nztop,nz
+
+c transfert i={1...9} vers i=10 au dessous de P_0.
+
+         if (p(k).gt.P_0) then 
+          do 10 i=1,nrad-1
+            c(k,nrad,lf)=c(k,nrad,lf)+c(k,i,lf)*xnuage
+     &               *(1.-exp(-dt/1.3824e+06/10.))
+	    c(k,i,lf)=c(k,i,lf)*exp(-dt/1.3824e+06/10.)
+ 10       continue
+         endif
+
+c transfert i=10 vers i=5 au dessus de P_0 Pascals
+
+         if (p(k).le.P_0) then 
+            c(k,5,lf)=c(k,5,lf)+c(k,nrad,lf)
+     &               *(1.-exp(-dt/1.3824e+06/30.))
+         c(k,nrad,lf)=c(k,nrad,lf)*exp(-dt/1.3824e+06/30.)
+         endif
+
+ 20     continue
+
+	return
+	end
+
+
+*__________________________________________________________________________
+
+	   subroutine sedif
+*
+*------------------------------------------------------------------*
+*  cette routine calcule l'evolution de la fonction de distribution*
+*  c(z,r,t) pour les phenomenes de sedimentation et de diffusion   *
+*------------------------------------------------------------------*
+*
+*
+* declaration des blocs communs
+*------------------------------
+#include "dimensions.h"
+#include "microtab.h"
+
+	common/donnees/p,t,rho,ach4,aar,an2,pb,tb,rhob
+	common/phys/pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
+	common/grille/z,zb,dz,dzb 
+	common/ctps/li,lf,tt,dt
+        common/con/c
+	common/part/v,rayon,vrat,dr,dv
+
+* declaration des variables communes
+* ----------------------------------
+
+cparameter(nz=200,nrad=nqtot,nztop=135)
+	integer li,lf
+	real tt,dt
+	real p(nz),t(nz),rho(nz),ach4(nz),aar(nz),an2(nz)
+	real pb(nz),tb(nz),rhob(nz)
+	real pi,nav,rgp,kbz,rtit,g0,mch4,mar,mn2,rhol
+	real zb(nz),z(nz),dz(nz),dzb(nz) 
+	real c(nz,nrad,2)
+        real v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad)
+
+* declaration des variables internes
+* ----------------------------------
+
+	real w,w1,dzbX,dc
+	double precision sigma,theta,hc,l,rap,cmp,wp 
+	double precision fs(nz+1),ft(nz+1)
+	real as(nz),bs(nz),cs(nz),ds(nz)
+	double precision asi(nztop:nz),bsi(nztop:nz),csi(nztop:nz)
+        double precision dsi(nztop:nz),xsol(nztop:nz)
+	real vitesse,kd
+
+        external dtridgl
+* resolution
+*------------
+
+c        print*,'ECHANTILLON.SEDIF.li'
+c        print*,c(100,1,li),c(100,3,lf),c(100,5,lf)
+c        print*,c(10,1,li),c(50,3,lf),c(50,5,lf)
+c        print*,c(10,1,li),c(10,3,lf),c(10,5,lf)
+
+           do 10 k=1,nrad  
+	   do 20 j=nztop,nz
+
+	    if (j.eq.1) goto 20
+
+* calcul de la vitesse corrigee
+
+	     dzbX=(dz(j)+dz(j-1))/2.
+	     w=-1*vitesse(j,k,0)
+	       if (kd(j).ne.0.) then
+	         theta=0.5*(w*dzbX/kd(j)+log(rho(j-1)/rho(j)))
+	            if (theta.ne.0) then
+	               sigma=1./dtanh(theta)-1./theta
+	            else
+	               sigma=1.
+	            endif
+	       else
+	         sigma=1.
+	       endif
+	       if(c(j,k,li).eq.0.) then
+	         rap=10.
+	       else
+	         rap=c(j-1,k,li)/c(j,k,li)
+	          if( rap.gt.10.) rap=10.
+	          if( rap.lt.0.1) rap=0.1
+	       endif
+	       if (rap.gt.0.9 .and. rap.lt.1.1) then
+	          w1=w
+	       else
+	          if(w.ne.0) then
+	              hc=dzbX/dlog(rap)
+	              l=dzbX/(w*dt)*(dexp(-w*dt/hc)-1.)/(1.-rap)
+                      wp=w*1.d0
+                      cmp=dlog(-wp)+abs(sigma)*dlog(l)
+                      if (cmp.gt.38) then
+                               goto 20
+                      endif
+                      w1=-dexp(cmp)
+
+	          else
+                      w1=0.
+	          endif
+	       endif
+
+*  calcul des flux aux interfaces
+
+
+	  if (kd(j).ne.0.) then
+              if (theta.ne.0.) then
+	        ft(j)=(w1+log(rho(j-1)/rho(j))*kd(j)/dzbX)/(dexp(2.*
+     s           theta)-1.)
+                fs(j)=ft(j)*dexp(2.*theta)
+	      else
+	        ft(j)=kd(j)/dzbX
+	        fs(j)=kd(j)/dzbX
+              endif
+	 else
+	   if (w1.lt.0.)then
+	     ft(j)=-w1
+	     fs(j)=0.
+	   else
+	     ft(j)=0.
+	     fs(j)=w1
+	   endif
+	endif
+
+20	   continue
+
+* conditions aux limites pour les flux aux interfaces
+
+	   fs(1)=0.
+	   ft(1)=0.
+	   fs(nz+1)=0.
+	   ft(nz+1)=-w1
+
+* calcul des coefficients de l'equation discrete
+
+	   do 21 j=nztop,nz
+	     as(j)=-dz(j)/dt
+	     bs(j)=-ft(j)
+	     cs(j)=ft(j+1)+fs(j)-dz(j)/dt
+	     ds(j)=-fs(j+1)
+
+	         if ( cs(j).gt.0) goto100
+21        continue
+
+* cas explicite (mu=0) : calcul de la fonction c(z,r,t+1)
+
+	  do 22 j=nztop,nz-1
+
+	   if (j.eq.nztop) then
+	     dc=(cs(nztop)*c(nztop,k,li)+ds(nztop)
+     &                    *c(nztop+1,k,li))/as(nztop)
+	     c(nztop,k,lf)=dc
+
+
+	     goto 22
+	   endif
+
+	      dc=(bs(j)*c(j-1,k,li)+cs(j)*c(j,k,li)+ds(j)*c(j+1,k,li))
+     s        /as(j)
+	     c(j,k,lf)=dc
+
+
+22	  continue
+
+	     dc=(bs(nz)*c(nz-1,k,li)+cs(nz)*c(nz,k,li))/as(nz)
+	     c(nz,k,lf)=dc
+
+
+	  if (nztop.ne.1) then
+	  do 32 j=1,nztop-1
+	    c(j,k,lf)=c(j,k,li)
+32	  continue
+	  endif
+
+	goto 10
+
+100      continue
+
+* cas implicite (mu=1) : calcul de la fonction c(z,r,t+1)
+
+	 do 101 j=nztop,nz
+	    asi(j)=ft(j)
+	    bsi(j)=-(ft(j+1)+fs(j)+dz(j)/dt)
+	    csi(j)=fs(j+1)
+	    dsi(j)=-dz(j)/dt*c(j,k,li)
+101	 continue
+
+* inversion de la matrice tridiagonale 
+
+	nb=nz-nztop+1
+
+        call dtridgl(nb,asi,bsi,csi,dsi,xsol) 
+
+
+        do 102 j=nztop,nz
+         c(j,k,lf)=xsol(j)
+102     continue
+
+	if (nztop.ne.1) then
+	  do 110 j=1,nztop-1
+	   c(j,k,lf)=c(j,k,li)
+110	  continue
+	 endif
+
+
+
+10	continue
+
+        return
+
+	end
+
Index: trunk/LMDZ.TITAN/libf/phytitan/phyetat0.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/phyetat0.F	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/phyetat0.F	(revision 175)
@@ -7,5 +7,5 @@
      .            rlat,rlon, tsol,tsoil,
      .           albe, solsw, sollw,
-     .           fder,radsol,
+     .           fder,radsol,resch4,
      .           tabcntr0,
      .           t_ancien,ancien_ok)
@@ -25,5 +25,5 @@
       REAL dtime
       INTEGER radpas,chimpas
-      REAL rlat(klon), rlon(klon)
+      REAL rlat(klon), rlon(klon)   ! in degrees
       REAL tsol(klon)
       REAL tsoil(klon,nsoilmx)
@@ -40,4 +40,7 @@
       LOGICAL ancien_ok
 
+      REAL resch4(klon)
+      INTEGER ig0
+
       REAL xmin, xmax
 c
@@ -329,4 +332,36 @@
          ENDIF
       ENDIF
+c     Par defaut on cree 2 bandes de methane au pole Nord et au pole Sud
+c     (entre 75 et 85 degres de latitude) de 2 metres.
+c     Les poles sont sec !
+      resch4(1) = 0.    ! pole nord = 1 point
+      DO ig0=2,klon
+          if ((rlat(ig0).ge.75..and.rlat(ig0).le.85.).or. 
+     &        (rlat(ig0).ge.-85.and.rlat(ig0).le.-75.)) then
+            resch4(ig0) = 2.
+          else
+            resch4(ig0) = 0.
+          endif
+      ENDDO
+      resch4(klon) = 0.   ! pole sud = 1 point
+
+      ierr = NF_INQ_VARID (nid, "RESCH4", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <RESCH4> est absent"
+         PRINT*, "Pas de reservoir de methane mais je continue..."
+         PRINT*, "Pour info, je met 2 metres de methane sur 2 bandes"
+         PRINT*, "comprises entre 75 et 85 degres de latitude dans  "
+         PRINT*, "chaque hemisphere."
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, resch4)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid,resch4)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <reservoir>"
+            CALL abort
+         ENDIF
+      ENDIF
 c
 c Fermer le fichier:
Index: trunk/LMDZ.TITAN/libf/phytitan/phyredem.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/phyredem.F	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/phyredem.F	(revision 175)
@@ -7,5 +7,5 @@
      .           albedo, 
      .           solsw, sollw,fder,
-     .           radsol,
+     .           radsol,resch4,
      .           t_ancien)
 
@@ -34,4 +34,5 @@
       real fder(klon)
       REAL radsol(klon)
+      real resch4(klon)
       REAL t_ancien(klon,klev)
 c
@@ -243,4 +244,19 @@
       ierr = NF_REDEF (nid)
 #ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RESCH4", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "RESCH4", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 26,
+     .                        "Reservoir CH4 a la surface")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,resch4)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,resch4)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
       ierr = NF_DEF_VAR (nid, "TANCIEN", NF_DOUBLE, 1, idim3,nvarid)
 #else
Index: trunk/LMDZ.TITAN/libf/phytitan/physiq.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/physiq.F	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/physiq.F	(revision 175)
@@ -79,4 +79,7 @@
 #include "logic.h"
 #include "comorbit.h"
+#include "microtab.h"
+#include "diagmuphy.h"
+#include "itemps.h"
 c======================================================================
       LOGICAL ok_mensuel ! sortir le fichier mensuel
@@ -395,4 +398,6 @@
 c Recuperation des TAU du TR
       REAL t_tauhvd(klon,klev),t_khvd(klon,klev)
+      REAL t_tcld(klon,klev),t_kcld(klon,klev)
+      REAL t_kcvd(klon,klev)
 c  ASTUCE POUR EVITER klon... EN ATTENDANT MIEUX
       INTEGER   ngrid
@@ -401,9 +406,25 @@
       PARAMETER (NSPECV=24,NSPECI=46,NLAYER=llm)
       REAL TAUHID(ngrid,NLAYER,NSPECI)
+     &               ,TAUCID(ngrid,NLAYER,NSPECI)
      &               ,TAUGID(ngrid,NLAYER,NSPECI)
      &               ,TAUHVD(ngrid,NLAYER,NSPECV)
+     &               ,TAUCVD(ngrid,NLAYER,NSPECV)
      &               ,TAUGVD(ngrid,NLAYER,NSPECV)
 
-      COMMON /TAUD/   TAUHID,TAUGID,TAUHVD,TAUGVD
+      COMMON /TAUD/   TAUHID,TAUCID,TAUGID,TAUHVD,TAUCVD,TAUGVD
+* common relatifs au nuages
+      real rmcbar(ngrid,NLAYER),xfbar(ngrid,NLAYER,4) 
+      integer ncount(ngrid,NLAYER)
+      COMMON/rnuabar/ncount,rmcbar,xfbar
+
+       REAL ch4(klon,jjm+1),dch4(jjm+1)
+       INTEGER ig0
+       integer ich4
+       common/ch4ind/ich4
+
+c     flux de chaleur latente d'evaporation CH4
+      REAL fclat(klon)
+c     reservoir de surface
+      REAL,save,allocatable :: reservoir(:)
 
 c Declaration des constantes et des fonctions thermodynamiques
@@ -446,4 +467,5 @@
          allocate(solsw(klon),sollw(klon),sollwdown(klon))
          allocate(source(klon,nqmax))
+         allocate(reservoir(klon))
 
          CALL suphec ! initialiser constantes et parametres phys.
@@ -458,7 +480,8 @@
 c Initialiser les compteurs:
 c
-         itap     = 0
-         itaprad  = 0
-         itapchim = 0
+         itap        = 0
+         itaprad     = 0
+         itapchim    = 0
+         ncount(:,:) = 0
 
 c         
@@ -469,5 +492,5 @@
      .       rlatd,rlond,ftsol,ftsoil,
      .       falbe, solsw, sollw,
-     .       dlw,radsol,
+     .       dlw,radsol,reservoir,
 c     .      zmea,zstd,zsig,zgam,zthe,zpic,zval,
      .       tabcntr0,
@@ -575,8 +598,14 @@
 c Verifications:
 c
-      if ((nmicro.eq.0).and.(microfi.eq.1)) then
-        print*,"MICROPHYSIQUE ONLINE, MAIS NMICRO=0..."
-	stop
-      endif
+         IF ((nmicro.eq.0).and.(microfi.eq.1)) THEN
+           abort_message="MICROPHYSIQUE ONLINE, MAIS NMICRO=0..."
+           call abort_gcm(modname,abort_message,1) 
+         ENDIF
+         IF (microfi.lt.1.and.clouds.eq.1) THEN
+          write(lunout,*)"microfi.lt.1.and.clouds.eq.1"
+          abort_message = 
+     &    "Impossible de faire des nuages sans microphysique..."
+          call abort_gcm(modname,abort_message,1)
+         ENDIF
          IF (nlon .NE. klon) THEN
             WRITE(lunout,*)'nlon et klon ne sont pas coherents', nlon, 
@@ -650,8 +679,14 @@
       ENDDO
 
+      rmcbar  = 0.
+      xfbar   = 0.
          
       ENDIF ! debut
 c====================================================================
 c======================================================================
+
+c   Creer un reservoir de surface infini 
+c
+      reservoir(:) = 2.
 
 c Mettre a zero des variables de sortie (pour securite)
@@ -1061,22 +1096,74 @@
 
       if (iflag_trac.eq.1) then
+c         call begintime(tt0)
          call phytrac (debut,lafin,
      .                   nqmax,nmicro,dtime,appel_chim,dtimechim,
      .                   paprs,pplay,delp,t,rmu0,fract,pdecli,zls,
-     .                   tr_seri,qaer,d_tr_mph,d_tr_kim)
-
-        if (microfi.eq.1) then
+     .                   yu1,yv1,zzlev,zzlay,ftsol,
+     .                   tr_seri,qaer,d_tr_mph,d_tr_kim,
+     .                   fclat,reservoir)
+
+c         call endtime(tt0,tt1)
+c         ttphytra=ttphytra+tt1
+
+c ----- ICI on ajuste radsol en tenant compte du flux de chaleur latente 
+c       d'evaporation du reservoir.
+c       NOTE : c'est pas tres elegant mais ca permet d'eviter d'aller
+c              toucher a clmain.
+        if (clouds.eq.1) then
+          radsol(:) = radsol(:)+fclat(:)    !test pas de flx de chaleur latente
+        endif
+
+        if (microfi.ge.1) then
          tr_seri(:,:,1:nmicro) = tr_seri(:,:,1:nmicro)
      .                        + d_tr_mph(:,:,1:nmicro)*dtime
 	endif
+c       PAS ELEGANT mais je n'ai pas trouve d'autres solutions :
+c       Il semblerait qu'il y ait un probleme lorsque les tendances de traceurs
+c       retourne des traceurs nuls et il y a parfois des valeurs negatives qui trainent.
+c       Pour ne diffuser le probleme, on force les valeurs negatives a ZERO.
+        DO iq=1,nmicro
+          DO i=1,klon
+            DO l=1,klev
+              if (tr_seri(i,l,iq).lt.0.) then
+                 tr_seri(i,l,iq) = 0.
+              endif
+            ENDDO
+          ENDDO
+        ENDDO
+
+c condensation:
+c       NE PAS OUBLIER LA CONDENSATION DES NUAGES !!!!
+        if ((clouds.eq.1.or.(chimi)).and.nqmax.gt.nmicro) then
+          tr_seri(:,:,nmicro+1:nqmax) = tr_seri(:,:,nmicro+1:nqmax)
+     .                         + d_tr_mph(:,:,nmicro+1:nqmax)*dtime
+        endif
         if ((chimi).and.(nqmax.gt.nmicro)) then
 c chimie:
          tr_seri(:,:,:) = tr_seri(:,:,:) + d_tr_kim(:,:,:)*dtime
-c condensation:
-         tr_seri(:,:,nmicro+1:nqmax) = tr_seri(:,:,nmicro+1:nqmax)
-     .                        + d_tr_mph(:,:,nmicro+1:nqmax)*dtime
 	endif
 
       endif
+
+c       ch4=0.
+c       do l=1,llm
+c         ch4(1,l) = tr_seri(1,l,ich4)
+c         do j=2,jjm
+c           ig0=1+(j-2)*iim
+c           do i=1,iim
+c             ch4(j,l)= ch4(j,l)  + tr_seri(ig0+i,l,ich4)/iim
+c           enddo
+c         enddo
+c         ch4(jjm+1,l) = tr_seri(klon,l,ich4)
+c       enddo
+c       do j=1,jjm+1
+c         write(501,*) j,ch4(j,1)
+c       enddo
+c       do l=1,llm
+c         write(502,'(I3,49(ES24.17,1X))') l, 
+c     &   (ch4(j,l),j=1,jjm+1)
+c       enddo
+c       write(501,*) ""
+c       write(502,*) ""
 
 c------------------
@@ -1107,4 +1194,18 @@
 c     print*,"sollw avant radlwsw=",sollw(klon/2)
 c     print*,"avant radlwsw"
+
+c   ----------------
+c   Calcul du rayon moyen des gouttes et des fractions volumique pour le TR
+c  ----------------
+      IF (clouds.eq.1) THEN
+        DO i=1,klon
+          DO j=1,klev
+            rmcbar(i,j)=rmcbar(i,j)/MAX(FLOAT(ncount(i,j)),1.)
+            xfbar(i,j,:)=xfbar(i,j,:)/MAX(FLOAT(ncount(i,j)),1.)
+          ENDDO 
+        ENDDO
+      ENDIF
+     
+c      call begintime(tt0)
       CALL radlwsw
      e            (dist, rmu0, fract, dtimerad, zzlev,
@@ -1115,5 +1216,14 @@
      s             sollwdown,
      s             lwnet, swnet)
+c      call endtime(tt0,tt1)
+c      ttrad=ttrad+tt1
+
 c     print*,"apres radlwsw"
+c     mise a zero du rayon moyen des gouttes et des fractions volumique 
+      IF (clouds.eq.1) THEN
+        rmcbar(:,:)  = 0.
+        xfbar(:,:,:) = 0.
+        ncount(:,:)  = 0
+      ENDIF
 
 c     print*,"radsol apres radlwsw=",radsol(klon/2)
@@ -1122,7 +1232,7 @@
       itaprad = 0
       DO k = 1, klev
-      DO i = 1, klon
+       DO i = 1, klon
          dtrad(i,k) = heat(i,k)-cool(i,k)     !K/s
-      ENDDO
+       ENDDO
       ENDDO
 c       print*,"heat (K/s) =",heat(klon/2,:)
@@ -1426,15 +1536,4 @@
       ENDDO
 c
-c incrementation de la tendance (repassee en extensif) sur qaer pour sorties
-      if (microfi.eq.1) then
-      do iq=1,nmicro
-         DO l=1,llm
-          DO i = 1, klon
-            qaer(i,l,iq) = qaer(i,l,iq) +
-     .                (d_tr_mph(i,l,iq)*delp(i,l)/RG)*dtime
-          ENDDO
-         ENDDO
-      enddo
-      endif   ! microfi
 c=============================================================
 c   Ecriture des sorties
@@ -1502,5 +1601,5 @@
      .      falbe,
      .      solsw, sollw,dlw,
-     .      radsol,
+     .      radsol,reservoir,
 c     .      zmea,zstd,zsig,zgam,zthe,zpic,zval,
      .      t_ancien)
Index: trunk/LMDZ.TITAN/libf/phytitan/phytrac.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/phytrac.F	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/phytrac.F	(revision 175)
@@ -2,5 +2,8 @@
      .                   nqmax,nmicro,ptimestep,appkim,dtkim,
      .                   pplev,pplay,delp,ptemp,pmu0,pfract,pdecli,
-     .                   lonsol,tr_seri,qaer,d_tr_mph,d_tr_kim)
+     .                   lonsol,
+     .                   pu,pv,pzlev,pzlay,ftsol,
+     .                   tr_seri,qaer,d_tr_mph,d_tr_kim,
+     .                   fclat,reservoir)
 
 c======================================================================
@@ -24,7 +27,14 @@
 c pdecli-------input-R-declinaison en radian
 c lonsol-------input-R-longitude solaire en radian
+c pu-----------input-R-vitesse dans la direction X (de O a E) en m/s (1ere couche)
+c pv-----------input-R-vitesse Y (de S a N) en m/s                   (1ere couche)
+c pzlev--------input-R-altitude pour chaque inter-couche (en m)
+c pzlay--------input-R-altitude pour chaque couche (en m)
+c ftsol--------input-R-temperature au sol (en K)
 c tr_seri------input-R-mass mixing ratio traceurs (kg/kg) 
 c d_tr_mph----output-R-tendance microphysique de "qx" (kg/kg/s)
 c d_tr_kim----output-R-tendance chimique de "qx" (kg/kg/s)
+c fclat--------output-R-flux de chaleur latente d'evaporation du reservoir CH4 (J/m2/s)
+c reservoir----outpur-R-un reservoir de surface !!! (m)
 c======================================================================
       USE infotrac
@@ -34,4 +44,8 @@
 #include "clesphys.h"
 #include "YOMCST.h"
+#include "microtab.h"
+#include "varmuphy.h"
+#include "diagmuphy.h"
+#include "itemps.h"
 
 c======================================================================
@@ -44,19 +58,46 @@
       REAL ptemp(klon,klev)
       REAL pmu0(klon), pfract(klon), pdecli, lonsol
+      REAL pu(klon),pv(klon)
+      REAL pzlev(klon,klev+1),pzlay(klon,klev)
+      REAL ftsol(klon)
       REAL tr_seri(klon,klev,nqmax)
       REAL qaer(klon,klev,nqmax)
       REAL d_tr_mph(klon,klev,nqmax),d_tr_kim(klon,klev,nqmax)
+      REAL fclat(klon)
+      REAL reservoir(klon)
 
 c======================================================================
 c Local variables
+      REAL qaer0(klon,klev,nqmax)
+
+c  ASTUCE POUR EVITER klon... EN ATTENDANT MIEUX
+      INTEGER   ngrid,NLAYER
+      PARAMETER (ngrid=(jjm-1)*iim+2)  ! = klon
+      PARAMETER (NLAYER=llm)           ! = klev
+* common relatifs au nuages
+      real rmcbar(ngrid,NLAYER),xfbar(ngrid,NLAYER,4) 
+      integer ncount(ngrid,NLAYER)
+      COMMON/rnuabar/ncount,rmcbar,xfbar
+
+      REAL rcloud(klon,klev,nrad),xfrac(klon,klev,4)
+
+      REAL vcl,nuc,xgsn,xmsn,xesn,xasn
+
+
+      ReAL gaz1(klon,klev),gaz2(klon,klev),gaz3(klon,klev)
+
+      REAL socccld
 
 c grandeurs en moyennes zonales
-      REAL zplev(jjm+1,klev+1),zplay(jjm+1,klev)
+      REAL zplev(jjm+1,klev+1),zplay(jjm+1,klev),ztsol(jjm+1)
+      REAL zzlev(jjm+1,klev+1),zzlay(jjm+1,klev)
       REAL ztemp(jjm+1,klev),zmu0(jjm+1),zfract(jjm+1)
       real temp_eq(klev),press_eq(klev)
       REAL zqaer(jjm+1,klev,nqmax)    ! et non nmicro... Permet nmicro=0.
       REAL zqaer0(jjm+1,klev,nqmax) 
-      REAL pdqmfi(jjm+1,klev,nqmax)
+      REAL zdqmufi(jjm+1,klev,nqmax)
       REAL ychim(jjm+1,klev,nqmax-nmicro) 
+      REAL zgaz1(jjm+1,klev),zgaz2(jjm+1,klev),zgaz3(jjm+1,klev)
+      REAL zgaz10(jjm+1,klev),zgaz20(jjm+1,klev),zgaz30(jjm+1,klev)
 c La saturation n est calculee qu une seule fois: sauvegarde qysat
 c La chimie n est pas calculee tous les pas, il faut donc
@@ -65,6 +106,22 @@
       
       character*10 nomqy(nqmax-nmicro+1)
-      integer      i,j,l,iq,ig0
+      integer      i,j,k,l,iq,ig0
       
+      REAL zprec(jjm+1,5),zsolesp(jjm+1,klev+1,3),
+     &     zflxesp_i(jjm+1,klev,3)
+      REAL ztau_drop(jjm+1,klev),ztau_aer(jjm+1,klev,nrad)
+c
+c    indice des esp chimiques utilisees dans la microfi  
+      integer icldch4,icldc2h6,icldc2h2
+      save icldch4,icldc2h6,icldc2h2
+     
+      real fte,ftm,Lvch4
+
+      REAL tmp,ex,kmin,kmax,dqsq
+      REAL dqch4
+c      REAL ch4(jjm+1),ch4b(jjm+1),dch4(jjm+1),ch4c(jjm+1,llm)
+c       integer ich4
+c       common/ch4ind/ich4
+
 c======================================================================
 c======================================================================
@@ -72,5 +129,33 @@
       if (firstcall) then
        allocate(qysat(klev,nqmax-nmicro),pdyfi(jjm+1,klev,nqmax-nmicro))
+
+c  -------- Quelques verifications au demarrage sur les tailles des tableaux.
+         IF (microfi.ge.1) then
+c        Faire de la microphysique sans traceurs... bon courage !
+           if (nmicro.le.0) then
+             print*,"aLeRtE cRiTiQuE !!!"
+             print*,"Vous faites de la microphysique sans traceurs"
+             print*,"microphysique..."
+             print*,"Je m'arrete et vous laisse reflechir !"
+             stop
+           endif
+c        Nombre de traceurs incompatibles avec la microphysique. 
+           if (nmicro.ne.ntype*nrad) then
+             print*,"aLeRtE cRiTiQuE !!!"
+             print*,"Nb trac imcompatible avec la microphysique."
+             print*,nmicro,ntype*nrad
+             stop
+           endif
+         ENDIF
+
       endif
+
+c RAZ des sorties : les moyennes se font directement dans IOIPSL :
+c
+          flxesp_i(:,:,:) = 0.
+          tau_drop(:,:)   = 0.
+          tau_aer(:,:,:)  = 0.
+          solesp(:,:,:)   = 0.
+          prec(:,:)       = 0.
 
 c-----------------------------------------------------------------------
@@ -80,21 +165,39 @@
 c     print*,'CONVERSION 2D ET CHANGEMENT UNITES (PHYTRAC)'
 
-      zplev = 0.0
-      zplay = 0.0
-      ztemp = 0.0
-      zqaer = 0.0
-      ychim = 0.0
-      zmu0  = 0.0
-      zfract= 0.0
-      
+c   -------------------
+c   Gestion de la temperature et de la pression :
+c   soit la chimie est active, soit la microphysique se fait en 2D.
+      IF (chimi.or.microfi.eq.1) THEN
+ 
+        zplev = 0.0
+        zplay = 0.0
+        zzlev = 0.0
+        zzlay = 0.0
+        ztemp = 0.0
+        zqaer = 0.0
+        ychim = 0.0
+        zmu0  = 0.0
+        zfract= 0.0
+        zgaz1 = 0.0
+        zgaz2 = 0.0
+        zgaz3 = 0.0
+        zprec = 0.0
+        zflxesp_i = 0.0
+        ztau_drop = 0.0 
+        ztau_aer  = 0.0
+        zsolesp   = 0.0
+   
        do l=1,llm+1
          zplev(1,l) = pplev(1,l)
+         zzlev(1,l) = pzlev(1,l)
 	 do j=2,jjm
 	    ig0=1+(j-2)*iim
 	    do i=1,iim
 	       zplev(j,l) = zplev(j,l) + pplev(ig0+i,l)/iim
+               zzlev(j,l) = zzlev(j,l) + pzlev(ig0+i,l)/iim
 	    enddo
 	 enddo
          zplev(jjm+1,l) = pplev(klon,l)
+         zzlev(jjm+1,l) = pzlev(klon,l)
        enddo
 
@@ -102,4 +205,5 @@
          ztemp(1,l) = ptemp(1,l)
          zplay(1,l) = pplay(1,l)
+         zzlay(1,l) = pzlay(1,l)
 	 do j=2,jjm
 	    ig0=1+(j-2)*iim
@@ -107,11 +211,99 @@
 	       ztemp(j,l) = ztemp(j,l) + ptemp(ig0+i,l)/iim
 	       zplay(j,l) = zplay(j,l) + pplay(ig0+i,l)/iim
+               zzlay(j,l) = zzlay(j,l) + pzlay(ig0+i,l)/iim
 	    enddo
 	 enddo
          ztemp(jjm+1,l) = ptemp(klon,l)
          zplay(jjm+1,l) = pplay(klon,l)
+         zzlay(jjm+1,l) = pzlay(klon,l)
 	 temp_eq  = ztemp((jjm+1)/2,:)
 	 press_eq = zplay((jjm+1)/2,:)/100. ! en mbar
        enddo
+
+      ENDIF   ! chimi or microfi=1
+
+c   -----------------------------
+c   Gestion des variables de la microphysique :
+c
+c   -------------------
+      if (microfi.ge.1) then
+
+c   Traceurs microphysiques: passage en extensif: n/kg --> n/m^2 (2D ou 3D passage obligatoire)
+      DO iq=1,nmicro
+c        print*,tname(iq)
+        DO l=1,llm
+          DO i = 1, klon
+            qaer(i,l,iq) = tr_seri(i,l,iq)*delp(i,l)/RG
+          ENDDO
+        ENDDO
+      ENDDO 
+c     copie du tableau de traceur :
+      qaer0(:,:,:)=qaer(:,:,:)
+c
+c   -------------------
+c    Extraction des gaz pour les nuages
+c
+c     recuperation des indices des gaz qui nous interesse       
+      if (firstcall) then
+        if (clouds.eq.1) then
+          icldch4=-1
+          icldc2h6=-1
+          icldc2h2=-1
+          do i=1,nqmax
+            if (tname(i).eq."CH4") then
+              icldch4=i
+c              ich4=i
+            elseif (tname(i).eq."C2H6") then
+              icldc2h6=i
+            elseif (tname(i).eq."C2H2") then
+              icldc2h2=i
+            endif
+          enddo
+          if (icldch4 .eq.-1 .or. 
+     &        icldc2h6.eq.-1 .or.
+     &        icldc2h2.eq.-1 ) then
+            print*, "Sacrebleu !!!"
+            print*, "Vous voulez faire des nuages sans gaz."
+            print*, "Mais vous etes inconscient. Je vais m'arreter la"
+            print*, "pour vous laisser reflechir au probleme"
+            STOP
+          endif
+        endif    ! clouds=1
+      endif      ! firstcall
+
+c     Saturation et fraction molaire CLOUD 
+c     Calcul des saturations pour les esp chimique de la muphy des nuages.
+c     On le fait ici pour les sortir dans physiq.F sans avoir a surcharger la routine. 
+c     Elles passent ensuite dans un common pour passer dans les I/O.
+c
+c-------------------------------------------
+      IF (clouds.eq.1) THEN
+        DO l=1,llm
+          DO i = 1, klon
+            call ch4sat(ptemp(i,l),pplay(i,l),tmp) !tmp en kg/kg !
+            satch4(i,l) = tr_seri(i,l,icldch4)/(tmp*28./16.)
+
+            call c2h6sat(ptemp(i,l),pplay(i,l),tmp)
+            satc2h6(i,l) =tr_seri(i,l,icldc2h6)/(tmp*28./30.)
+
+            call c2h2sat(ptemp(i,l),pplay(i,l),tmp)
+            satc2h2(i,l) =tr_seri(i,l,icldc2h2)/(tmp*28./26.)
+   
+          ENDDO
+        ENDDO
+
+c   Copie des gaz (en 3D)  <== UNIQUEMENT SI ON FAIT DES NUAGES
+        gaz1(:,:) = tr_seri(:,:,icldch4)
+        gaz2(:,:) = tr_seri(:,:,icldc2h6)
+        gaz3(:,:) = tr_seri(:,:,icldc2h2)
+
+      ENDIF      ! clouds=1
+        
+      endif      ! microfi.ge.1
+
+c     -------------------
+c     Si microfi = 1 on est en 2D :
+c     conversion des inputs de muphys
+      IF (microfi.eq.1) THEN
 
          zmu0(1)   = pmu0(1)
@@ -126,19 +318,8 @@
          zmu0(jjm+1)   = pmu0(klon)
          zfract(jjm+1) = pfract(klon)
-
-c TRACEURS MICROPHYSIQUES
-
-      if (microfi.eq.1) then
-
-      do iq=1,nmicro
-c        print*,tname(iq)
-
-c       Traceurs microphysiques: passage en extensif: n/kg --> n/m^2
-         DO l=1,llm
-          DO i = 1, klon
-            qaer(i,l,iq) = tr_seri(i,l,iq)*delp(i,l)/RG
-          ENDDO
-         ENDDO
-
+c
+c     traceurs 3D --> 2D
+c 
+      do iq=1,nqmax
        do l=1,llm
          zqaer(1,l,iq) = qaer(1,l,iq)
@@ -152,6 +333,33 @@
        enddo
       enddo
-
-      endif   ! microfi
+c       copie du tableau de traceur
+        zqaer0(:,:,:) = zqaer(:,:,:)
+c 
+c      gaz 3D --> 2D    <=== UNIQUEMENT SI ON FAIT DES NUAGES.
+c
+        if (clouds.eq.1) then
+          do l=1,llm
+            zgaz1(1,l) = gaz1(1,l)
+            zgaz2(1,l) = gaz2(1,l)
+            zgaz3(1,l) = gaz3(1,l)
+            do j=2,jjm
+              ig0=1+(j-2)*iim
+              do i=1,iim
+                zgaz1(j,l) = zgaz1(j,l) + gaz1(ig0+i,l)/iim
+                zgaz2(j,l) = zgaz2(j,l) + gaz2(ig0+i,l)/iim
+                zgaz3(j,l) = zgaz3(j,l) + gaz3(ig0+i,l)/iim
+              enddo
+            enddo
+            zgaz1(jjm+1,l) = gaz1(klon,l)
+            zgaz2(jjm+1,l) = gaz2(klon,l)
+            zgaz3(jjm+1,l) = gaz3(klon,l)
+          enddo
+ 
+          zgaz10=zgaz1
+          zgaz20=zgaz2
+          zgaz30=zgaz3
+        endif ! clouds=1
+
+      endif   ! microfi=1
 
 c AUTRES TRACEURS
@@ -170,8 +378,6 @@
          ychim(jjm+1,l,iq-nmicro) = tr_seri(klon,l,iq)
        enddo
-         nomqy(iq-nmicro) = tname(iq)
-
+       nomqy(iq-nmicro) = tname(iq)
 c       print*,iq-nmicro,nomqy(iq-nmicro)
-
       enddo
       nomqy(nqmax-nmicro+1) = "HV"
@@ -190,45 +396,193 @@
 
 c-----------------------------------------------------------------------
-c     Appel de la microphysique
+c     Appel de la microphysique   en 2D/3D !!!!!!
 c    --------------------------
 
-       pdqmfi = 0.
-       zqaer0 = zqaer
-       
        IF(firstcall) THEN 
         print*,'MICROPHYSIQUE ',MICROFI
        ENDIF
 
-       IF(MICROFI.eq.1) THEN
-
-         IF(firstcall) THEN 
-          print*,'OH! On passe dans la microphysique'
+c       call begintime(tt0)
+       IF (MICROFI.eq.0) THEN
+c        PAS DE MICROPHYSIQUE :
+c        On appelle juste rdf pour creer la grille de rayons.
+         IF (firstcall) THEN
+          print*,'MICROPHYSIQUE OFF-LINE',MICROFI
+           call rdf()
          ENDIF
-
-         CALL pg2(zplev,ztemp,zqaer,pdqmfi    ! tendances 2D, /s
-     &   ,nmicro,ptimestep,zmu0,zfract,lastcall)
-
+c        NOTES : 
+c        L'appel de rdf ne sert a rien ici mis a part pour le TR. Si cet
+c        appel a deja lieu dans le TR inutile de le refaire ici.
+c        Je ne sais pas exactement comment marche les modules en F90
+c        Mais je recopie les valeurs du common/part/ de rdf pour 
+c        les mettre dans un common interne a la microphysique (voir varmuphy.h)
+c        DONC J'AI BESOIN D'AVOIR ACCES A L'ANCIEN COMMON !!!
+c
+       ELSEIF (MICROFI.eq.1) THEN
+c      MICROPHYSIQUE 2D :
+c      Les input/output comportent le prefixe z pour 2D :)
+         zdqmufi = 0.  ! ne sert que pour chimi pour condensation
+         call muphys(jjm+1,
+     &        zplev,zplay,zzlev,zzlay,
+     &        ztemp,zqaer,zgaz1,zgaz2,zgaz3,
+     &        nmicro,ptimestep,
+     &        zmu0,zfract,
+c -------- sorties diagnostiques
+     &        zflxesp_i,
+     &        ztau_drop,ztau_aer,
+     &        zsolesp,zprec)
        ELSE
-
-        IF(firstcall) THEN 
-          print*,'MICROPHYSIQUE OFF-LINE',MICROFI
-          if (nmicro.gt.0) then
-            CALL pg2(zplev,ztemp,zqaer,pdqmfi
-     &    ,nmicro,ptimestep,zmu0,zfract,lastcall)
-          endif
-        ENDIF
-
+c      MICROPHYSIQUE 3D :
+c      Les input sont des champs 3D directement !
+         call muphys(klon,
+     &        pplev,pplay,pzlev,pzlay,
+     &        ptemp,qaer,gaz1,gaz2,gaz3,
+     &        nmicro,ptimestep,
+     &        pmu0,pfract,     
+c ------ sorties diagnostiques
+     &        flxesp_i,
+     &        tau_drop,tau_aer,
+     &        solesp,prec)
+c
+c    NOTES :
+c    Ici toutes nos sorties sont des champs 3D...(meme les diagnostiques)
+c    On a rien a faire mis a part copier les dq dans les d_tr
+c
        ENDIF
-
-       zqaer  = zqaer+pdqmfi*ptimestep
-       pdqmfi = (zqaer-zqaer0)/ptimestep
+c       call endtime(tt0,tt1)
+c       ttmuphys=ttmuphys+tt1
+
+c-----------------------------------------------------------------------
+c     Mise a jour des sorties de muphys
+c    -------------
+c       En 2D on copie les sorties de muphys de la grille LATxALT
+c       sur la grille complete. 
+       IF (microfi.eq.1) THEN
+c        precipitations
+         DO l=1,5
+           prec(1,l) = zprec(1,l)
+           ig0 = 2
+           DO j=2,jjm
+             DO i = 1, iim
+               prec(ig0,l) = zprec(j,l)
+               ig0 = ig0 + 1
+             ENDDO
+           ENDDO
+           prec(ig0,l) = zprec(jjm+1,l)
+         ENDDO
+c        taux sedimentation
+         DO l=1,llm
+c          taux sed goutte
+           IF (clouds.eq.1) THEN
+             tau_drop(1,l) = ztau_drop(1,l)
+             ig0 = 2
+             DO j=2,jjm
+               DO i = 1, iim
+                 tau_drop(ig0,l) = ztau_drop(j,l)
+                 ig0 = ig0 + 1
+               ENDDO
+             ENDDO
+             tau_drop(ig0,l) = ztau_drop(jjm+1,l)
+           ENDIF
+c          taux sed aer
+           DO iq=1,nrad
+             tau_aer(1,l,iq)  = ztau_aer(1,l,iq)
+             ig0 = 2
+             DO j=2,jjm
+               DO i = 1, iim
+                 tau_aer(ig0,l,iq)  = ztau_aer(j,l,iq)
+                 ig0 = ig0 + 1
+               ENDDO
+             ENDDO
+             tau_aer(ig0,l,iq) = ztau_aer(jjm+1,l,iq)
+           ENDDO
+         ENDDO
+c        flux glace / production glace
+         IF (clouds.eq.1) THEN
+           DO iq=1,3
+             DO l=1,llm+1
+               if (l.le.llm) flxesp_i(1,l,iq) = zflxesp_i(1,l,iq)
+               solesp(1,l,iq) = zsolesp(1,l,iq)
+               ig0 = 2
+               DO j=2,jjm
+                 DO i = 1, iim
+                   if (l.le.llm) flxesp_i(ig0,l,iq)=zflxesp_i(1,l,iq)
+                   solesp(ig0,l,iq) = zsolesp(1,l,iq)    
+                   ig0 = ig0 + 1
+                 ENDDO
+               ENDDO
+               if (l.le.llm) flxesp_i(ig0,l,iq)=zflxesp_i(jjm+1,l,iq)
+               solesp(ig0,l,iq) = zsolesp(jjm+1,l,iq)
+             ENDDO
+           ENDDO
+         ENDIF
+       ENDIF
        
+c-----------------------------------------------------------------------
+c     Gestion des sources
+c    -------------
+c
+       IF (clouds.eq.1) THEN
+         IF (microfi.eq.1) THEN
+c          On repasse les gaz en 3D si on a fait de la microphysique en 2D
+           DO l=1,llm
+             gaz1(1,l) = zgaz1(1,l)
+             gaz2(1,l) = zgaz2(1,l)
+             gaz3(1,l) = zgaz3(1,l)
+             ig0 = 2
+             DO j=2,jjm
+               DO i = 1, iim
+                 gaz1(ig0,l) = zgaz1(j,l)* gaz1(ig0,l) /zgaz10(j,l)
+                 gaz2(ig0,l) = zgaz2(j,l)* gaz2(ig0,l) /zgaz20(j,l)
+                 gaz3(ig0,l) = zgaz3(j,l)* gaz3(ig0,l) /zgaz30(j,l)
+                 ig0 = ig0 + 1
+               ENDDO
+             ENDDO
+             gaz1(ig0,l) = zgaz1(jjm+1,l)
+             gaz2(ig0,l) = zgaz2(jjm+1,l)
+             gaz3(ig0,l) = zgaz3(jjm+1,l)
+           ENDDO
+         ENDIF
+c        Mise a jour du reservoir de CH4 (ie : seul le CH4 remplit le reservoir)
+         DO i=1,klon
+            reservoir(i) = reservoir(i)+prec(i,1)
+         ENDDO 
+c        Calcul des sources :
+c        ch4=0.
+c        ch4(1) = gaz1(1,1)
+c         do j=2,jjm
+c           ig0=1+(j-2)*iim
+c           do i=1,iim
+c             ch4(j)= ch4(j) + gaz1(ig0+i,1)/iim
+c           enddo
+c         enddo
+c         ch4(jjm+1) = gaz1(ig0,1)
+
+         CALL sources(klon,klev,ptimestep,z0,
+     &                pu,pv,pplev,pzlay,pzlev,
+     &                gaz1,gaz2,gaz3,
+     &                ftsol,solesp,reservoir) 
+ 
+c        ch4b=0.
+c        ch4b(1) = gaz1(1,1)
+c         do j=2,jjm
+c           ig0=1+(j-2)*iim
+c           do i=1,iim
+c             ch4b(j)= ch4b(j) + gaz1(ig0+i,1)/iim
+c           enddo
+c         enddo
+c         ch4b(jjm+1) = gaz1(ig0,1)
+c         do j=1,jjm+1
+c           write(499,*) j,ch4(j),ch4b(j)
+c         enddo
+c         write(499,*) ""
+       ENDIF
 c-----------------------------------------------------------------------
 c     Condensation
 c    -------------
 
-      if ((chimi).and.(nqmax.gt.nmicro)) then
-
-c   tendance (en /s) passee sur pdqmfi(nmicro+1 a nqmax)
+      IF ((chimi).and.(nqmax.gt.nmicro)) then
+
+c   tendance (en /s) passee sur zdqmufi(nmicro+1 a nqmax)
 c        print*,'Condensation'
 
@@ -237,6 +591,6 @@
               do j=1,jjm+1
                  if (ychim(j,l,iq).gt.qysat(l,iq)) then
-           pdqmfi(j,l,nmicro+iq)= (-ychim(j,l,iq)+qysat(l,iq)) !delta y
-     .                            / ptimestep                  ! / dt
+           zdqmufi(j,l,nmicro+iq)= (-ychim(j,l,iq)+qysat(l,iq)) !delta y
+     .                             / ptimestep                  ! / dt
                  endif
               enddo
@@ -249,5 +603,5 @@
 c eventuellement, modif initiale de la compo
 c
-c   tendance (en /s) passee sur pdqmfi(nmicro+1 a nqmax)
+c   tendance (en /s) passee sur zdqmufi(nmicro+1 a nqmax)
 c
 c     if (firstcall .and. chimi .and.(nqmax.gt.nmicro)) then
@@ -260,5 +614,5 @@
 c             do j=1,jjm+1
 c                if (ychim(j,l,iq).le.0.015) then
-c          pdqmfi(j,l,nmicro+iq)= (-ychim(j,l,iq)+0.015) !delta y
+c          zdqmufi(j,l,nmicro+iq)= (-ychim(j,l,iq)+0.015) !delta y
 c    .                            / ptimestep                  ! / dt
 c                endif
@@ -278,5 +632,5 @@
 c             do j=1,jjm+1
 c                if (ychim(j,l,iq).gt.1.e-5) then
-c          pdqmfi(j,l,nmicro+iq)= (-ychim(j,l,iq)+1.e-5) !delta y
+c          zdqmufi(j,l,nmicro+iq)= (-ychim(j,l,iq)+1.e-5) !delta y
 c    .                            / ptimestep                  ! / dt
 c                endif
@@ -288,5 +642,5 @@
 c             do j=1,jjm+1
 c                if (ychim(j,l,iq).gt.3.e-5) then
-c          pdqmfi(j,l,nmicro+iq)= (-ychim(j,l,iq)+3.e-5) !delta y
+c          zdqmufi(j,l,nmicro+iq)= (-ychim(j,l,iq)+3.e-5) !delta y
 c    .                            / ptimestep                  ! / dt
 c                endif
@@ -298,4 +652,6 @@
 c     endif
 c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+          
+c ----- commentaire de fin (mise a jour des profil de fraction molaire)
           
 c-----------------------------------------------------------------------
@@ -326,32 +682,67 @@
 
 c TRACEURS MICROPHYSIQUES
-
-      if (microfi.eq.1) then
-
-      DO iq=1,nmicro
-         DO l=1,llm
-            d_tr_mph(1,l,iq) = pdqmfi(1,l,iq)
-            ig0          = 2
-            DO j=2,jjm
+c                                        
+c ---> pas de microphysique
+       IF (microfi.eq.0) THEN
+         DO iq=1,nmicro
+           d_tr_mph(:,:,iq)=0.
+         ENDDO
+       ENDIF
+c ---> microphysique 2D
+      IF (microfi.eq.1) THEN
+c  on repasse le champ de traceurs en 3D (pas les tendances)
+         DO iq=1,nmicro
+           DO l=1,llm
+             qaer(1,l,iq) = zqaer(1,l,iq)
+             ig0          = 2
+             DO j=2,jjm
                DO i = 1, iim
-                  d_tr_mph(ig0,l,iq)  = pdqmfi(j,l,iq)
-     &                 *qaer(ig0,l,iq)/zqaer0(j,l,iq)
-                  ig0             = ig0 + 1
+c    un petit patch : 
+c    Si la moyenne zonale au depart est "nulle" :
+c    On a quand meme le droit de produire des traceurs dans la cellule.
+c    On considere donc que la valeur de sortie 3D correspond a la valeur de sortie 2D.
+c    Cela permet aussi entre autre d'eviter les NaN pour les traceurs des nuages !
+c    (au dessus de la tropo pas de nuages donc qaer(nrad+1:ntype*nrad) = 0 !!!)
+                 IF (zqaer0(j,l,iq).lt.1e-100) THEN
+                   qaer(ig0,l,iq) = zqaer(j,l,iq) 
+                 ELSE
+                   qaer(ig0,l,iq) = zqaer(j,l,iq) *
+     &             qaer0(ig0,l,iq)/zqaer0(j,l,iq)
+                 ENDIF
+                 ig0 = ig0 + 1
                ENDDO
-            ENDDO
-            d_tr_mph(ig0,l,iq) = pdqmfi(jjm+1,l,iq)
-         ENDDO
-      ENDDO
-
-      do iq=1,nmicro
-         DO l=1,llm
-          DO i = 1, klon
+             ENDDO
+             qaer(ig0,l,iq) = zqaer(jjm+1,l,iq)
+           ENDDO
+         ENDDO
+c        La tendances correspond a (qaer-qaer0)/ptimestep
+         DO iq=1,nmicro
+           DO i=1,klon
+             DO l=1,llm
+               d_tr_mph(i,l,iq) = (qaer(i,l,iq)-qaer0(i,l,iq))/
+     &                            ptimestep
+             ENDDO
+           ENDDO
+         ENDDO
+c ---> microphysique 3D
+       ELSEIF(microfi.gt.1) THEN 
+         DO iq=1,nmicro
+           DO l=1,llm
+             DO i = 1, klon
+               d_tr_mph(i,l,iq)=(qaer(i,l,iq)-qaer0(i,l,iq))/ptimestep
+             ENDDO
+           ENDDO
+         ENDDO
+
+         do iq=1,nmicro
+          DO l=1,llm
+           DO i = 1, klon
 c  Traceurs microphysiques: passage en intensif: n/m^2 --> n/kg
-            d_tr_mph(i,l,iq) = d_tr_mph(i,l,iq)*RG/delp(i,l)
+             d_tr_mph(i,l,iq) = d_tr_mph(i,l,iq)*RG/delp(i,l)
+           ENDDO
           ENDDO
-         ENDDO
-      enddo
-
-      endif   ! microfi
+         enddo
+
+       ENDIF   ! microfi
 
 c AUTRES TRACEURS
@@ -360,10 +751,10 @@
 c on passe de pdyfi (tendance chimique en /s calculee quand chimie appelee)
 c          a  d_tr_kim (tendance chimique 3D en /s, passee a physiq)
-c  et de pdqmfi a d_tr_mph (tendance condensation 3D en /s passee a physiq)
+c  et de zdqmufi a d_tr_mph (tendance condensation 3D en /s passee a physiq)
 
       DO iq=nmicro+1,nqmax
          DO l=1,llm
             d_tr_kim(1,l,iq) = pdyfi(1,l,iq-nmicro)
-            d_tr_mph(1,l,iq) = pdqmfi(1,l,iq)
+            d_tr_mph(1,l,iq) = zdqmufi(1,l,iq)
             ig0          = 2
             DO j=2,jjm
@@ -371,5 +762,5 @@
                   d_tr_kim(ig0,l,iq)  = pdyfi(j,l,iq-nmicro)
      &                 *tr_seri(ig0,l,iq)/ychim(j,l,iq-nmicro)
-                  d_tr_mph(ig0,l,iq)  = pdqmfi(j,l,iq)
+                  d_tr_mph(ig0,l,iq)  = zdqmufi(j,l,iq)
      &                 *tr_seri(ig0,l,iq)/ychim(j,l,iq-nmicro)
                   ig0             = ig0 + 1
@@ -377,9 +768,189 @@
             ENDDO
             d_tr_kim(ig0,l,iq) = pdyfi(jjm+1,l,iq-nmicro)
-            d_tr_mph(ig0,l,iq) = pdqmfi(jjm+1,l,iq)
+            d_tr_mph(ig0,l,iq) = zdqmufi(jjm+1,l,iq)
          ENDDO
       ENDDO
 
       endif   ! chimi
+
+c--------------------------------------------------
+c  CONDENSATION VIA MICROFI
+c----------------------
+c La microphysique avec nuages doit se faire obligatoirement en 3D.
+c Rien n'empeche de faire la chimie en 2D. Cependant pour prendre en compte la 
+c condensation due a la microfi (en 3D) on recalcule la tendance finale pour
+c les especes concernees (CH4, C2H6 pour le moment). 
+       IF (microfi.ge.1.and.clouds.eq.1) THEN
+         DO i=1,klon
+           DO l=1,klev
+c     condensation CH4
+             d_tr_mph(i,l,icldch4)=(gaz1(i,l)-tr_seri(i,l,icldch4))
+     &                            /ptimestep
+c     condensation C2H6
+             d_tr_mph(i,l,icldc2h6)=(gaz2(i,l)-tr_seri(i,l,icldc2h6))
+     &                             /ptimestep
+c     condensation C2H2
+             d_tr_mph(i,l,icldc2h2)=(gaz3(i,l)-tr_seri(i,l,icldc2h2))
+     &                             /ptimestep
+           ENDDO 
+         ENDDO
+       ENDIF
+c        ch4c=0.
+c       do l=1,llm
+c       ch4c(1,l) = tr_seri(1,l,icldch4)
+c       do j=2,jjm
+c         ig0=1+(j-2)*iim
+c         do i=1,iim
+c            ch4c(j,l)= ch4c(j,l)+tr_seri(ig0+i,l,icldch4)/iim
+c         enddo
+c       enddo
+c        ch4c(jjm+1,l) = tr_seri(klon,l,icldch4)
+c      enddo
+c       do l=1,llm
+c         write(500,*) pplay(25,l),ch4c(25,l)
+c       enddo
+c       write(500,*) ""
+
+
+c--------------------------------------------------
+c  MISE A JOUR CH4 : (pour refixer la fraction 
+c                     molaire)
+c--------------------------------------------------
+c       IF (firstcall) THEN
+c         do i=1,klon
+c           do j=1,llm
+c             call ch4sat(ptemp(i,j),pplay(i,j),tmp) !tmp en kg/kg !
+c             tmp=0.95*0.85*tmp*28./16.
+c             if (pplay(i,j).lt.20000.) then
+c               dqch4 = 1.4e-2          
+c             else
+c               dqch4 = tmp
+c             endif
+c             d_tr_mph(i,j,icldch4)=(-tr_seri(i,j,icldch4)+dqch4)/ 
+c     &       ptimestep
+c           enddo
+c         enddo
+c         
+c       ENDIF
+
+c--------------------------------------------------
+c CALCUL DU FLUX DE CHALEUR LATENTE D'EVAPORATION 
+c DU METHANE 
+c--------------------------------------------------
+       IF (clouds.eq.1) THEN
+         DO i=1,klon
+           fte= (1.-ftsol(i)/305.5)
+           ftm= (1.-ftsol(i)/190.5)
+           if(ftm.le.1.e-3) ftm=1.e-3
+           if(fte.le.1.e-3) fte=1.e-3
+           Lvch4 =8.314*190.4*
+     &     (7.08*ftm**0.354+10.95*1.1e-2*ftm**0.456)
+     &     /mch4
+           ! solcxhy en m3/m2 {ok}
+           ! 425 en kg/m3
+           ! Lv en J/kg       {ok}
+           ! ptimestep en s   {ok}
+           fclat(i)=(solesp(i,klev+1,1)*Lvch4*rhoi_ch4)   ! en J/m2/s
+         ENDDO
+       ENDIF
+
+c--------------------------------------------------
+c  GESTION DES RAYONS DE GOUTTES POUR TR
+c--------------------------------------------------
+       IF (clouds.eq.1) THEN
+
+c Calcul du rayon des gouttes par bin ...
+c----------------------------------------
+         DO i=1,klon
+           DO j=1,klev 
+             DO iq=1,nrad
+*      Rayon minimum selon la quantité de noyaux
+               IF (qaer(i,j,iq+nrad) .le.   1.e-5) THEN
+                  rcloud(i,j,iq) = 1.e-10
+               ELSE
+                 rcloud(i,j,iq)=
+     &           ((qaer(i,j,iq+2*nrad)/qaer(i,j,iq+nrad)+
+     &           qaer(i,j,iq+3*nrad)/qaer(i,j,iq+nrad) +
+     &           v_e(iq))*0.75/3.1415926353)**(1./3.)
+               ENDIF 
+             ENDDO
+           ENDDO
+         ENDDO
+
+c .... et de leur rayon moyen total (tt bins confondu)
+c------------------------------------------------------
+         DO i=1,klon
+           socccld=0.
+           DO j=klev,1,-1    !de haut en bas pour le calcul des opacites
+             vcl=0.
+             nuc=0.
+             xgsn=0.
+             xmsn=0.
+             xesn=0.
+             xasn=0.
+             DO iq=1,nrad
+               vcl=vcl+qaer(i,j,iq+2*nrad)+
+     &         qaer(i,j,iq+3*nrad)+ 
+     &         qaer(i,j,iq+4*nrad)+ 
+     &         v_e(iq)*qaer(i,j,iq+nrad)            ! volume des gouttes
+               nuc=nuc+qaer(i,j,iq+nrad)            ! nombre de noyaux
+               xgsn=xgsn+qaer(i,j,iq+nrad)*v_e(iq)  ! volume de noyaux
+               xmsn=xmsn+qaer(i,j,iq+2*nrad)        ! volume de methane
+               xesn=xesn+qaer(i,j,iq+3*nrad)        ! volume d' ethane
+               xasn=xasn+qaer(i,j,iq+4*nrad)        ! volume d' acethylene
+             ENDDO 
+             IF (nuc .le.  1.e-5) THEN
+               rmcloud(i,j)=1.0e-10
+               xfrac(i,j,:)=0.
+             ELSE
+               IF(xgsn/vcl.lt.0.  .or. xgsn/vcl.gt.1.001)
+     &         print*, 'PB AVEC XFRAC:', i,j,xgsn,vcl 
+               rmcloud(i,j)=          ! rayon moyen des gouttes
+     &         (vcl/nuc*0.75/3.1415926353)**(1./3.)
+               xfrac(i,j,1)=xgsn/vcl         ! fraction volumique noyau/goutte
+               xfrac(i,j,2)=xmsn/vcl         ! fraction volumique CH4/goutte
+               xfrac(i,j,3)=xesn/vcl         ! fraction volumique C2H6/goutte
+               xfrac(i,j,4)=xasn/vcl         ! fraction volumique C2H2/goutte
+c              calcul du rayon moyen (moyenne temporelle)
+               rmcbar(i,j)=rmcbar(i,j)+rmcloud(i,j)
+               xfbar(i,j,:)=xfbar(i,j,:)+xfrac(i,j,:)
+               ncount(i,j) = ncount(i,j)+1
+             ENDIF
+             socccld=socccld+3.1415926*(rmcloud(i,j)**2.)*nuc
+             occcld(i,j)=socccld
+           ENDDO
+         ENDDO
+c
+c      OCCCLD
+c      Calcul le nombre d'occurence d'un nuage 
+c      d'opacité comprise en kmin et kmax
+c          k        kmin            kmax
+c          1   0.0000000      0.10000000    
+c          2  0.10000000      0.17782794    
+c          3  0.17782794      0.31622776    
+c          4  0.31622776      0.56234139    
+c          5  0.56234139       1.0000000    
+c          6   1.0000000       1.7782795    
+c          7   1.7782795       3.1622777    
+c          8   3.1622777       5.6234136    
+c          9   5.6234136       10.000000    
+c         10   10.000000       17.782795    
+c         11   17.782795       31.622778    
+c         12   31.622778       100000.00
+c
+         DO i=1,klon
+           DO j=1,klev
+             DO k=1,12
+               ex=10.**(0.25)
+               kmin=0.
+               kmax=1.e5
+               if(k.ne.1)  kmin=0.1*ex**(k-2)
+               if(k.ne.12) kmax=0.1*ex**(k-1)
+               if(occcld(i,j).ge.kmin .and. occcld(i,j).lt.kmax)
+     &         occcld_m(i,j,k)=1.
+             ENDDO
+           ENDDO
+         ENDDO
+       ENDIF  ! fin condition clouds => pas besoin de calculer des rayons
 
       RETURN
Index: trunk/LMDZ.TITAN/libf/phytitan/radlwsw.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/radlwsw.F	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/radlwsw.F	(revision 175)
@@ -59,5 +59,5 @@
       real solsw(klon), sollw(klon)
       real sollwdown(klon)
-      REAL swnet(klon,kflev+1),lwnet(klon,kflev+1)
+      REAL swnet(klon,klev+1),lwnet(klon,klev+1)
 c
 c LOCAL VARIABLES
@@ -65,7 +65,11 @@
       real zp(klon,klev+1),zt(klon,klev+1),zz(klon,klev+1)
       real zq(klon,klev,nq)
-      real zheat(klon,klev), zcool(klon,klev)
-      REAL zswnet(klon,kflev+1),zlwnet(klon,kflev+1)
-      
+      real zheatc(klon,klev), zcoolc(klon,klev)
+      real zheatp(klon,klev), zcoolp(klon,klev)
+      REAL zswnetc(klon,klev+1),zlwnetp(klon,klev+1)
+      REAL zswnetp(klon,klev+1),zlwnetc(klon,klev+1)
+      REAL zsollwdownc(klon),zsollwdownp(klon)
+      INTEGER icld
+
 
 c =======================================
@@ -123,17 +127,27 @@
       print*,'On calcule le rayonnement SW'
 
-      CALL heating(dist,rmu0,fract,zheat,zswnet)
+       IF (clouds.eq.1) THEN
+         ICLD = 1   ! colonne avec nuages
+         CALL heating(dist,rmu0,fract,zheatc,zswnetc,icld)
+       ELSE
+         zheatc  = 0.
+         zswnetc = 0.
+       ENDIF 
+       ICLD = 0   ! colonne sans nuages
+       CALL heating(dist,rmu0,fract,zheatp,zswnetp,icld)
 
 c inversion de l'axe vertical
-             do l=1,klev
-                do i=1,klon
-                   heat(i,l)=zheat(i,klev+1-l)
-                enddo
-             enddo
-             do l=1,klev+1
-                do i=1,klon
-                   swnet(i,l)=zswnet(i,klev+2-l)
-                enddo
-             enddo
+       do l=1,klev
+         do i=1,klon
+           heat(i,l)=zheatc(i,klev+1-l)*xnuf +
+     &               zheatp(i,klev+1-l)*(1.-xnuf)
+         enddo
+       enddo
+       do l=1,klev+1
+         do i=1,klon
+           swnet(i,l)=zswnetc(i,klev+2-l)*xnuf +
+     &                zswnetp(i,klev+2-l)*(1.-xnuf)
+         enddo
+       enddo
 
       solsw = swnet(:,1)
@@ -146,17 +160,35 @@
       print*,'On calcule le rayonnement LW'
 
-      CALL cooling(klev+1,zp,zt,zz,zcool,zlwnet,sollwdown)
+       IF (clouds.eq.1) THEN
+         ICLD = 1
+         CALL cooling(klon,klev+1,zp,zt,zz,zcoolc,zlwnetc,zsollwdownc,
+     &   icld)
+       ELSE
+         zcoolc      = 0.
+         zlwnetc     = 0.
+         zsollwdownc = 0.
+       ENDIF
+       ICLD = 0
+       CALL cooling(klon,klev+1,zp,zt,zz,zcoolp,zlwnetp,zsollwdownp,
+     & icld)
 
 c inversion de l'axe vertical
-             do l=1,klev
-                do i=1,klon
-                   cool(i,l)=zcool(i,klev+1-l)
-                enddo
-             enddo
-             do l=1,klev+1
-                do i=1,klon
-                   lwnet(i,l)=zlwnet(i,klev+2-l)
-                enddo
-             enddo
+       do l=1,klev
+         do i=1,klon
+           cool(i,l)=zcoolc(i,klev+1-l)*xnuf +
+     &               zcoolp(i,klev+1-l)*(1.-xnuf)
+         enddo
+       enddo
+       do l=1,klev+1
+         do i=1,klon
+           lwnet(i,l)=zlwnetc(i,klev+2-l)*xnuf +
+     &                zlwnetp(i,klev+2-l)*(1.-xnuf)
+         enddo
+       enddo
+   
+       do i=1,klon
+         sollwdown(i)=zsollwdownc(i)*xnuf +
+     &                zsollwdownp(i)*(1.-xnuf)
+       enddo
 
       sollw  = -lwnet(:,1)
Index: trunk/LMDZ.TITAN/libf/phytitan/radtitan.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/radtitan.F	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/radtitan.F	(revision 175)
@@ -81,47 +81,11 @@
 c   ---------------------------------------------
 
-      REAL DTAUP(ngrid,NLAYER,NSPECI)
-      REAL UBARI,UBARV,UBAR0
       REAL DZED(NLAYER)
       REAL Z(NLEVEL),PRESS(NLEVEL),DEN(NLEVEL),TEMP(NLEVEL)
-      REAL  DTDP(NLAYER),CONVEQ
       REAL  CH4(NLEVEL),XN2(NLEVEL),H2(NLEVEL),AR(NLEVEL)
       REAL  XMU(NLEVEL),GAS1(NLAYER),COLDEN(NLAYER)
       REAL  C2H2(NLAYER),C2H6(NLAYER),HCN(NLAYER)
-      REAL  SOLARF(NSPECV),PEXPON(NSPECV),ATERM(4,NSPECV) 
-      INTEGER NTERM(NSPECV) 
-      REAL  BTERM(4,NSPECV)
-      REAL  RADIUS(NLAYER), XNUMB(NLAYER),REALI(NSPECI), XIMGI(NSPECI)
-      REAL  REALV(NSPECV), XIMGV(NSPECV)
-      REAL  RADCLD(NLAYER), XNCLD(NLAYER),RCLDI(NSPECI),  XICLDI(NSPECI)
-      REAL  RCLDV(NSPECV),  XICLDV(NSPECV)
-      REAL  TAUHI(ngrid,NSPECI),TAUCI(ngrid,NSPECI)
-      REAL  TAUGI(ngrid,NSPECI), TAUGV(ngrid,NSPECV)
-      REAL  TAURV(ngrid,NSPECV),TAUHV(ngrid,NSPECV)
-      REAL  TAUCV(ngrid,NSPECV)
-c
-      REAL  DTAUI(ngrid,NLAYER,NSPECI)
-      REAL  TAUI(ngrid,NLEVEL,NSPECI)
-      REAL  WBARI(ngrid,NLAYER,NSPECI)
-      REAL  COSBI(ngrid,NLAYER,NSPECI)
-      REAL  BWNI(NSPC1I),WNOI(NSPECI)
-      REAL  WLNI(NSPECI),DWNI(NSPECI)
-c
-      REAL DTAUV(ngrid,NLAYER,NSPECV,4)
-      REAL TAUV(ngrid,NLEVEL,NSPECV,4)
-      REAL WBARV(ngrid,NLAYER,NSPECV,4) 
-      REAL COSBV(ngrid,NLAYER,NSPECV,4) 
-      REAL BWNV(NSPC1V), WNOV(NSPECV),DWNV(NSPECV), WLNV(NSPECV)
-      REAL FNETV(ngrid,NLEVEL),FUPV(ngrid,NLEVEL,NSPECV)  
-      REAL FDV(ngrid,NLEVEL,NSPECV),FMNETV(ngrid,NLEVEL)
-      REAL FMUPV(NLEVEL),FMDV(NLEVEL)
-      REAL FNET(ngrid,NLEVEL),FMNET(ngrid,NLEVEL)
-      REAL THEAT(ngrid,NLAYER)
-      REAL CSUBP,RSFI,RSFV,F0PI
       REAL  RHCH4,FH2,FHAZE,FHVIS,FHIR,TAUFAC,RCLOUD,FARGON
-      REAL RGAS,RHOP,PII,SIGMA
-      REAL TIDAL
-
-      COMMON /IRTAUS/ DTAUP
+      REAL RGAS,RHOP,PI,SIGMA
 
       COMMON /VERTICAL/ DZED
@@ -129,8 +93,4 @@
       COMMON /ATM/ Z,PRESS
      &            ,DEN,TEMP
-
-      COMMON /LAPSE/ DTDP,CONVEQ
-      COMMON /UBARED/ UBARI,UBARV,UBAR0
-
 
 
@@ -143,68 +103,7 @@
       COMMON /STRAT2/ HCN
 
-      COMMON /VISGAS/ SOLARF,NTERM
-     &               ,PEXPON,ATERM
-     &               ,BTERM
-
-      COMMON /AERSOL/ RADIUS, XNUMB
-     &               ,REALI, XIMGI
-     &               ,REALV, XIMGV
-
-      COMMON /CLOUD/ RADCLD, XNCLD
-     &             , RCLDI,  XICLDI
-     &             , RCLDV,  XICLDV
-
-      COMMON /TAUS/   TAUHI,TAUCI,
-     &                TAUGI, TAUGV,
-     &                TAURV,TAUHV,
-     &                TAUCV
-
-*     INFRARED  CHARACTERISTICS
-*------------------------------
-
-
-      COMMON /SPECTI/ BWNI,WNOI
-     &               ,DWNI,WLNI
-
-      COMMON /OPTICI/ DTAUI, 
-     &                TAUI,
-     &                WBARI, 
-     &                COSBI
-
-
-
-*     VISIBLE  CHARACTERISTICS
-*------------------------------
- 
-
-
-      COMMON /OPTICV/ DTAUV
-     &               ,TAUV
-     &               ,WBARV
-     &               ,COSBV
-
-      COMMON /SPECTV/ BWNV, WNOV
-     &               ,DWNV, WLNV
-
-      COMMON /FLUXvV/ FNETV,     
-     &               FUPV,
-     &               FDV, 
-     &               FMNETV
-
-      COMMON /FLUX/  FNET,      FMNET
-     &              ,THEAT
-
-
-      COMMON /PLANT/ CSUBP,RSFI,RSFV,F0PI
       COMMON /ADJUST/ RHCH4,FH2,FHAZE,FHVIS,FHIR,TAUFAC,RCLOUD,FARGON
-      COMMON /CONST/RGAS,RHOP,PII,SIGMA
-      COMMON /IO/ TIDAL
-
-* nrad dans microtab.h
-      REAL volume(nrad),rayon(nrad),vrat,
-     &      drayon(nrad),dvolume(nrad)
-
-      common/part/volume,rayon,vrat,
-     &      drayon,dvolume
+      COMMON /CONST/RGAS,RHOP,PI,SIGMA
+
 c-----------------------------------------------------------------------
 c   1. Initialisations:
@@ -368,13 +267,4 @@
       print*,'On sort de optci'
 
-C THIS ROUTINE HAS ALREADY SET THE DTAUI(J,K) VALUES BUT MUST BE PASSED
-        DO 225 IG=1,klon
-         DO 220 J=1,NLAYER
-          DO 230 K=1,NSPECI
-              DTAUP(IG,J,K)=DTAUI(IG,J,K)
-230       CONTINUE
-220      CONTINUE
-225     CONTINUE
-
 C  NOW, THIS COMPUTATION IS DONE FOR EACH VALUE OF klon
 C  INFRARED. AND THEN IN THE VISIBLE.
@@ -397,15 +287,8 @@
 c on ne recalcule pas optci si microfi=0 et compo lellouch
 c -----------------------------
-      IF ((MICROFI.eq.1).or.(.not.ylellouch)) THEN  
+      IF ((MICROFI.ge.1).or.(.not.ylellouch)) THEN  
       IF(notfirstcall)    THEN  !F au 1er appel   T aux autres appels!!
        print*,'aerosol/gas/cloud properties'
        CALL OPTCI(ycomp,qaer,nmicro,IPRINT)        ! #1
-        DO  IG=1,klon
-         DO  J=1,NLAYER
-          DO  K=1,NSPECI
-              DTAUP(IG,J,K)=DTAUI(IG,J,K)
-          ENDDO
-         ENDDO
-        ENDDO
       ENDIF
       ENDIF
@@ -413,5 +296,5 @@
 c ni optcv si microfi=0
 
-      IF (MICROFI.eq.1) THEN  
+      IF (MICROFI.ge.1) THEN  
       IF(notfirstcall)    THEN  !F au 1er appel   T aux autres appels!!
        print*,'aerosol/gas/cloud properties'
Index: trunk/LMDZ.TITAN/libf/phytitan/sfluxv.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/sfluxv.F	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/sfluxv.F	(revision 175)
@@ -1,3 +1,3 @@
-      SUBROUTINE SFLUXV(IPRINT,IG,dist_sol)
+      SUBROUTINE SFLUXV(IPRINT,IG,dist_sol,icld)
 
       use dimphy
@@ -10,5 +10,5 @@
       PARAMETER (ngrid=(jjm-1)*iim+2)  ! = klon
 c
-      INTEGER NLAYER,NLEVEL,NSPECV,NSPC1V
+      INTEGER NLAYER,NLEVEL,NSPECV,NSPC1V,icld
       PARAMETER (NLAYER=llm,NLEVEL=NLAYER+1)
       PARAMETER (NSPECV=24,NSPC1V=25)
@@ -24,4 +24,8 @@
      &     ,WBARV(ngrid,NLAYER,NSPECV,4) 
      &     ,COSBV(ngrid,NLAYER,NSPECV,4)
+     &     ,DTAUVP(ngrid,NLAYER,NSPECV,4)
+     &     ,TAUVP(ngrid,NLEVEL,NSPECV,4)
+     &     ,WBARVP(ngrid,NLAYER,NSPECV,4)
+     &     ,COSBVP(ngrid,NLAYER,NSPECV,4)
       REAL BWNV(NSPC1V),WNOV(NSPECV)
      &     ,DWNV(NSPECV),WLNV(NSPECV)
@@ -43,4 +47,8 @@
      &                ,WBARV 
      &                ,COSBV
+     &                ,DTAUVP
+     &                ,TAUVP
+     &                ,WBARVP
+     &                ,COSBVP
 
       COMMON /SPECTV/ BWNV,WNOV
@@ -86,5 +94,9 @@
 C LOOP OVER THE NTERMS BEGINING HERE
       DO 912 NT=1,NTERM(K)
-      BSURF=0.+ RSFV*UBAR0*F0PI*EXP(-TAUV(ig,NLEVEL,K,NT)/UBAR0)
+      IF (ICLD.eq.1) THEN
+        BSURF=0.+ RSFV*UBAR0*F0PI*EXP(-TAUV(ig,NLEVEL,K,NT)/UBAR0)
+      ELSE
+        BSURF=0.+ RSFV*UBAR0*F0PI*EXP(-TAUVP(ig,NLEVEL,K,NT)/UBAR0)
+      ENDIF
 C
 C* WE CAN NOW SOLVE FOR THE COEFFICIENTS OF THE TWO STREAM
@@ -99,12 +111,22 @@
 C  USE DT0,T0,WB0,CO0 INSTEAD OF DTAUV(ig,1,K,NT)..etc...
 
-       DO  J=1,NLAYER        
-             DT0(J)=DTAUV(ig,J,K,NT)
-             T0(J) =TAUV(ig,J,K,NT)
-             WB0(J)=WBARV(ig,J,K,NT)
-             CO0(J)=COSBV(ig,J,K,NT)
-       ENDDO
+       IF (ICLD.EQ.1) THEN
+         DO  J=1,NLAYER        
+           DT0(J)=DTAUV(ig,J,K,NT)
+           T0(J) =TAUV(ig,J,K,NT)
+           WB0(J)=WBARV(ig,J,K,NT)
+           CO0(J)=COSBV(ig,J,K,NT)
+         ENDDO
+         T0(NLEVEL)=TAUV(ig,NLEVEL,K,NT)
+       ELSE
+         DO  J=1,NLAYER        
+           DT0(J)=DTAUVP(ig,J,K,NT)
+           T0(J) =TAUVP(ig,J,K,NT)
+           WB0(J)=WBARVP(ig,J,K,NT)
+           CO0(J)=COSBVP(ig,J,K,NT)
+         ENDDO
+         T0(NLEVEL)=TAUVP(ig,NLEVEL,K,NT)
 
-             T0(NLEVEL)=TAUV(ig,NLEVEL,K,NT)
+       ENDIF
 
 c       PRINT*,'entree gfluxv #: ',ig,K
Index: trunk/LMDZ.TITAN/libf/phytitan/snuages3D.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/snuages3D.F	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/snuages3D.F	(revision 175)
@@ -0,0 +1,1681 @@
+         subroutine snuages(ngrid,tab1,tab2,tab3,tab4,tab5,
+     &   x1,xnz,xnrad,ihor,fluxi,taused,precip)
+
+!*
+!
+!1   c quantite de noyaux  de la grille de rayon r a l'altitude z 
+!2   c quantite de glace 1 de la grille de rayon r a l'altitude z 
+!3   c quantite de glace 2 de la grille de rayon r a l'altitude z 
+!4   c quantite de glace 3 de la grille de rayon r a l'altitude z 
+!5   c quantite d'aerosols de la grille de rayon r a l'altitude z 
+c
+c
+!x1  timestep.
+
+c    Notes : taused n'est actuellement pas calculé !
+c    taused = dz/vitesse(z)
+c
+c
+*--------------------------------------------------------------*
+*                                                               *
+*             ENTRE 0 ET 1000 KILOMETRES                        *     
+*                                                               * 
+*     la dimension fractale est en tableau, attention au        *
+*     raccordement entre le regime moleculaire et le regime     *
+*     fluide                                                    *
+*                                                               *
+*     Modele microphysique:    Cabane et al.,1992 /             *
+*     Modele version fractale: Cabane et al.,1993 /             *
+*                                                               *
+*--------------------------------------------------------------*
+*  VERSION DU 2 JUIN 1993  --- AUT 1994 --- 11/04/96
+*
+*  changer: altitude de production z0=/taux de production ctot= 
+*         : la charge/micron, ne
+*         : df(h),rf... 
+*  raccordement aknc 
+*
+*  declaration des blocs communs
+*------------------------------
+
+         use dimphy          
+         IMPLICIT NONE
+#include  "dimensions.h"
+#include  "microtab.h"
+#include  "varmuphy.h"
+
+         common/x2ctps/li,lf,dt
+         common/x2con/c,c1,c2,c3,caer
+         common/cldpart/rad,mmu
+         common/x2frac/rfg,dfg
+         common/x2effets/ xsaison
+
+  
+*  declaration des variables communes
+*  ----------------------------------
+
+         integer xnz,xnrad,ngrid
+         integer i,j,k,ihor,ibidon
+         integer ihormx,imx
+         integer li,lf
+         real xsaison
+         real dt
+         real c(nz,nrad,2)
+         real c1(nz,nrad,2),c2(nz,nrad,2)
+         real c3(nz,nrad,2)
+         real caer(nz,nrad,2)
+         real rad(nz,nrad), mmu(nz,nrad)
+         real rtemp(nz,nrad),mmutemp(nz,nrad)
+         real knu,knu2,w
+         real rfg(nz),dfg(nz,nrad)
+         real ddt,dtau,vitesse2
+         real vmax,vmin,rmax,rmin
+         real fluxi(ngrid,nz,3)
+         real taused(ngrid,nz)
+         real precip(ngrid,5)
+         real rmx
+
+
+*   variables internes
+*   ------------------
+
+         integer h,ti,itime,icoal
+         real tab1(nz,nrad),tab2(nz,nrad),
+     &        tab3(nz,nrad),tab4(nz,nrad)
+         real tab5(nz,nrad)
+         real x1,xvolume,xmasse,xnoyaux 
+         real knd1,knd2,knd3,knd4,knd5,knd6
+
+         real dice1,dice2,dice3,dice4
+
+          data itime/0/
+          data icoal/0/
+          save itime,icoal
+          save vmax,vmin,rmax,rmin
+
+
+*  controles
+*  ---------
+
+         if (nrad.ne.xnrad)  stop 'nrad.ne.xnrad'
+         if (nz.ne.xnz)      stop 'nz.ne.xnz'
+
+         do i=1,nz
+           do j=1,nrad 
+             c(i,j,1)=tab1(i,j)
+             c(i,j,2)=0.0 
+             c1(i,j,1)=tab2(i,j)
+             c1(i,j,2)=0.0
+             c2(i,j,1)=tab3(i,j)
+             c2(i,j,2)=0.0 
+             c3(i,j,1)=tab4(i,j)
+             c3(i,j,2)=0.0 
+             caer(i,j,1)=tab5(i,j)
+             caer(i,j,2)=0.0 
+           enddo 
+         enddo 
+
+
+*  initialisation
+*  --------------
+
+*  Parametres physiques de Titan 
+  
+         if (itime.eq.0) then 
+           call init2
+           print*,'init2 dans snuages.F'
+           itime=1
+         endif
+
+         aknc=2.92         !<--------Df=3
+
+*  Propriete des gouttes nuageuses/ calculee ici pour la sedimentation
+*  r(i,j)=r  (cst pour la colonne). Cela evite les accumulations dans
+*  certains niveaux du a des differences de vitesse de sedimentation...
+
+*  ATTENTION, CES DEFINITIONS SONT INTERNES/ VOIR MUPHYS.F POUR DEFINITIONS
+*  EXTERNES (UTILISEES DANS OPTCV ET OPTCI, PAR EX.)
+
+         do i=1,nz
+           xnoyaux=0.
+           xvolume=0.
+           xmasse=0.
+           do j=1,nrad
+             dfg(i,j)=3.00
+             rfg(j)=6.6e-8     !<--- arbitraire pour df=3
+             xnoyaux=xnoyaux+c(i,j,1)
+             xvolume=xvolume+c1(i,j,1)+c2(i,j,1)+c3(i,j,1)+
+     &       v_e(j)*c(i,j,1)
+             xmasse =xmasse+
+     &       c1(i,j,1)*rhoi_ch4+
+     &       c2(i,j,1)*rhoi_c2h6+
+     &       c3(i,j,1)*rhoi_c2h2+ 
+     &       v_e(j)*c(i,j,1)*rhol
+           enddo
+
+           do j=1,nrad
+
+             if (xnoyaux .le. 1.e-25 .or. xvolume.eq.0.) then   !  utile ?
+               dfg(i,j)=3.00
+               rtemp(i,j) =  1.e-9
+               mmutemp(i,j)= rhol     !on prend la masse vol des aerosols
+             else
+c         Mais pourquoi se compliquer la vie alors que de toute facon on 
+c         reforce la masse volumique a son veritable calcul ^^
+c
+               if ((c1(i,j,1)+c2(i,j,1)+c3(i,j,1))/xvolume.le.0.1) then !  glace / total  
+                 dfg(i,j)=3.00
+                 rtemp(i,j) = ( (xvolume/xnoyaux)*0.75/pi)**(1./3.)
+c                 mmutemp(i,j) = 1000.
+                 mmutemp(i,j)= xmasse/xvolume 
+                 if(rtemp(i,j).gt.3.e-4) rtemp(i,j)=3.e-4
+               else
+                 dfg(i,j)=3.00
+                 rtemp(i,j) = ( (xvolume/xnoyaux)*0.75/pi)**(1./3.)
+                 mmutemp(i,j)= xmasse/xvolume 
+                 if(rtemp(i,j).gt.3.e-4) rtemp(i,j)=3.e-4
+               endif
+             endif
+           enddo
+         enddo
+
+         do i=1,nz
+           do j=1,nrad
+             rad(i,j)=rtemp(i,1)   ! mm valeur qqsoit j
+             mmu(i,j)=mmutemp(i,1)
+           enddo
+         enddo
+
+
+*  Coefficients de coagulation
+
+         if (icoal.eq.1) call calcoag2             ! 2 <-- 1
+         vmin=1.e+6
+         vmax=0.
+         rmin=1.e+6
+         rmax=0.
+         ihormx=1
+         imx=1
+
+
+*  choix interne du temps d iteration
+*  ----------------------------------
+
+         dt=x1
+
+*  iteration du modele sur le temps
+*  ---------------------------------
+
+         li=1  
+         lf=2
+
+*  li=1  lf=2
+
+         call sedifn_fast(ihor,dice1,dice2,dice3,dice4) ! 1 <-- 1
+!        call sedifn                                 ! 2 <-- 1
+
+         li=3-li         ! li devient 2
+         lf=3-lf         ! lf devient 1
+
+         if (icoal.eq.1) then 
+*  li=2  lf=1
+           call coagul2(ihor)                          ! 1 <-- 2
+
+           li=3-li         ! li devient 1
+           lf=3-lf         ! lf devient 2
+
+         endif
+
+         do i=1,nz
+           vmin=vitesse2(i,1,1)
+           do j=1,nrad
+             fluxi(ihor,nz+1-i,1)=fluxi(ihor,nz+1-i,1)
+     &             -vmin*c1(i,j,li)*rhoi_ch4 
+             fluxi(ihor,nz+1-i,2)=fluxi(ihor,nz+1-i,2)
+     &            -vmin*c2(i,j,li)*rhoi_c2h6
+             fluxi(ihor,nz+1-i,3)=fluxi(ihor,nz+1-i,3)
+     &            -vmin*c3(i,j,li)*rhoi_c2h2
+           enddo
+         enddo
+  
+c        En theorie, les diceX sont NEGATIF (en sedimentant on ne fait que perdre de la glace)
+c        Le precipitations sont comptées positivement.
+         precip(ihor,1)=-dice1/rhoi_ch4     ! m3/m2 = m :)
+         precip(ihor,2)=-dice2/rhoi_c2h6
+         precip(ihor,3)=-dice3/rhoi_c2h2
+         precip(ihor,4)=-dice4/rhol
+
+         do i=1,nz
+           do j=1,nrad
+             tab1(i,j)=c(i,j,li)      ! li=1
+             tab2(i,j)=c1(i,j,li)     ! li=1
+             tab3(i,j)=c2(i,j,li)     ! li=1
+             tab4(i,j)=c3(i,j,li)     ! li=1
+           enddo
+         enddo 
+
+         return  
+
+         end 
+
+
+
+*______________________________________________________________________
+
+         real function lambda2(j,indic)
+*
+*------------------------------------------------------------------*
+*   fonction calculant le libre parcours moyen des molecules        *
+*   atmospheriques( rayon =ra) se trouvant dans la couche no j.     *
+*   pour indic=0  ...... la particule se trouve a la frontiere entre*
+*                         les couches j et j-1                      *
+*   pour indic=1  ...... la particule se trouve au milieu de la     *
+*                          la couche j                              *
+*------------------------------------------------------------------*
+*
+*  declaration des blocs communs
+*------------------------------
+         use dimphy
+         IMPLICIT NONE
+#include  "dimensions.h"
+#include  "microtab.h"
+#include  "varmuphy.h"
+
+         common/x2frac/rfg,dfg
+
+*  declaration des variables communes
+*  ----------------------------------
+
+         real rfg(nz),dfg(nz,nrad)
+
+*   declaration des variables internes
+*   ----------------------------------
+
+         integer indic,j
+         real pp,ra
+
+         ra=1.75e-10
+
+*  traitement
+*  ----------
+
+         if (indic.eq.0) then
+           pp=pb(j)
+         else
+           if (indic.ne.1) then
+             print*,'erreur argument fonction lambda'
+             stop 
+           endif
+           pp=p(j)
+         endif
+
+         lambda2=kbz*t(j)/(4*sqrt(2.)*pi*(ra**2)*pp)
+         end
+
+*******************************************************************************
+
+         real function knu2(j,k,indic)
+*
+*--------------------------------------------------------------*
+*   fonction calculant le nombre de knudsen d'une particule    *
+*   d'aerosol de rayon rad(k) se trouvant dans la couche no j    *
+*   indic ......  idem function lambda                         *
+*--------------------------------------------------------------*
+*
+*  declaration des blocs communs
+*------------------------------
+         use dimphy
+         IMPLICIT NONE
+#include  "dimensions.h"
+#include  "microtab.h"
+#include  "varmuphy.h"
+
+         common/cldpart/rad,mmu
+         common/x2frac/rfg,dfg
+
+
+*  declaration des variables communes
+*  ----------------------------------
+
+         real rad(nz,nrad),mmu(nz,nrad)
+         real rfg(nz),dfg(nz,nrad)
+
+
+*   declaration des variables internes
+*   ----------------------------------
+
+         integer indic,j,k 
+         real  lambda2,rfk
+
+*  traitement
+*  ----------
+
+         if (indic.ne.0 .and.indic.ne.1) then
+           print*,'erreur argument fonction knu'
+           stop 
+         endif
+    
+
+         rfk=(rad(j,k)**(3./dfg(j,k)))*((rfg(k))**(1.-3./dfg(j,k)))
+         knu2=lambda2(j,indic)/rfk
+ 
+         end
+
+*****************************************************************************
+
+         real function nud2(j,indic)
+*
+*--------------------------------------------------------------*
+*   fonction calculant la viscosite dynamique (en USI) de l air *
+*   d apres la formule de Sutherlant a l altitude j             *
+*   indic  ......... idem fonction lambda                       *
+*--------------------------------------------------------------*
+*
+         use dimphy 
+         IMPLICIT NONE
+#include  "dimensions.h"
+#include  "microtab.h"
+#include  "varmuphy.h"          
+         integer indic,j
+         real nud0,c,tt
+         real rfg(nz),dfg(nz,nrad)
+
+         common/x2frac/rfg,dfg
+
+*
+         nud0=1.74e-5
+         c=109.
+
+         if(indic.ne.0.and.indic.ne.1) then
+           print*,'erreur argument fonction nud'
+           stop 
+         endif
+
+         if (indic.eq.0) tt=tb(j)
+         if (indic.eq.1) tt=t(j)
+         nud2=nud0*sqrt(tt/293)*(1+c/293)/(1+c/tt)
+         end
+
+****************************************************************************
+
+         real function vitesse2(j,k,indic)
+*
+*-----------------------------------------------------------------*
+*   fonction calculant la vitesse de chute d une particule de rayon*
+*   k se trouvant a l altitude j  suivant la valeur du nombre de   *
+*    Knudsen                                                       *
+*   indic ....... idem function lambda                             *
+*-----------------------------------------------------------------*
+*
+
+*  declaration des blocs communs
+*------------------------------
+         use dimphy
+         IMPLICIT NONE
+#include  "dimensions.h"
+#include  "microtab.h"
+#include  "varmuphy.h"          
+         common/cldpart/rad,mmu
+         common/x2frac/rfg,dfg
+         common/x2ctps/li,lf,dt
+
+*  declaration des variables communes
+*  ----------------------------------
+
+         real rad(nz,nrad),mmu(nz,nrad)
+         real rfg(nz),dfg(nz,nrad)
+
+
+*   declaration des variables internes
+*   ----------------------------------
+
+         integer indic,j,k,li,lf
+         real w,g,m,a0,zz,knu2,nud2,knud,tt,rhoh
+         real vlimite,akncx,rbis,rfk
+         real dt
+
+*   traitement
+*   ----------
+
+         if (indic.ne.0.and.indic.ne.1) then
+           print*,'erreur argument fonction vitesse'
+           stop 
+         endif
+
+         if(indic.eq.0) then
+           zz=z(j)+dz(j)/2.
+           tt=tb(j)
+           rhoh=rhob(j)
+         endif
+         if(indic.eq.1) then
+            zz=z(j)
+            tt=t(j)
+            rhoh=rho(j)
+         endif
+
+         g=g0*(rtit/(rtit+zz))**2
+         a0=0.74
+         m=(ach4(j)*mch4+aar(j)*mar+an2(j)*mn2)/nav
+         knud=knu2(j,k,indic)
+
+c        akncx=aknc
+c        if(df(k).gt.2.5) akncx=2.7
+
+c        if(knud.ge.akncx) then
+c        rbis=(rad(j,k)**(3.-6./dfg(j,k)))*((rfg(k))**(-2.+6./dfg(j,k)))
+c        w=a0*g*rbis*mmu(j,k)/(rhoh*sqrt(8*kbz*tt/(pi*m)))
+c        endif
+
+          rfk=(rad(j,k)**(3./dfg(j,k)))*((rfg(k))**(1.-3./dfg(j,k)))
+          w=2./9.*rfk**(dfg(j,k)-1.)*rfg(k)**(3.-dfg(j,k))*g*mmu(j,k)
+     &       /nud2(j,indic)
+
+          w=w*(1+1.2517*knud+0.4*knud*exp(-1.1/knud))
+
+          w=w!*3.   ! on tient compte de la largeur de distribution... a affiner
+          vitesse2=w 
+
+         
+         end
+***********************************************************************
+         real function kd2(h)
+*
+*--------------------------------------------------------------------*
+*   cette fonction calcule le coefficient du terme de  eddy diffusion *
+*   a l altitude j                                                    *
+*--------------------------------------------------------------------*
+*
+         use dimphy
+         IMPLICIT NONE
+#include  "dimensions.h"
+#include  "microtab.h"
+#include  "varmuphy.h"
+
+         common/x2frac/rfg,dfg
+
+         real zbx
+         real rfg(nz),dfg(nz,nrad)
+
+         integer h
+
+         zbx=z(h)+dz(h)/2.
+         if(zbx.le.42000.) then
+c           kd2=1.64e+12*(pb(h)/(kbz*tb(h)))**(-1./2.)
+           kd2=4.
+         else
+           kd2=1.64e+12*(pb(h)/(kbz*tb(h)))**(-1./2.)
+           kd2=0.0*kd2
+         endif
+         kd2=00.
+
+
+         return
+         end
+
+
+*____________________________________________________________________________
+
+         subroutine init2
+*
+*--------------------------------------------------------------------*
+*   cette routine effectue  :                                         *
+*		1)  interpolation a partir des donnees initiales des  *
+*                    valeurs de p,t,rho,ach4,aar,an2  sur la grille   *
+*                2) initialisation des constantes (common/x2phys/)      *
+*	         3) initialisation des variables temporelles (common  *
+*                     /temps/)                                        *
+*                4) definition des grilles en rayon et verticale      *
+*                5)  initialisation de c(z,r,t) avec les donnees du   *
+*                      fichier unit=1                                 *
+*                                                                     *
+*   les donnees sont des valeurs caracterisques de l atmosphere de    *
+*     TITAN  ( voir Lelouch and co )                                  *
+*--------------------------------------------------------------------*
+
+*  declaration des blocs communs
+*------------------------------
+         use dimphy
+         IMPLICIT NONE
+#include  "dimensions.h"
+#include  "microtab.h"
+#include  "varmuphy.h"          
+         common/x2ctps/li,lf,dt
+         common/cldpart/rad,mmu
+
+*  declaration des variables communes
+*  ----------------------------------
+
+         integer li,lf
+         real dt
+         real rad(nz,nrad), mmu(nz,nrad)
+
+
+*  declaration des variables internes
+*  ----------------------------------
+         integer nzd,i,ii
+         parameter (nzd=254)
+         integer limsup,liminf,j1,j2
+         real zd(nzd),ach4d(nzd),rap
+         real m
+
+
+*  initialisation des variables temporelles
+*  ----------------------------------------
+
+         li=1
+         lf=2
+
+
+*  interpolation de xch4,xar et xn2 sur la grille
+*  ----------------------------------------------
+
+*  donnees initiales (Lellouch et al,87) 
+*  ------------------------------------- 
+
+c        print*,'****** init'
+         do 1 i=1,168
+           zd(i)=(1000.-5*(i-1))*1000.
+1        continue
+         do 2 i=1,78
+           zd(168+i)=(160.-2*(i-1))*1000.
+2        continue
+         do 3 i=1,4
+           zd(246+i)=(5.-(i-1))*1000.
+3        continue
+         do 4 i=1,4
+           zd(250+i)=(1.5-(i-1)*0.5)*1000.
+4        continue
+
+         data (ach4d(i),i=1,168)/168*1.5e-2/
+         data (ach4d(i),i=169,254)/63*1.5e-2,1.6e-2,1.8e-2,1.8e-2,
+     &   1.9e-2,2.e-2,2.1e-2,2.3e-2,2.5e-2,2.8e-2,3.1e-2,3.6e-2,
+     &   4.1e-2,4.7e-2,5.7e-2,6.7e-2,7.5e-2,7*8.e-2/
+
+         liminf=0
+         limsup=0
+
+*  interpolation des taux de melange de ch4,ar,n2  
+*-----------------------------------------------   
+
+         do 20 j1=1,nz
+           do 21 j2=1,nzd
+             if( zd(j2).le.z(j1)) goto 22
+21           continue
+22           liminf=j2
+             if (zd(liminf).eq.z(j1) )then
+               ach4(j1)=ach4d(liminf)
+               goto 20
+             endif
+             if (j2.ne.1) then
+               limsup=j2-1
+             else
+               limsup=j2
+             endif
+             if (limsup.eq.liminf) then
+               ach4(j1)=ach4(limsup)
+             else
+               ach4(j1)=ach4d(liminf)-(ach4d(limsup)-ach4d(liminf))/
+     s         (zd(limsup)-zd(liminf))*(zd(liminf)-z(j1))
+             endif
+20       continue
+
+*   rap= aar/an2  cst sur l altitude
+
+         rap=0.191
+         do 23 i=1,nz
+           an2(i)=(1.-ach4(i))/(1.+rap)
+           aar(i)=rap*an2(i)
+23       continue
+
+         do 24 i=1,nz
+           m=ach4(i)*mch4+an2(i)*mn2+aar(i)*mar
+           rho(i)=p(i)*m/(rgp*t(i))
+24       continue
+
+         do 34 i=1,nz
+           m=ach4(i)*mch4+an2(i)*mn2+aar(i)*mar
+           rhob(i)=pb(i)*m/(rgp*tb(i))
+c          print*,pb(i),m,rgp,tb(i),rhob(i),rho(i)
+34       continue
+
+*  fin d interpolation des taux de melange
+*----------------------------------------  
+
+c        print*,'**** fin init'
+540      continue
+         return
+
+500       print*,'erreur lecture initialisation de c...erreur=',ii
+          stop
+
+         end
+
+*__________________________________________________________________________
+
+         subroutine sedifn
+*
+*------------------------------------------------------------------*
+*   cette routine calcule l evolution de la fonction de distribution*
+*   c(z,r,t) pour les phenomenes de sedimentation et de diffusion   *
+*------------------------------------------------------------------*
+*
+*
+*  declaration des blocs communs
+*------------------------------
+         use dimphy
+         IMPLICIT NONE
+#include  "dimensions.h"
+#include  "microtab.h"
+#include  "varmuphy.h"          
+
+         common/x2ctps/li,lf,dt
+         common/x2con/ctmp,c1,c2,c3,caer
+         common/cldpart/rad,mmu
+         common/x2frac/rfg,dfg
+
+
+*  declaration des variables communes
+*  ----------------------------------
+
+         integer li,lf
+         real  dt
+         real  c(nz,nrad,2)
+         real  c1(nz,nrad,2)
+         real  c2(nz,nrad,2)
+         real  c3(nz,nrad,2)
+         real caer(nz,nrad,2)
+         real  ctmp(nz,nrad,2)
+         real  rad(nz,nrad),mmu(nz,nrad)
+         real rfg(nz),dfg(nz,nrad)
+
+
+*  declaration des variables internes
+*  ----------------------------------
+
+         real w,w1,dzbX,dc
+         integer i,j,k,ii,nb
+         double precision sigma,theta,hc,l,rap,cmp,wp 
+         double precision fs(nz+1),ft(nz+1)
+         real as(nz),bs(nz),cs(nz),ds(nz)
+         double precision asi(nztop:nz),bsi(nztop:nz),
+     &                    csi(nztop:nz)
+         double precision dsi(nztop:nz),xsol(nztop:nz)
+         real vitesse2,kd2
+
+         external dtridgl
+
+*  resolution
+*------------
+  
+         do 5 ii=1,4
+           do  k=1,nrad  
+             do  j=nztop,nz
+               if( ii.eq.1 ) c(j,k,li)=ctmp(j,k,li)
+               if( ii.eq.2 ) c(j,k,li)=c1(j,k,li)
+               if( ii.eq.3 ) c(j,k,li)=c2(j,k,li)
+               if( ii.eq.4 ) c(j,k,li)=c3(j,k,li)
+             enddo
+           enddo
+
+           do 10 k=1,nrad  
+             do 20 j=nztop,nz
+               if (j.eq.1) goto 20
+*  calcul de la vitesse corrigee
+
+               dzbX=(dz(j)+dz(j-1))/2.
+               w= -1*vitesse2(j,k,0)
+
+               if (kd2(j).ne.0.) then
+                 theta=0.5*(w*dzbX/kd2(j)+log(rho(j-1)/rho(j)))
+                 if (theta.ne.0) then
+                   sigma=1./dtanh(theta)-1./theta
+                 else
+                   sigma=1.
+                 endif
+               else
+                 sigma=1.
+               endif
+
+               if(c(j,k,li).eq.0.) then
+                 rap=10.
+               else
+                 rap=c(j-1,k,li)/c(j,k,li)
+                 if( rap.gt.10.) rap=10.
+                 if( rap.lt.0.1) rap=0.1
+               endif
+
+               if (rap.gt.0.9 .and. rap.lt.1.1) then
+                 w1=w
+               else
+                 if(w.ne.0) then
+                   hc=dzbX/dlog(rap)
+                   l=dzbX/(w*dt)*(dexp(-w*dt/hc)-1.)/(1.-rap)
+                   wp=w*1.d0
+                   cmp=dlog(-wp)+abs(sigma)*dlog(l)
+                   if (cmp.gt.38) then
+                     goto 20
+                   endif
+                   w1=-dexp(cmp)
+                 else
+                   w1=0.
+                 endif
+               endif
+
+*   calcul des flux aux interfaces
+
+
+               if (kd2(j).ne.0.) then
+                 if (theta.ne.0.) then
+                   ft(j)=(w1+log(rho(j-1)/rho(j))*kd2(j)/dzbX)/
+     &             (dexp(2.*theta)-1.)
+                   fs(j)=ft(j)*dexp(2.*theta)
+                 else
+                   ft(j)=kd2(j)/dzbX
+                   fs(j)=kd2(j)/dzbX
+                 endif
+               else
+                 if (w1.lt.0.)then
+                   ft(j)=-w1
+                   fs(j)=0.
+                 else
+                   ft(j)=0.
+                   fs(j)=w1
+                 endif
+               endif
+
+20           continue
+
+*  conditions aux limites pour les flux aux interfaces
+
+             fs(1)=0.
+             ft(1)=0.
+             fs(nz+1)=0.
+             ft(nz+1)=-w1
+
+*  calcul des coefficients de l equation discrete
+
+             do 21 j=nztop,nz
+               as(j)=-dz(j)/dt
+               bs(j)=-ft(j)
+               cs(j)=ft(j+1)+fs(j)-dz(j)/dt
+               ds(j)=-fs(j+1)
+               if ( cs(j).gt.0) goto 100
+21           continue
+
+*  cas explicite (mu=0) : calcul de la fonction c(z,r,t+1)
+
+             do 22 j=nztop,nz-1
+
+               if (j.eq.nztop) then
+                 dc=(cs(nztop)*c(nztop,k,li)+ds(nztop)
+     &                        *c(nztop+1,k,li))/as(nztop)
+                 c(nztop,k,lf)=dc
+                 goto 22
+               endif
+
+               dc=(bs(j)*c(j-1,k,li)+cs(j)*c(j,k,li)+ds(j)*c(j+1,k,li))
+     s            /as(j)
+               c(j,k,lf)=dc
+
+22           continue
+
+             dc=(bs(nz)*c(nz-1,k,li)+cs(nz)*c(nz,k,li))/as(nz)
+             c(nz,k,lf)=dc
+
+             if (nztop.ne.1) then
+               do 32 j=1,nztop-1
+                 c(j,k,lf)=c(j,k,li)
+32             continue
+             endif
+
+             goto 10
+
+100          continue
+
+*  cas implicite (mu=1) : calcul de la fonction c(z,r,t+1)
+
+             do 101 j=nztop,nz
+               asi(j)=ft(j)
+               bsi(j)=-(ft(j+1)+fs(j)+dz(j)/dt)
+               csi(j)=fs(j+1)
+               dsi(j)=-dz(j)/dt*c(j,k,li)
+101          continue
+
+*  inversion de la matrice tridiagonale 
+
+             nb=nz-nztop+1
+
+             call dtridgl(nb,asi,bsi,csi,dsi,xsol) 
+
+             do 102 j=nztop,nz
+               c(j,k,lf)=xsol(j)
+102          continue
+
+             if (nztop.ne.1) then
+               do 110 j=1,nztop-1
+                 c(j,k,lf)=c(j,k,li)
+110            continue
+             endif
+
+
+
+10         continue
+
+           do  k=1,nrad  
+             do  j=nztop,nz
+               if( ii.eq.1 ) ctmp(j,k,lf)=c(j,k,lf)
+               if( ii.eq.2 ) c1(j,k,lf)  =c(j,k,lf)
+               if( ii.eq.3 ) c2(j,k,lf)  =c(j,k,lf)
+               if( ii.eq.4 ) c3(j,k,lf)  =c(j,k,lf)
+             enddo
+           enddo
+
+5        continue
+
+         return
+
+         end
+
+*__________________________________________________________________________
+
+         subroutine sedifn_fast(ihor,dice1,dice2,dice3,dice4)
+*
+*------------------------------------------------------------------    *
+*   cette routine calcule l evolution de la fonction de distribution   *
+*   c(z,r,t) pour les phenomenes de sedimentation  {pas de diffusion}  *
+*   dice1 = delta glace CH4                                            *
+*   dice2 = delta glace C2H6                                           *
+*   dice3 = delta glace C2H2                                           *
+*   dice4 = delta Volume noyaux                                        *
+*------------------------------------------------------------------    *
+*
+*  declaration des blocs communs
+*------------------------------
+         use dimphy
+         IMPLICIT NONE
+#include  "dimensions.h"
+#include  "microtab.h"
+#include  "varmuphy.h"          
+
+         common/x2ctps/li,lf,dt
+         common/x2con/c,c1,c2,c3,caer
+         common/cldpart/rad,mmu
+         common/x2frac/rfg,dfg
+
+
+*  declaration des variables communes
+*  ----------------------------------
+
+         integer li,lf,i,j,k,ihor
+         integer jinf,jsup,jj,iiter
+         real dt
+         real c(nz,nrad,2)
+         real c1(nz,nrad,2)
+         real c2(nz,nrad,2)
+         real c3(nz,nrad,2)
+         real caer(nz,nrad,2)
+         real ci(nz,nrad,2)
+         real ci1(nz,nrad,2)
+         real ci2(nz,nrad,2)
+         real ci3(nz,nrad,2)
+         real rad(nz,nrad),mmu(nz,nrad)
+         real rfg(nz),dfg(nz,nrad)
+         real puit(nz)
+c ------ echange est decrit sur ngrid=klon mais peut etre utilisee 
+c        uniquement sur jjm+1
+         integer ngrid
+         parameter (ngrid=(jjm-1)*iim+2)  ! = klon
+         real echange(nz,nz,ngrid)
+         real bilan1,bilan2,bilan3,bilan4,bilan5
+         real bilan11,bilan12,bilan13,bilan14,bilan15
+         real compte,compte2,xepl
+         real dice1,dice2,dice3,dice4
+        
+
+
+*  declaration des variables internes
+*  ----------------------------------
+
+         real vitesse2,kd2
+         real w,ws,wi,zs,zi,alpha,v0,deltazs,deltazi
+         real zni,znip1,xcnt,ichx,arg1,arg2,xft,xf
+         real argexp,explim
+
+         save echange
+
+
+*  resolution
+*------------
+  
+
+         bilan1=0.
+         bilan2=0.
+         bilan3=0.
+         bilan4=0.
+         bilan5=0.
+         do  k=1,nrad  
+           do  j=nztop,nz
+             ci(j,k,li)=  c(j,k,li)*dzb(j)   ! li
+             ci1(j,k,li)=c1(j,k,li)*dzb(j)
+             ci2(j,k,li)=c2(j,k,li)*dzb(j)
+             ci3(j,k,li)=c3(j,k,li)*dzb(j)
+             bilan5=bilan5+ci(j,k,li)
+             bilan1=bilan1+ci1(j,k,li)
+             bilan2=bilan2+ci2(j,k,li)
+             bilan3=bilan3+ci3(j,k,li)
+             bilan4=bilan4+
+     &       ci(j,k,li)*4./3.*pi*rf(k)**3.*vrat_e**(k-imono)
+
+             ci(j,k,lf)= 0.                 ! lf
+             ci1(j,k,lf)=0.
+             ci2(j,k,lf)=0.
+             ci3(j,k,lf)=0.
+           enddo
+         enddo
+
+*  calcul de la matrice d echange 
+*----------------------------------------------------------------
+
+         do j=nztop,nz
+           do i=nztop,nz
+             echange(i,j,ihor)=0.
+           enddo
+         enddo
+
+         do 20 i=nztop,nz
+           puit(i)=0.
+           do 30 k=1,1 
+             xcnt=0.
+             ICHX=1         ! extrapolation 0: lineaire 1: exponentielle
+             IF(ICHX.eq.0  .or. ICHX.eq.2) THEN 
+               ws=vitesse2(i,k,0)
+               if(i.lt.nz) wi=vitesse2(i+1,k,0)
+               if(i.eq.nz) wi=vitesse2(i  ,k,1)
+               w=(ws+wi)/2.
+               zni  =zb(i)-w*dt
+               znip1=zb(i)-dzb(i)-w*dt
+             ENDIF
+
+             explim=30.
+
+             IF(ICHX.eq.1 .or.  ICHX.eq.2) THEN 
+               ws=vitesse2(i,k,0)
+               zs=zb(i)
+               wi=vitesse2(i,k,1)
+               zi=z(i)
+
+c              if(wi.eq.ws)  wi=ws/1.001   ! sinon ca plante !
+               if(abs(wi-ws)/wi .le. 1.e-3)  wi=ws/1.001   ! sinon ca plante !
+
+               if(wi.ne.0.) alpha= alog(ws/wi) /(zs-zi)
+               argexp=alpha*zs
+               if(argexp.lt.-explim) argexp=-explim
+               if(argexp.gt. explim) argexp=+explim
+               v0   = ws/exp(argexp)
+
+               argexp=alpha*zb(i)
+               if(argexp.lt.-explim) argexp=-explim
+               if(argexp.gt. explim) argexp=+explim
+               arg1=1.+v0*alpha*exp(argexp)*dt
+
+               argexp=alpha*(zb(i)-dzb(i))
+               if(argexp.lt.-explim) argexp=-explim
+               if(argexp.gt. explim) argexp=+explim
+               arg2=1.+v0*alpha*exp(argexp)*dt
+
+               iiter=0
+101            continue 
+
+               if (iiter.le.25) then
+                 if(arg1.le.0.  .or. arg2.le.0.) then 
+                   print*,ihor,i,iiter, 'ajustement vitesse',arg1,arg2
+                   print*,ws,wi,     ' w1 w2 anc valeurs'
+                   print*,alpha,     ' alpha anc valeurs'
+                   print*,rad(i,k),  'r(j,k)'
+                   print*,mmu(i,k),  ' mmu(j,k)'
+                   print*,t(i),      ' t(j,k)'
+                   print*,arg1,arg2, ' arg1 arg2 anc valeurs'
+                   arg2=1+(arg2-1.)/2.
+                   arg1=1+(arg1-1.)/2.
+                   iiter=iiter+1
+                   print*,arg1,arg2, ' arg1 arg2 nle valeurs'
+                   goto 101
+                 endif
+               else 
+                 stop 
+               endif
+
+               if(arg1.lt.0.) print*,'arg1:',arg1
+               if(arg2.lt.0.) print*,'arg2:',arg2
+
+               deltazs=-alog(arg1)/alpha
+               deltazi=-alog(arg2)/alpha
+
+               zni  =zb(i)+deltazs
+               znip1=zb(i)-dzb(i)+deltazi
+
+             ENDIF
+
+             if(zni.ne.znip1) xft=zni/(zni-znip1)
+             if(zni.eq.znip1 .and. zni.le.0.) xft=0.
+             if(zni.eq.znip1 .and. zni.gt.0.) then
+               xft=0.
+               print*,'zni..znip1', zni,znip1
+             endif
+
+*  Si des aerosols touchent le sol (zni < 0 )  alors on fixe
+*  le niveau a 0, et on elimine les aerosols correspondants
+*-----------------------------------------------------------
+
+             if(znip1 .lt. 0.) znip1=0.
+             if(zni   .lt. 0.) zni  =0.
+            
+             if(zni.le.0.  .and.  znip1 .le. 0.) then 
+c            print*,'voie 1 / disparition complete'
+               xft=0.
+               xf=1.
+               xcnt=xcnt+xf
+               puit(i)=puit(i)+xf
+             endif
+
+             if(zni.gt.0.  .and.  znip1 .le. 0.) then 
+c            print*,'voie 2 / disparitipon partielle'
+               xf=(1-xft)
+               xcnt=xcnt+xf
+               puit(i)=puit(i)+xf
+             endif
+
+             if(zni.gt.0.  .and.  znip1 .gt. 0.) then 
+c            print*,'voie 3 / pas de disparition'
+               xft=1.
+               xf=(1-xft)
+               xcnt=xcnt+xf
+               puit(i)=puit(i)+xf
+             endif
+
+             jsup=nz+1
+             jinf=nz+1
+             do j=nztop,nz
+               if(zni.le.zb(j)  .and. zni.ge.zb(j)-dzb(j))   jsup=j
+               if(znip1.le.zb(j).and. znip1.ge.zb(j)-dzb(j)) jinf=j
+             enddo
+             if(zni   .ge. 0. .and. zni   .lt. 1.e-3)   jsup=nz
+             if(znip1 .ge. 0. .and. znip1 .lt. 1.e-3)   jinf=nz
+           
+
+*  Volume inclu dans un seul niveau
+*----------------------------------
+  
+             if (jsup .eq. jinf. and. jsup.ge. nz+1) then 
+               xcnt=xcnt+1.
+               print*,'cas impossible'
+               print*,'alpha= ',alpha
+               print*,'ws wi ',ws,wi
+               print*,'deltazs deltazi ',deltazs,deltazi 
+               print*,' r(i,k) mmu(i,k)', rad(i,k),mmu(i,k)
+               print*,' t(j,k)',t(i)
+               print*,zni,znip1,jsup,jinf
+               print*,'STOP'
+               STOP
+             endif
+
+             if (jsup .eq. jinf. and. jsup.le. nz) then 
+               xf=1.
+               xcnt=xcnt+xft*xf
+               if(jinf.le.nz) then 
+                 echange(jinf,i,ihor)=echange(jinf,i,ihor)+xft*xf
+               endif
+             endif
+
+*  Volume a cheval sur 2  niveaux
+*--------------------------------
+
+             if (jinf .eq. jsup+1) then
+               xf=(zni-zb(jsup)+dzb(jsup))/(zni-znip1)
+               xcnt=xcnt+xf*xft
+               if(jsup.le.nz) then 
+                 echange(jsup,i,ihor)=echange(jsup,i,ihor)+xft*xf
+               endif
+               xf=(zb(jinf)-znip1)/(zni-znip1)
+               xcnt=xcnt+xf*xft
+               if(jinf.le.nz) then 
+                 echange(jinf,i,ihor)=echange(jinf,i,ihor)+xft*xf
+               endif
+             endif
+
+*  Volume a cheval sur 3 ou plus de niveaux
+*------------------------------------------
+
+             if (jinf .gt. jsup+1) then
+
+c             print*,' voie C / dans N  cases'
+               xf=(zni-zb(jsup)+dzb(jsup))/(zni-znip1)
+               xcnt=xcnt+xf*xft
+               if(jsup.le.nz) then 
+                 echange(jsup,i,ihor)=echange(jsup,i,ihor)+xft*xf
+               endif
+
+               xf=(zb(jinf)-znip1)/(zni-znip1)
+               xcnt=xcnt+xf*xft
+               if(jinf.le.nz) then 
+                 echange(jinf,i,ihor)=echange(jinf,i,ihor)+xft*xf
+               endif
+
+               do jj=jsup+1,jinf-1
+                 xf=(zb(jj)-zb(jj+1))/(zni-znip1)
+                 xcnt=xcnt+xf*xft
+                 if(jj.le.nz) then 
+                   echange(jj,i,ihor)=echange(jj,i,ihor)+xft*xf
+                 endif
+               enddo
+
+             endif 
+
+
+*  et sur les rayons...
+*---------------------
+30         continue
+
+*  fin de la grande boucle sur les altitudes...
+*----------------------------------------------
+20       continue
+
+*  Calcul etat final     Cfinal = Echange*initial 
+*----------------------------------------------
+
+         compte=0.
+         compte2=0.
+         do  j=1,nz
+           xepl=0.
+           do  jj=1,nz
+             xepl=xepl+echange(jj,j,ihor)
+             compte=compte+echange(jj,j,ihor)
+             compte2=compte2+echange(jj,j,ihor)
+           enddo
+           compte2=compte2+puit(j)
+         enddo
+  
+         if(abs(compte2-nz) .gt. 1.e-4) 
+     &   print*,'Matrice calculee#',ihor,'tx d expl (/55):',
+     &   compte,compte2 
+
+
+*  Fin du calcul de la matrice d*echange
+*----------------------------------------------
+
+         do  j=nztop,nz
+           do k=1,nrad
+
+             do  jj=nztop,nz
+               ci(j,k,lf)=ci(j,k,lf)+
+     &         echange(j,jj,ihor)*ci(jj,k,li)
+               ci1(j,k,lf)=ci1(j,k,lf)+
+     &         echange(j,jj,ihor)*ci1(jj,k,li)
+               ci2(j,k,lf)=ci2(j,k,lf)+
+     &         echange(j,jj,ihor)*ci2(jj,k,li)
+               ci3(j,k,lf)=ci3(j,k,lf)+
+     &         echange(j,jj,ihor)*ci3(jj,k,li)
+             enddo
+           enddo
+         enddo
+
+
+*  Controles et affichage Bilan
+*----------------------------------------------
+  
+         bilan11=0.
+         bilan12=0.
+         bilan13=0.
+         bilan14=0.
+         bilan15=0.
+         do  k=1,nrad  
+           do  j=nztop,nz
+             c(j,k,lf) =ci(j,k,lf)/dzb(j)
+             c1(j,k,lf)=ci1(j,k,lf)/dzb(j)
+             c2(j,k,lf)=ci2(j,k,lf)/dzb(j)
+             c3(j,k,lf)=ci3(j,k,lf)/dzb(j)
+             bilan15=bilan15+ ci(j,k,lf)
+             bilan11=bilan11+ci1(j,k,lf)
+             bilan12=bilan12+ci2(j,k,lf)
+             bilan13=bilan13+ci3(j,k,lf)
+             bilan14=bilan14+
+     &       ci(j,k,lf)*4./3.*pi*rf(k)**3.*vrat_e**(k-imono)
+           enddo
+         enddo
+
+c           print*,'sedifn_fast Bilans:'        
+c     &     ,bilan11,bilan12,bilan13        
+c           print*,'Bilan1:',bilan1,bilan11
+c           print*,'Bilan2:',bilan2,bilan12
+c           print*,'Bilan3:',bilan3,bilan13
+c           print*,'Bilan5:',bilan5,bilan15
+  
+         dice1=0.
+         dice2=0.
+         dice3=0.
+         dice4=0.
+         dice1=(bilan11-bilan1)*rhoi_ch4     !glace 1    m^3.m^-2 * kg.m^-3   pourquoi ????
+         dice2=(bilan12-bilan2)*rhoi_c2h6    !glace 2
+         dice3=(bilan13-bilan3)*rhoi_c2h2    !glace 3
+         dice4=(bilan14-bilan4)*rhol         !noyaux
+
+         return
+         end
+
+
+         subroutine coagul2(ihor)
+
+*********************************************************
+*  ce programme calcule la nouvelle concentration dans   *
+*  le a ieme intervalle de rayon, a l'altitude h, a      *
+*  l'instant t+dt                                        *
+*********************************************************
+
+         use dimphy
+         IMPLICIT NONE
+#include  "dimensions.h"
+#include  "microtab.h"
+#include  "varmuphy.h"          
+
+*  declaration des blocs communs
+*------------------------------
+
+         common/x2ctps/li,lf,dt
+         common/x2con/c,c1,c2,c3,caer
+         common/cldpart/rad,mmu
+
+*  declaration des variables
+*  --------------------------
+
+         integer li,lf
+         real dt
+         real c(nz,nrad,2), c1(nz,nrad,2), c2(nz,nrad,2),
+     &        c3(nz,nrad,2)
+         real caer(nz,nrad,2)
+         real rad(nz,nrad),mmu(nz,nrad)
+
+*  declaration des variables propres au ss-programme
+*  -------------------------------------------------
+
+         integer h,a,ihor,i
+         real pr,pe,eta1,eta2
+         real  sum11,sum12,sum13,sum21,sum22,sum23
+         real rfb,rfx,rpr
+
+*   traitement
+*   ----------
+
+
+         sum11=0.
+         sum12=0.
+         sum13=0.
+         sum21=0.
+         sum22=0.
+         sum23=0.
+         
+         do 10 h=nztop,nz
+           do 11 a=1,nrad  ! boucle aerosol secs
+             call pertpro2(ihor,h,a,pe,pr)
+
+             if(1+dt*pe .gt. 1.1) print*,a,1+dt*pe,' scav'
+             caer(h,a,lf)=(caer(h,a,li)+pr*dt)/(1+dt*pe)
+             c(h,a,lf)=c(h,a,li)
+             c1(h,a,lf)=c1(h,a,li)
+             c2(h,a,lf)=c2(h,a,li)
+c
+c           eta1=0.
+c           eta2=0.
+c           if(c(h,a,li) .ne. 0.)  eta1=c1(h,a,li)/c(h,a,li)
+c           if(c(h,a,li) .ne. 0.)  eta2=c2(h,a,li)/c(h,a,li)
+c            c(h,a,lf) =( c(h,a,li)+pr*dt)/(1+dt*pe)
+c            c1(h,a,lf)=(c1(h,a,li)+eta1*pr*dt)/(1+dt*pe)
+c            c2(h,a,lf)=(c2(h,a,li)+eta2*pr*dt)/(1+dt*pe)
+c
+c
+c           sum11=sum11+c(h,a,li)
+c           sum12=sum12+c1(h,a,li)
+c           sum13=sum13+c2(h,a,li)
+c
+c           sum21=sum21+ c(h,a,lf)
+c           sum22=sum22+c1(h,a,lf)
+c           sum23=sum23+c2(h,a,lf)
+c
+c
+11         continue
+10       continue
+
+
+         if (nztop.ne.1) then
+           do 12 h=1,nztop-1
+             do 12 a=1,nrad
+               c(h,a,lf)=c(h,a,li)
+               c1(h,a,lf)=c1(h,a,li)
+               c2(h,a,lf)=c2(h,a,li)
+               caer(h,a,lf)=caer(h,a,li)
+12         continue
+         endif
+
+         return
+         end
+       
+       
+*__________________________________________________________________________
+
+         subroutine  calcoag2
+
+***************************************************************
+*                                                              *
+*   Ce programme calcule les coefficients de collection  d'une *
+*  particule de rayon x avec une particule de rayon b a une    *
+*  altitude donnee h                                           *
+***************************************************************  
+
+*  declaration des blocs communs
+*------------------------------
+         use dimphy
+         IMPLICIT NONE
+#include  "dimensions.h"
+#include  "microtab.h"
+#include  "varmuphy.h"          
+         
+         common/x2ctps/li,lf,dt
+         common/x2con/c,c1,c2,c3,caer
+         common/cldpart/rad,mmu
+         common/x2coag/k
+         common/x2frac/rfg,dfg
+
+*  declaration des variables
+*  --------------------------
+
+         integer li,lf
+         real dt
+         real knu2,nud2,k(nz,nrad,nrad)
+         real c(nz,nrad,2), c1(nz,nrad,2), c2(nz,nrad,2),
+     &        c3(nz,nrad,2)
+         real caer(nz,nrad,2)
+         real rad(nz,nrad),mmu(nz,nrad)
+         real rfg(nz),dfg(nz,nrad)
+
+
+*  declaration des variables propres au ss-programme
+*  -------------------------------------------------
+
+         integer h,b,x,ihor,i
+         real nua,lambb,lambx,knb,knx,alphab,alphax,d,e,f,kcg
+         real db,dx,rm,dm,deltab,deltax,del,g,beta,gx,gb
+         real rfb,rfx,rpr
+         real*8 ne,qe,epso
+         real*8 corelec,yy
+
+         real kco,vx,vb,vitesse2,sto,ee,a,dd,bb,p0,t0,l0,ccol
+         real st(37),ef(37)
+         real vitesse,knu
+         external vitesse,knu 
+
+
+*  initialisation
+*  --------------
+
+
+
+*   -nombres de STOCKES
+
+         data(st(i),i=1,37)/1.35,1.5,1.65,1.85,2.05,2.25,2.5,2.8,3.1,
+     s    3.35,3.6,3.95,4.3,4.7,5.05,5.45,5.9,6.4,7.,7.6,8.3,9.05,9.9,
+     s       10.9,11.1,13.5,15.3,17.25,20.5,24.5,30.4,39.3,48,57,86.,
+     s       187.,600./
+
+*   -coef. d'efficacite de collection
+
+         ef(1)=3.75
+         ef(2)=8.75
+         do 11 i=3,37
+           ef(i)=ef(i-1)+2.5
+11       continue
+
+         do 2 i=1,37
+           ef(i)=ef(i)*1e-2
+2        continue
+
+         qe=1.6e-19
+         ne=-30e+6
+         epso=1e-9/(36*pi)
+
+         d=1.257
+         e=0.4
+         f=-1.1
+
+*   iteration sur z
+  
+         do 1 h=1,nz
+
+           nua=nud2(h,1)      
+
+*   iteration sur les rayons
+
+           do 1 b=1,nrad  ! boucle aerosols secs : indice '' 
+
+             knb=knu(h,b,1)      ! knu et vitesse se trouvent dans brume.F
+             vb=vitesse(h,b,1)   ! ils concernent les aerosols 
+
+             do 1 x=1,nrad  !boucles gouttes : indice '2'
+
+               knx=knu2(h,x,1)
+               vx=vitesse2(h,x,1)
+
+**   COAGULATION  ****************************************************
+**  --------------****************************************************
+*  calcul du terme correcteur 'slip-flow'
+
+               alphab=d+e*exp(f/knb)
+               alphax=d+e*exp(f/knx)
+
+*  calcul du coefficient de diffusion
+
+
+               rfb=(r_e(b)**(3./df(b))) *((rf(b)) **(1.-3./df(b)))
+               rfx=(rad(h,x)**
+     &         (3./dfg(h,x)))*((rfg(x))**(1.-3./dfg(h,x)))
+
+               db=kbz*t(h)*(1+alphab*knb)/(6*pi*nua*rfb)
+               dx=kbz*t(h)*(1+alphax*knx)/(6*pi*nua*rfx)
+
+*  calcul du coefficient de coagulation
+
+               rpr=rfb+rfx
+               kcg=4*pi*rpr*(db+dx)
+
+*  calcul de la vitesse thermique
+
+               gb=sqrt(6*kbz*t(h)/(rhol*pi**2*r_e(b)**3))
+               gx=sqrt(6*kbz*t(h)/(rhol*pi**2*rad(h,x)**3))
+
+*  calcul du libre parcours apparent des aerosols
+
+               lambb=8*db/(pi*gb)
+               lambx=8*dx/(pi*gx)
+
+*calcul  du terme correcteur beta
+
+               rm=rpr/2.
+               dm=(dx+db)/2.
+               g=sqrt(gx**2+gb**2)
+               deltab=(((2*rfb+lambb)**3-(4*rfb**2+lambb**2)**1.5)
+     s         /(6*rfb*lambb)-2*rfb)*sqrt(2.)
+               deltax=(((2*rfx+lambx)**3-(4*rfx**2+lambx**2)**1.5)
+     s         /(6*rfx*lambx)-2*rfx)*sqrt(2.)
+               del=sqrt(deltab**2+deltax**2)
+               beta=1/((rm/(rm+del/2))+(4*dm/(g*rm)))
+
+*  calcul du coefficient de coagulation corrige
+
+               kcg=kcg*beta
+
+**   COALESCENCE  **************************************************
+**   -------------**************************************************
+
+               kco=0.
+
+               if ( b.eq. x) continue ! goto 9
+
+
+*  calcul du nombre de Stockes de la petite particule
+
+               sto=2*rhol*rfx**2*abs(vx-vb)/(9*nua*rfb)
+
+*  calcul du coef. de Cunningham-Millikan
+
+               a=1.246
+               bb=0.42
+               dd=0.87
+               l0=0.653e-7
+               p0=101325.
+               t0=288.
+
+               ee=1+
+     &         (l0*t(h)*p0*(a+bb*exp(-dd*rfx*t0*p(h)/(l0*t(h)*p0))))
+     s         /(rfx*t0*p(h))
+
+*  calcul du nombre de Stockes corrige
+
+               sto=sto*ee
+
+               if (sto .le. 1.2) goto 9
+
+               if (sto .ge. 600.) then 
+                 ccol=1.
+                 goto 8
+               endif
+
+*   recherche du coefficient de collection
+
+               do 3 i=1,37
+                 if (sto .gt. st(i)) then
+                   goto 3
+                 endif
+                 if (sto .eq. st(i)) then
+                   ccol=ef(i+1)
+                 else
+                   ccol=ef(i)
+                 endif
+                 goto 8
+3              continue
+
+*   calcul du coefficient de coalescence
+
+8              kco=pi*(rfb+rfx)**2*ccol*abs(vb-vx)
+
+9              continue
+
+**   CORRECTION ELECTRICITE *******************************
+**   ------------------------******************************
+
+c        yy=1.d0*ne**2*r(x)*r(b)*qe**2
+c     &  /(1.d0*kbz*t(h)*(r(b)+r(x))*4*pi*epso)
+c        corelec=0.
+c        if (yy.lt.50.) corelec=yy/(exp(yy)-1.)
+
+               corelec=1.
+
+c        b=aerosol
+c        x=gouttes
+
+               k(h,b,x)=(kcg+kco)*corelec
+
+c
+c        ATTENTION, IL N'Y A PLUS DE SYMETRIE...
+c        k(ihor,h,x,b)=k(ihor,h,b,x)
+c
+c
+
+
+1        continue
+         return
+         end
+
+*______________________________________________________________________
+
+         subroutine pertpro2(ihor,h,a,l_,pr_)
+
+*****************************************************************************
+*                                                                           *
+*  ce programme permet le calcul du terme de production (pr) et de perte (l)*
+*  pour le phenomene de coagulation                                         *
+*  dans le a ieme intervalle de rayon a une altitude h                      *
+****************************************************************************
+
+*  declaration des blocs communs
+*------------------------------
+         use dimphy          
+         IMPLICIT NONE
+#include  "dimensions.h"
+#include  "microtab.h"
+#include  "varmuphy.h"
+
+         common/x2ctps/li,lf,dt
+         common/x2con/c,c1,c2,c3,caer 
+         common/cldpart/rad,mmu
+         common/x2coag/k
+
+
+*  declaration des variables
+*  --------------------------
+
+         integer li,lf
+         real dt
+         real dr(nrad),dv(nrad)
+         real k(nz,nrad,nrad)
+         real c(nz,nrad,2), c1(nz,nrad,2), c2(nz,nrad,2),
+     &        c3(nz,nrad,2)
+         real caer(nz,nrad,2)
+         real rad(nz,nrad),mmu(nz,nrad)
+
+
+*  declaration des variables propres au ss-programme
+*  -------------------------------------------------
+
+         integer h,b,a,x,ihor,i
+         real*8 pr,ss,s,l
+         real pr_,l_,vol,del
+
+*  traitement
+*  -----------
+
+
+
+*   production
+*+++++++++++++
+         s=0.d0
+         ss=0.d0
+         pr=0.d0
+
+c   Pas de production d'aerosols par scavenging !!!
+
+         pr=0.d0
+
+*   perte
+*-  - - - -
+
+         l=0.d0
+
+
+         do 10 x=1,nrad   ! boucle sur les gouttes
+           l=l+k(h,a,x)*c(h,x,li)
+           if(l.ne.0.d0) then 
+             print*,a,x,k(h,a,x),c(h,x,li),l,' : detail coal'
+           endif
+  10     continue 
+
+
+#ifdef  CRAY
+         l_=l
+         pr_=pr
+#else
+         l_=sngl(l)
+         pr_=sngl(pr)
+#endif
+
+         return
+
+         end
+
Index: trunk/LMDZ.TITAN/libf/phytitan/sources.F
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/sources.F	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/sources.F	(revision 175)
@@ -0,0 +1,237 @@
+         SUBROUTINE sources(ngrid,nlay,
+     $                      ptimestep,pz0,pu,pv,
+     $                      pplev,pzlay,pzlev,
+     $                      gaz1,gaz2,gaz3,
+     $                      ptsrf,solesp,reserv)
+
+c=======================================================================
+c     Calcul des flux aux interfaces pour les sources
+c     CH4 a la surface
+c     Production de C2H6 en haut du modele.
+c     Production de C2H2 en haut du modele.
+c     
+c     NOTE :
+c     Les gaz ont la tete en haut. 
+c     ils ne suivent pas la meme convention que muphys :
+c     (1 -> sol  / klev = haut du modele)
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+         use dimphy
+         IMPLICIT NONE
+#include "dimensions.h"
+#include "microtab.h"
+#include "YOMCST.h"
+c
+c   arguments:
+c   ----------
+
+         INTEGER ngrid,nlay,nq,ihor
+         REAL ptimestep
+         REAL pplev(ngrid,nlay+1)
+         REAL pzlay(ngrid,nlay),pzlev(ngrid,nlay+1)
+         REAL pu(ngrid),pv(ngrid)
+         REAL gaz1(ngrid,nlay),gaz2(ngrid,nlay),gaz3(ngrid,nlay)
+         REAL ptsrf(ngrid)
+         REAL solesp(ngrid,klev+1,3)
+c
+c   local:
+c   ------
+ 
+         INTEGER ilev,ig,ilay,nlev,k,inch4,inc2h6
+
+         REAL zgz1(klon,klev),zgz2(klon,klev),zgz3(klon,klev)
+         REAL zcdv(klon),zu2,pz0
+         REAL xmair,gg,zrho,ws,ch,qch4,flux
+         REAL xmuair
+         REAL zmem,zmem2,zmem3
+         REAL prodc2h6,prodc2h2
+         real reserv(ngrid),restemp,drestemp
+         REAL evapch4
+
+         real umin
+         data umin/1.e-12/
+         save umin
+
+c
+c-----------------------------------------------------------------------
+c   initialisations:
+c   -----------------
+
+         nlev=nlay+1
+
+         if(nlay.ne.klev) THEN
+           PRINT*,'STOP dans sources.F'
+           PRINT*,'probleme de dimensions :'
+           PRINT*,'nlay  =',nlay
+           PRINT*,'klev  =',klev
+           STOP
+         endif
+
+         IF(ngrid.NE.klon) THEN
+           PRINT*,'STOP dans sources.F'
+           PRINT*,'probleme de dimensions :'
+           PRINT*,'ngrid  =',ngrid
+           PRINT*,'klon  =',klon
+           STOP
+         ENDIF
+
+         zgz1 = gaz1
+         zgz2 = gaz2
+         zgz3 = gaz3
+
+c-----------------------------------------------------------------------
+c     2. calcul de  cd :
+c     ----------------
+c
+         DO ig=1,ngrid
+           zu2=pu(ig)*pu(ig)+pv(ig)*pv(ig)+umin
+           zcdv(ig)=pz0*(1.+sqrt(zu2))
+c           write(99,'(I4,3(ES24.17,1X))') ig,
+c     &     pz0,zu2,(1.+sqrt(zu2))
+         ENDDO
+c          write(99,*) ""
+
+c-----------------------------------------------------------------------
+c    4. Conditions aux limites pour CH4 et C2H6
+c    -------------------------------------------
+c
+
+*   Conditions CH4
+         DO ig=1,ngrid
+           evapch4=0.
+           restemp=0.
+           gg=RG*RA**2/(RA+pzlay(ig,1))**2.
+           zrho=(pplev(ig,1)-pplev(ig,2))/gg
+           zrho=zrho/(pzlev(ig,2)-pzlev(ig,1))
+           ws=sqrt(pu(ig)**2.+pv(ig)**2.)*(10./pzlay(ig,1))**0.2
+           ch=1.5*sqrt(zcdv(ig))
+c           write(100,'(I4,3(ES24.17,1X))')
+c     &     ig,sqrt(pu(ig)**2.+pv(ig)**2.),
+c     &     (10./pzlay(ig,1))**0.2,ws
+           call ch4sat(ptsrf(ig),pplev(ig,1),qch4) ! qch4=kg/kg
+           qch4=qch4*0.50 ! ici on impose 50% d'humidité au sol 
+        
+           if(reserv(ig).le. 1.e-10 ) then  
+             flux=0.
+             reserv(ig)=1.e-10
+           else
+             flux=zrho*ch*ws
+             flux=flux*0.1 ! fraction occupée par les lacs 
+           endif
+c           write(101,'(I4,5(ES24.17,1X))') 
+c     &     ig,reserv(ig),ws,ch,zrho,(pzlev(ig,1+1)-pzlev(ig,1))
+c           flux=flux/zrho/(pzlev(ig,1+1)-pzlev(ig,1)) ! dx/ds
+
+           zmem=zgz1(ig,1)
+           zgz1(ig,1)=(zgz1(ig,1)+flux*ptimestep*qch4*28./16.)
+     &                /(1.+flux*ptimestep)
+
+           gg=RG!*RA**2/(RA+pzlay(ig,1))**2.
+           xmair=(pplev(ig,1)-pplev(ig,1+1))/gg
+           xmair=xmair/(pzlev(ig,1+1)-pzlev(ig,1))
+           xmuair=28.!*(1.-zmem)+zmem*16.
+
+           drestemp = - (zgz1(ig,1)-zmem)*xmair ! en m3/m2=m
+     &     *(pzlev(ig,2)-pzlev(ig,1))*16./xmuair/425.
+
+c           ici on peut fixer un seuil sur drestemp 
+c           (ie limiter l'echange atm/surface)
+      
+           restemp=reserv(ig) +drestemp
+
+           IF (restemp.ge.0.) THEN 
+             reserv(ig) = reserv(ig) + drestemp
+             evapch4    = evapch4    + drestemp
+           ELSE
+*          Il n'y a pas suffisamment de méthane; on re-évalue le flux d'évaporation
+*          Quelle nouvelle concentration zgz1(ig,1) atteint-on en évaporant tout ?
+             zgz1(ig,1)=reserv(ig)/(xmair*(pzlev(ig,1+1)-pzlev(ig,1))
+     &                 *16./xmuair/425.)+zmem
+             evapch4=evapch4-reserv(ig)
+
+             if(reserv(ig).eq.0.) 
+     &       print*,'assechement du sol en ig=', ig,reserv(ig),flux
+
+             reserv(ig)=0.  ! on a tout évaporé...
+           ENDIF
+c         
+           solesp(ig,klev+1,1)=solesp(ig,klev+1,1)+evapch4  ! <0 si volume évaporé (m3/m2)
+
+c         write(498,'(I3,4(ES24.17,1X))') ig,gaz1(ig,1),zgz1(ig,1),flux
+         ENDDO
+c         write(498,*) "" 
+c         write(101,*) "" 
+*   Conditions C2H6
+
+         prodc2h6=6.e-12/5. ! kg/m2/s
+ 
+         IF (1.EQ.1) THEN
+           DO ig=1,ngrid
+             DO ilev=nlay,nlay-4,-1
+*            calcule de zrho (kg/m3) pour la couche...
+               gg=RG*RA**2/(RA+pzlay(ig,ilev))**2.
+               zrho=(pplev(ig,ilev)-pplev(ig,ilev+1))/gg
+               zrho=zrho/(pzlev(ig,ilev+1)-pzlev(ig,ilev))
+
+*              passage taux de production --> Dx_c2h6 a rajouter au niveau ilev
+               zmem2=zgz2(ig,ilev)
+               zgz2(ig,ilev)=zgz2(ig,ilev)+
+     &         prodc2h6*ptimestep/
+     &         abs(pzlev(ig,ilev+1)-pzlev(ig,ilev))    !  kg/m3/s
+     &         /zrho*28./30.
+
+             ENDDO
+           ENDDO
+
+         ELSE
+
+           DO ig=1,ngrid
+             DO ilev=nlay,nlay-8,-1
+               zgz2(ig,ilev)=1.2e-5
+             ENDDO
+           ENDDO
+
+         ENDIF  ! (fin 1.eq.0)
+
+*-------------------------------------
+*   Conditions C2H2
+
+         prodc2h2=1.6e-12/5. ! kg/m2/s
+
+         IF(1  .EQ.  1) THEN 
+
+           DO ig=1,ngrid
+             DO ilev=nlay,nlay-4,-1
+*            calcule de zrho (kg/m3) pour la couche...
+                gg=RG*RA**2/(RA+pzlay(ig,ilev))**2.
+                zrho=(pplev(ig,ilev)-pplev(ig,ilev+1))/gg
+                zrho=zrho/(pzlev(ig,ilev+1)-pzlev(ig,ilev))
+
+*            passage taux de production --> Dx_c2h2 a rajouter au niveau ilev
+                zmem3=zgz3(ig,ilev)
+                zgz3(ig,ilev)=zgz3(ig,ilev)+
+     &          (prodc2h2)*ptimestep/
+     &          abs(pzlev(ig,ilev+1)-pzlev(ig,ilev))  !  kg/m3/s
+     &          /zrho*28./26.
+
+             ENDDO
+
+           ENDDO
+
+         ENDIF
+
+c-----------------------------------------------------------------------
+         DO ig=1,ngrid
+           DO ilev=1,nlay
+             gaz1(ig,ilev)=zgz1(ig,ilev)
+             gaz2(ig,ilev)=zgz2(ig,ilev)
+             gaz3(ig,ilev)=zgz3(ig,ilev)
+           ENDDO
+         ENDDO
+
+        RETURN
+        END
Index: trunk/LMDZ.TITAN/libf/phytitan/varmuphy.h
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/varmuphy.h	(revision 175)
+++ trunk/LMDZ.TITAN/libf/phytitan/varmuphy.h	(revision 175)
@@ -0,0 +1,36 @@
+!***********************************************************************
+! varmuphy.h : 
+! fichier contenant toutes les variables communes a la microphysique.
+! Necessite microtab.h (pour la definition de nrad).
+! NOTE : certaines variables restent spécifiques a seulement quelques 
+!        une des routines de la microphysique.  
+!***********************************************************************
+!***********************************************************************
+!             variables communes a tous les routines
+!***********************************************************************
+       real p(llm),t(llm),rho(llm),pb(llm+1),tb(llm+1),rhob(llm+1)
+       real ach4(llm),aar(llm),an2(llm) !var communes a brume.F et snuages.F
+       real z(llm),dz(llm),zb(llm+1),dzb(llm+1)
+       real v_e(nrad),r_e(nrad),vrat_e,dr_e(nrad),dv_e(nrad)
+
+       common/grille/z,zb,dz,dzb
+       common/donnees/p,pb,t,tb,rho,rhob,ach4,aar,an2
+       common/aergrid/v_e,r_e,vrat_e,dr_e,dv_e
+!***********************************************************************
+!             constantes communes a la microphysique.
+!***********************************************************************
+       real pi,                                                         &
+     &      nav,rgp,kbz,                                                &
+     &      rtit,g0,                                                    &
+     &      mch4,mc2h6,mc2h2,mar,mn2,mair,                              &
+     &      rhol,rhoi_ch4,rhoi_c2h6,rhoi_c2h2,                          &
+     &      mtetach4,mtetac2h6,mtetac2h2       
+   
+       common/phys/                                                     &
+     &      pi,                                                         &
+     &      nav,rgp,kbz,                                                &
+     &      rtit,g0,                                                    &
+     &      mch4,mc2h6,mc2h2,mar,mn2,mair,                              &
+     &      rhol,rhoi_ch4,rhoi_c2h6,rhoi_c2h2,                          &
+     &      mtetach4,mtetac2h6,mtetac2h2
+
Index: trunk/LMDZ.TITAN/libf/phytitan/write_histday.h
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/write_histday.h	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/write_histday.h	(revision 175)
@@ -94,19 +94,116 @@
      .                                   iim*jjmp1*klev,ndex3d)
 c
-      ENDIF !lev_histday.GE.2
-c
-c-------------------------------------------------------
-      IF(lev_histday.GE.3) THEN
-c
 cccccccccccccccccc  Tracers
 c
          if (iflag_trac.eq.1) THEN
-          if (microfi.eq.1) then
-           DO iq=1,nmicro
-       CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qaer(1,1,iq), zx_tmp_3d)
-       CALL histwrite(nid_day,tname(iq),itau_w,zx_tmp_3d,
-     .                                   iim*jjmp1*klev,ndex3d)
-           ENDDO
+          if (microfi.ge.1) then
+c           DO iq=1,nmicro
+c      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qaer(1,1,iq), zx_tmp_3d)
+c      CALL histwrite(nid_day,tname(iq),itau_w,zx_tmp_3d,
+c     .                                   iim*jjmp1*klev,ndex3d)
+c           ENDDO
+c    -------   NB AER TOT
+               do i=1,klon
+                 do j=1,klev
+                   zx_tmp_fi3d(i,j)= SUM(qaer(i,j,1:nrad))
+                 enddo
+               enddo
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+       CALL histwrite(nid_day,"qaer",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c    -------   NB NOY TOT
+               do i=1,klon
+                 do j=1,klev
+                   zx_tmp_fi3d(i,j)= SUM(qaer(i,j,nrad+1:2*nrad))
+                 enddo
+               enddo
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+       CALL histwrite(nid_day,"qnoy",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c    -------   V GLA1 TOT
+               do i=1,klon
+                 do j=1,klev
+                   zx_tmp_fi3d(i,j)= SUM(qaer(i,j,2*nrad+1:3*nrad))
+                 enddo
+               enddo
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+       CALL histwrite(nid_day,"qgl1",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c    -------   V GLA2 TOT
+               do i=1,klon
+                 do j=1,klev
+                   zx_tmp_fi3d(i,j)= SUM(qaer(i,j,3*nrad+1:4*nrad))
+                 enddo
+               enddo
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+       CALL histwrite(nid_day,"qgl2",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c    -------   V GLA3 TOT
+               do i=1,klon
+                 do j=1,klev
+                   zx_tmp_fi3d(i,j)= SUM(qaer(i,j,4*nrad+1:5*nrad))
+                 enddo
+               enddo
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+       CALL histwrite(nid_day,"qgl3",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c --------------
+c ----- SATURATION ESP NUAGES
+             if (clouds.eq.1) then
+
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1, satch4,zx_tmp_3d)
+       CALL histwrite(nid_day,"ch4sat", itau_w, zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1, satc2h6,zx_tmp_3d)
+       CALL histwrite(nid_day,"c2h6sat", itau_w, zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1, satc2h2,zx_tmp_3d)
+       CALL histwrite(nid_day,"c2h2sat", itau_w, zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c --------------
+c ----- RESERVOIR DE SURFACE
+       CALL gr_fi_ecrit(1, klon,iim,jjmp1,reservoir,zx_tmp_2d)
+       CALL histwrite(nid_day,"reserv",itau_w,zx_tmp_2d,
+     .                        iim*jjmp1,ndex2d)
+c --------------
+c ----- PRECIPITATIONS
+c       -----  CH4
+       CALL gr_fi_ecrit(1, klon,iim,jjmp1,prec(:,1),zx_tmp_2d)
+       CALL histwrite(nid_day,"prech4",itau_w,zx_tmp_2d,
+     .                        iim*jjmp1,ndex2d)
+c       -----  C2H6
+       CALL gr_fi_ecrit(1, klon,iim,jjmp1,prec(:,2),zx_tmp_2d)
+       CALL histwrite(nid_day,"prec2h6",itau_w,zx_tmp_2d,
+     .                        iim*jjmp1,ndex2d)
+c       -----  C2H2
+       CALL gr_fi_ecrit(1, klon,iim,jjmp1,prec(:,3),zx_tmp_2d)
+       CALL histwrite(nid_day,"prec2h2",itau_w,zx_tmp_2d,
+     .                        iim*jjmp1,ndex2d)
+c
+c --------------
+c ----- FLUX GLACE
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1,flxesp_i(1,1,1),zx_tmp_3d)
+       CALL histwrite(nid_day,"flxgl1", itau_w, zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1,flxesp_i(1,1,2),zx_tmp_3d)
+       CALL histwrite(nid_day,"flxgl2", itau_w, zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1,flxesp_i(1,1,3),zx_tmp_3d)
+       CALL histwrite(nid_day,"flxgl3", itau_w, zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+c --------------
+c ----- RAYON MOYEN GOUTTE
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1, rmcloud,zx_tmp_3d)
+       CALL histwrite(nid_day,"rcldbar", itau_w, zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+             endif
 	  endif
+c
+c --------------
+c ----- TRACEURS CHIMIQUES
 	  if (nmicro.lt.nqmax) then
            DO iq=nmicro+1,nqmax
@@ -118,4 +215,9 @@
          endif
 c
+      ENDIF !lev_histday.GE.2
+c
+c-------------------------------------------------------
+      IF(lev_histday.GE.3) THEN
+c
 cccccccccccccccccc  Radiative transfer
 c
@@ -143,6 +245,6 @@
      .                                   iim*jjmp1*klev,ndex3d)
 c
-c 3D adding Tau and k  (31/08/10)
-c 
+c --------------
+c ----- OPACITE BRUME
        do k=7,NSPECV,10
          do i=1,klon
@@ -158,13 +260,27 @@
        enddo      ! fin boucle NSPECV 
 
+       do k=8,NSPECI,10
+         do i=1,klon
+         do l=1,klev
+           t_tauhvd(i,l)=TAUHID(i,klev-l+1,k)
+         enddo
+         enddo
+         write(str1,'(i2.2)') k
+      zx_tmp_fi3d(1:klon,1:klev)=t_tauhvd(1:klon,1:klev)
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite(nid_day,"thi"//str1,itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+       enddo      ! fin boucle NSPECI 
+c
+c --------------
+c ----- EXTINCTION BRUME
        do k=7,NSPECV,10
          do i=1,klon
          do l=1,klev
-         if(l.ne.klev)
-     s    t_khvd(i,l)=TAUHVD(i,klev-l+1,k)
-     s    -TAUHVD(i,klev-l+1-1,k)
-
+          if(l.ne.klev)
+     s     t_khvd(i,l)=TAUHVD(i,klev-l+1,k)
+     s                -TAUHVD(i,klev-l+1-1,k)
           if(l.eq.klev)
-     s    t_khvd(i,l)=TAUHVD(i,klev-l+1,k)
+     s     t_khvd(i,l)=TAUHVD(i,klev-l+1,k)
 
          t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l))
@@ -178,4 +294,25 @@
        enddo      ! fin boucle NSPECV 
 
+       do k=8,NSPECI,10
+         do i=1,klon
+         do l=1,klev
+          if(l.ne.klev)
+     s     t_khvd(i,l)=TAUHID(i,klev-l+1,k)
+     s                -TAUHID(i,klev-l+1-1,k)
+          if(l.eq.klev)
+     s     t_khvd(i,l)=TAUHID(i,klev-l+1,k)
+
+         t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l))
+         enddo
+         enddo
+         write(str1,'(i2.2)') k
+      zx_tmp_fi3d(1:klon,1:klev)=t_khvd(1:klon,1:klev)
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite(nid_day,"khi"//str1,itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+       enddo      ! fin boucle NSPECI 
+c
+c --------------
+c ----- OPACITE GAZ
        do k=7,NSPECV,10
          do i=1,klon
@@ -191,13 +328,27 @@
        enddo      ! fin boucle NSPECV 
 
+       do k=8,NSPECI,10
+         do i=1,klon
+         do l=1,klev
+           t_tauhvd(i,l)=TAUGID(i,klev-l+1,k)
+         enddo
+         enddo
+         write(str1,'(i2.2)') k
+      zx_tmp_fi3d(1:klon,1:klev)=t_tauhvd(1:klon,1:klev)
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite(nid_day,"tgi"//str1,itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+       enddo      ! fin boucle NSPECI 
+c
+c --------------
+c ----- EXTINCTION GAZ
        do k=7,NSPECV,10
          do i=1,klon
          do l=1,klev
-         if(l.ne.klev)
-     s    t_khvd(i,l)=TAUGVD(i,klev-l+1,k)
-     s    -TAUGVD(i,klev-l+1-1,k)
-
+          if(l.ne.klev)
+     s     t_khvd(i,l)=TAUGVD(i,klev-l+1,k)
+     s                -TAUGVD(i,klev-l+1-1,k)
           if(l.eq.klev)
-     s    t_khvd(i,l)=TAUGVD(i,klev-l+1,k)
+     s     t_khvd(i,l)=TAUGVD(i,klev-l+1,k)
 
          t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l))
@@ -214,67 +365,44 @@
          do i=1,klon
          do l=1,klev
-           t_tauhvd(i,l)=TAUHID(i,klev-l+1,k)
-         enddo
-         enddo
-         write(str1,'(i2.2)') k
-      zx_tmp_fi3d(1:klon,1:klev)=t_tauhvd(1:klon,1:klev)
-      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
-      CALL histwrite(nid_day,"thi"//str1,itau_w,zx_tmp_3d,
+          if(l.ne.klev)
+     s     t_khvd(i,l)=TAUGID(i,klev-l+1,k)
+     s                -TAUGID(i,klev-l+1-1,k)
+
+          if(l.eq.klev)
+     s     t_khvd(i,l)=TAUGID(i,klev-l+1,k)
+
+         t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l))
+         enddo
+         enddo
+         write(str1,'(i2.2)') k
+      zx_tmp_fi3d(1:klon,1:klev)=t_khvd(1:klon,1:klev)
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite(nid_day,"kgi"//str1,itau_w,zx_tmp_3d,
      .                                   iim*jjmp1*klev,ndex3d)
        enddo      ! fin boucle NSPECI 
 
-       do k=8,NSPECI,10
-         do i=1,klon
-         do l=1,klev
-         if(l.ne.klev)
-     s    t_khvd(i,l)=TAUHID(i,klev-l+1,k)
-     s    -TAUHID(i,klev-l+1-1,k)
-
-          if(l.eq.klev)
-     s    t_khvd(i,l)=TAUHID(i,klev-l+1,k)
-
-         t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l))
-         enddo
-         enddo
-         write(str1,'(i2.2)') k
-      zx_tmp_fi3d(1:klon,1:klev)=t_khvd(1:klon,1:klev)
-      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
-      CALL histwrite(nid_day,"khi"//str1,itau_w,zx_tmp_3d,
-     .                                   iim*jjmp1*klev,ndex3d)
-       enddo      ! fin boucle NSPECI 
-
-       do k=8,NSPECI,10
-         do i=1,klon
-         do l=1,klev
-           t_tauhvd(i,l)=TAUGID(i,klev-l+1,k)
-         enddo
-         enddo
-         write(str1,'(i2.2)') k
-      zx_tmp_fi3d(1:klon,1:klev)=t_tauhvd(1:klon,1:klev)
-      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
-      CALL histwrite(nid_day,"tgi"//str1,itau_w,zx_tmp_3d,
-     .                                   iim*jjmp1*klev,ndex3d)
-       enddo      ! fin boucle NSPECI 
-
-       do k=8,NSPECI,10
-         do i=1,klon
-         do l=1,klev
-         if(l.ne.klev)
-     s    t_khvd(i,l)=TAUGID(i,klev-l+1,k)
-     s    -TAUGID(i,klev-l+1-1,k)
-
-          if(l.eq.klev)
-     s    t_khvd(i,l)=TAUGID(i,klev-l+1,k)
-
-         t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l))
-         enddo
-         enddo
-         write(str1,'(i2.2)') k
-      zx_tmp_fi3d(1:klon,1:klev)=t_khvd(1:klon,1:klev)
-      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
-      CALL histwrite(nid_day,"kgi"//str1,itau_w,zx_tmp_3d,
-     .                                   iim*jjmp1*klev,ndex3d)
-       enddo      ! fin boucle NSPECI 
-
+c --------------
+c ----- OPACITE NUAGES (ATTENTION PROXY)
+         if (clouds.eq.1) then
+           zx_tmp_fi3d(1:klon,1:klev)=occcld(1:klon,1:klev)
+           CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+           CALL histwrite(nid_day,"tcld",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c --------------
+c ----- EXTINCTION NUAGES (ATTENTION PROXY)
+           do i=1,klon
+             t_kcld(i,klev)=occcld(i,klev)
+     .       /(zzlev(i,klev+1)-zzlev(i,klev))
+             do j=klev-1,1,-1
+               t_kcld(i,j)=(occcld(i,j)-occcld(i,j+1))
+     .         /(zzlev(i,j+1)-zzlev(i,j))
+             enddo
+           enddo
+           zx_tmp_fi3d(1:klon,1:klev)=t_kcld(1:klon,1:klev)
+           CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+           CALL histwrite(nid_day,"kcld",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+        endif  
+c
       ENDIF !lev_histday.GE.3
 c
Index: trunk/LMDZ.TITAN/libf/phytitan/write_histins.h
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/write_histins.h	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/write_histins.h	(revision 175)
@@ -143,6 +143,6 @@
      .                                   iim*jjmp1*klev,ndex3d)
 c
-c 3D adding Tau and k  (31/08/10)
-c 
+c --------------
+c ----- OPACITE BRUME
        do k=7,NSPECV,10
          do i=1,klon
@@ -158,13 +158,27 @@
        enddo      ! fin boucle NSPECV 
 
+       do k=8,NSPECI,10
+         do i=1,klon
+         do l=1,klev
+           t_tauhvd(i,l)=TAUHID(i,klev-l+1,k)
+         enddo
+         enddo
+         write(str1,'(i2.2)') k
+      zx_tmp_fi3d(1:klon,1:klev)=t_tauhvd(1:klon,1:klev)
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite(nid_ins,"thi"//str1,itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+       enddo      ! fin boucle NSPECI 
+c --------------
+c ----- EXTINCTION BRUME
        do k=7,NSPECV,10
          do i=1,klon
          do l=1,klev
-         if(l.ne.klev)
-     s    t_khvd(i,l)=TAUHVD(i,klev-l+1,k)
-     s    -TAUHVD(i,klev-l+1-1,k)
+          if(l.ne.klev)
+     s     t_khvd(i,l)=TAUHVD(i,klev-l+1,k)
+     s                -TAUHVD(i,klev-l+1-1,k)
 
           if(l.eq.klev)
-     s    t_khvd(i,l)=TAUHVD(i,klev-l+1,k)
+     s     t_khvd(i,l)=TAUHVD(i,klev-l+1,k)
 
          t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l))
@@ -178,4 +192,25 @@
        enddo      ! fin boucle NSPECV 
 
+       do k=8,NSPECI,10
+         do i=1,klon
+         do l=1,klev
+          if(l.ne.klev)
+     s     t_khvd(i,l)=TAUHID(i,klev-l+1,k)
+     s                -TAUHID(i,klev-l+1-1,k)
+
+          if(l.eq.klev)
+     s     t_khvd(i,l)=TAUHID(i,klev-l+1,k)
+
+         t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l))
+         enddo
+         enddo
+         write(str1,'(i2.2)') k
+      zx_tmp_fi3d(1:klon,1:klev)=t_khvd(1:klon,1:klev)
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite(nid_ins,"khi"//str1,itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+       enddo      ! fin boucle NSPECI 
+c --------------
+c ----- OPACITE GAZ
        do k=7,NSPECV,10
          do i=1,klon
@@ -191,13 +226,27 @@
        enddo      ! fin boucle NSPECV 
 
+       do k=8,NSPECI,10
+         do i=1,klon
+         do l=1,klev
+           t_tauhvd(i,l)=TAUGID(i,klev-l+1,k)
+         enddo
+         enddo
+         write(str1,'(i2.2)') k
+      zx_tmp_fi3d(1:klon,1:klev)=t_tauhvd(1:klon,1:klev)
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite(nid_ins,"tgi"//str1,itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+       enddo      ! fin boucle NSPECI 
+c --------------
+c ----- EXTINCTION GAZ
        do k=7,NSPECV,10
          do i=1,klon
          do l=1,klev
-         if(l.ne.klev)
-     s    t_khvd(i,l)=TAUGVD(i,klev-l+1,k)
-     s    -TAUGVD(i,klev-l+1-1,k)
+          if(l.ne.klev)
+     s     t_khvd(i,l)=TAUGVD(i,klev-l+1,k)
+     s                -TAUGVD(i,klev-l+1-1,k)
 
           if(l.eq.klev)
-     s    t_khvd(i,l)=TAUGVD(i,klev-l+1,k)
+     s     t_khvd(i,l)=TAUGVD(i,klev-l+1,k)
 
          t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l))
@@ -214,56 +263,10 @@
          do i=1,klon
          do l=1,klev
-           t_tauhvd(i,l)=TAUHID(i,klev-l+1,k)
-         enddo
-         enddo
-         write(str1,'(i2.2)') k
-      zx_tmp_fi3d(1:klon,1:klev)=t_tauhvd(1:klon,1:klev)
-      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
-      CALL histwrite(nid_ins,"thi"//str1,itau_w,zx_tmp_3d,
-     .                                   iim*jjmp1*klev,ndex3d)
-       enddo      ! fin boucle NSPECI 
-
-       do k=8,NSPECI,10
-         do i=1,klon
-         do l=1,klev
-         if(l.ne.klev)
-     s    t_khvd(i,l)=TAUHID(i,klev-l+1,k)
-     s    -TAUHID(i,klev-l+1-1,k)
+          if(l.ne.klev)
+     s     t_khvd(i,l)=TAUGID(i,klev-l+1,k)
+     s                -TAUGID(i,klev-l+1-1,k)
 
           if(l.eq.klev)
-     s    t_khvd(i,l)=TAUHID(i,klev-l+1,k)
-
-         t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l))
-         enddo
-         enddo
-         write(str1,'(i2.2)') k
-      zx_tmp_fi3d(1:klon,1:klev)=t_khvd(1:klon,1:klev)
-      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
-      CALL histwrite(nid_ins,"khi"//str1,itau_w,zx_tmp_3d,
-     .                                   iim*jjmp1*klev,ndex3d)
-       enddo      ! fin boucle NSPECI 
-
-       do k=8,NSPECI,10
-         do i=1,klon
-         do l=1,klev
-           t_tauhvd(i,l)=TAUGID(i,klev-l+1,k)
-         enddo
-         enddo
-         write(str1,'(i2.2)') k
-      zx_tmp_fi3d(1:klon,1:klev)=t_tauhvd(1:klon,1:klev)
-      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
-      CALL histwrite(nid_ins,"tgi"//str1,itau_w,zx_tmp_3d,
-     .                                   iim*jjmp1*klev,ndex3d)
-       enddo      ! fin boucle NSPECI 
-
-       do k=8,NSPECI,10
-         do i=1,klon
-         do l=1,klev
-         if(l.ne.klev)
-     s    t_khvd(i,l)=TAUGID(i,klev-l+1,k)
-     s    -TAUGID(i,klev-l+1-1,k)
-
-          if(l.eq.klev)
-     s    t_khvd(i,l)=TAUGID(i,klev-l+1,k)
+     s     t_khvd(i,l)=TAUGID(i,klev-l+1,k)
 
          t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l))
Index: trunk/LMDZ.TITAN/libf/phytitan/write_histmth.h
===================================================================
--- trunk/LMDZ.TITAN/libf/phytitan/write_histmth.h	(revision 174)
+++ trunk/LMDZ.TITAN/libf/phytitan/write_histmth.h	(revision 175)
@@ -92,6 +92,8 @@
       CALL histwrite(nid_mth,"tops",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
 c
+cccccccccccccccccc  Tracers
+c
          if (iflag_trac.eq.1) THEN
-c         if (microfi.eq.1) then
+          if (microfi.ge.1) then
 c          DO iq=1,nmicro
 c      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qaer(1,1,iq), zx_tmp_3d)
@@ -99,5 +101,107 @@
 c    .                                   iim*jjmp1*klev,ndex3d)
 c          ENDDO
-c         endif
+c    -------   NB AER TOT
+               do i=1,klon
+                 do j=1,klev
+                   zx_tmp_fi3d(i,j)= SUM(qaer(i,j,1:nrad))
+                 enddo
+               enddo
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+       CALL histwrite(nid_mth,"qaer",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c    -------   NB NOY TOT
+               do i=1,klon
+                 do j=1,klev
+                   zx_tmp_fi3d(i,j)= SUM(qaer(i,j,nrad+1:2*nrad))
+                 enddo
+               enddo
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+       CALL histwrite(nid_mth,"qnoy",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c    -------   V GLA1 TOT
+               do i=1,klon
+                 do j=1,klev
+                   zx_tmp_fi3d(i,j)= SUM(qaer(i,j,2*nrad+1:3*nrad))
+                 enddo
+               enddo
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+       CALL histwrite(nid_mth,"qgl1",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c    -------   V GLA2 TOT
+               do i=1,klon
+                 do j=1,klev
+                   zx_tmp_fi3d(i,j)= SUM(qaer(i,j,3*nrad+1:4*nrad))
+                 enddo
+               enddo
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+       CALL histwrite(nid_mth,"qgl2",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c    -------   V GLA3 TOT
+               do i=1,klon
+                 do j=1,klev
+                   zx_tmp_fi3d(i,j)= SUM(qaer(i,j,4*nrad+1:5*nrad))
+                 enddo
+               enddo
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+       CALL histwrite(nid_mth,"qgl3",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c --------------
+c ----- SATURATION ESP NUAGES
+             if (clouds.eq.1) then
+
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1, satch4,zx_tmp_3d)
+       CALL histwrite(nid_mth,"ch4sat", itau_w, zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1, satc2h6,zx_tmp_3d)
+       CALL histwrite(nid_mth,"c2h6sat", itau_w, zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1, satc2h2,zx_tmp_3d)
+       CALL histwrite(nid_mth,"c2h2sat", itau_w, zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c --------------
+c ----- RESERVOIR DE SURFACE
+       CALL gr_fi_ecrit(1, klon,iim,jjmp1,reservoir,zx_tmp_2d)
+       CALL histwrite(nid_mth,"reserv",itau_w,zx_tmp_2d,
+     .                        iim*jjmp1,ndex2d)
+c --------------
+c ----- PRECIPITATIONS
+c       -----  CH4
+       CALL gr_fi_ecrit(1, klon,iim,jjmp1,prec(:,1),zx_tmp_2d)
+       CALL histwrite(nid_mth,"prech4",itau_w,zx_tmp_2d,
+     .                        iim*jjmp1,ndex2d)
+c       -----  C2H6
+       CALL gr_fi_ecrit(1, klon,iim,jjmp1,prec(:,2),zx_tmp_2d)
+       CALL histwrite(nid_mth,"prec2h6",itau_w,zx_tmp_2d,
+     .                        iim*jjmp1,ndex2d)
+c       -----  C2H2
+       CALL gr_fi_ecrit(1, klon,iim,jjmp1,prec(:,3),zx_tmp_2d)
+       CALL histwrite(nid_mth,"prec2h2",itau_w,zx_tmp_2d,
+     .                        iim*jjmp1,ndex2d)
+c
+c --------------
+c ----- FLUX GLACE
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1,flxesp_i(1,1,1),zx_tmp_3d)
+       CALL histwrite(nid_mth,"flxgl1", itau_w, zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1,flxesp_i(1,1,2),zx_tmp_3d)
+       CALL histwrite(nid_mth,"flxgl2", itau_w, zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1,flxesp_i(1,1,3),zx_tmp_3d)
+       CALL histwrite(nid_mth,"flxgl3", itau_w, zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+c --------------
+c ----- RAYON MOYEN GOUTTE
+       CALL gr_fi_ecrit(klev,klon,iim,jjmp1, rmcloud,zx_tmp_3d)
+       CALL histwrite(nid_mth,"rcldbar", itau_w, zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+             endif
+	  endif
+c
+c --------------
+c ----- TRACEURS CHIMIQUES
           if (nmicro.lt.nqmax) then
            DO iq=nmicro+1,nqmax
@@ -145,6 +249,6 @@
      .                                   iim*jjmp1*klev,ndex3d)
 c
-c 3D adding Tau and k  (31/08/10)
-c 
+c --------------
+c ----- OPACITE BRUME
        do k=7,NSPECV,10
          do i=1,klon
@@ -160,13 +264,27 @@
        enddo      ! fin boucle NSPECV 
 
+       do k=8,NSPECI,10
+         do i=1,klon
+         do l=1,klev
+           t_tauhvd(i,l)=TAUHID(i,klev-l+1,k)
+         enddo
+         enddo
+         write(str1,'(i2.2)') k
+      zx_tmp_fi3d(1:klon,1:klev)=t_tauhvd(1:klon,1:klev)
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite(nid_mth,"thi"//str1,itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+       enddo      ! fin boucle NSPECI 
+c
+c --------------
+c ----- EXTINCTION BRUME
        do k=7,NSPECV,10
          do i=1,klon
          do l=1,klev
-         if(l.ne.klev)
-     s    t_khvd(i,l)=TAUHVD(i,klev-l+1,k)
-     s    -TAUHVD(i,klev-l+1-1,k)
-
+          if(l.ne.klev)
+     s     t_khvd(i,l)=TAUHVD(i,klev-l+1,k)
+     s                -TAUHVD(i,klev-l+1-1,k)
           if(l.eq.klev)
-     s    t_khvd(i,l)=TAUHVD(i,klev-l+1,k)
+     s     t_khvd(i,l)=TAUHVD(i,klev-l+1,k)
 
          t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l))
@@ -180,4 +298,25 @@
        enddo      ! fin boucle NSPECV 
 
+       do k=8,NSPECI,10
+         do i=1,klon
+         do l=1,klev
+          if(l.ne.klev)
+     s     t_khvd(i,l)=TAUHID(i,klev-l+1,k)
+     s                -TAUHID(i,klev-l+1-1,k)
+          if(l.eq.klev)
+     s     t_khvd(i,l)=TAUHID(i,klev-l+1,k)
+
+         t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l))
+         enddo
+         enddo
+         write(str1,'(i2.2)') k
+      zx_tmp_fi3d(1:klon,1:klev)=t_khvd(1:klon,1:klev)
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite(nid_mth,"khi"//str1,itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+       enddo      ! fin boucle NSPECI 
+c
+c --------------
+c ----- OPACITE GAZ
        do k=7,NSPECV,10
          do i=1,klon
@@ -193,13 +332,27 @@
        enddo      ! fin boucle NSPECV 
 
+       do k=8,NSPECI,10
+         do i=1,klon
+         do l=1,klev
+           t_tauhvd(i,l)=TAUGID(i,klev-l+1,k)
+         enddo
+         enddo
+         write(str1,'(i2.2)') k
+      zx_tmp_fi3d(1:klon,1:klev)=t_tauhvd(1:klon,1:klev)
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite(nid_mth,"tgi"//str1,itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+       enddo      ! fin boucle NSPECI 
+c
+c --------------
+c ----- EXTINCTION GAZ
        do k=7,NSPECV,10
          do i=1,klon
          do l=1,klev
-         if(l.ne.klev)
-     s    t_khvd(i,l)=TAUGVD(i,klev-l+1,k)
-     s    -TAUGVD(i,klev-l+1-1,k)
-
+          if(l.ne.klev)
+     s     t_khvd(i,l)=TAUGVD(i,klev-l+1,k)
+     s                -TAUGVD(i,klev-l+1-1,k)
           if(l.eq.klev)
-     s    t_khvd(i,l)=TAUGVD(i,klev-l+1,k)
+     s     t_khvd(i,l)=TAUGVD(i,klev-l+1,k)
 
          t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l))
@@ -216,67 +369,54 @@
          do i=1,klon
          do l=1,klev
-           t_tauhvd(i,l)=TAUHID(i,klev-l+1,k)
-         enddo
-         enddo
-         write(str1,'(i2.2)') k
-      zx_tmp_fi3d(1:klon,1:klev)=t_tauhvd(1:klon,1:klev)
-      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
-      CALL histwrite(nid_mth,"thi"//str1,itau_w,zx_tmp_3d,
+          if(l.ne.klev)
+     s     t_khvd(i,l)=TAUGID(i,klev-l+1,k)
+     s                -TAUGID(i,klev-l+1-1,k)
+
+          if(l.eq.klev)
+     s     t_khvd(i,l)=TAUGID(i,klev-l+1,k)
+
+         t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l))
+         enddo
+         enddo
+         write(str1,'(i2.2)') k
+      zx_tmp_fi3d(1:klon,1:klev)=t_khvd(1:klon,1:klev)
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite(nid_mth,"kgi"//str1,itau_w,zx_tmp_3d,
      .                                   iim*jjmp1*klev,ndex3d)
        enddo      ! fin boucle NSPECI 
 
-       do k=8,NSPECI,10
-         do i=1,klon
-         do l=1,klev
-         if(l.ne.klev)
-     s    t_khvd(i,l)=TAUHID(i,klev-l+1,k)
-     s    -TAUHID(i,klev-l+1-1,k)
-
-          if(l.eq.klev)
-     s    t_khvd(i,l)=TAUHID(i,klev-l+1,k)
-
-         t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l))
-         enddo
-         enddo
-         write(str1,'(i2.2)') k
-      zx_tmp_fi3d(1:klon,1:klev)=t_khvd(1:klon,1:klev)
-      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
-      CALL histwrite(nid_mth,"khi"//str1,itau_w,zx_tmp_3d,
-     .                                   iim*jjmp1*klev,ndex3d)
-       enddo      ! fin boucle NSPECI 
-
-       do k=8,NSPECI,10
-         do i=1,klon
-         do l=1,klev
-           t_tauhvd(i,l)=TAUGID(i,klev-l+1,k)
-         enddo
-         enddo
-         write(str1,'(i2.2)') k
-      zx_tmp_fi3d(1:klon,1:klev)=t_tauhvd(1:klon,1:klev)
-      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
-      CALL histwrite(nid_mth,"tgi"//str1,itau_w,zx_tmp_3d,
-     .                                   iim*jjmp1*klev,ndex3d)
-       enddo      ! fin boucle NSPECI 
-
-       do k=8,NSPECI,10
-         do i=1,klon
-         do l=1,klev
-         if(l.ne.klev)
-     s    t_khvd(i,l)=TAUGID(i,klev-l+1,k)
-     s    -TAUGID(i,klev-l+1-1,k)
-
-          if(l.eq.klev)
-     s    t_khvd(i,l)=TAUGID(i,klev-l+1,k)
-
-         t_khvd(i,l)=t_khvd(i,l)/(zzlev(i,l+1)-zzlev(i,l))
-         enddo
-         enddo
-         write(str1,'(i2.2)') k
-      zx_tmp_fi3d(1:klon,1:klev)=t_khvd(1:klon,1:klev)
-      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
-      CALL histwrite(nid_mth,"kgi"//str1,itau_w,zx_tmp_3d,
-     .                                   iim*jjmp1*klev,ndex3d)
-       enddo      ! fin boucle NSPECI 
-
+c --------------
+c ----- OPACITE NUAGES (ATTENTION PROXY)
+         if (clouds.eq.1) then
+           zx_tmp_fi3d(1:klon,1:klev)=occcld(1:klon,1:klev)
+           CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+           CALL histwrite(nid_mth,"tcld",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c --------------
+c ----- EXTINCTION NUAGES (ATTENTION PROXY)
+           do i=1,klon
+             t_kcld(i,klev)=occcld(i,klev)
+     .       /(zzlev(i,klev+1)-zzlev(i,klev))
+             do j=klev-1,1,-1
+               t_kcld(i,j)=(occcld(i,j)-occcld(i,j+1))
+     .         /(zzlev(i,j+1)-zzlev(i,j))
+             enddo
+           enddo
+           zx_tmp_fi3d(1:klon,1:klev)=t_kcld(1:klon,1:klev)
+           CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+           CALL histwrite(nid_mth,"kcld",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+c --------------
+c ----- OCCURENCE NUAGES
+           do k=1,12
+             write(str1,'(i2.2)') k
+             zx_tmp_fi3d(1:klon,1:klev)=occcld_m(1:klon,1:klev,k)
+             CALL histwrite(nid_mth,"occcld"//str1,itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+           enddo
+c
+        endif  
+c
       ENDIF !lev_histmth.GE.3
 c
Index: trunk/LMDZ.VENUS/libf/phyvenus/physiq.F
===================================================================
--- trunk/LMDZ.VENUS/libf/phyvenus/physiq.F	(revision 174)
+++ trunk/LMDZ.VENUS/libf/phyvenus/physiq.F	(revision 175)
@@ -340,5 +340,4 @@
 c
       INTEGER nhori, nvert, idayref
-      INTEGER itau_phy_modif
       REAL zsto, zout, zsto1, zsto2, zero
       parameter (zero=0.0e0)
