Index: /trunk/LMDZ.MARS/README
===================================================================
--- /trunk/LMDZ.MARS/README	(revision 497)
+++ /trunk/LMDZ.MARS/README	(revision 498)
@@ -1365,2 +1365,9 @@
 >> Corrections to the thermals scheme following latest revisions of the related paper. Replaced the surface layer interpolator by a more
 complete routine, that will ultimately become a post-processing utility (and disappear from libf) and a subroutine in the MCD.
+
+== 23/11/11 == FGG
+>> Cleanup of the NLTE routines which have been packed together to limit the 
+   number of files. Also enforced that file names are non-capitalized (needed
+   by the create_make_gcm scripts to better evaluate dependencies when
+   building the makefile).
+   
Index: unk/LMDZ.MARS/libf/phymars/LUdec.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/LUdec.F	(revision 497)
+++ 	(revision )
@@ -1,52 +1,0 @@
-ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c
-c Solution of linear equation without inverting matrix
-c using LU decomposition: 
-c        AA * xx = bb         AA, bb: known
-c                                 xx: to be found
-c AA and bb are not modified in this subroutine
-c                               
-c MALV , Sep 2007
-ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-      subroutine LUdec(xx,aa,bb,m,n)
-
-      implicit none
-
-! Arguments 
-      integer     m, n
-      real*8      aa(m,m), bb(m), xx(m)
-
-
-! Local variables
-      real*8      a(n,n), b(n), x(n), d
-      integer    i, j, indx(n)      
-
-
-! Subrutinas utilizadas
-!     ludcmp_dp, lubksb_dp
-
-!!!!!!!!!!!!!!! Comienza el programa !!!!!!!!!!!!!!
-      
-      do i=1,n
-        b(i) = bb(i+1)
-        do j=1,n
-           a(i,j) = aa(i+1,j+1)
-        enddo
-      enddo
-
-      ! Descomposicion de auxm1
-      call ludcmp_dp ( a, n, n, indx, d)
-
-      ! Sustituciones foward y backwards para hallar la solucion
-      do i=1,n
-           x(i) = b(i)
-      enddo
-      call lubksb_dp( a, n, n, indx, x )
-
-      do i=1,n
-        xx(i+1) = x(i)
-      enddo
-
-      return
-      end
Index: unk/LMDZ.MARS/libf/phymars/NIR_leedat.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/NIR_leedat.F	(revision 497)
+++ 	(revision )
@@ -1,38 +1,0 @@
-c***********************************************************************
-      subroutine NIR_leedat                              
-                                                
-c 	reads parameters for NIR NLTE calculation    
-                                                
-c 	nov 2011    fgg+malv    first version                
-c***********************************************************************
-
-      implicit none                                  
-                                                
-      include 'datafile.h'
-      include 'NIRdata.h'
-                                                
-                                                
-c local variables                               
-
-      integer 	ind                      
-
-                              
-c***********************************************************************
-
-      open(43,file=trim(datafile)//'/NIRcorrection_feb2011.dat',
-     $       status='old')         
-      do ind=1,9
-         read(43,*)
-      enddo
-      
-      do ind=1,npres
-         read(43,*)pres1d(ind),corgcm(ind),oco21d(ind),p1999(ind),
-     $        alfa(ind)
-                                !Tabulated pression to Pa
-         pres1d(ind)=pres1d(ind)*100.
-      enddo
-      close(43)
-
-      return
-
-      end
Index: unk/LMDZ.MARS/libf/phymars/NIRdata.h
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/NIRdata.h	(revision 497)
+++ 	(revision )
@@ -1,8 +1,0 @@
-
-      integer npres                ! Number of pressures in NIR correction
-      parameter (npres=42)         ! table
-
-      common /NIRdata/ pres1d,corgcm,oco21d,alfa,p1999
-      real    pres1d(npres)
-      real    corgcm(npres)
-      real    oco21d(npres),alfa(npres),p1999(npres)
Index: unk/LMDZ.MARS/libf/phymars/NLTE_leedat.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/NLTE_leedat.F	(revision 497)
+++ 	(revision )
@@ -1,206 +1,0 @@
-c***********************************************************************
-	subroutine NLTE_leedat                              
-                                                
-c 	reads planetary and molecular parameters     
-                                                
-c 	jan 98 	malv		first version	 
-c       jul 2011 malv+fgg       adapted to LMD-MGCM
-c***********************************************************************
-                                                
-	implicit none                                  
-                                                
-	include	'nltedefs.h'          
-	include	'nlte_data.h'       
-	include 'datafile.h'
-	include 'nlte_curtis.h'
-                                                
-                                                
-c local variables                               
-	integer 	i,j, k,lun1, lun2                      
-	integer		ib
-	integer		isot
-	character	isotcode*2
-	character       ibcode1*1
-                              
-c formats                                       
-132	format (i2)
-101	format(i1)                               
-c***********************************************************************
-                                                
-	lun1 = 1                                       
-	lun2 = 2    
-
-	do k=1,nisot                                   
-!	  encode (2,132,isotcode) indexisot(k)  
-	  write (isotcode,132) indexisot(k)        
-	  open (lun1,                                  
-     @        file=trim(datafile)//'/NLTEDAT/enelow'//isotcode//'.dat',
-     @        status='old')                               
-	  open (lun2,                                  
-     @        file=trim(datafile)//'/NLTEDAT/deltanu'//isotcode//'.dat',            
-     @        status='old')                               
-	    read (lun1,*)                              
-	    read (lun2,*)                              
-	    read (lun1,*) (elow(k,i), i=1,nb)          
-	    read (lun2,*) (deltanu(k,i), i=1,nb)       
-	  close (lun1)                                 
-	  close (lun2)                                 
-	end do                                         
-          
-
-c       Call to rhist
-	
-	hfile1='hid'
-!	if (ib.eq.13 .or. ib.eq.14 ) hfile1 = dirspec//'his' 
-	if (ib.eq.13 .or. ib.eq.14 ) hfile1 = 'his' 
-         
-	ib=1
-	do isot=1,4
-c       Cases 1,2,3,4
-	   if (isot.eq.1) hisfile = hfile1//'26-1.dat' 
-	   if (isot.eq.2) hisfile = hfile1//'28-1.dat' 
-	   if (isot.eq.3) hisfile = hfile1//'36-1.dat' 
-	   if (isot.eq.4) hisfile = hfile1//'27-1.dat'
-	   call rhist(1.0)
-	   if (isot.eq.1) then !Case 1
-	      mm_c1=mm
-	      nbox_c1=nbox
-	      tmin_c1=tmin
-	      tmax_c1=tmax
-	      do i=1,nbox_max
-		 no_c1(i)=no(i)
-		 dist_c1(i)=dist(i)
-		 do j=1,nhist
-		    sk1_c1(j,i)=sk1(j,i)
-		    xls1_c1(j,i)=xls1(j,i)
-		    xln1_c1(j,i)=xln1(j,i)
-		    xld1_c1(j,i)=xld1(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist_c1(j)=thist(j)
-	      enddo
-	   else if(isot.eq.2) then !Case 2
-	      mm_c2=mm
-	      nbox_c2=nbox
-	      tmin_c2=tmin
-	      tmax_c2=tmax
-	      do i=1,nbox_max
-		 no_c2(i)=no(i)
-		 dist_c2(i)=dist(i)
-		 do j=1,nhist
-		    sk1_c2(j,i)=sk1(j,i)
-		    xls1_c2(j,i)=xls1(j,i)
-		    xln1_c2(j,i)=xln1(j,i)
-		    xld1_c2(j,i)=xld1(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist_c2(j)=thist(j)
-	      enddo
-	   else if (isot.eq.3) then ! Case 3
-	      mm_c3=mm
-	      nbox_c3=nbox
-	      tmin_c3=tmin
-	      tmax_c3=tmax
-	      do i=1,nbox_max
-		 no_c3(i)=no(i)
-		 dist_c3(i)=dist(i)
-		 do j=1,nhist
-		    sk1_c3(j,i)=sk1(j,i)
-		    xls1_c3(j,i)=xls1(j,i)
-		    xln1_c3(j,i)=xln1(j,i)
-		    xld1_c3(j,i)=xld1(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist_c3(j)=thist(j)
-	      enddo
-	   else if (isot.eq.4) then ! Case 4
-	      mm_c4=mm
-	      nbox_c4=nbox
-	      tmin_c4=tmin
-	      tmax_c4=tmax
-	      do i=1,nbox_max
-		 no_c4(i)=no(i)
-		 dist_c4(i)=dist(i)
-		 do j=1,nhist
-		    sk1_c4(j,i)=sk1(j,i)
-		    xls1_c4(j,i)=xls1(j,i)
-		    xln1_c4(j,i)=xln1(j,i)
-		    xld1_c4(j,i)=xld1(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist_c4(j)=thist(j)
-	      enddo
-	   endif
-	enddo
-	do ib=2,4
-	   isot=1
-	   write (ibcode1,101) ib
-	   hisfile = hfile1//'26-'//ibcode1//'.dat' 
-	   call rhist (1.0)
-	   if (ib.eq.2) then !Case 5
-	      mm_c5=mm
-	      nbox_c5=nbox
-	      tmin_c5=tmin
-	      tmax_c5=tmax
-	      do i=1,nbox_max
-		 no_c5(i)=no(i)
-		 dist_c5(i)=dist(i)
-		 do j=1,nhist
-		    sk1_c5(j,i)=sk1(j,i)
-		    xls1_c5(j,i)=xls1(j,i)
-		    xln1_c5(j,i)=xln1(j,i)
-		    xld1_c5(j,i)=xld1(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist_c5(j)=thist(j)
-	      enddo
-	   else if (ib.eq.3) then !Case 6
-	      mm_c6=mm
-	      nbox_c6=nbox
-	      tmin_c6=tmin
-	      tmax_c6=tmax
-	      do i=1,nbox_max
-		 no_c6(i)=no(i)
-		 dist_c6(i)=dist(i)
-		 do j=1,nhist
-		    sk1_c6(j,i)=sk1(j,i)
-		    xls1_c6(j,i)=xls1(j,i)
-		    xln1_c6(j,i)=xln1(j,i)
-		    xld1_c6(j,i)=xld1(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist_c6(j)=thist(j)
-	      enddo
-	   else if (ib.eq.4) then !Case 7
-	      mm_c7=mm
-	      nbox_c7=nbox
-	      tmin_c7=tmin
-	      tmax_c7=tmax
-	      do i=1,nbox_max
-		 no_c7(i)=no(i)
-		 dist_c7(i)=dist(i)
-		 do j=1,nhist
-		    sk1_c7(j,i)=sk1(j,i)
-		    xls1_c7(j,i)=xls1(j,i)
-		    xln1_c7(j,i)=xln1(j,i)
-		    xld1_c7(j,i)=xld1(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist_c7(j)=thist(j)
-	      enddo
-	   endif
-	enddo
-
-c end                                           
-	return                                         
-
-	end                                            
-                                                
-
Index: unk/LMDZ.MARS/libf/phymars/NLTEdlvr09_CZALU.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/NLTEdlvr09_CZALU.F	(revision 497)
+++ 	(revision )
@@ -1,842 +1,0 @@
-c***********************************************************************
-                                                            
-	subroutine NLTEdlvr09_CZALU(ig) 
-
-c       jul 2011 malv+fgg
-c***********************************************************************
-                                                            
-	implicit none                                  
-                                                            
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! common variables and constants  
-                                                            
-	include 'nltedefs.h'          
-	include 'nlte_atm.h'        
-	include 'nlte_data.h'       
-	include 'nlte_results.h'  
-        include 'tcr_15um.h'
-	include 'nlte_matrix.h'      
-        include 'nlte_rates.h'
-	include 'nlte_curtis.h'        
-                                                            
-c arguments                           
-
-        integer  ig   !ADDED FOR TRACEBACK
-                                                            
-c local variables                               
-                                                            
-! matrixes and vectors                          
-                                                            
-	real*8 e110(nl), e210(nl), e310(nl), e410(nl)  
-	real*8 e121(nl), e112(nl)                      
-                                                            
-	real*8 f1(nl,nl)
-                                                           
-	real*8 cax1(nl,nl), cax2(nl,nl), cax3(nl,nl)   
-	real*8 v1(nl), v2(nl), v3(nl)
-
-	real*8 alf11(nl,nl), alf12(nl,nl)              
-	real*8 alf21(nl,nl), alf31(nl,nl), alf41(nl,nl)            
-	real*8 a11(nl), a1112(nl,nl)                   
-	real*8 		a1121(nl,nl), a1131(nl,nl), a1141(nl,nl)          
-	real*8 a21(nl), a2131(nl,nl), a2141(nl,nl)     
-	real*8 		a2111(nl,nl), a2112(nl,nl)            
-	real*8 a31(nl), a3121(nl,nl), a3141(nl,nl)     
-	real*8 		a3111(nl,nl), a3112(nl,nl)            
-	real*8 a41(nl), a4121(nl,nl), a4131(nl,nl)     
-	real*8 		a4111(nl,nl), a4112(nl,nl)            
-	real*8 a12(nl), a1211(nl,nl)                   
-	real*8 		a1221(nl,nl), a1231(nl,nl), a1241(nl,nl)          
-                                                            
-	real*8 aalf11(nl,nl),aalf21(nl,nl),aalf31(nl,nl),aalf41(nl,nl)         
-	real*8 aa11(nl), aa1121(nl,nl), aa1131(nl,nl), aa1141(nl,nl)           
-	real*8 aa21(nl), aa2111(nl,nl), aa2131(nl,nl), aa2141(nl,nl)           
-	real*8 aa31(nl), aa3111(nl,nl), aa3121(nl,nl), aa3141(nl,nl)           
-	real*8 aa41(nl), aa4111(nl,nl), aa4121(nl,nl), aa4131(nl,nl)           
-	real*8 aa12(nl)                              
-	real*8 aa1211(nl,nl), aa1221(nl,nl), aa1231(nl,nl), aa1241(nl,nl)      
-	real*8 aa1112(nl,nl), aa2112(nl,nl), aa3112(nl,nl), aa4112(nl,nl)      
-                                                            
-	real*8 aaalf11(nl,nl),aaalf21(nl,nl),aaalf31(nl,nl),aaalf41(nl,nl)     
-	real*8 aaa11(nl),aaa1121(nl,nl),aaa1131(nl,nl),aaa1141(nl,nl)          
-	real*8 aaa21(nl),aaa2111(nl,nl),aaa2131(nl,nl),aaa2141(nl,nl)          
-	real*8 aaa31(nl),aaa3111(nl,nl),aaa3121(nl,nl),aaa3141(nl,nl)          
-	real*8 aaa41(nl),aaa4111(nl,nl),aaa4121(nl,nl),aaa4131(nl,nl)          
-                                                            
-	real*8 aaaalf11(nl,nl),aaaalf41(nl,nl)         
-	real*8 aaaa11(nl),aaaa1141(nl,nl)              
-	real*8 aaaa41(nl),aaaa4111(nl,nl)              
-                                                            
-                                                            
-                                                            
-! populations                                   
-	real*8 n10(nl), n11(nl)
-	real*8 n20(nl), n21(nl)
-	real*8 n30(nl), n31(nl)
-	real*8 n40(nl), n41(nl)
-                                                            
-                                                            
-! productions and loses                         
-	real*8 d19a1,d19b1,d19c1
-        real*8 d19ap1,d19bp1,d19cp1  
-	real*8 d19a2,d19b2,d19c2 
-        real*8 d19ap2,d19bp2,d19cp2  
-	real*8 d19a3,d19b3,d19c3 
-        real*8 d19ap3,d19bp3,d19cp3  
-	real*8 d19a4,d19b4,d19c4 
-        real*8 d19ap4,d19bp4,d19cp4  
-                                                            
-	real*8 l11, l12, l21, l31, l41                 
-	real*8 p11, p12, p21, p31, p41                 
-	real*8 p1112, p1211, p1221, p1231, p1241       
-	real*8 p1121, p1131, p1141                     
-	real*8 p2111, p2112, p2131, p2141              
-	real*8 p3111, p3112, p3121, p3141              
-	real*8 p4111, p4112, p4121, p4131              
-                                                            
-                                                            
-	real*8 ps11, ps21, ps31, ps41, ps12            
-                                                            
-	real*8 pl11, pl12, pl21, pl31, pl41            
-                                                            
-c local constants and indexes                   
-                                                            
-	integer 	ii		! decides if output of tv,hr   
-	integer 	icurt		! decides if read/comp c.matrix 
-
-	real*8 co2t                                    
-	real*8 ftest                                   
-                                                            
-	real*8 a11_einst(nl), a12_einst(nl)            
-	real*8 a21_einst(nl), a31_einst(nl), a41_einst(nl)         
-	real tsurf                                     
-
-        real*8 nu11, nu12, nu121, nu21, nu31, nu41
-                                                            
-	integer i, j, ik, isot , icurtishb                        
-	integer i_by15sh, i_col020, i_col010636                   
-                                                            
-                                                            
-c external functions and subroutines            
-                                                            
-	external planckdp                              
-	real*8 	planckdp                               
-                                                            
-! subroutines called:                           
-! 	mz4sub, dmzout, readc_mz4, mztf              
-                                                            
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!  start program 
-                                                            
-
-        ii = 4
-        icurt = 1
-
-        call zero4v( aa11, aa21, aa31, aa41, nl)
-        call zero4m( aa1121, aa1131, aa1141, aalf11, nl)
-        call zero4m( aa2111, aa2131, aa2141, aalf21, nl)
-        call zero4m( aa3111, aa3121, aa3141, aalf31, nl)
-        call zero4m( aa4111, aa4121, aa4131, aalf41, nl)
-        call zero4m( aa1112, aa2112, aa3112, aa4112, nl)
-        call zero4m( aa1211, aa1221, aa1231, aa1241, nl)
-        call zero3v( aaa41, aaa31, aaa11, nl )
-        call zero3m( aaa4111, aaa4131, aaalf41, nl)
-        call zero3m( aaa3111, aaa3141, aaalf31, nl)
-        call zero3m( aaa1131, aaa1141, aaalf11, nl)
-        call zero2v( aaaa11, aaaa41, nl )
-        call zero2m( aaaa1141, aaaalf11, nl)
-        call zero2m( aaaa4111, aaaalf41, nl)
-
-	!write (*,*)  ' --- c z a  simple ---    input_cza : ', input_cza   
-                                    
-
-	call zero3v (vt11,vt12,vt13,nl)                
-	call zero3v (vt21,vt22,vt23,nl)                
-	call zero3v (vt31,vt32,vt33,nl)                
-	call zero3v (vt41,vt42,vt43,nl)                
-                                                            
-	call zero3v (hr110,hr121,hr132,nl)             
-	call zero3v (hr210,hr221,hr232,nl)             
-	call zero3v (hr310,hr321,hr332,nl)             
-	call zero3v (hr410,hr421,hr432,nl)             
-	call zero3v (sl110,sl121,sl132,nl)             
-	call zero3v (sl210,sl221,sl232,nl)             
-	call zero3v (sl310,sl321,sl332,nl)             
-	call zero3v (sl410,sl421,sl432,nl)             
-                                                            
-	call zero4v (el11,el21,el31,el41,nl)           
-	call zero4v (e110,e210,e310,e410,nl)           
-	call zero3v (el12,e121,e112,nl)                
-	                                               
-	call zero3m (cax1,cax2,cax3,nl)                
-	call zerom (f1,nl)                             
-	call zero3v (v1,v2,v3,nl)                      
-                                                            
-	call zero4m (alf11,alf21,alf31,alf41,nl)       
-	call zerom (alf12,nl)                          
-	call zero2v (a11,a12,nl)                       
-	call zero3v (a21,a31,a41,nl)                   
-                                                            
-	call zero3m (a1121,a1131,a1141,nl)             
-	call zerom (a1112,nl)                          
-                                                            
-	call zero3m (a1221,a1231,a1241,nl)             
-	call zerom (a1211,nl)                          
-                                                            
-	call zero2m (a2111,a2112,nl)                   
-	call zero2m (a2131,a2141,nl)                   
-	call zero2m (a3111,a3112,nl)                   
-	call zero2m (a3121,a3141,nl)                   
-	call zero2m (a4111,a4112,nl)                   
-	call zero2m (a4121,a4131,nl)                   
-                                                            
-                                                            
-	call zero4v (n11,n21,n31,n41,nl)               
-                                                            
-	nu11 = nu(1,1)                                 
-	nu12 = nu(1,2)                                 
-	nu121 = nu12-nu11                              
-                                                            
-	nu21 = nu(2,1)                                 
-                                                            
-	nu31 = nu(3,1)                                 
-                                                            
-	nu41 = nu(4,1)                                 
-                                                            
-	ftest = 1.d0                                   
-	i_by15sh = 1 
-	i_col020 = 1                                   
-                                                            
-	i_col010636 = 1                                
-                                                            
-                                                            
-101	format(a1)                                  
-180	format(a80)                                 
-                                                            
-                                                            
-c establishing molecular populations needed as input        
-	do i=1,nl                                      
-	  n10(i) = dble( co2(i) * imr(1) )             
-	  n20(i) = dble( co2(i) * imr(2) )             
-	  n30(i) = dble( co2(i) * imr(3) )             
-	  n40(i) = dble( co2(i) * imr(4) )             
-	  if ( input_cza.ge.1 ) then                   
-	    n11(i) = n10(i) *2.d0 *exp( dble(-ee*nu(1,1))/v626t1(i) )          
-	    n21(i) = n20(i) *2.d0 *exp( dble(-ee*nu(2,1))/v628t1(i) )          
-	    n31(i) = n30(i) *2.d0* exp( dble(-ee*nu(3,1))/v636t1(i) )          
-	    n41(i) = n40(i) *2.d0* exp( dble(-ee*nu(4,1))/v627t1(i) )          
-	  end if                                       
-        enddo                                   
-	                                               
-cc                                              
-cc   curtis matrix calculation                  
-cc                           
-        if ( input_cza.ge.1 ) then 
-
-          if (itt_cza.eq.15 ) then 
-
-	    call cm15um_hb_simple ( ig,icurt ) 
-
-          elseif (itt_cza.eq.13) then 
-
-            call mztvc_626fh(ig)
-
-          endif
-
-        endif
-
-
-
-	do 4,i=nl,1,-1	!----------------------------------------------
-
-	  co2t = dble ( co2(i) *(imr(1)+imr(3)+imr(2)+imr(4)) )      
-
-	  call getk ( t(i) )                             
-                                                                      
-	  ps11 = 0.d0                                    
-	  ps21 = 0.d0                                    
-	  ps31 = 0.d0                                    
-	  ps41 = 0.d0                                    
-	  ps12 = 0.d0  
-                                  
-          ! V-T productions and losses V-T
-                                                            
-	  isot = 1
- 	  d19b1 = dble(k19ba(isot)*co2t+k19bb(isot)*n2(i))         
-     @     	+ dble(k19bc(isot)*co(i))                    
-	  d19c1 = dble(k19ca(isot)*co2t+k19cb(isot)*n2(i))         
-     @     	+ dble(k19cc(isot)*co(i))                    
-	  d19bp1 = dble( k19bap(isot)*co2t + k19bbp(isot)*n2(i) )  
-     @     	+ dble( k19bcp(isot)*co(i) )                 
-	  d19cp1 = dble( k19cap(isot)*co2t + k19cbp(isot)*n2(i) )  
-     @     	+ dble( k19ccp(isot)*co(i) )                 
-	  isot = 2
-	  d19c2 =dble(k19ca(isot)*co2t+k19cb(isot)*n2(i))          
-     @     	+ dble(k19cc(isot)*co(i))                    
-	  d19cp2 =dble( k19cap(isot)*co2t + k19cbp(isot)*n2(i) )   
-     @     	+ dble( k19ccp(isot)*co(i) )                 
-	  isot = 3
-	  d19c3 =dble(k19ca(isot)*co2t+k19cb(isot)*n2(i))          
-     @     	+ dble(k19cc(isot)*co(i))                    
-	  d19cp3 =dble( k19cap(isot)*co2t + k19cbp(isot)*n2(i) )   
-     @      	+ dble( k19ccp(isot)*co(i) )                
-	  isot = 4
-	  d19c4 =dble(k19ca(isot)*co2t+k19cb(isot)*n2(i))          
-     @     	+ dble(k19cc(isot)*co(i))                    
-	  d19cp4 =dble( k19cap(isot)*co2t + k19cbp(isot)*n2(i) )   
-     @     	+ dble(k19ccp(isot)*co(i) )                  
-          ! 
-	  l11 = d19c1 + k20c(1)*dble(o3p(i))             
-	  p11 = ( d19cp1 + k20cp(1)*dble(o3p(i)) ) * n10(i)          
-	  l21 = d19c2 + k20c(2)*dble(o3p(i))             
-	  p21 = ( d19cp2 + k20cp(2)*dble(o3p(i)) ) *n20(i)           
-	  l31 = d19c3 + k20c(3)*dble(o3p(i))             
-	  p31 = ( d19cp3 + k20cp(3)*dble(o3p(i)) ) *n30(i)           
-	  l41 = d19c4 + k20c(4)*dble(o3p(i))             
-	  p41 = ( d19cp4 + k20cp(4)*dble(o3p(i)) ) *n40(i)           
-           
-          ! Addition of V-V
-        
-	  l11 = l11 + k21cp(2)*n20(i) + k21cp(3)*n30(i) + k21cp(4)*n40(i)      
-	  p1121 = k21c(2) * n10(i)                     
-	  p1131 = k21c(3) * n10(i)                     
-	  p1141 = k21c(4) * n10(i)                     
-          !
-	  l21 = l21 + k21c(2)*n10(i) + k23k21c*n30(i) + k24k21c*n40(i)         
-	  p2111 = k21cp(2) * n20(i)                    
-	  p2131 = k23k21cp * n20(i)                    
-	  p2141 = k24k21cp * n20(i)                    
-          !                                                  
-	  l31 = l31 + k21c(3)*n10(i) + k23k21cp*n20(i) + k34k21c*n40(i)        
-	  p3111 = k21cp(3)* n30(i)                     
-	  p3121 = k23k21c * n30(i)                     
-	  p3141 = k34k21cp* n30(i)                     
-          !                                                  
-	  l41 = l41 + k21c(4)*n10(i) + k24k21cp*n20(i) + k34k21cp*n30(i)       
-	  p4111 = k21cp(4)* n40(i)                     
-	  p4121 = k24k21c * n40(i)                     
-	  p4131 = k34k21c * n40(i)                     
-                                                            
-                                                            
-	  if ( input_cza.ge.1 ) then         
-                                                            
-	    l12 = d19b1                                   
-     @     	+ k20b(1)*dble(o3p(i))                       
-     @     	+ k21b(1)*n10(i)                             
-     @     	+ k33c*( n20(i) + n30(i) + n40(i) )          
-	    p12 = k21bp(1)*n11(i) * n11(i)                
-	    p1211 = d19bp1 + k20bp(1)*dble(o3p(i))        
-	    p1221 = k33cp(2)*n11(i)                       
-	    p1231 = k33cp(3)*n11(i)                       
-	    p1241 = k33cp(4)*n11(i)                       
-                                                            
-	    l11 = l11 + d19bp1                            
-     @          + k20bp(1)*dble(o3p(i))                  
-     @          + 2.d0 * k21bp(1) * n11(i)               
-     @          +   k33cp(2)*n21(i) + k33cp(3)*n31(i) + k33cp(4)*n41(i)
-	    p1112 = d19b1                               
-     @          + k20b(1)*dble(o3p(i))                   
-     @          + 2.d0*k21b(1)*n10(i)                    
-     @          + k33c*( n20(i) + n30(i) + n40(i) )      
-                                                            
-	    l21 = l21 + k33cp(2)*n11(i)                   
-	    p2112 = k33c*n20(i)                           
-                                                            
-	    l31 = l31 + k33cp(3)*n11(i)                   
-	    p3112 = k33c*n30(i)                           
-                                                            
-	    l41 = l41 + k33cp(4)*n11(i)                   
-	    p4112 = k33c*n40(i)                           
-                                                            
-	  end if                                         
-                                                            
-
-          ! Changes in local losses for ITT=13,15 cases 
-
-	    a21_einst(i) = 1.3452d00 * 1.8 / 4.0 * taustar21(i)   
-	    a31_einst(i) = 1.1878d00 * 1.8 / 4.0 * taustar31(i)   
-	    a41_einst(i) = 1.2455d00 * 1.8 / 4.0 * taustar41(i)   
-
-            l21 = l21 + a21_einst(i)              
-            l31 = l31 + a31_einst(i)              
-            l41 = l41 + a41_einst(i)              
-
-            if (input_cza.ge.1 .and. itt_cza.eq.13) then 
-              a12_einst(i) = 4.35d00 / 3.0d0 * 1.8 / 4.0 * taustar12(i) 
-	      l12=l12+a12_einst(i)  
-            endif
-
-            if (itt_cza.eq.24) then 
-               a11_einst(i) = a11_einst(i)  * 1.8 / 4.0 * taustar11(i)
-               l11 = l11 + a11_einst(i)
-            endif
-            
-
-          !  vectors and matrices for the formulation                  
-
-	  a11(i) = dble(gamma*nu11**3.) * 1.d0/2.d0 * (p11+ps11) / 
-     @               (n10(i)*l11)  
-	  a1121(i,i) = dble((nu11/nu21))**3.d0 * n20(i)/n10(i) * p1121/l11
-	  a1131(i,i) = dble((nu11/nu31))**3.d0 * n30(i)/n10(i) * p1131/l11
-	  a1141(i,i) = dble((nu11/nu41))**3.d0 * n40(i)/n10(i) * p1141/l11
-	  e110(i) = 2.d0* dble(vlight*nu11**2.) * 1.d0/2.d0 / 
-     @               ( n10(i) * l11 )   
-                                                            
-	  a21(i) = dble( gamma*nu21**3.) * 1.d0/2.d0 * 
-     @               (p21+ps21)/(n20(i)*l21)   
-	  a2111(i,i) = dble((nu21/nu11))**3.d0 * n10(i)/n20(i) * p2111/l21
-	  a2131(i,i) = dble((nu21/nu31))**3.d0 * n30(i)/n20(i) * p2131/l21   
-	  a2141(i,i) = dble((nu21/nu41))**3.d0 * n40(i)/n20(i) * p2141/l21   
-	  e210(i) = 2.d0*dble(vlight*nu21**2.) * 1.d0/2.d0 / 
-     @               ( n20(i) * l21 )    
-                                                            
-	  a31(i) = dble(gamma*nu31**3.) * 1.d0/2.d0 * (p31+ps31) / 
-     @               (n30(i)*l31)  
-	  a3111(i,i) = dble((nu31/nu11))**3.d0 * n10(i)/n30(i) * p3111/l31   
-	  a3121(i,i) = dble((nu31/nu21))**3.d0 * n20(i)/n30(i) * p3121/l31   
-	  a3141(i,i) = dble((nu31/nu41))**3.d0 * n40(i)/n30(i) * p3141/l31   
-	  e310(i) = 2.d0*dble(vlight*nu31**2.) * 1.d0/2.d0 / 
-     @               ( n30(i) * l31 )    
-                                                            
-	  a41(i) = dble(gamma*nu41**3.) * 1.d0/2.d0 * (p41+ps41) / 
-     @               (n40(i)*l41)  
-	  a4111(i,i) = dble((nu41/nu11))**3.d0 * n10(i)/n40(i) * p4111/l41   
-	  a4121(i,i) = dble((nu41/nu21))**3.d0 * n20(i)/n40(i) * p4121/l41   
-	  a4131(i,i) = dble((nu41/nu31))**3.d0 * n30(i)/n40(i) * p4131/l41 
-	  e410(i) = 2.d0*dble(vlight*nu41**2.) * 1.d0/2.d0 / 
-     @               ( n40(i) * l41 )   
-                                                            
-	  if (input_cza.ge.1) then                       
-
-	    a1112(i,i) = dble((nu11/nu121))**3.d0 * n11(i)/n10(i) * 
-     @                        p1112/l11    
-	    a2112(i,i) = dble((nu21/nu121))**3.d0 * n11(i)/n20(i) * 
-     @                        p2112/l21    
-	    a3112(i,i) = dble((nu31/nu121))**3.d0 * n11(i)/n30(i) * 
-     @                        p3112/l31    
-	    a4112(i,i) = dble((nu41/nu121))**3.d0 * n11(i)/n40(i) * 
-     @                        p4112/l41    
-	    e112(i) = -2.d0*dble(vlight*nu11**3.)/nu121 /2.d0 /
-     @                        ( n10(i)*l11 )    
-	    a12(i) = dble( gamma*nu121**3.) *2.d0/4.d0* (p12+ps12)/
-     @                        (n11(i)*l12)  
-	    a1211(i,i) = dble((nu121/nu11))**3.d0 * n10(i)/n11(i) * 
-     @                        p1211/l12    
-	    a1221(i,i) = dble((nu121/nu21))**3.d0 * n20(i)/n11(i) * 
-     @                        p1221/l12    
-	    a1231(i,i) = dble((nu121/nu31))**3.d0 * n30(i)/n11(i) * 
-     @                        p1231/l12    
-	    a1241(i,i) = dble((nu121/nu41))**3.d0 * n40(i)/n11(i) * 
-     @                        p1241/l12    
-	    e121(i) = 2.d0*dble(vlight*nu121**2.) *2.d0/4.d0 / 
-     @                        ( n11(i) * l12 )  
-                                                            
-	  end if                                         
-                                                            
-                                                            
-4	continue  !-------------------------------------------------------    
-                                                            
-                                                            
-        ! Change C.M. 
-                                                            
-	do i=1,nl                                    
-	  do j=1,nl                                  
-		c210(i,j) = 0.0d0                             
-		c310(i,j) = 0.0d0                             
-		c410(i,j) = 0.0d0                             
-	  end do                                     
-	end do 
-	if ( itt_cza.eq.13 ) then 
-	  do i=1,nl                                    
-	    do j=1,nl                                  
-		c121(i,j) = 0.0d0          
-	    end do                                     
-	  end do 
-        endif
-        !Añadido para hacer diagonal C121
-!        if ( itt_cza.eq.15 ) then 
-!	  do i=1,nl                                    
-!	    do j=1,nl
-!               if(abs(i-j).eq.1.or.abs(i-j).eq.2) c121(i,j) = 0.0d0          
-!	    end do                                     
-!	  end do 
-!        endif
-        if ( itt_cza.eq.24 ) then 
-          do i=1,nl                                    
-            do j=1,nl                                  
-                c110(i,j) = 0.0d0          
-            end do                                     
-          end do 
-        endif
-                                                           
-        ! Lower Boundary 
-	tsurf = t(1) + tsurf_excess                    
-	do i=1,nl                                      
-	  sl110(i) = sl110(i) + vc110(i) * planckdp( tsurf, nu11 ) 
-	  sl210(i) = sl210(i) + vc210(i) * planckdp( tsurf, nu21 ) 
-	  sl310(i) = sl310(i) + vc310(i) * planckdp( tsurf, nu31 ) 
-	  sl410(i) = sl410(i) + vc410(i) * planckdp( tsurf, nu41 ) 
-	end do                                         
-	if (input_cza.ge.1) then                       
-	  do i=1,nl                                      
-	    sl121(i) = sl121(i) + vc121(i) * planckdp( tsurf, nu121 ) 
-	  end do     
-        endif
-               
-                                             
-        !!!!!!!!!!!! Solucion del sistema
-                                                            
-        !! Paso 0 :  Calculo de los alphas   alf11, alf21, alf31, alf41, alf12
-
-	call unit  ( cax2, nl ) 
-			                 
-	call diago ( cax1, e110, nl )
-	call mulmm ( cax3, cax1,c110, nl ) 			   
-!        cax3=matmul(cax1,c110)
-	call resmm ( alf11, cax2,cax3, nl ) 			     
-
-	call diago ( cax1, e210, nl ) 	
-	call mulmm ( cax3, cax1,c210, nl ) 			      
-!        cax3=matmul(cax1,c210)
-	call resmm ( alf21, cax2,cax3, nl ) 			     
-
-	call diago ( cax1, e310, nl ) 	
-	call mulmm ( cax3, cax1,c310, nl ) 			      
-!        cax3=matmul(cax1,c310)
-	call resmm ( alf31, cax2,cax3, nl ) 			     
-	!
-        call diago ( cax1, e410, nl ) 	
-	call mulmm ( cax3, cax1,c410, nl ) 			   
-!        cax3=matmul(cax1,c410)
-	call resmm ( alf41, cax2,cax3, nl ) 			  
-           !
-!        if(ig.eq.2223.and.input_cza.eq.1) then
-!           open(168,file='output_curtis_c121diagminus2.dat')
-!           do i=1,nl
-!              do j=1,nl
-!                 write(168,*)i,j,c110(i,j),c121(i,j)
-!              enddo
-!           enddo
-!           close(168)
-!           open(178,file='output_taustar.dat')
-!           do i=1,nl
-!              write(178,*)i,taustar21(i),taustar31(i),taustar41(i)
-!           enddo
-!           close(178)
-!        endif
-	if (input_cza.ge.1) then                   
-          call diago ( cax1, e121, nl ) 	
-	  call mulmm ( cax3, cax1,c121, nl ) 			   
-!          cax3=matmul(cax1,c121)
-	  call resmm ( alf12, cax2,cax3, nl )
-        endif
- 
-        !! Paso 1 :  Calculo de vectores y matrices con 1 barra (aa***)
-           
-	if (input_cza.eq.0) then  !  Skip paso 1, pues el12 no se calcula
-
-          ! el11
-          call sypvvv( aa11, a11,e110,sl110, nl )
-          call samem( aa1121, a1121, nl )
-          call samem( aa1131, a1131, nl )
-          call samem( aa1141, a1141, nl )
-          call samem( aalf11, alf11, nl )
-
-          ! el21
-          call sypvvv( aa21, a21,e210,sl210, nl )
-          call samem( aa2111, a2111, nl )
-          call samem( aa2131, a2131, nl )
-          call samem( aa2141, a2141, nl )
-          call samem( aalf21, alf21, nl )
-
-          ! el31
-          call sypvvv( aa31, a31,e310,sl310, nl )
-          call samem( aa3111, a3111, nl )
-          call samem( aa3121, a3121, nl )
-          call samem( aa3141, a3141, nl )
-          call samem( aalf31, alf31, nl )
-
-          ! el41
-          call sypvvv( aa41, a41,e410,sl410, nl )
-          call samem( aa4111, a4111, nl )
-          call samem( aa4121, a4121, nl )
-          call samem( aa4131, a4131, nl )
-          call samem( aalf41, alf41, nl )
-
-
-	else   !      (input_cza.ge.1) ,   FH !
-
-
-          call sypvvv( v1, a12,e121,sl121, nl )      ! a12 + e121 * sl121
-
-          ! aa11
-          call sypvvv( v2, a11,e110,sl110, nl )
-          call trucommvv( aa11 , alf12,a1112,v2, v1, nl )
-           
-          ! aalf11
-          call invdiag( cax1, a1112, nl )
-         call mulmm( cax2, alf12, cax1, nl )        ! alf12 * (1/a1112)
-!          cax2=matmul(alf12,cax1)
-         call mulmm( cax3, cax2, alf11, nl )
-!          cax3=matmul(cax2,alf11)
-          
-          call resmm( aalf11, cax3, a1211, nl )
-          ! aa1121
-          call trucodiag(aa1121, alf12,a1112,a1121, a1221, nl)
-          ! aa1131
-          call trucodiag(aa1131, alf12,a1112,a1131, a1231, nl)
-          ! aa1141
-          call trucodiag(aa1141, alf12,a1112,a1141, a1241, nl)
-
-           
-          ! aa21
-          call sypvvv( v2, a21,e210,sl210, nl )
-          call trucommvv( aa21 , alf12,a2112,v2, v1, nl )
-
-          ! aalf21
-          call invdiag( cax1, a2112, nl )
-         call mulmm( cax2, alf12, cax1, nl )        ! alf12 * (1/a2112)
-!          cax2=matmul(alf12,cax1)
-         call mulmm( cax3, cax2, alf21, nl )
-!          cax3=matmul(cax2,alf21)
-          call resmm( aalf21, cax3, a1221, nl )
-          ! aa2111
-          call trucodiag(aa2111, alf12,a2112,a2111, a1211, nl)
-          ! aa2131
-          call trucodiag(aa2131, alf12,a2112,a2131, a1231, nl)
-          ! aa2141
-          call trucodiag(aa2141, alf12,a2112,a2141, a1241, nl)
-
-          
-          ! aa31
-          call sypvvv( v2, a31,e310,sl310, nl )
-          call trucommvv( aa31 , alf12,a3112,v2, v1, nl )
-          ! aalf31
-          call invdiag( cax1, a3112, nl )
-          call mulmm( cax2, alf12, cax1, nl )        ! alf12 * (1/a3112)
-!          cax2=matmul(alf12,cax1)
-          call mulmm( cax3, cax2, alf31, nl )
-!          cax3=matmul(cax2,alf31)
-          call resmm( aalf31, cax3, a1231, nl )
-          ! aa3111
-          call trucodiag(aa3111, alf12,a3112,a3111, a1211, nl)
-          ! aa3121
-          call trucodiag(aa3121, alf12,a3112,a3121, a1221, nl)
-          ! aa3141
-          call trucodiag(aa3141, alf12,a3112,a3141, a1241, nl)
- 
-
-          ! aa41
-          call sypvvv( v2, a41,e410,sl410, nl )
-          call trucommvv( aa41 , alf12,a4112,v2, v1, nl )
-          ! aalf41
-          call invdiag( cax1, a4112, nl )
-         call mulmm( cax2, alf12, cax1, nl )        ! alf12 * (1/a4112)
-!          cax2=matmul(alf12,cax1)
-         call mulmm( cax3, cax2, alf41, nl )
-!          cax3=matmul(cax2,alf41)
-          call resmm( aalf41, cax3, a1241, nl )
-          ! aa4111
-          call trucodiag(aa4111, alf12,a4112,a4111, a1211, nl)
-          ! aa4121
-          call trucodiag(aa4121, alf12,a4112,a4121, a1221, nl)
-          ! aa4131
-          call trucodiag(aa4131, alf12,a4112,a4131, a1231, nl)
-
-        endif  ! Final  caso input_cza.ge.1
-
-
-         !! Paso 2 :  Calculo de vectores y matrices con 2 barras (aaa***)
-
-         ! aaalf41
-         call invdiag( cax1, aa4121, nl )
-        call mulmm( cax2, aalf21, cax1, nl )        ! alf21 * (1/a4121)
-!         cax2=matmul(aalf21,cax1)
-        call mulmm( cax3, cax2, aalf41, nl )
-!         cax3=matmul(cax2,aalf41)
-         call resmm( aaalf41, cax3, aa2141, nl )
-         ! aaa41
-         call trucommvv(aaa41, aalf21,aa4121,aa41, aa21, nl)
-         ! aaa4111
-         call trucodiag(aaa4111, aalf21,aa4121,aa4111, aa2111, nl)
-         ! aaa4131
-         call trucodiag(aaa4131, aalf21,aa4121,aa4131, aa2131, nl)
-
-         ! aaalf31
-         call invdiag( cax1, aa3121, nl )
-        call mulmm( cax2, aalf21, cax1, nl )        ! alf21 * (1/a3121)
-!         cax2=matmul(aalf21,cax1)
-        call mulmm( cax3, cax2, aalf31, nl )
-!         cax3=matmul(cax2,aalf31)
-         call resmm( aaalf31, cax3, aa2131, nl )
-         ! aaa31
-         call trucommvv(aaa31, aalf21,aa3121,aa31, aa21, nl)
-         ! aaa3111
-         call trucodiag(aaa3111, aalf21,aa3121,aa3111, aa2111, nl)
-         ! aaa3141
-         call trucodiag(aaa3141, aalf21,aa3121,aa3141, aa2141, nl)
-
-         ! aaalf11
-         call invdiag( cax1, aa1121, nl )
-         call mulmm( cax2, aalf21, cax1, nl )        ! alf21 * (1/a1121)
-!         cax2=matmul(aalf21,cax1)
-         call mulmm( cax3, cax2, aalf11, nl )
-!         cax3=matmul(cax2,aalf11)
-         call resmm( aaalf11, cax3, aa2111, nl )
-         ! aaa11
-         call trucommvv(aaa11, aalf21,aa1121,aa11, aa21, nl)
-         ! aaa1131
-         call trucodiag(aaa1131, aalf21,aa1121,aa1131, aa2131, nl)
-         ! aaa1141
-         call trucodiag(aaa1141, aalf21,aa1121,aa1141, aa2141, nl)
-
-
-         !! Paso 3 :  Calculo de vectores y matrices con 3 barras (aaaa***)
-
-         ! aaaalf41
-         call invdiag( cax1, aaa4131, nl )
-         call mulmm( cax2, aaalf31, cax1, nl )        ! aaalf31 * (1/aaa4131)
-!         cax2=matmul(aaalf31,cax1)
-         call mulmm( cax3, cax2, aaalf41, nl )
-!         cax3=matmul(cax2,aaalf41)
-         call resmm( aaaalf41, cax3, aaa3141, nl )
-         
-         ! aaaa41
-         call trucommvv(aaaa41, aaalf31,aaa4131,aaa41, aaa31, nl)
-         ! aaaa4111
-         call trucodiag(aaaa4111, aaalf31,aaa4131,aaa4111,aaa3111, nl)
-
-         ! aaaalf11
-         call invdiag( cax1, aaa1131, nl )
-         call mulmm( cax2, aaalf31, cax1, nl )        ! aaalf31 * (1/aaa4131)
-!         cax2=matmul(aaalf31,cax1)
-         call mulmm( cax3, cax2, aaalf11, nl )
-!         cax3=matmul(cax2,aaalf11)
-         call resmm( aaaalf11, cax3, aaa3111, nl )
-         ! aaaa11
-         call trucommvv(aaaa11, aaalf31,aaa1131,aaa11, aaa31, nl)
-         ! aaaa1141
-         call trucodiag(aaaa1141, aaalf31,aaa1131,aaa1141,aaa3141, nl)
-
-
-         !! Paso 4 :  Calculo de vectores y matrices finales y calculo de J1
-
-         call trucommvv(v1, aaaalf41,aaaa1141,aaaa11, aaaa41, nl)
-         ! 
-         call invdiag( cax1, aaaa1141, nl )
-         call mulmm( cax2, aaaalf41, cax1, nl )   ! aaaalf41 * (1/aaaa1141)
-!         cax2=matmul(aaaalf41,cax1)
-         call mulmm( cax3, cax2, aaaalf11, nl )
-!         cax3=matmul(cax2,aaaalf11)
-         call resmm( cax1, cax3, aaaa4111, nl )
-         ! 
-         call LUdec ( el11, cax1, v1, nl, nl2 )
-
-         ! Solucion para el41 
-         call sypvmv( v1, aaaa41, aaaa4111,el11, nl )
-         call LUdec ( el41, aaaalf41, v1, nl, nl2 )
-
-         ! Solucion para el31 
-         call sypvmv( v2, aaa31, aaa3111,el11, nl )
-         call sypvmv( v1,    v2, aaa3141,el41, nl )
-         call LUdec ( el31, aaalf31, v1, nl, nl2 )
-
-         ! Solucion para el21 
-         call sypvmv( v3, aa21, aa2111,el11, nl )
-         call sypvmv( v2,   v3, aa2131,el31, nl )
-         call sypvmv( v1,   v2, aa2141,el41, nl )
-         call LUdec ( el21, aalf21, v1, nl, nl2 )
-
-         !!!
-	 el11(1) = planckdp( t(1), nu11 )          
-	 el21(1) = planckdp( t(1), nu21 )          
-	 el31(1) = planckdp( t(1), nu31 )          
-	 el41(1) = planckdp( t(1), nu41 )          
-	 el11(nl) = 2.d0 * el11(nl-1) - el11(nl2)    
-	 el21(nl) = 2.d0 * el21(nl-1) - el21(nl2)    
-	 el31(nl) = 2.d0 * el31(nl-1) - el31(nl2)    
-	 el41(nl) = 2.d0 * el41(nl-1) - el41(nl2)    
-                                                           
-	 call mulmv ( v1, c110,el11, nl )               
-	 call sumvv ( hr110, v1,sl110, nl )             
-
-         ! Solucion para el12
-	 if (input_cza.ge.1) then    
-
-           call sypvmv( v1, a12, a1211,el11, nl )
-           call sypvmv( v3,  v1, a1221,el21, nl )
-           call sypvmv( v2,  v3, a1231,el31, nl )
-           call sypvmv( v1,  v2, a1241,el41, nl )
-           call LUdec ( el12, alf12, v1, nl, nl2 )
-
-   	   el12(1) = planckdp( t(1), nu121 )           
-	   el12(nl) = 2.d0 * el12(nl-1) - el12(nl2)    
-
-           if (itt_cza.eq.15) then 
-  	     call mulmv ( v1, c121,el12, nl )           
-	     call sumvv ( hr121, v1,sl121, nl )           
-           endif
-
- 	 end if                                        
-                                                            
-                                                            
-                                                            
-        if (input_cza.lt.1) then 
-
-	  do i=1,nl                                                           
-	    pl11 = el11(i)/dble( gamma * nu11**3.0d0  * 1./2. / n10(i) )   
-	    pl21 = el21(i)/dble( gamma * nu21**3.0d0  * 1./2. / n20(i) )   
-	    pl31 = el31(i)/dble( gamma * nu31**3.0d0  * 1./2. / n30(i) )    
-	    pl41 = el41(i)/dble( gamma * nu41**3.0d0  * 1./2. / n40(i) )    
-	    vt11(i) = dble(-ee*nu11) / log( abs(pl11) / (2.0d0*n10(i)) )    
-	    vt21(i) = dble(-ee*nu21) / log( abs(pl21) / (2.0d0*n20(i)) )    
-	    vt31(i) = dble(-ee*nu31) / log( abs(pl31) / (2.0d0*n30(i)) )    
-	    vt41(i) = dble(-ee*nu41) / log( abs(pl41) / (2.0d0*n40(i)) ) 
-	    hr210(i) = sl210(i) - hplanck*vlight*nu21 * a21_einst(i)*pl21
-	    hr310(i) = sl310(i) - hplanck*vlight*nu31 * a31_einst(i)*pl31
-	    hr410(i) = sl410(i) - hplanck*vlight*nu41 * a41_einst(i)*pl41
-!            hr410(i) = 0.
-          enddo 
-
-	  call dinterconnection ( v626t1, vt11 )         
-	  call dinterconnection ( v628t1, vt21 )         
-	  call dinterconnection ( v636t1, vt31 )         
-	  call dinterconnection ( v627t1, vt41 )         
-
-        else
-                                                
-	  do i=1,nl                                                           
-	    pl21 = el21(i)/dble( gamma * nu21**3.0d0  * 1./2. / n20(i) )   
-	    pl31 = el31(i)/dble( gamma * nu31**3.0d0  * 1./2. / n30(i) )   
-	    pl41 = el41(i)/dble( gamma * nu41**3.0d0  * 1./2. / n40(i) ) 
-	    hr210(i) = sl210(i) - hplanck*vlight*nu21 * a21_einst(i)*pl21
-	    hr310(i) = sl310(i) - hplanck*vlight*nu31 * a31_einst(i)*pl31
-	    hr410(i) = sl410(i) - hplanck*vlight*nu41 * a41_einst(i)*pl41
-!            hr410(i) = 0.
- 	    if (itt_cza.eq.13) then                    
-	      pl12 = el12(i)/dble( gamma * nu121**3.0d0 * 2./4. / n11(i) )  
-	      hr121(i) = - hplanck*vlight * nu121 * a12_einst(i) * pl12        
-	      hr121(i) = hr121(i) + sl121(i) 
-            endif                         
-          enddo
-
-	endif
-
-        ! K/Dday
-	do i=1,nl                                      
-	  hr110(i)=hr110(i)*( hrkday_factor(i) / nt(i) )
-	  hr210(i)=hr210(i)*( hrkday_factor(i) / nt(i) )           
-	  hr310(i)=hr310(i)*( hrkday_factor(i) / nt(i) )           
-	  hr410(i)=hr410(i)*( hrkday_factor(i) / nt(i) )           
-	  hr121(i)=hr121(i)*( hrkday_factor(i) / nt(i) )           
-	end do                                         
-                                                            
-                                                            
-
-c  output                                       
-                                                            
-	!codigo = codeout                                                     
-        !call dmzout_tv ( 1 )             
-        !call dmzout_hr ( 1 )             
-
-c final subrutina                                                            
-	return                                         
-	end                                            
Index: unk/LMDZ.MARS/libf/phymars/NLTEdlvr09_TCOOL.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/NLTEdlvr09_TCOOL.F	(revision 497)
+++ 	(revision )
@@ -1,123 +1,0 @@
-c***********************************************************************
-                                                            
-	subroutine NLTEdlvr09_TCOOL (ngridgcm,n_gcm,  
-     @          p_gcm, t_gcm, z_gcm, 
-     @          co2vmr_gcm, n2vmr_gcm, covmr_gcm, o3pvmr_gcm,  
-     @          q15umco2_gcm )
-
-c       jul 2011 malv+fgg                             
-c***********************************************************************
-                                                            
-	implicit none                                  
-         
-        include "dimensions.h"
-	include "dimphys.h"
-        include 'nltedefs.h'
-	include	'nlte_atm.h'       
-	include 'nlte_results.h'  
-        include 'tcr_15um.h'
-	include 'nlte_matrix.h'      
-	include	'nlte_data.h' 
-        include "chimiedata.h"
-        include "conc.h"
-
-c Arguments 
-        integer n_gcm,ngridgcm
-        real p_gcm(ngridgcm,n_gcm), t_gcm(ngridgcm,n_gcm)
-        real co2vmr_gcm(ngridgcm,n_gcm), n2vmr_gcm(ngridgcm,n_gcm)
-        real covmr_gcm(ngridgcm,n_gcm), o3pvmr_gcm(ngridgcm,n_gcm)
-        real q15umco2_gcm(ngridgcm,n_gcm)
-        real z_gcm(ngridgcm,n_gcm)
-                                                             
-c local variables and constants                 
-	integer 	iz, i, j, k, l, ig,istyle
-                                                            
-	real*8		q15umco2_nl(nl)                        
-	real*8		zld(nl), zgcmd(n_gcm)                      
-	real*8          auxdgcm(n_gcm)                        
-
-
-        real p_ig(n_gcm),z_ig(n_gcm)
-        real t_ig(n_gcm)
-        real co2_ig(n_gcm),n2_ig(n_gcm),co_ig(n_gcm),o3p_ig(n_gcm)
-        real mmean_ig(n_gcm),cpnew_ig(n_gcm)
-        
-
-c**********************************************************************
-
-        do ig=1,ngridgcm
-           do l=1,n_gcm
-              p_ig(l)=p_gcm(ig,l)
-              t_ig(l)=t_gcm(ig,l)
-              co2_ig(l)=co2vmr_gcm(ig,l)
-              n2_ig(l)=n2vmr_gcm(ig,l)
-              o3p_ig(l)=o3pvmr_gcm(ig,l)
-              co_ig(l)=covmr_gcm(ig,l)
-              z_ig(l)=z_gcm(ig,l)/1000.
-              mmean_ig(l)=mmean(ig,l)
-              cpnew_ig(l)=cpnew(ig,l)
-           enddo 
-
-           call NLTEdlvr09_ZGRID (n_gcm,  
-     @          p_ig, t_ig, z_ig, 
-     @          co2_ig,n2_ig,co_ig, 
-     $          o3p_ig , mmean_ig, cpnew_ig)
-
-c And sets zero to all Curtis Matrixes and Escape Transmissions
-           call leetvt
-           call zero3m (c110,cup110,cdw110, nl)
-           call zero2v (taugr110,vc110, nl)
-           if (itt_cza.eq.24) then 
-              call mzescape ( ig,taustar11,tauinf110,tauii110, 
-     @                        1, 1,irw_mztf,imu ) 
-              istyle=2
-              call mzescape_normaliz ( taustar11, istyle )   
-           else
-              call mztud (ig, c110,cup110,cdw110, vc110,taugr110,            
-     @               1, 1, irw_mztf, imu, 0,0,0 ) 
-           endif
-           call mztvc (ig,vc210, 1, 2, irw_mztf, imu, 0,0,0 ) 
-           call mztvc (ig,vc310, 1, 3, irw_mztf, imu, 0,0,0 ) 
-           call mztvc (ig,vc410, 1, 4, irw_mztf, imu, 0,0,0 ) 
-           call mzescape_fb (ig)        
-           input_cza = 0  
-           call NLTEdlvr09_CZALU(ig) 
-
-           if (itt_cza.ne.24) then 
-              call mzescape_fh (ig)        
-              input_cza = 1  
-              call NLTEdlvr09_CZALU(ig)
-           endif
-
-
-c total cooling rate                                                
-c smoothing and 
-c interpolation back to original Pgrid 
-c 
-          do i = 1, nl                                   
-             q15umco2_nl(i) = hr110(i) + hr210(i) + hr310(i) + hr410(i) 
-     @            + hr121(i)
-          enddo             
-          
-          do i=1,nl                                      
-             zld(i) = - dble ( alog(pl(i)) )                      
-          enddo                                          
-          do i=1,n_gcm                                      
-             zgcmd(i) = - dble( alog(p_gcm(ig,i)) )  
-          enddo                    
-          call zerov( auxdgcm, n_gcm )
-          call interdp_limits                            
-     @    (     auxdgcm,    zgcmd, n_gcm,   jlowerboundary,jtopboundary,
-     @         q15umco2_nl,      zld,    nl,   1,nl,   1 )        
-          call suaviza ( auxdgcm, n_gcm, 1, zgcmd )     
-                                                
-          do i=1,n_gcm                                      
-             q15umco2_gcm(ig,i) = sngl( auxdgcm(i) )                       
-          enddo 
-          
-       enddo
-       
-       
-c end subroutine                                   
-        return
-	end                                            
Index: unk/LMDZ.MARS/libf/phymars/NLTEdlvr09_ZGRID.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/NLTEdlvr09_ZGRID.F	(revision 497)
+++ 	(revision )
@@ -1,149 +1,0 @@
-c***********************************************************************
-
-	subroutine NLTEdlvr09_ZGRID (n_gcm,  
-     @          p_gcm, t_gcm, z_gcm, 
-     @          co2vmr_gcm, n2vmr_gcm, covmr_gcm, o3pvmr_gcm ,mmean_gcm,
-     @          cpnew_gcm)
-
-c       jul 2011 malv+fgg    First version
-c***********************************************************************
-                                                
-	implicit none                                  
-        
-	include "dimensions.h"
-	include "dimphys.h"
-	include 'nltedefs.h'          
-	include 'nlte_atm.h'        
-	include 'tcr_15um.h'
-	include 'nlte_data.h'       
-	include 'chimiedata.h'
-	include 'conc.h'
-                                                
-c Arguments 
-        integer n_gcm
-        real p_gcm(n_gcm), t_gcm(n_gcm)
-        real co2vmr_gcm(n_gcm), n2vmr_gcm(n_gcm)
-        real covmr_gcm(n_gcm), o3pvmr_gcm(n_gcm)
-	real z_gcm(n_gcm)
-	real mmean_gcm(n_gcm)
-	real cpnew_gcm(n_gcm)
-
-c local variables                               
-	integer i, j  , iz                               
-!	real  distancia, meanm, gz, Hkm
-	real  zmin, zmax, deltazz, deltazzy
-	real  nt_gcm(n_gcm)
-	real  mmean_nlte(n_gcm),cpnew_nlte(n_gcm)
-              
-c functions                                     
-	external 	hrkday_convert                       
-	real 		hrkday_convert                          
-                                                
-c***********************************************************************
-
-
-! Define working grid for MZ1D model (NL, ZL, ZMIN) 
-! y otro mas fino para M.Curtis (NZ, ZX, ZXMIN = ZMIN
-
-! Para ello hace falta una z de ref del GCM, que voy a suponer la inferior
-
-! Primero, construimos escala z_gcm 
-
-!	z_gcm (1) = zmin_gcm             ! [km]
-
-        !write (*,*) ' iz, p, g, H, z =', 1, p_gcm(1), z_gcm(1)
-!	do iz = 2, n_gcm
-!	do iz=1,n_gcm
-!	   z_gcm(iz)=zlay(iz)/1.e3
-
-!	  meanm = ( co2vmr_gcm(iz)*44. + o3pvmr_gcm(iz)*16. 
-!     @               + n2vmr_gcm(iz)*28. + covmr_gcm(iz)*28. ) 
-!	  meanm = meanm / n_avog
-!	  distancia = ( radio + z_gcm(iz-1) )*1.e5 
-!	  gz = gg * masa / ( distancia * distancia ) 
-!          Hkm = 0.5*( t_gcm(iz)+t_gcm(iz-1) ) / ( meanm * gz )
-!          Hkm = kboltzman * Hkm *1e-5                           ! [km] 
-!          z_gcm(iz) = z_gcm(iz-1) - Hkm * log( p_gcm(iz)/p_gcm(iz-1) )
-
-          !write (*,*) iz, p_gcm(iz), gz, Hkm, z_gcm(iz)
-
-!        enddo
-! Segundo, definimos los límites del modelo, entre las 2 presiones clave
-
-	! Bottom boundary for NLTE model : Pbottom=2e-2mb=1.974e-5 atm
-        jlowerboundary = 1 
-	do while ( p_gcm(jlowerboundary) .gt. Pbottom_atm )
-	   jlowerboundary = jlowerboundary + 1
-	enddo
-	zmin = z_gcm(jlowerboundary)
-!	write (*,*) ' jlowerboundary, Pmin, zmin =', 
-!     @            jlowerboundary, p_gcm(jlowerboundary), zmin
-
-	! Top boundary for NLTE model : Ptop=2e-7mb = 1.974e-5 atm
-        jtopboundary = jlowerboundary  
-	do while ( p_gcm(jtopboundary) .gt. Ptop_atm ) 
-	   jtopboundary = jtopboundary + 1
-	enddo
-	zmax = z_gcm(jtopboundary)
-!	write (*,*) ' jtopboundary, Pmax, zmax =', 
-!     @      jtopboundary, p_gcm(jtopboundary),zmax
-
-	deltaz = (zmax-zmin) / (nl-1) 
-	do i=1,nl                                      
-	    zl(i) = zmin + (i-1) * deltaz
-	enddo                                          
-!	write (*,*) ' ZL grid:  dz,zmin,zmax ', deltaz, zl(1),zl(nl)
-! Creamos el perfil interpolando
-	call intersp (    pl,zl,nl,      p_gcm,z_gcm,n_gcm, 2)   ! [atm]
-	call intersp (     t,zl,nl,      t_gcm,z_gcm,n_gcm, 1)       
-	do i = 1, n_gcm
-           nt_gcm(i) = 7.339e+21 * p_gcm(i) / t_gcm(i)    ! [cm-3]	   
-	enddo
-	call intersp (    nt,zl,nl,     nt_gcm,z_gcm,n_gcm, 2)       
-	call intersp (co2vmr,zl,nl, co2vmr_gcm,z_gcm,n_gcm, 1)       
-	call intersp ( n2vmr,zl,nl,  n2vmr_gcm,z_gcm,n_gcm, 1)       
-	call intersp ( covmr,zl,nl,  covmr_gcm,z_gcm,n_gcm, 1)       
-	call intersp (o3pvmr,zl,nl, o3pvmr_gcm,z_gcm,n_gcm, 1)  
-	call intersp (mmean_nlte,zl,nl,mmean_gcm,z_gcm,n_gcm,1)
-	call intersp (cpnew_nlte,zl,nl,cpnew_gcm,z_gcm,n_gcm,1)
-	
-
-	do i = 1, nl
-
-           co2(i) = nt(i) * co2vmr(i)
-           n2(i) = nt(i) * n2vmr(i)
-           co(i) = nt(i) * covmr(i)
-           o3p(i) = nt(i) * o3pvmr(i)
-
-!          	hrkday_factor(i) =  hrkday_convert( t(i),        
-!     @        	  co2vmr(i), o3pvmr(i), n2vmr(i), covmr(i) )
-	   hrkday_factor(i) = hrkday_convert (mmean_nlte(i),cpnew_nlte(i))
-
-	enddo
-                                                
-                                              
-
-c  Fine grid for transmittance calculations
-
-	deltazy = (zmax-zmin) / (nzy-1) 
-	do i=1,nzy                                      
-	    zy(i) = zmin + (i-1) * deltazy	             
-	enddo                                          
-!	write (*,*) ' ZY grid:  nzy,dzy,zmin,zmax ', 
-!     @         nzy, deltazy, zy(1),zy(nzy)
-
-	call intersp (    py,zy,nzy,      p_gcm,z_gcm,n_gcm, 2)   ! [atm]
-	call intersp (    ty,zy,nzy,      t_gcm,z_gcm,n_gcm, 1)       
-	call intersp (   nty,zy,nzy,     nt_gcm,z_gcm,n_gcm, 2)       
-
-	call intersp (  co2y,zy,nzy,   co2vmr_gcm,z_gcm,n_gcm, 1) 
-	do i=1,nzy 
-	   co2y(i) = co2y(i) * nty(i)
-	enddo
-
-
-  
-
-c end                                           
-	return                                         
-	end                                            
Index: unk/LMDZ.MARS/libf/phymars/bloque.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/bloque.F	(revision 497)
+++ 	(revision )
@@ -1,66 +1,0 @@
-c***********************************************************************
-	block data bloque                             
-                                                
-c 	reads planetary and molecular parameters     
-                                                
-c 	jan 98 	malv		first version	                 
-c       jul 2011 malv+fgg       Adapted to LMD-MGCM
-c***********************************************************************
-                                                
-	implicit none                                  
-                                                
-	include	'nltedefs.h'          
-	include	'nlte_data.h'       
-                                                
-c data                                          
-        data nu(1,1),nu(1,2),nu(1,3),nu(1,4)    
-     @    /667.3801, 1335.1317, 2003.2463, 2349.1433/       
-        data nu(1,5),nu(1,6),nu(1,7),nu(1,8)    
-     @   /3004.0112, 3612.8417, 3659.2728, 3714.7828/       
-        data nu(2,1),nu(2,2),nu(2,3),nu(2,4)    
-     @   /662.3734, 1325.1410, 1988.3280, 2332.1128/        
-        data nu(2,5),nu(2,6),nu(2,7),nu(2,8)    
-     @   /2982.1115, 3571.1404, 3632.5240, 3675.1332/       
-        data nu(3,1),nu(3,2),nu(3,3),nu(3,4)    
-     @   /648.4784, 1297.2640, 1946.3507, 2283.4876/        
-        data nu(3,5),nu(3,6),nu(3,7),nu(3,8)    
-     @   /2920.2387, 3527.7380, 3557.3145, 3632.9112/       
-        data nu(4,1),nu(4,2),nu(4,3),nu(4,4)    
-     @   /664.7289, 1329.8430, 1995.3520, 2340.0136/        
-        data nu(4,5),nu(4,6),nu(4,7),nu(4,8)    
-     @   /2992.3100, 3591.2510, 3644.9900, 3693.3460/       
-        data nu12_0200,nu12_1000, nu22_0200,nu22_1000       
-     @   /1285.4087, 1388.1847, 1259.4257, 1365.8439/       
-         data nu32_0200,nu32_1000, nu42_0200,nu42_1000      
-     @   /1265.8282, 1370.0626, 1272.2866, 1376.0275/       
-        data nun2, nuco_10
-     @   /2331.0, 2143.2716 /     
-        data deltanuco/306./                    
-                                                
-        data indexisot/26,28,36,27/             
-                                                
-	! ctes en el sistema cgs                       
-        data vlight, ee /2.9979245e10, 1.43876866/      
-        data hplanck, gamma/6.6260755e-27, 1.191043934e-5/    
-
-                     
-	! datos de marte                               
-        data imrco / 0.9865 /    
-        data imr / 0.987, 0.00408, 0.0112, 0.000742 /    
-
-	! datos de venus 
-        !data radio 	/ 6052. /	! radio [km]   
-	!data mean_distance / 0.723 /     ! mean heliocentric distance [AU]
-	!data amplitude_excentricity / 0.0 /     ! [AU]
-	!data phase_equinox / 0.0 /              ! [degree]
-        !data period_rot / 2.15404e7 /	! period_rot [s] (=243 [Earth days])
-	                                !OJO! El periodo es realmente 116 days
-                                        ! pues se combinan la rotacion (243 d)
-	                                ! con la traslacion (xxx d)
-	!data planet_inclination / 3.39 / ! [degree]  
-        !data masa 	/ 2.53104e27 /	! masa [g]     
-        !data imr, imrco / 0.987, 0.00408, 0.0112, 0.000742, 0.9865 /    
-        !data imr637,imr638,imr828,imr728 /9.e-6, 4.4e-5, 4.e-6, 2.e-6/  
-                                                
-
-	end                                            
Index: unk/LMDZ.MARS/libf/phymars/cm15um_hb_simple.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/cm15um_hb_simple.F	(revision 497)
+++ 	(revision )
@@ -1,201 +1,0 @@
-c***********************************************************************
-                                                            
-	subroutine cm15um_hb_simple (ig,icurt)            
-                                                            
-c   computing the curtix matrixes for the 15 um hot bands   
-c   (las de las bandas fudnamentales las calcula cm15um_fb) 
-                                                            
-c	jan 98 		malv		version de mod3/cm_15um.f para mz1d 
-c       jul 2011 malv+fgg               adapted to LMD-MGCM
-c***********************************************************************
-                                                            
-	implicit none                                  
-                                                            
-!!!!!!!!!!!!!!!!!!!!!!!                         
-! common variables & constants                  
-                                                            
-	include 'nltedefs.h'          
-	include 'nlte_atm.h'        
-	include 'nlte_data.h'       
-!	include '../CMN/tcr_15um.cmn'      
-        include 'tcr_15um.h'
-	include 'nlte_results.h'  
-	include 'nlte_matrix.h'      
-	include 'nlte_curtis.h'      
-                                                            
-!!!!!!!!!!!!!!!!!!!!!!!                         
-! arguments                                     
-                   
-        integer ig                      ! ADDED FOR TRACEBACK
-	integer icurt			! icurt=0,1,2                  
-					! new calculations? (see caa.f heads)
-                                                            
-!!!!!!!!!!!!!!!!!!!!!!!                         
-! local variables                               
-                                                            
-	real*4 cdummy(nl,nl), csngl(nl,nl)             
-                                                            
-	real*8 cax1(nl,nl), cax2(nl,nl), cax3(nl,nl)   
-	real*8 v1(nl), v2(nl), v3(nl), cm_factor, vc_factor        
-                                                            
-	integer itauout,icfout,itableout, interpol,ismooth, isngldble          
-	integer i,j,ik,ist,isot,ib,itt                 
-                                                            
-	!character 	bandcode*2
-	character 	isotcode*2
-	character 	codmatrx_hot*5                      
-                                                            
-!!!!!!!!!!!!!!!!!!!!!!!                         
-! external functions                            
-                                                            
-	external bandid                                
-	character*2 bandid                             
-                                                            
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!               
-! subroutines called:                           
-! 	mz4sub, dmzout, readc_mz4, readcupdw, mztf   
-                                                            
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!               
-! formatos                                      
- 132	format(i2)                                 
-                                                            
-************************************************************************
-************************************************************************
-                                                            
-	call zerom (c121,nl)                           
-                                                            
-	call zerov (vc121,nl)                          
-                                                            
-	call zerom (cup121,nl)                         
-	call zerom (cdw121,nl)                         
-                                                            
-	call zerov (taugr121,nl)                       
-                                                            
-                                                            
-	itauout = 0		! =1 --> with output of tau       
-	icfout = 0		! =1 --> with output of cf         
-	itableout = 0		! =1 --> with output of table of taus       
-	isngldble = 1		! =1 --> dble precission        
-                                                            
-        codmatrx_hot='     '
-	if (icurt.eq.2) then                           
-		icfout=1                                      
-	elseif (icurt.eq.0) then                       
-		write (*,'(a,a$)')                            
-     @		' hot bands. code for old matrixes (5 chars): '     
-		read (*,'(a)')  codmatrx_hot                  
-	endif                                          
-                                                            
-	fileroot = 'cfl'                               
-                                                            
-! ====================== curtis matrixes for fh bands ==================
-                                                            
-                                                            
-! una piedra en el camino ...                   
-!	write (*,*)  ' cm15um_hb/1 '                                   
-                                                            
-ccc                                             
-	if ( input_cza.ge.1 ) then                     
-ccc                                             
-                                                            
-	if (icurt.eq.2) then                           
-	  write (*,'(a,a$)')                           
-     @        '  new calculation of curt. mat. for fh bands.',         
-     @        '    code for new matrixes : '               
-	  read (*,'(a)') codmatrx_hot                  
-	elseif (icurt.eq.0) then                       
-	  write (*,'(a,a$)')                           
-     @        '  reading in curt. mat. for fh bands.',     
-     @        '    code for old matrixes : '               
-	  read (*,'(a)') codmatrx_hot                  
-	else                                           
-!	  write (*,'(a)')                             
-!     @        '  new calculation of curt. mat. for fh bands.'         
-	end if                                         
-                                                            
-!       fh bands for the 626 isotope ================================-  
-                                                            
-	ist = 1                                        
-	isot = 26                                      
-! 	encode (2,132,isotcode) isot                  
- 	write (isotcode,132) isot  
-                             
-	do 11, ik=1,3                                  
-                                                            
-	  ib=ik+1                                      
-                                                            
-	  if (icurt.gt.0) then                         
-	    call zero3m (cax1,cax2,cax3,nl)            
-! una piedra en el camino ...                   
-	    !write (*,*)  ' cm15um_hb/11 '                                  
-	    !write (*,*)  ' ib, ist, irw, imu =', ib, ist, irw_mztf, imu     
-	    call mztf ( ig,cax1,cax2,cax3,v1,v2, ib,ist,irw_mztf,imu,      
-     @        itauout,icfout,itableout)                    
-!	  else                                         
-!	    bandcode = bandid(ib)                      
-!	    filend=isotcode//dn//bandcode//codmatrx_hot            
-!!	    write (*,*)  char(9), fileroot//filend                     
-!	    call zero3m (cax1,cax2,cax3,nl)            
-!	    call readcud_mz1d ( cax1,cax2,cax3, v1, v2,            
-!     @        	fileroot,filend, csngl, nl,nan,0,isngldble) 
-	  end if                                       
-                                                            
-c 	  calculating the total c121(n,r) matrix for the first hot band      
-	  do i=1,nl                                    
-                                                            
-	   if ( ib .eq. 4 ) then                       
-!	    write (*,*)  ' '                                           
-!	    write (*,*)  i, ' ib,ist, altura :', ib,ist, zl(i)         
-	   endif                                       
-                                                            
-!	    if ( v1(i) .le. 1.d-99 ) v1(i) = 0.0d0    
-!	    if ( v2(i) .le. 1.d-99 ) v2(i) = 0.0d0    
-                                                            
-                                                            
-	    if(ik.eq.1)then                            
-		cm_factor = (dble(618.03/667.75))**2.d0*      
-     @  	          exp( dble(ee*(667.75-618.03)/t(i)) )     
-		vc_factor = dble(667.75/618.03)               
-	    elseif(ik.eq.2)then                        
-		cm_factor = 1.d0                              
-		vc_factor = 1.d0                              
-	    elseif(ik.eq.3)then                        
-		cm_factor = ( dble(720.806/667.75) )**2.d0*   
-     @ 		          exp( dble(ee*(667.75-720.806)/t(i)) )    
-		vc_factor = dble(667.75/720.806)              
-	    end if                                     
-	    do j=1,nl                                  
-!	       if (cax1(i,j) .le. 1.d-99 ) cax1(i,j) = 0.0d0      
-!	       if (cax2(i,j) .le. 1.d-99 ) cax2(i,j) = 0.0d0      
-!	       if (cax3(i,j) .le. 1.d-99 ) cax3(i,j) = 0.0d0      
-	      c121(i,j) = c121(i,j) + cax1(i,j) * cm_factor        
-	      cup121(i,j) = cup121(i,j) + cax2(i,j) * cm_factor    
-	      cdw121(i,j) = cdw121(i,j) + cax3(i,j) * cm_factor    
-	    end do                                     
-                                                            
-!	    write (*,*)  ' i =', i                                     
-!	    write (*,*)  ' vc_factor =', vc_factor                     
-!	    write (*,*)  ' v1 =', v1(i)                                
-!	    write (*,*)  ' v2 =', v2(i)                                
-!	    write (*,*)  vc121(i), taugr121(i)                         
-!	    write (*,*)  v1(i) * vc_factor                             
-!	    write (*,*)  vc121(i) + v1(i) * vc_factor                  
-                                                            
-	    vc121(i) = vc121(i) + v1(i) * vc_factor    
-            
-                                      
-!	    write (*,*)  v2(i) * vc_factor                             
-!	    write (*,*)  taugr121(i) + v2(i) * vc_factor               
-                                                            
-	    taugr121(i) = taugr121(i) + v2(i) * vc_factor          
-                                                            
-	  end do                                       
-11	continue                                     
-                                                            
-ccc                                             
-	end if                                         
-ccc                                             
-                                                            
-                                                            
-	return                                         
-	end                                            
Index: unk/LMDZ.MARS/libf/phymars/einsteincoefs.h
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/einsteincoefs.h	(revision 497)
+++ 	(revision )
@@ -1,194 +1,0 @@
-c**********************************************************************
-c*
-c* Einstein coefficients
-c*
-c* fgg mar 2010 (adapted from MALV get_a subroutine)
-c*
-c**********************************************************************
-c                                                
-! isotope  626		for this isotope the values are from mlp    
-c
-      real*8 a1_103, a1_102, a1_101, a1_023, a1_022, a1_021
-c
-  parameter (a1_103       = 1260.d0)
-  parameter (a1_102       = 820.d0)
-  parameter (a1_101       = 410.d0)
-  parameter (a1_023       = 1220.d0)
-  parameter (a1_022       = 814.d0)
-  parameter (a1_021       = 406.d0)
-c
-c
-      real*8 	a1_003, a1_002, a1_301, a1_221, a1_141, a1_061
-c
-  parameter (a1_003       = 1200.d0)
-  parameter (a1_002       = 780.d0)
-  parameter (a1_301       = 400.d0)
-  parameter (a1_221       = 400.d0)
-  parameter (a1_141       = 400.d0)
-  parameter (a1_061       = 400.d0)
-c
-c
-      real*8 a1_201, a1_121, a1_041, a1_220, a1_130, a1_050
-c
-  parameter (a1_201       = 424.d0)
-  parameter (a1_121       = 418.d0)
-  parameter (a1_041       = 418.d0)
-  parameter (a1_220       = 1.43d0)
-  parameter (a1_130       = 2.3d0)
-  parameter (a1_050       = 7.15d0)
-c
-c
-      real*8 a1_120, a1_55, a1_44, a1_300, a1_a43, a1_210, a1_200
-c
-  parameter (a1_120       = 2.08d0)
-  parameter (a1_55        = (5.67d0+a1_120)/2.d0)
-  parameter (a1_44        = 3.68d0)
-  parameter (a1_300       = 4.3d0)
-  parameter (a1_a43       = 2.44d0)
-  parameter (a1_210       = a1_a43+a1_44)
-  parameter (a1_200       = 4.53d0)
-c
-c
-      real*8 a1_140, a1_060, a1_0510, a1_040,  a1_0420, a1_1220
-c
-  parameter (a1_140       = 2.27d0)
-  parameter (a1_060       = 2.32d0)
-  parameter (a1_0510      = a1_0510_0420+a1_0510_0400)
-  parameter (a1_040       = 2.35d0)
-  parameter (a1_0420      = 3.3d0)
-  parameter (a1_1220      = 4.71d0)
-c
-c
-      real*8 a1_1111_1110,a1_1111_0110, a1_0311_0310,a1_0311_0110
-c
-  parameter (a1_1111_1110 = 367.0d0)
-  parameter (a1_1111_0110 = 17.0d0)
-  parameter (a1_0311_0310 = 370.8d0)
-  parameter (a1_0311_0110 = 9.65d0)
-c
-c
-      real*8 a1_0111_010, a1_0201_0200, a1_0201_000, a1_0221_0220
-c
-  parameter (a1_0111_010  = 388.4d0)
-  parameter (a1_0201_000  = 10.39d0)
-  parameter (a1_0201_0200 = 383.756d0)
-  parameter (a1_0221_0220 = 386.56d0)
-c
-c
-      real*8 a1_1001_1000, a1_1001_000, a1_001_000,a1_010_000
-c
-  parameter (a1_1001_1000 = 381.222d0)
-  parameter (a1_1001_000  = 16.68d0)
-  parameter (a1_001_000   = 389.34d0)
-  parameter (a1_010_000   = 1.3546d0)
-c
-c
-      real*8 a1_0421_1220, a1_0421_0420, a1_0421_000
-c
-  parameter (a1_0421_000  = 0.66d0)
-  parameter (a1_0421_0420 = 360.5d0)
-  parameter (a1_0421_1220 = 0.129d0)
-c
-c
-      real*8 a1_1221_0111, a1_1221_1220, a1_1221_0420
-c
-  parameter (a1_1221_0420 = 0.01227d0)
-  parameter (a1_1221_1220 = 355.2d0)
-  parameter (a1_1221_0111 = 0.0219d0)
-c
-c
-      real*8 a1_0510_000, a1_0510_0420, a1_0510_0400
-c
-  parameter (a1_0510_000  = 4.d-4)
-  parameter (a1_0510_0420 = 1.086d0)
-  parameter (a1_0510_0400 = 2.406d0)
-c
-c
-      real*8 a1_0510_1000, a1_0510_0220, a1_0510_0200
-  parameter (a1_0510_1000 = 3.44d-5)
-  parameter (a1_0510_0220 = 6.339d-4)
-  parameter (a1_0510_0200 = 1.5d-3)
-c
-c
-      real*8 a1_1310_000 , a1_1310_0420 , a1_1310_0400
-c
-  parameter (a1_1310_000  = 4.45d-4)
-  parameter (a1_1310_0420 = 0.7535d0)
-  parameter (a1_1310_0400 = 0.21d0)
-c
-c
-      real*8 a1_1310_1200 , a1_1310_1220 , a1_1310_2000
-c
-  parameter (a1_1310_1200 = 2.264d0)
-  parameter (a1_1310_1220 = 0.3609d0)
-  parameter (a1_1310_2000 = 0.074d0)
-c
-c
-      real*8 a1_1310_0111,a1_1310_1000,a1_1310_0220,a1_1310_0200 
-c
-  parameter (a1_1310_0111 = 1.64d-4)
-  parameter (a1_1310_1000 = 1.433d-3)
-  parameter (a1_1310_0220 = 2.4d-4)
-  parameter (a1_1310_0200 = 9.719d-3)
-c
-c
-      real*8 a1_2110_000 , a1_2110_0420 , a1_2110_0400
-c
-  parameter (a1_2110_000  = 3.265d-4)
-  parameter (a1_2110_0420 = 6.48d-3)
-  parameter (a1_2110_0400 = 1.54d-3)
-c
-c
-      real*8 a1_2110_1200,a1_2110_1220,a1_2110_2000,a1_2110_0111
-c
-  parameter (a1_2110_1200 = 0.0738d0)
-  parameter (a1_2110_1220 = 1.957d0)
-  parameter (a1_2110_2000 = 3.289d0)
-  parameter (a1_2110_0111 = 2.68d-4)
-c
-c
-      real*8 a1_2110_1000 , a1_2110_0220 , a1_2110_0200
-c
-  parameter (a1_2110_1000 = 3.445d-2)
-  parameter (a1_2110_0220 = 1.976d-2)
-  parameter (a1_2110_0200 = 6.539d-3)
-c
-c
-      real*8 a1_0403_0402, a1_0403_0202
-c
-  parameter (a1_0403_0402 = 728.7d0)
-  parameter (a1_0403_0202 = 28.9d0)
-c
-      real*8 a1_1203_1202, a1_1203_1002, a1_1203_0202
-c
-c
-  parameter (a1_1203_1202 = 716.3d0)
-  parameter (a1_1203_1002 = 27.25d0)
-  parameter (a1_1203_0202 = 43.68d0)
-c
-c
-      real*8 a1_2003_2002, a1_2003_1002, a1_2003_0202
-c
-  parameter (a1_2003_2002 = 995.7d0)
-  parameter (a1_2003_1002 = 83.27d0)
-  parameter (a1_2003_0202 = 1.15d0)
-c
-c
-      real*8 a1_0402_0401, a1_0402_0201
-c
-  parameter (a1_0402_0401 = 700.0d0)
-  parameter (a1_0402_0201 = 28.97d0)
-c
-c
-      real*8 a1_1202_1201, a1_1202_1001, a1_1202_0201
-c
-  parameter (a1_1202_1201 = 687.0d0)  
-  parameter (a1_1202_1001 =  26.07d0)
-  parameter (a1_1202_0201 =  39.57d0)
-c
-c
-      real*8 a1_2002_2001, a1_2002_1001
-c
-  parameter (a1_2002_2001 = 686.1d0)
-  parameter (a1_2002_1001 = 54.67d0)
-
Index: unk/LMDZ.MARS/libf/phymars/elimin_mz1d.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/elimin_mz1d.F	(revision 497)
+++ 	(revision )
@@ -1,300 +1,0 @@
-c	************************************************************************
-	subroutine elimin_mz1d (c,vc, ilayer,nan,itblout, nw)
-
-c 	Eliminate anomalous negative numbers in c(nl,nl) according to "nan":
-
-c	 nan = 0 -> no eliminate 
-c	       @       -> eliminate all numbers with absol.value<abs(max(c(n,r)))/300.
-c	       2 -> eliminate all anomalous negative numbers in c(n,r).
-c	       3 -> eliminate all anomalous negative numbers far from the main
-c                   diagonal. 
-c	       8 -> eliminate all non-zero numbers outside the main diagonal,
-c		    and the contibution of lower boundary. 
-c	       9 -> eliminate all non-zero numbers outside the main diagonal. 
-c              4 -> hace un smoothing cuando la distancia de separacion entre
-c		    el valor maximo y el minimo de cf > 50 capas.
-c	       5 -> elimina valores menores que 1.0d-19
-c	       6 -> incluye los dos casos 4 y 5 
-c	       7 -> llama a lisa: smooth con width=nw & elimina mejorado
-c	       78-> incluye los dos casos 7 y 8
-c	       79-> incluye los dos casos 7 y 9
-
-c	itblout (itableout in calling program) is the option for writing 
-c       out or not the purged c(n,r) matrix: 
-c       itblout = 0 -> no write  
-c               = 1 -> write out in curtis***.out according to ilayer
-
-c       ilayer is the index for the layer selected to write out the matrix:
-c       ilayer = 0  => matrix elements written out cover all the altitudes
-c                                                     with 5 layers steps
-c              > 0  =>   "        "      "      "  are  c(ilayer,*)
-c       NOTA: 
-c         EXISTE LA POSIBILIDAD DE SACAR TODAS LAS CAPAS (TODA LA MATRIZ)
-c         UTILIZANDO itableout=30 EN MZTUD
-
-c       jul 2011        malv+fgg       adapted to LMD-MGCM
-c       Sep-04          FGG+MALV        Correct include and call parameters
-c       cristina	25-sept-1996   y  27-ene-1997
-c	JAN 98		MALV		Version for mz1d
-c	************************************************************************
-
-	implicit none
-
-	include 'nltedefs.h'
-
-	integer   nan,j,i,itblout,kk,k,ir,in
-        integer   ilayer,jmin, jmax,np,nw,ntimes,ntimes2
-!*	real*8    c(nl,nl), vc(nl), amax, cmax, cmin, cs(nl,nl), mini
-	real*8    c(nl,nl), vc(nl), amax, cmax, cmin, mini
-	real*8 aux(nl), auxs(nl)
-	character layercode*3
-
-	ntimes=0
-	ntimes2=0
-!	type *,'from elimin_mz4: nan, nw',nan,nw
-
-	if (nan .eq. 0) goto 200 
-
-	if(nan.eq.1)then
-		do i=1,nl
-			amax=1.0d-36
-			do j=1,nl
-			  if(abs(c(i,j)).gt.amax)amax=abs(c(i,j))
-			end do
-			do j=1,nl
-			  if(abs(c(i,j)).lt.amax/300.0d0)c(i,j)=0.0d0
-			end do
-		enddo
-	elseif(nan.eq.2)then
-		do i=1,nl
-			do j=1,nl
-			  if( ( j.le.(i-2) .or. j.gt.(i+2) ).and.
-     @			  ( c(i,j).lt.0.0d0 ) ) c(i,j)=0.0d0
-			end do
-		enddo
-	elseif(nan.eq.3)then
-		do i=1,nl
-			do j=1,nl
-			    if (abs(i-j).ge.10) c(i,j)=0.0d0
-			end do
-		enddo
-	elseif(nan.eq.8)then
-		do i=1,nl
-			do j=1,i-1 
-				c(i,j)=0.0d0
-			enddo
-			do j=i+1,nl 
-				c(i,j)=0.0d0
-			enddo
-			vc(i)= 0.d0
-		enddo
-	elseif(nan.eq.9)then
-		do i=1,nl
-			do j=1,i-1 
-				c(i,j)=0.0d0
-			enddo
-			do j=i+1,nl 
-				c(i,j)=0.0d0
-			enddo
-		enddo
-!	elseif(nan.eq.7.or.nan.eq.78.or.nan.eq.79)then
-!		call lisa(c, vc, nl, nw)
-	end if
-	if(nan.eq.78)then
-		do i=1,nl
-			do j=1,i-1 
-				c(i,j)=0.0d0
-			enddo
-			do j=i+1,nl 
-				c(i,j)=0.0d0
-			enddo
-			vc(i)= 0.d0
-		enddo
-	endif
-	if(nan.eq.79)then
-		do i=1,nl
-			do j=1,i-1 
-				c(i,j)=0.0d0
-			enddo
-			do j=i+1,nl 
-				c(i,j)=0.0d0
-			enddo
-		enddo
-	endif
-
-	if(nan.eq.5.or.nan.eq.6)then
-		do i=1,nl
-			mini = 1.0d-19
-			do j=1,nl
-			 if(abs(c(i,j)).le.mini.and.c(i,j).ne.0.d0) then
-			    ntimes2=ntimes2+1
-			 end if
-			   if ( abs(c(i,j)).le.mini) c(i,j)=0.d0
-                        end do
-		enddo
-	end if
-
-	if(nan.eq.4.or.nan.eq.6)then
-		do i=1,nl
-			do j=1,nl
-			  aux(j)=c(i,j)
-			  auxs(j)=c(i,j)
-			end do
-			call maxdp_2(aux,nl,cmax,jmax)
-			   if(abs(jmax-i).ge.50) then
-				call smooth_cf(aux,auxs,i,nl,3)
-				!!!call smooth_cf(aux,auxs,i,nl,5)
-				ntimes=ntimes+1
-			   end if
-			do j=1,nl
-			  c(i,j)=auxs(j)
-			end do
-		end do
-	end if
-
-!	   type *, 'elimin_mz4: c(n,r) procesed for elimination. '
-!	   type *, ' '
-!	   if(nan.eq.4.or.nan.eq.6) type *, '    call smoothing:',ntimes
-!	   if(nan.eq.5.or.nan.eq.6) type *, '    call elimina:  ',ntimes2
-!	   if(nan.eq.7)   type *, '    from elimin: lisa w=',nw
-!	   type *, ' '
-
-
- 200	continue
-
-c	writting out of c(n,r) in ascii file 
-
-!	if(itblout.eq.1) then
-
-!	  if (ilayer.eq.0) then
-
-!	   open (unit=2, status='new', 
-!     @    file=dircurtis//'curtis_gnu.out', recl=1024)
-!	    write(2,'(a)') 
-!     @    ' curtis matrix:     table with   1.e+7 * acf(n,r) '
-!	    write(2,114) 'n,r', ( i, i=nl,1,-5 )
-!	    do in=nl,1,-5
-!	      write(2,*)
-!	      write(2,115) in, ( c(in,ir)*1.d7, ir=nl,1,-5 )
-!	    end do 
-!	   close(2)
-
-
-!	   write (*,*)  ' '
-!	   write (*,*)  '  curtis.out has been created. '
-!	   write (*,*)  ' '
-
-!	  else
-
-!            write (layercode,132) ilayer
-!	    open (2, status='new', 
-!     @    file=dircurtis//'curtis'//layercode//'.out')
-!	    write(2,'(a)') 
-!     @    ' curtis matrix:     table with   1.e+7 * acf(n,r) '
-!	    write(2,116) ' layer x       c(',layercode,
-!     @    ',x)           c(x,', layercode,')' 
-!	    do in=nl,1,-1
-!	     if (c(ilayer,ilayer).ne.0.d0) then 
-!	      write(2,117) in, c(ilayer,in), c(in,ilayer), 
-!     @        c(ilayer,in)/c(ilayer,ilayer),
-!     @        c(in,ilayer)/c(ilayer,ilayer)
-!	     else
-!	      write(2,118) in, c(ilayer,in), c(in,ilayer)
-!	     end if
-!	    end do 
-!	    close(2)
-!	    write (*,*)  ' '
-!	    write (*,*)  dircurtis//'curtis'//layercode//'.out', 
-!     @ ' has been created.'
-!	    write (*,*) ' '
-
-!	  end if
-
-!	elseif(itblout.eq.0)then
-
-!	  continue
-
-!	else
-
-!	  write (*,*) ' error from elimin: ', 
-!     @      ' itblout should be 1 or 0;   itblout= ',itblout
-!	  stop
-
-!	end if
-	
-	return
-
-112	format(10x,10(i3,9x))
-113	format(1x,i3,2x,9(1pe9.2,2x))
-
-114	format(1x,a3, 11(8x,i3))
-115	format( 1x,i3, 2x, 11(1pe10.3))
-116	format( 1x,a17,a2,a18,a2,a1 ) 
-117	format( 3x,i3, 4(8x,1pe10.3) )
-118	format( 3x,i3, 2(8x,1pe10.3) )
-120	format( 1x,i3, 1x,i3, 2x, 11(1pe10.3))
-
-132     format(i3)
-
-!  cambio: los formatos 114, 115 , 117 y 118
-!  cambio: al cambia nl de 51 a 140 hay que cambiar el formato i2-->i3
-!          y ahora en vez de 11 capas de 5 en 5, hay 28
-!
-	end
-c**************************************************************************
-	subroutine smooth_cf( c, cs, i, nl, w )
-c	hace un smoothing de c(i,*), de la contribucion de todas las capas
-c	menos de la capa en cuestion, la i.
-c	opcion w (width): el tamanho de la ventana del smoothing.
-c       output values: cs
-c**************************************************************************
-
-	implicit none
-
-	integer  j,np,i,nl,w
-	real*8   c(nl), cs(nl)
-
-	if(w.eq.0) then
-	 do j=1,nl
-		cs(j)=c(j)
-	 end do
-
-	elseif(w.eq.3) then
-
-!	write (*,*) 'smoothing w=3'
-	 do j=1,i-4
-		   if(j.eq.1) then
-			cs(j)=c(j)
-		   else
-			cs(j)=1/3.d0*(c(j-1)+c(j)+c(j+1))
-                   end if
-	 end do
-	 do j=i+4,nl-1
-		   if(j.eq.nl) then
-			cs(j)=c(j)
-		   else
-			cs(j)=1/3.d0*(c(j-1)+c(j)+c(j+1))
-                   end if
-	 end do
-	elseif(w.eq.5) then
-
-!	type *,'smoothing w=5'
-	 do j=3,i-4
-		   if(j.eq.1) then
-			cs(j)=c(j)
-		   else
-			cs(j)=1/5.d0*(c(j-2)+c(j-1)+c(j)+c(j+1)+c(j+2))
-                   end if
-	 end do
-	 do j=i+4,nl-2
-		   if(j.eq.nl) then
-			cs(j)=c(j)
-		   else
-			cs(j)=1/5.d0*(c(j-2)+c(j-1)+c(j)+c(j+1)+c(j+2))
-                   end if
-	 end do
-	end if
-        return
-        end
-
-
Index: unk/LMDZ.MARS/libf/phymars/getk_V09.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/getk_V09.F	(revision 497)
+++ 	(revision )
@@ -1,819 +1,0 @@
-c***********************************************************************
-                                                
-	subroutine getk (tt)                           
-                                                
-c	jan 98	malv 		version for mz1d. copied from solar10/getk.f
-c       jul 2011 malv+fgg       adapted to LMD-MGCM
-c***********************************************************************
-	                                               
-	implicit none                                  
-                                                
-	include 'nltedefs.h'          
-        include 'tcr_15um.h'
-	include 'nlte_data.h'       
-        include 'nlte_rates.h'
-                                                
-c arguments 	                                   
-	real 		tt	! i. temperature                     
-                                                
-!! local variables:                             
-	real*8 k1x, k7x,k7xa,k7xb
-        real*8 k3x, k3xaa,k3xac,k3xab,k3xbb,k3xba,k3xbc    
-	real*8 k3xco2,k3xn2,k3xco, k6x,k6x1,k6x2
-        real*8 k20x,k20xa,k20xb,k20xc       
-	real*8 k19xca,k19xcb,k19xcc
-        real*8 k19xba,k19xbb,k19xbc
-        real*8 k19xaa,k19xab,k19xac  
-	real*8 k21x,k21xa,k21xb,k21xc                  
-	real*8 anu, factor , k21xa_626               
-	real tt1,tt2, de                             
-	integer 	i                                     
-                                                
-c***********************************************************************
-                                                
-co2i(001) + n2 ---> co2i + n2(1)     k1     (not considered in the model
-c k1(i)  i = 1 --- 626	                         
-!	     2 --- 636                                
-!	     3 --- 628                                
-!	     4 --- 627                                
-                                                
-!	k1x = 5.d-13 * sqrt(300.d0/tt)                
-!	do i=1,nisot                                  
-!		k1(i) = k1x * rf1                            
-!		k1p(i) = k1(i) * exp( -ee/tt *1.d0* (-nun2+nu(i,4)) )    
-!	end do                                        
-                                                
-co2(001) + co2i ---> co2 + co2i(001)	k2   (vv1 in table 4, paper i)     
-c  k2i	i = x --- 628                            
-!	    y --- 636                                 
-!	    z --- 627                                 
-		                                              
-	k2a = 6.8d-12 * sqrt(tt)  	! delta(e)< 42 cm-1 
-	k2b = 3.6d-11 * sqrt(tt) * exp(-65.6557/26.3)   ! > 42 cm-1 see table 3
-	k2a = k2a * rf2desac                           
-	k2b = k2b * rf2desac                           
-                                                
-	k2x = 6.8d-12 * sqrt(tt)                       
-	k2y = 3.6d-11 * sqrt(tt) * exp(-65.6557/26.3)  
-	k2z = 6.8d-12 * sqrt(tt)                       
-	k2x = k2x * rf2iso 	                           
-	k2y = k2y * rf2iso 	                           
-	k2z = k2z * rf2iso 	                           
-	k2xp = k2x * exp( dble( -ee/tt * (nu(1,4)-nu(2,4)) ) )     
-	k2yp = k2y * exp( dble( -ee/tt * (nu(1,4)-nu(3,4)) ) )     
-	k2zp = k2z * exp( dble( -ee/tt * (nu(1,4)-nu(4,4)) ) )     
-                                                
-! these are vt1 in table 3, paper i             
-co2i(001) + m ---> co2i(0v0) + m	k3             
-co2i(001) + o3p ---> co2i(0v0) + o3p 	k7        
-c  k3vm(i)  m = a --- co2       v = a --- 3     i = 1,2,3,4 
-!	        b --- n2,o2	    b --- 2		             
-!	        c --- co 	    		                      
-c  k7v(i)  v = a --- 3  	i = 1,2,3,4            
-!	       b --- 2		                              
-                                                
-	k7x = 2.0d-13*sqrt(tt/300.d0)                  
-	k7x = k7x * rf7                                
-                                                
-	if (iopt3.eq.0) then                           
-                                                
-	  k3x = 2.2d-15 + 1.14d-10 * exp( dble(-76.75/tt**(1.d0/3.d0)) )      
-	  k3xaa = 3.0d-15 + 1.72d-10 * exp( dble(-76.75/tt**(1.d0/3.d0)) )  
-	  k3xac = 2.2d-15 + 9.66d-11 * exp( dble(-76.75/tt**(1.d0/3.d0)) )  
-	  k3x = k3x * rf3                              
-	  k3xaa = k3xaa * rf3                          
-	  k3xac = k3xac * rf3                          
-                                                
-	  tt1=220.0  !500.0  !220.0                    
-	  tt2=250.0  !250.0                            
-	  if(tt.le.tt1)then                            
-	    k3xab = k3x                                
-	    k3xbb = 0.d0                               
-	    k7xa=k7x                                   
-	    k7xb=0.d0                                  
-	  else if(tt.gt.tt2)then                       
-	    k3xab = 0.d0                               
-	    k3xbb = k3x                                
-	    k7xa=0.d0                                  
-	    k7xb=k7x                                   
-	  else                                         
-	    k3xab = k3x/30.d0*(tt2-tt)                 
-	    k3xbb = k3x/30.d0*(tt-tt1)                 
-	    k7xa=k7x/30.d0*(tt2-tt)                    
-	    k7xb=k7x/30.d0*(tt-tt1)                    
-	  end if                                       
-	  k3xba = k3xbb                                
-	  k3xbc = k3xbb                                
-                                                
-	elseif (iopt3.gt.0) then 	! bauer et. al., 1987            
-                                                
-	  if (tt.ge.190. .and. tt.le.250.) then        
-	    factor = 0.9d0 + dble( (0.1-0.9)/(250.-190.) * (tt-190.) )         
-	  elseif (tt.lt.190.) then                     
-	    factor = 0.9d0                             
-	  elseif (tt.gt.250.) then                     
-	    factor = 0.1d0                             
-	  end if                                       
-                                                
-	  k3xn2 = 2.2d-15 + 1.14d-10 * exp(dble( -76.75/tt**(1.d0/3.d0)) )     
-	  k3xn2 = k3xn2 * rf3                          
-	  k3xab = k3xn2 * factor                       
-	  k3xbb = k3xn2 * (1.-factor)                  
-                                                
-	  k7xa = k7x * factor                          
-	  k7xb = k7x * (1.-factor)                     
-                                                
-	  if (iopt3.eq.1) then 	                       
-                                                
-	    if (tt.le.148.8) then                      
-	      k3xco2 = 13.8 - 0.1807 * (tt-140.)       
-	    elseif (tt.ge.148.8 .and. tt.le.159.6) then            
-	      k3xco2 = 12.21 - 0.1787 * (tt-148.8)     
-	    elseif (tt.ge.159.6 .and. tt.le.171.0) then            
-	      k3xco2 = 10.28 - 0.04035 * (tt-159.6)    
-	    elseif (tt.ge.171.0 .and. tt.le.186.4) then            
-	      k3xco2 = 9.82 - 0.027273 * (tt-171.0)    
-	    elseif (tt.ge.186.4 .and. tt.le.244.1) then            
-	      k3xco2 = 9.4 + 0.002253 * (tt-186.4)     
-	    elseif (tt.ge.244.1 .and. tt.le.300) then  
-	      k3xco2 = 9.53 + 0.02129 * (tt-244.1)     
-	    elseif (tt.ge.300 .and. tt.le.336.1) then  
-	      k3xco2 = 10.72 + 0.052632 * (tt-300)     
-	    elseif (tt.ge.336.1 .and. tt.le.397.0) then            
-	      k3xco2 = 12.62 + 0.0844 * (tt-336.1)     
-	    elseif (tt.ge.397.0 .and. tt.le.523.4) then            
-	      k3xco2 = 17.76 + 0.2615 * (tt-397.)      
-	    end if                                     
-	    k3xco2 = k3xco2 * 1.d-15 * rf3             
-	    k3xaa = 0.82d0 * k3xco2                    
-	    k3xba = 0.18d0 * k3xco2                    
-                                                
-	    if (tt.le.163.) then                       
-	      k3xco = 10.58 - 0.093 * (tt-140)         
-	    elseif (tt.ge.163. .and. tt.le.180.) then  
-	      k3xco = 8.44 - 0.05353 * (tt-163.)       
-	    elseif (tt.ge.180. .and. tt.le.196.) then  
-	      k3xco = 7.53 - 0.034375 * (tt-180.)      
-	    elseif (tt.ge.196. .and. tt.le.248.) then  
-	      k3xco = 6.98 - 0.0108 * (tt-196.)        
-	    elseif (tt.ge.248. .and. tt.le.301.) then  
-	      k3xco = 6.42 + 0.01415 * (tt-248.)       
-	    elseif (tt.ge.301. .and. tt.le.353.) then  
-	      k3xco = 7.17 + 0.02865 * (tt-301.)       
-	    end if                                     
-	    k3xac = k3xco * 1.d-15 * rf3               
-	    k3xbc = 0.d0                               
-                                                
-	  elseif (iopt3.eq.2) then 	! revision for the papers (feb 93)
-                                                
-	    k3xco2 = 7.3d-14 * exp( -850.3/tt + 86523/tt**2.d0 )   
-	    k3xco2 = k3xco2 * rf3                      
- 	    k3xaa = 0.82d0 * k3xco2                   
-	    k3xba = 0.18d0 * k3xco2                    
-                                                
-	    k3xco = 1.7d-14 * exp( -448.3/tt + 53636/tt**2.d0 )    
-	    k3xac = k3xco * rf3                        
-	    k3xbc = 0.d0                               
-                                                
-	  end if                                       
-                                                
-	end if                                         
-                                                
-	do i=1,nisot                                   
-	  k3aa(i) = k3xaa                              
-	  k3ba(i) = k3xba                              
-	  k3ab(i) = k3xab                              
-	  k3bb(i) = k3xbb                              
-	  k3ac(i) = k3xac                              
-	  k3bc(i) = k3xbc                              
-	  anu = nu(i,4)-nu(i,3)                        
-!	  anu = nu(i,4)-nu(i,3)+70                    
-	  k3aap(i) = k3aa(i) * exp( -ee/tt * anu )/6.d0            
-	  k3abp(i) = k3ab(i) * exp( -ee/tt * anu )/6.d0            
-	  k3acp(i) = k3ac(i) * exp( -ee/tt * anu )/6.d0            
-	  anu = nu(i,4)-nu(i,2)                        
-!	  anu = nu(i,4)-nu(i,2)+40                    
-	  k3bap(i) = k3ba(i) * exp( -ee/tt * anu )/4.d0            
-	  k3bbp(i) = k3bb(i) * exp( -ee/tt * anu )/4.d0            
-	  k3bcp(i) = k3bc(i) * exp( -ee/tt * anu )/4.d0            
-                                                
-  	  k7a(i) = k7xa                              
-	  k7b(i) = k7xb                                
-	  k7ap(i) = k7a(i) * exp(dble( -ee/tt*(nu(i,4)-nu(i,3)) ))/6.d0        
-	  k7bp(i) = k7b(i) * exp(dble( -ee/tt*(nu(i,4)-nu(i,2)) ))/4.d0        
-	end do                                         
-                                                
-                                                
-! the next ones correspond to vv2 in table 4, paper i       
-co2i(001) + co2 ---> co2i(020) + co2(010)	k6    
-! k6(i)  i = 1,2,3,4                            
-! we need a new index for the inverse rates due to both fractions :     
-c  k6a(i) i=2,3,4      co2i(001) + co2 ---> co2i(020) + co2(010)        
-c  k6b(i)    "          co2i(001) + co2 ---> co2i(010) + co2(020)       
-                                                
-	if (iopt6.eq.1) then                           
-                                                
-	  if(tt.le.175.d0)then                         
-	    k6x=8.6d-15                                
-	  elseif(tt.gt.175.0.and.tt.le.200.d0)then     
-	    k6x=8.6d-15+9.d-16*(175.d0-tt)/25.d0       
-	  elseif(tt.gt.200.0.and.tt.le.225.d0)then     
-	    k6x=7.7d-15+5.d-16*(200.d0-tt)/25.d0       
-	  elseif(tt.gt.225.0.and.tt.le.250.d0)then     
-	    k6x=7.20d-15+6.d-16*(tt-225.d0)/25.d0      
-	  elseif(tt.gt.250.0.and.tt.le.275.d0)then     
-	    k6x=7.80d-15+1.d-15*(tt-250.d0)/25.d0      
-	  elseif(tt.gt.275.0.and.tt.le.300.d0)then     
-	    k6x=8.80d-15+1.3d-15*(tt-275.d0)/25.d0     
-	  elseif(tt.gt.300.0.and.tt.le.325.d0)then     
-	    k6x=10.1d-15+1.54d-15*(tt-300.d0)/25.d0    
-	  elseif(tt.gt.325.0)then                      
-            k6x=11.6d-15                        
-	  end if                                       
-                                                
-	elseif (iopt6.eq.2) then                       
-                                                
-          k6x = 3.6d-13 * exp( -1660/tt + 176948/tt**2.d0 ) 
-	  if (tt.lt.175) k6x = 8.8d-15                 
-                                                
-	end if                                         
-                                                
-	k6x1 = k6x * rf6 * frac6                       
-	k6x2 = k6x * rf6 * (1.-frac6)                  
-                                                
-	k6 = k6x * rf6                                 
-	k6p = k6 / 8.d0 * exp(dble( -ee/tt * (nu(1,4)-nu(1,2)-nu(1,1)) ))      
-	do i=2,nisot                                   
-	  k6a(i) = k6x1                                
-	  k6b(i) = k6x2                                
-	  anu = nu(i,4)-nu(i,2)-nu(1,1)                
-	  k6ap(i) = k6a(i) / 8.d0 * exp(dble( -ee*anu/tt ))        
-	  anu = nu(i,4)-nu(i,1)-nu(1,2)                
-	  k6bp(i) = k6b(i) / 8.d0 * exp(dble( -ee*anu/tt ))        
-	end do                                         
-                                                
-                                                
-co2i(0v0) + co2i ---> co2i(0v-10) + co2i(010)   
-c  k5 		esta reaccion es desdenable frente a co2 como colisionante. 
-!	  k5=3.0d-15+6.0d-17*(tt-210.d0)              
-!	  k5=k5*rf5                                   
-!	  k5p=k5/2.d0*exp(-ee*125.77/tt)              
-                                                
-                                                
-co2i(0v0) + m ---> co2i(0v-10) + m	k19     (vt2,k5,k6 in table 3, paper 
-co2i(0v0) + o3p ---> co2i(0v-10) + o3p	k20     (vt2,k7 in table 3, paper
-c  k19vm(i)  m = a --- co2	v = a --- 3   i=1,2,3,4          
-!	       b --- n2		    b --- 2		                
-!	       c --- co		    c --- 1		                
-c  k20v(i)  v = a --- 3		i = 1,2,3,4            
-!	        b --- 2		                             
-!	        c --- 1		                             
-!                                               
-!	  k20x=1.9d-8*exp(-76.75/(tt**(1.d0/3.d0))) ! taylor,74 reajusted     
-!	  k20x=2.32d-9*exp(-76.75/(tt**(1./3.)))+1.0d-14*sqrt(tt) ! k&j, 83   
-!	  k20x = 1.43d-12*(tt/300.d0)	! shved et al, 90           
-                                                
-	if (iopt20.eq.1) then      ! first version of pap1         
-	  k20x=2.32d-9*exp(-76.75/(tt**(1./3.)))+3.5d-13*sqrt(tt) ! s&w, 91    
-	  k20xb = k20x / 2.d0 * rf20                   
-	  k20xc = k20xb                                
-	  k20xa = 3.d0/2.d0 * k20xb                    
-	elseif(iopt20.eq.2) then  ! revision for the papers in feb 93          
-	  k20x=3.d-12 ! minimum value of lopez-puertas et al., 92  
-	  k20xc = k20x * rf20                          
-	  k20xb = 2.d0 * k20xc                         
-	  k20xa = 3.d0/2.d0 * k20xb                    
-	elseif(iopt20.eq.3) then  ! values from boug & roble '91   
-		k20x=1.d-12/sqrt(300.) * sqrt(tt)             
-	  k20xc = k20x * rf20                          
-	  k20xb = 2.d0 * k20xc                         
-	  k20xa = 3.d0/2.d0 * k20xb                    
-	elseif(iopt20.eq.4) then  ! values from boug & dick '88  case b        
-		k20x=7.d-13                                   
-	  k20xc = k20x * rf20                          
-	  k20xb = 2.d0 * k20xc                         
-	  k20xa = 3.d0/2.d0 * k20xb                    
-	elseif(iopt20.eq.5) then  ! values from s.bougher (oct-98) 
-		k20x = 1.732d-13 * sqrt(tt)    ! 1/sqrt(300) * sqrt(t)    
-	  k20xc = k20x * rf20                          
-	  k20xb = 2.d0 * k20xc                         
-	  k20xa = 3.d0/2.d0 * k20xb                    
-	end if                                         
-                                                
-	if (iopt19.eq.0) then                          
-                                                
-	  k19xca = 4.64d-10 * exp(dble(  - 74.75 / tt**(1.d0/3.d0) ))          
-	  k19xcb = 6.69d-10 * exp(dble(  - 84.07 / tt**(1.d0/3.d0) ))          
-	  k19xcc = k19xcb                              
-                                                
-	  if ( tt.le.250 ) then                        
-		k19xba = 181.25d0                             
-	  elseif ( tt.ge.310 ) then                    
-		k19xba = 200.d0 + 0.9d0 * ( tt - 310.d0 )     
-	  else                                         
-		k19xba = 181.25d0 + 0.3125d0 * ( tt - 250.d0 )            
-	  end if                                       
-	  k19xba = k19xba * 1.03558d-19 * tt	! cm-1 s-1            
-	  k19xbb = 1.24d-14 * ( tt / 273.3d0 )**2.d0    ! taine & lepoutre 1979
-	  k19xbc = k19xbb                              
-                                                
-	  k19xaa = 3.d0/2.d0 * k19xba                  
-	  k19xab = 3.d0/2.d0 * k19xbb                  
-	  k19xac = 3.d0/2.d0 * k19xbc                  
-                                                
-	  k19xaa = k19xaa * rf19                       
-	  k19xab = k19xab * rf19                       
-	  k19xac = k19xac * rf19                       
-	  k19xba = k19xba * rf19                       
-	  k19xbb = k19xbb * rf19                       
-	  k19xbc = k19xbc * rf19                       
-	  k19xca = k19xca * rf19                       
-	  k19xcb = k19xcb * rf19                       
-	  k19xcc = k19xcc * rf19                       
-                                                
-	elseif (iopt19.ge.1) then 		                   
-                                                
-	  if (iopt19.eq.1) then 	! lunt et. al., 1985 (thesis values)
-                                                
-	    if (tt.le.175.) then                       
-	      k19xca = 4.d0 - 0.02d0 * (tt-140.d0)     
-	      k19xcb = 0.494d0 + 0.0076 * (tt-140.d0)	 
-	    elseif (tt.ge.175. .and. tt.le.200.) then  
-	      k19xca = 3.3d0 - 0.02d0 * (tt-175.)      
-	      k19xcb = 0.76d0 + 0.0076d0 * (tt-175.d0)	            
-	    elseif (tt.ge.200. .and. tt.le.225.) then  
-	      k19xca = 2.8d0 + 0.004d0 * (tt-200.d0)   
-	      k19xcb = 0.95d0 + 0.014d0 * (tt-200.d0)	 
-	    elseif (tt.ge.225. .and. tt.le.250.) then  
-	      k19xca = 2.9d0 + 0.024d0 * (tt-225.d0)   
-	      k19xcb = 1.3d0 + 0.016d0 * (tt-225.d0)	  
-	    elseif (tt.ge.250. .and. tt.le.275.) then  
-	      k19xca = 3.5d0 + 0.04d0 * (tt-250.d0)    
-	      k19xcb = 1.7d0 + 0.032d0 * (tt-250.d0)	  
-	    elseif (tt.ge.275. .and. tt.le.295.) then  
-	      k19xca = 4.5d0 + 0.055d0 * (tt-275.d0)   
-	      k19xcb = 2.5d0 + 0.045d0 * (tt-275.d0)	  
-	    elseif (tt.ge.295. .and. tt.le.320.) then  
-	      k19xca = 5.6d0 + 0.54d0 * (tt-295.d0)    
-	      k19xcb = 3.4d0 + 0.045d0 * (tt-295.d0)	  
-	    end if                                     
-	    k19xca = k19xca * 1.d-15 * rf19            
-	    k19xcb = k19xcb * 1.d-15 * rf19            
-	    k19xcc = k19xcb                            
-                                                
-	  elseif (iopt19.eq.2) then 	! revision for the papers, feb 1993
-                                                
-!	    k19xca = 7.3d-14 * exp( -850.3d0/tt + 86523.d0/tt**2.d0 )         
-	    k19xca = 4.2d-12 * exp( -2988.d0/tt + 303930.d0/tt**2.d0 )         
-	    if (tt.le.175.) k19xca = 3.3d-15           
-	    k19xcb = 2.1d-12 * exp( -2659.d0/tt + 223052.d0/tt**2.d0 ) 	       
-	    if (tt.le.175.) k19xcb = 7.6d-16           
-	    k19xca = k19xca * rf19                     
-	    k19xcb = k19xcb * rf19                     
-	    k19xcc = k19xcb                            
-                                                
-	  elseif (iopt19.eq.3) then 	! values from dick'72 for k19xc
-					! k19xcb is not modified     
-	    if (tt.le.158.) then                       
-		k19xca = 0.724d-15                            
-	    elseif (tt.le.190.) then                   
-		k19xca = 0.724d-15 +                          
-     @   		(1.1d-15-0.724d-15) * (tt-158.) / (190.-158.)  
-	    elseif (tt.le.250.) then                   
-		k19xca = 1.1d-15 +                            
-     @   		(3.45d-15-1.1d-15) * (tt-190.) / (250.-190.) 
- 	    elseif (tt.gt.250.) then                  
-	        k19xca = 3.45d-15                      
-	    end if                                     
-	    k19xcb = 2.1d-12 * exp( -2659.d0/tt + 223052.d0/tt**2.d0 ) 	       
-	    if (tt.le.175.) k19xcb = 7.6d-16           
-	    k19xca = k19xca * rf19                     
-	    k19xcb = k19xcb * rf19                     
-	    k19xcc = k19xcb                            
-                                                
-	  elseif (iopt19.eq.5) then 	                  
-                                                
-	    k19xca = 5.2d-15            ! s.bougher, nov-98        
-	    k19xcb = 7.6d-16            ! nuestro, de feb-93       
-	    k19xcc = k19xcb                            
-                                                
-	    k19xca = k19xca * rf19                     
-	    k19xcb = k19xcb * rf19                     
-                                                
-	  end if                                       
-                                                
-	  factor = 2.5d0                               
-	  k19xba = factor * k19xca                     
-	  k19xbb = factor * k19xcb                     
-	  k19xbc = factor * k19xcc                     
-	  factor = 3.d0/2.d0                           
-	  k19xaa = factor * k19xba                     
-	  k19xab = factor * k19xbb                     
-	  k19xac = factor * k19xbc                     
-                                                
-	end if                                         
-                                                
-	do i = 1, nisot                                
-                                                
-	  k19aa(i) = k19xaa                            
-	  k19ba(i) = k19xba                            
-	  k19ca(i) = k19xca                            
-	  k19ab(i) = k19xab                            
-	  k19bb(i) = k19xbb                            
-	  k19cb(i) = k19xcb                            
-	  k19ac(i) = k19xac                            
-	  k19bc(i) = k19xbc                            
-	  k19cc(i) = k19xcc                            
-	  anu = nu(i,3)-nu(i,2)                        
-	  k19aap(i) = k19aa(i) * 6.d0/4.d0 * exp(dble( -ee*anu/tt))            
-	  k19abp(i) = k19ab(i) * 6.d0/4.d0 * exp(dble( -ee*anu/tt))            
-	  k19acp(i) = k19ac(i) * 6.d0/4.d0 * exp(dble( -ee*anu/tt))            
-	  anu = nu(i,2)-nu(i,1)                        
-	  k19bap(i) = k19ba(i) * 2.d0 * exp(dble( -ee*anu/tt))     
-	  k19bbp(i) = k19bb(i) * 2.d0 * exp(dble( -ee*anu/tt))     
-	  k19bcp(i) = k19bc(i) * 2.d0 * exp(dble( -ee*anu/tt))     
-	  anu = nu(i,1)                                
-	  k19cap(i) = k19ca(i) * 2.d0 * exp(dble( -ee*anu/tt))     
-	  k19cbp(i) = k19cb(i) * 2.d0 * exp(dble( -ee*anu/tt))     
-	  k19ccp(i) = k19cc(i) * 2.d0 * exp(dble( -ee*anu/tt))     
-                                                
-	  k20a(i) = k20xa                              
-	  k20b(i) = k20xb                              
-	  k20c(i) = k20xc                              
-	  k20ap(i) = k20a(i)*6.d0/4.d0 * 
-     @                exp(dble( -ee/tt * (nu(i,3)-nu(i,2)) )) 
-	  k20bp(i) = k20b(i)*4.d0/2.d0 *
-     @                exp(dble( -ee/tt * (nu(i,2)-nu(i,1)) )) 
-	  k20cp(i) = k20c(i)*2.d0/1.d0 *
-     @                exp(dble( -ee/tt * nu(i,1) ))           
-	end do                                         
-                                                
-!	write(1,*) tt,k19cap(1),k19ac(1)              
-                                                
-! the next ones correspond to vv3 in table 4 (paper i)      
-co2i(0v0) + co2 ---> co2i(0v-10) + co2(010)	k21	also see k33 
-c  k21v(i)  v = a --- 3		i = 1,2,3,4            
-!	        b --- 2		                             
-!	        c --- 1		                             
-! we need a new index for the 030i rates due to both fractions :        
-c  k21a1       co2i(030) + co2 ---> co2i(020) + co2(010)    
-c  k21a2       co2i(030) + co2 ---> co2i(010) + co2(020)    
-co2i(010) + co2j(000) ---> co2i(000) + co2j(010)   kijk21c  see pag.22-s
-!  k23k21c   i=628,j=636                        
-!  k24k21c   i=628,j=627                        
-!  k34k21c   i=636,j=627                        
-                                                
-	if (iopt21.eq.0) then                          
-	  k21x = 1.2d-11      	                        
-	  k21xb = k21x                                 
-	  k21xa = 3.d0/2.d0 * k21x                     
-	  k21xc = k21x 	        	! esta ultima no se usa con 626   
-	elseif (iopt21.eq.1) then 	                    
-	  k21x = 2.49d-11		! orr & smith, 1987         
-	  k21xb = k21x      	                          
-	  k21xa = 3.d0/2.d0 * k21xb		! oscilador armonico          
-	  k21xc = k21xb / 2.d0		! novedad mia          
-	elseif (iopt21.eq.2) then 	                    
-	  k21x = 100.d0*k19xca		! dickinson'76 (icarus)            
-	  k21xb = k21x      	                          
-	  k21xa = 3.d0/2.d0 * k21xb		! oscilador armonico          
-	  k21xc = k21xb / 2.d0		! novedad mia          
-	end if                                         
-	k21xa_626 = k21xa * rf21a    !* 0.01d0  !* 10.d0	          
-	k21xa = k21xa * rf21a        !* 0.01d0         
-	k21xb = k21xb * rf21b                          
-	k21xc = k21xc * rf21c                          
-                                                
-	k21a = k21xa_626                               
-	k21ap = k21a * 6.d0/8.d0 *                     
-     @   	exp( dble( -ee/tt * (nu(1,3)-nu(1,2)-nu(1,1)) ) )        
-	do i = 2, nisot                                
-	  k21a1(i) = k21xa * frac21                    
-	  k21a2(i) = k21xa * (1.d0-frac21)             
-	  k21a1p(i) = k21a1(i) * 6.d0/8.d0 *           
-     @   	exp(dble(  -ee/tt* (nu(i,3)-nu(i,2)-nu(1,1)) ))          
-	  k21a2p(i) = k21a2(i) * 6.d0/8.d0 *           
-     @   	exp(dble(  -ee/tt* (nu(i,3)-nu(i,1)-nu(1,2)) ))          
-	end do                                         
-	                                               
-                                                
-	do i = 1, nisot                                
-	 k21b(i) = k21xb                               
-	 k21c(i) = k21xc                               
-	 k21bp(i) = k21b(i) * 
-     @                exp(dble( -ee/tt* (nu(i,2)-nu(i,1)-nu(1,1)) ))   
-	 k21cp(i) = k21c(i) * 
-     @                exp(dble( -ee/tt * (nu(i,1)-nu(1,1)) ))          
-	end do                                         
-                                                
-	k23k21c = k21xc                                
-	k24k21c = k21xc                                
-	k34k21c = k21xc                                
-	k23k21cp = k23k21c*2.d0/2.d0 * 
-     @               exp(dble( -ee/tt* (nu(2,1)-nu(3,1)) ))  
-	k24k21cp = k24k21c*2.d0/2.d0 * 
-     @               exp(dble( -ee/tt* (nu(2,1)-nu(4,1)) ))  
-	k34k21cp = k34k21c*2.d0/2.d0 * 
-     @               exp(dble( -ee/tt* (nu(3,1)-nu(4,1)) ))  
-                                                
-!these are also vv3 in table 4, paper i         
-c  k31 & k32	                                   
-                                                
-	k31 = k21x * rf31 ! we're suposing thar the rate for the deactivation  
-			 ! v-v from high combinational levels is the same
-	k32 = k21x * rf32 ! that the one for :  (020) --> (010) + (010)        
-                                                
-co2(***) + co2i ---> co2(***) + co2i(***)	k33   
-c k33a1 :   co2(001) + co2i ---> co2(020) + co2i(010)    (vv2, table 4, 
-!    a2 :   co2(001) + co2i ---> co2(010) + co2i(020)      "            
-!    b1 :   co2(030) + co2i ---> co2(020) + co2i(010)    (vv3, table 4, 
-!    b2 :   co2(030) + co2i ---> co2(010) + co2i(020)      "            
-!    c :   co2(020) + co2i ---> co2(010) + co2i(010)       "            
-! we have to add an index to the inverse rates, depending on the isotope
-                                                
-	k33c = k21x * rf33bc                           
-	k33b1 = 3.d0/3.d0 * k33c * frac33              
-	k33b2 = 3.d0/3.d0 * k33c * (1.d0-frac33)       
-	k33a1 = k6x * rf33a * frac33                   
-	k33a2 = k6x * rf33a * (1.d0-frac33)            
-                                                
-	do i=2,nisot                                   
-	 k33a1p(i)=k33a1*                              
-     @   	1.d0/8.d0*exp(dble( -ee/tt* (nu(1,4)-nu(1,2)-nu(i,1)) )) 
-	 k33a2p(i)=k33a2*                              
-     @   	1.d0/8.d0*exp(dble( -ee/tt* (nu(1,4)-nu(1,1)-nu(i,2)) )) 
-	 k33b1p(i)=k33b1*                              
-     @   	6.d0/8.d0*exp(dble( -ee/tt* (nu(1,3)-nu(1,2)-nu(i,1)) )) 
-	 k33b2p(i)=k33b2*                              
-     @   	6.d0/8.d0*exp(dble( -ee/tt* (nu(1,4)-nu(1,1)-nu(i,2)) )) 
-	 k33cp(i) =k33c * exp(dble( -ee/tt * (nu(1,2)-nu(1,1)-nu(i,1)) ))      
-	end do                                         
-                                                
-! here they are the vt3 in table 3, paper i     
-co2(2.7um) + m ---> co2(2.7um) + m	k27          
-c k27a :    n8 + m ---> n6 + m                  
-!    b :    n7 + m ---> n6 + m                  
-!    c :    n8 + m ---> n7 + m                  
-                                                
-	if (iopt27.eq.0) then	                         
-	  k27a = 3.d-11	!between fermi levels          
-	  k27b = 3.d-13   !between side levels         
-	  k27c = 2.d0 * k27b !between side levels      
-	elseif (iopt27.ge.1) then  	! orr & smith, 1987            
-	  k27a = 1.55d-12                              
-	  k27c = 4.97d-12                              
-	  k27b = k27c                                  
-	end if                                         
-	k27a = k27a * rf27f                            
-	k27b = k27b * rf27s                            
-	k27c = k27c * rf27s                            
-                                                
-	k27ap = k27a * exp(dble( -ee/tt * (nu(1,8)-nu(1,6)) ))     
-	k27bp = k27b * exp(dble( -ee/tt * (nu(1,7)-nu(1,6)) ))     
-	k27cp = k27c * exp(dble( -ee/tt * (nu(1,8)-nu(1,7)) ))     
-                                                
-                                                
-! the next two are not used in the model:       
-                                                
-c k28 :    n* + n2 ---> n*low + n2(1)           
-!	k28v   v = a --- n8                           
-!		   b --- n7                                  
-!	           c --- n6                           
-!	k28a = 5.d-13 * sqrt(300.d0/tt) * rf28 	! = k1            
-!	k28b = k28a                                   
-!	k28c = k28a                                   
-!	k28ap = k28a * exp( -ee/tt * (nu(1,8)-1388.1847-nun2) )   
-!	k28bp = k28b * exp( -ee/tt * (nu(1,7)-1335.1317-nun2) )   
-!	k28cp = k28c * exp( -ee/tt * (nu(1,6)-1285.4087-nun2) )   
-                                                
-c k29 :    n* + co ---> n*low + co(1)           
-!	k29v   v = a --- n8                           
-!		   b --- n7                                  
-!	           c --- n6                           
-	                                               
-c	k29a = ?????????? * rf29                      
-c	k29b = k29a                                   
-c	k29c = k29a                                   
-                                                
-c	k29ap = k29a * exp( -ee/tt * (nu(1,8)-1388.1847-nuco) )   
-c	k29bp = k29b * exp( -ee/tt * (nu(1,7)-1335.1317-nuco) )   
-c	k29cp = k29c * exp( -ee/tt * (nu(1,6)-1285.4087-nuco) )   
-                                                
-                                                
-! these are also vv1 processes in table 4, paper i          
-c k26 :                                         
-! 1. deactivation of the 626 isotope:           
-!	reaction: n* + co2i ---> n*low + co2i(001)  ; i=1-4       
-!	nomenclature: k26v   ;  v=a,b,c,d  for n8,n7,n6,n5  respectively      
-!	inverse rates: k26vp(i) ; i=1-4               
-! 2. deactivation of the minor isotopes:        
-!	reaction: n*_i + co2j ---> n*_i_low + (001)_j  ; i=2-4 ; j=1-4        
-!	nomenclature:  k26vij ;  v=a,c,d  for n8,n6,n5 respectively           
-!	inverse rates: k26vijp                        
-! 3. notes:                                     
-!   a * it is clear that :  k26vij=/=k26vjip,   
-!   b * at the moment we do not include inverse rates for the case 2., o
-!	   the deactivation of the main isotope (pg. 32b, sn1).   
-!   c * not 0221 level for minor isotopes is considered.    
-!   d * only a value is known for these rates, so all of the deactivatio
-! 	   the same, but not the inverse rates.      
-!   e * although all the direct deactivation constants have the same val
-!          it is useful to distinguish between them with the present nam
-                                                
-	k26a = 6.8d-12 * sqrt(tt) * rf26 	! = k2       
-	k26b = k26a                                    
-	k26c = k26a                                    
-	if (iopt26.eq.0 .or. iopt26.eq.2) then         
-	  k26d = k26a                                  
-	elseif( iopt26.eq.1) then                      
-	  k26d = 1.15d-10 * rf26                       
-	end if                                         
-                                                
-	do i=1,4                                       
-	  k26ap(i) = k26a * 
-     @                 exp(dble( -ee/tt * (nu(1,8)-nu12_1000-nu(i,4)) ))  
-	  k26bp(i) = k26b * 
-     @                 exp(dble( -ee/tt * (nu(1,7)- nu(1,2) -nu(i,4)) ))  
-	  k26cp(i) = k26c * 
-     @                 exp(dble( -ee/tt * (nu(1,6)-nu12_0200-nu(i,4)) ))  
-	  k26dp(i) = k26d * 
-     @                 exp(dble( -ee/tt * (nu(1,5)- nu(1,1) -nu(i,4)) ))  
-	end do                                         
-                                                
-	k26a21 = k26a                                  
-	k26c21 = k26c                                  
-	k26d21 = k26d                                  
-	k26a22 = k26a                                  
-	k26c22 = k26c                                  
-	k26d22 = k26d                                  
-	k26a23 = k26a                                  
-	k26c23 = k26c                                  
-	k26d23 = k26d                                  
-	k26a24 = k26a                                  
-	k26c24 = k26c                                  
-	k26d24 = k26d                                  
-                                                
-	k26a31 = k26a                                  
-	k26c31 = k26c                                  
-	k26d31 = k26d                                  
-	k26a32 = k26a                                  
-	k26c32 = k26c                                  
-	k26d32 = k26d                                  
-	k26a33 = k26a                                  
-	k26c33 = k26c                                  
-	k26d33 = k26d                                  
-	k26a34 = k26a                                  
-	k26c34 = k26c                                  
-	k26d34 = k26d                                  
-                                                
-	k26a41 = k26a                                  
-	k26c41 = k26c                                  
-	k26d41 = k26d                                  
-	k26a42 = k26a                                  
-	k26c42 = k26c                                  
-	k26d42 = k26d                                  
-	k26a43 = k26a                                  
-	k26c43 = k26c                                  
-	k26d43 = k26d                                  
-	k26a44 = k26a                                  
-	k26c44 = k26c                                  
-	k26d44 = k26d                                  
-                                                
-!!	some examples of inverse rates, although not used at the moment      
-!	k26a32p = k26a32 * exp( -ee* (nu(3,8)-nu32_1000-nu(2,4)) / tt )*1./1. 
-!	k26c32p = k26c32 * exp( -ee* (nu(3,6)-nu32_0200-nu(2,4)) / tt )*1./1. 
-!	k26d32p = k26d32 * exp( -ee* (nu(3,5)- nu(3,1) -nu(2,4)) / tt )*2./2. 
-!                                               
-!	k26a43 = k26a34 * exp( -ee* (nu(3,8)-nu32_1000-nu(4,4)) / tt )*1./1.  
-!	k26c43 = k26c34 * exp( -ee* (nu(3,6)-nu32_0200-nu(4,4)) / tt )*1./1.  
-!	k26d43 = k26d34 * exp( -ee* (nu(3,5)- nu(3,1) -nu(4,4)) / tt )*2./2.  
-!                                               
-!	k26a24p = k26a24 * exp( -ee* (nu(2,8)-nu22_1000-nu(4,4)) / tt )*1./1. 
-!	k26c24p = k26c24 * exp( -ee* (nu(2,6)-nu22_0200-nu(4,4)) / tt )*1./1. 
-!	k26d24p = k26d24 * exp( -ee* (nu(2,5)- nu(2,1) -nu(4,4)) / tt )*2./2. 
-	                                               
-	                                               
-! this is taken as vv4 in table 4, paper i (in the inverse direction)   
-c k41 :    co(v) + co2 ---> co(v-1) + co2(001) + de         
-!	k41_v      v=1,2,3,4                
-!
-! de = -205.9 cm-1   when v=1                   
-! de = -232.9 cm-1   when v=2                   
-! de = -258.6 cm-1   when v=3                   
-! de = -285.0 cm-1   when v=4                   
-                                                
-	k41p_taylor = 1.56d-11 * exp( -30.12/tt**0.333333 )! [ s-1 cm+3 ]     
-	k41p_shved = 7.5d7/sqrt(tt) 			! [ s-1 atm-1 ]
-	k41p_shved = k41p_shved * 1.38d-16/1013250. * tt! [ s-1 cm+3 ]       
-	k41p_starr_hannock = 6.27d3 			! [ s-1 torr-1 ]
-                                                
-	if (iopt41.eq.1) then                          
-	  k41p_1 = k41p_starr_hannock *                
-     @   			760.*1.38d-16/1013250. * tt	! [ s-1 cm+3 ] 
-	elseif (iopt41.eq.2) then                      
-	  k41p_1 = 1.6d-12 * exp( -1169/tt + 77601/tt**2.d0 )      
-	end if                                         
-	k41p_1 = k41p_1 * rf41                          
-	k41_1 = k41p_1 * exp(dble( -ee * 205.9/tt ))   
-	k41_2 = k41_1                                  
-	k41p_2 = k41_2 * exp(dble( -ee * (-232.9)/tt ))            
-	k41_3 = k41_1                                  
-	k41p_3 = k41_3 * exp(dble( -ee * (-258.6)/tt ))            
-	k41_4 = k41_1                                  
-	k41p_4 = k41_4 * exp(dble( -ee * (-285.0)/tt ))            
-
-        !k41p_1 = k41p_1 * 1.d-6
-        !k41p_2 = k41p_2 * 1.d-6
-
-c k41iso :    63(v) + co2 ---> 63(v-1) + co2(001) + de         
-!	k41iso_v      v=1,2,3                
-! de = -253 cm-1   when v=1                   
-! de = -278 cm-1   when v=2                   
-! de = -303 cm-1   when v=3                   
-
-        k41iso_1 = k41_1
-	k41iso_1p = k41iso_1 * exp(dble( -ee * (-253.)/tt ))            
-        k41iso_2 = k41iso_1
-	k41iso_2p = k41iso_2 * exp(dble( -ee * (-278.)/tt ))            
-        k41iso_3 = k41iso_1
-	k41iso_3p = k41iso_3 * exp(dble( -ee * (-303.)/tt ))            
-        
-
-
-c k42 :    co(v) + co ---> co(v-1) + co(1) + de=-26.481  si v=2  K42
-!                                               -52.8940 si v=3  k42b
-!                                               -79.2402 si v=4  k42c
-!	tomado de stepanova & shved (ellos de powell, 1975), ver pg .. l5     
-	! solo para v=2 :                              
-                                                
-	k42 = 2.89d-10 * (1./sqrt(tt) + 67.4/tt**1.5) * 
-     @          exp(dble(24.78/tt))    
-	k42 = k42 * rf42                               
-	k42b = k42 
-	k42c = k42 
-	k42p = k42 * exp(dble( -ee * (-26.481)/tt ))   
-	k42bp = k42b * exp(dble( -ee * (-52.894)/tt ))   
-	k42cp = k42c * exp(dble( -ee * (-79.24)/tt ))   
-
-c k42iso :    63(v) + 63 ---> 63(v-1) + 63(1) + de=-25.31  si v=2  K42iso
-!                                                  -50.57  si v=3  k42isob
-!	tomado de stepanova & shved (ellos de powell, 1975), ver pg .. l5     
-	! solo para v=2 :                              
-                                                
-	k42iso = k42 
-	k42isop = k42iso * exp(dble( -ee * (-25.31)/tt ))   
-	k42isob = k42
-	k42isobp = k42isob * exp(dble( -ee * (-50.57)/tt ))   
-
-                                                
-c k43 :   co(v) + o3p ---> co(v-1) + o3p + de=2143   
-! 	tomado de lewittes et. al, 1978 para v=1              
-                                                
-	if (iopt43.eq.1) then 	                        
-	  tt1 = tt - 300.                              
-	  k43 = 2.85d-14 * exp( dble( 9.5e-3*tt1 + 1.11e-4*tt1**2. ) )         
-	elseif (iopt43.eq.2) then                      
-	  k43 = 1.4d-5 * exp( -10957.d0 / tt + 1.486d6 / tt**2.d0 )            
-	  if ( tt.lt.265.0 ) k43 = 2.3d-14             
-	end if                                         
-	k43 = k43 * rf43                               
-	k43p = k43 * exp( -ee * dble(2143.3 / tt) )    
-
-c k43iso :   co63(v) + o3p ---> co63(v-1) + o3p + de=2096   
-! 	Por similitud con el anterior 
-                                                
-	k43iso = k43 
-	k43isop = k43iso * exp( -ee * dble(2096. / tt) )    
-                                 
-               
-c k44 :    co62(v) + co63 ---> co62(v-1) + co63(1) + de
-!	basado en Lopez-Valverde et al para el caso v=1, solo usamos este
-!	k44x   x = a --- v=1   de= 147.33 
-!	           b --- v=2   de=  20.7241
-!	           c --- v=3   de=  -5.7               
-!	           d --- v=4   de= -32.0361              
-                                                
-	k44a = 2.0d-12 * rf44        ! Solo vamos a usar este, no los b,c,d
-        k44b = k44a
-        k44c = k44a
-        k44d = k44a
-
-        de = 147.33
-	k44ap = k44a * exp(dble( -ee * de/tt ))   
-        de = 20.7241
-	k44bp = k44b * exp(dble( -ee * de/tt ))   
-        de =  -5.7
-	k44cp = k44c * exp(dble( -ee * de/tt ))   
-        de = -32.0361
-	k44dp = k44d * exp(dble( -ee * de/tt ))   
- 
-
-co2(hcl) + co2 --> co2 + co2 + de(hcl)          
-! este rate tambien lo usamos para los high combination levels (para tra
-! al lte. cualquier valor vale, supongo. es k_vthcl         
-                                                
-	k_vthcl = 3.3d-15	! similar al valor pequenho del vt2      
-	k_vthcl = k_vthcl * rf_hcl                     
-                                                
-	return                                         
-	end                                            
Index: unk/LMDZ.MARS/libf/phymars/hrkday_convert.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/hrkday_convert.F	(revision 497)
+++ 	(revision )
@@ -1,31 +1,0 @@
-c***********************************************************************
-c	hrkday_convert.f                              
-c                                               
-c	fortran function that returns the factor for conversion from          
-c	hr' [erg s-1 cm-3] to hr [ k day-1 ]           
-c
-c       mar 2010        fgg      adapted to GCM
-c       jan 99          malv     add o2 as major component. 
-c       ago 98          malv     also returns cp_avg,pm_avg 
-c	jul 98 		malv	 first version.	                
-c***********************************************************************
-                                                
-	function hrkday_convert                        
-     @     ( mmean_nlte,cpmean_nlte )         
-                                                
-        implicit none                           
-                          
-        include 'comcstfi.h'
-        include 'param.h'
-                                                
-c argumentos                                    
-	real	mmean_nlte,cpmean_nlte
-	real 	hrkday_convert                           
-                                                
-ccccccccccccccccccccccccccccccccccccc           
-        
-	hrkday_convert = daysec * n_avog / ( cpmean_nlte * 1.e4 * mmean_nlte ) 
-                                                
-c end                                           
-        return                                  
-        end                                     
Index: unk/LMDZ.MARS/libf/phymars/interdp.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/interdp.F	(revision 497)
+++ 	(revision )
@@ -1,67 +1,0 @@
-c	***********************************************************************
-	subroutine interdp(yy,zz,m,y,z,n,opt)
-c	interpolation soubroutine. input values: y(n) at z(n). 
-c	output values: yy(m) at zz(m). options: 1 -> lineal; 2 -> logarithmic
-c       jul 2011:  malv+fgg   Adapted to LMD-MGCM
-c	***********************************************************************
-        implicit none
-	integer n,m,i,j,opt
-	real*8 zz(m),yy(m),z(n),y(n), zmin,zzmin,zmax,zzmax
-
-!	write (*,*) ' d interpolating '
-	call mindp (z,n,zmin)
-	call mindp (zz,m,zzmin)
-	call maxdp (z,n,zmax)
-	call maxdp (zz,m,zzmax)
-
-	if(zzmin.lt.zmin)then
-		write (*,*) 'from d interp: new variable out of limits'
-		write (*,*) zzmin,'must be .ge. ',zmin
-		stop
-!	elseif(zzmax.gt.zmax)then
-!		write (*,*) 'from interp: new variable out of limits'
-!		write (*,*) zzmax, 'must be .le. ',zmax
-!		stop
-	end if
-
-	do 1,i=1,m
-
-	do 2,j=1,n-1
-	if(zz(i).ge.z(j).and.zz(i).lt.z(j+1)) goto 3
- 2	continue
-c	in this case (zz(m).eq.z(n)) and j leaves the loop with j=n-1+1=n
-	if(opt.eq.1)then
-	 	yy(i)=y(n-1)+(y(n)-y(n-1))*(zz(i)-z(n-1))/(z(n)-z(n-1))
-	elseif(opt.eq.2)then
-		if(y(n).eq.0.0d0.or.y(n-1).eq.0.0d0)then
-			yy(i)=0.0d0
-		else
-			yy(i)=dexp(dlog(y(n-1))+dlog(y(n)/y(n-1))*
-     @			(zz(i)-z(n-1))/(z(n)-z(n-1)))
-		end if
-	else
-		write (*,*) 
-     @           ' from d interp error: opt must be 1 or 2, opt= ',opt
-	end if
-	goto 1
- 3	continue
-	if(opt.eq.1)then
-	 	yy(i)=y(j)+(y(j+1)-y(j))*(zz(i)-z(j))/(z(j+1)-z(j))
-!	write (*,*) ' '
-!	write (*,*) ' z(j),z(j+1) =', z(j),z(j+1)
-!	write (*,*) ' t(j),t(j+1) =', y(j),y(j+1)
-!	write (*,*) ' zz, tt =  ', zz(i), yy(i)
-	elseif(opt.eq.2)then
-		if(y(j+1).eq.0.0d0.or.y(j).eq.0.0d0)then
-			yy(i)=0.0d0
-		else
-			yy(i)=dexp(dlog(y(j))+dlog(y(j+1)/y(j))*
-     @			(zz(i)-z(j))/(z(j+1)-z(j)))
-		end if
-	else
-		write (*,*) ' from interp error: opt must be 1 or 2, opt= ',
-     @                      opt
-	end if
- 1	continue
-	return
-	end
Index: unk/LMDZ.MARS/libf/phymars/interdp_limits.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/interdp_limits.F	(revision 497)
+++ 	(revision )
@@ -1,96 +1,0 @@
-c	***********************************************************************
-
-	subroutine interdp_limits ( yy,zz,m, i1,i2, y,z,n, j1,j2, opt)
-
-c	Interpolation soubroutine. 
-c       Returns values between indexes i1 & i2, donde  1 =< i1 =< i2 =< m
-c       Solo usan los indices de los inputs entre j1,j2, 1 =< j1 =< j2 =< n    
-c	Input values: y(n) , z(n)  (solo se usan los valores entre j1,j2)
-c                     zz(m) (solo se necesita entre i1,i2)
-c	Output values: yy(m) (solo se calculan entre i1,i2)
-c	Options:    opt=1 -> lineal ,,  opt=2 -> logarithmic
-c	Difference with interdp:  
-c          here interpolation proceeds between indexes i1,i2 only 
-c	   if i1=1 & i2=m, both subroutines are exactly the same
-c          thus previous calls to interdp or interdp2 could be easily replaced
-
-c	JAN 98 	MALV 		Version for mz1d
-c       jul 2011 malv+fgg       Adapted to LMD-MGCM
-c	***********************************************************************
-
-        implicit none
-
-! Arguments 
-	integer 	n,m             	! I. Dimensions
-	integer 	i1, i2, j1, j2, opt     ! I
-	real*8 		zz(m),yy(m)		! O
-	real*8		z(n),y(n)		! I
-
-! Local variables
-	integer 	i,j
-	real*8 		zmin,zzmin,zmax,zzmax
-
-c  	*******************************
-
-!	type *, ' d interpolating '
-	call mindp_limits (z,n,zmin, j1,j2)
-	call mindp_limits (zz,m,zzmin, i1,i2)
-	call maxdp_limits (z,n,zmax, j1,j2)
-	call maxdp_limits (zz,m,zzmax, i1,i2)
-
-	if(zzmin.lt.zmin)then
-	   write (*,*) 'from d interp: new variable out of limits'
-	   write (*,*) zzmin,'must be .ge. ',zmin
-	   stop
-!	elseif(zzmax.gt.zmax)then
-!		type *,'from interp: new variable out of limits'
-!		type *,zzmax, 'must be .le. ',zmax
-!		stop
-	end if
-
-	do 1,i=i1,i2
-
-	do 2,j=j1,j2-1
-	if(zz(i).ge.z(j).and.zz(i).lt.z(j+1)) goto 3
- 2	continue
-c	in this case (zz(i2).eq.z(j2)) and j leaves the loop with j=j2-1+1=j2
-	if(opt.eq.1)then
-	  yy(i)=y(j2-1)+(y(j2)-y(j2-1))*(zz(i)-z(j2-1))/(z(j2)-z(j2-1))
-	elseif(opt.eq.2)then
-	  if(y(j2).eq.0.0d0.or.y(j2-1).eq.0.0d0)then
-		yy(i)=0.0d0
-	  else
-		yy(i)=exp(log(y(j2-1))+log(y(j2)/y(j2-1))*
-     @		(zz(i)-z(j2-1))/(z(j2)-z(j2-1)))
-	  end if
-	else
-	  write (*,*) ' d interp : opt must be 1 or 2, opt= ',opt
-	end if
-	goto 1
- 3	continue
-	if(opt.eq.1)then
-	 	yy(i)=y(j)+(y(j+1)-y(j))*(zz(i)-z(j))/(z(j+1)-z(j))
-!	type *, ' '
-!	type *, ' z(j),z(j+1) =', z(j),z(j+1)
-!	type *, ' t(j),t(j+1) =', y(j),y(j+1)
-!	type *, ' zz, tt =  ', zz(i), yy(i)
-	elseif(opt.eq.2)then
-		if(y(j+1).eq.0.0d0.or.y(j).eq.0.0d0)then
-			yy(i)=0.0d0
-		else
-			yy(i)=exp(log(y(j))+log(y(j+1)/y(j))*
-     @			(zz(i)-z(j))/(z(j+1)-z(j)))
-		end if
-	else
-	 write (*,*) ' interp : opt must be 1 or 2, opt= ',opt
-	end if
- 1	continue
-	return
-	end
-
-
-
-
-
-
-
Index: unk/LMDZ.MARS/libf/phymars/intersp.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/intersp.F	(revision 497)
+++ 	(revision )
@@ -1,68 +1,0 @@
-c	***********************************************************************
-	subroutine intersp(yy,zz,m,y,z,n,opt)
-c	interpolation soubroutine. input values: y(n) at z(n). 
-c	output values: yy(m) at zz(m). options: 1 -> lineal; 2 -> logarithmic
-
-c       jul 2011 malv+fgg
-c	***********************************************************************
-
-	implicit none
-
-	integer	n,m,i,j,opt
-	real	zz(m),yy(m),z(n),y(n)
-	real	zmin,zzmin,zmax,zzmax
-
-!	write(*,*) ' interpolating'
-	call minsp(z,n,zmin)
-	call minsp(zz,m,zzmin)
-	call maxsp(z,n,zmax)
-	call maxsp(zz,m,zzmax)
-
-	if(zzmin.lt.zmin)then
-	  write(*,*) 'from interp: new variable out of limits'
-	  write(*,*) zzmin,'must be .ge. ',zmin
-	  stop
-!	elseif(zzmax.gt.zmax)then
-!	  write(*,*)'from interp: new variable out of limits'
-!	  write(*,*)zzmax, 'must be .le. ',zmax
-!	  stop
-	end if
-
-	do 1,i=1,m
-
-	do 2,j=1,n-1
-	if(zz(i).ge.z(j).and.zz(i).lt.z(j+1)) goto 3
- 2	continue
-c	in this case (zz(m).ge.z(n)) and j leaves the loop with j=n-1+1=n
-	if(opt.eq.1)then
-	  yy(i)=y(n-1)+(y(n)-y(n-1))*(zz(i)-z(n-1))/(z(n)-z(n-1))
-	elseif(opt.eq.2)then
-	  if(y(n).eq.0.0.or.y(n-1).eq.0.0)then
-		yy(i)=0.0
-	  else
-		yy(i)=exp(log(y(n-1))+log(y(n)/y(n-1))*
-     @		(zz(i)-z(n-1))/(z(n)-z(n-1)))
-	  end if
-	else
-	  write(*,*)' from interp error: opt must be 1 or 2, opt= ',opt
-	end if
-	goto 1
- 3	continue
-	if(opt.eq.1)then
-	  yy(i)=y(j)+(y(j+1)-y(j))*(zz(i)-z(j))/(z(j+1)-z(j))
-	elseif(opt.eq.2)then
-	  if(y(j+1).eq.0.0.or.y(j).eq.0.0)then
-		yy(i)=0.0
-	  else
-		yy(i)=exp(log(y(j))+log(y(j+1)/y(j))*
-     @		(zz(i)-z(j))/(z(j+1)-z(j)))
-	  end if
-	else
-	  write(*,*)' from interp error: opt must be 1 or 2, opt= ',opt
-	end if
- 1	continue
-
-	return
-	end
-
-
Index: unk/LMDZ.MARS/libf/phymars/invdiag.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/invdiag.F	(revision 497)
+++ 	(revision )
@@ -1,27 +1,0 @@
-c	***********************************************************************
-	subroutine invdiag(a,b,n)
-c	inverse of a diagonal matrix 
-c       jul 2011 malv
-c	***********************************************************************
-	implicit none
-
-	integer n,i,j,k
-	real*8 a(n,n),b(n,n)
-
-	do 1,i=2,n-1
-	  do 2,j=2,n-1
-	    if (i.eq.j) then
-              a(i,j) = 1.d0/b(i,i)
-	    else
-	      a(i,j)=0.0d0
-	    end if
- 2	  continue
- 1	continue
-	do k=1,n
-	  a(n,k) = 0.0d0
-	  a(1,k) = 0.0d0
-	  a(k,1) = 0.0d0
-	  a(k,n) = 0.0d0
-	end do
-	return
-	end
Index: unk/LMDZ.MARS/libf/phymars/leetvt.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/leetvt.F	(revision 497)
+++ 	(revision )
@@ -1,47 +1,0 @@
-c***********************************************************************
-	subroutine leetvt                              
-                                                
-c 	reads input vibr. temps. from external files or sets lte values      
-c	according to the driver table                 
-
-c       jul 2011 malv+fgg   adapted to LMD-MGCM
-c       malv    Jan 07          Add new vertical fine-grid for NLTE
-c 	jan 98 	malv		based on solar10sub            
-c***********************************************************************
-                                                
-	implicit none                                  
-                                                
-	include 'nltedefs.h'          
-	include 'nlte_atm.h'        
-	include 'nlte_results.h'  
-                                                
-c local variables                               
-	integer i                                      
-	real*8	zld(nl), zyd(nzy)
-	real*8 xvt11(nzy), xvt21(nzy), xvt31(nzy), xvt41(nzy)
-                                                
-c***********************************************************************
-                                                
-	   do i=1,nzy                                   
-		zyd(i) = dble(zy(i))                          
-		xvt11(i)= dble( ty(i) )                     
-		xvt21(i)= dble( ty(i) )                     
-		xvt31(i)= dble( ty(i) )                     
-		xvt41(i)= dble( ty(i) )                     
-           end do		                             
-                                                
-                                                
-c interpolate to the nlte subgrid               
-                                                
-	do i=1,nl                                      
-	    zld(i) = dble( zl(i) )                     
-	enddo                                             
-	call interdp ( v626t1,zld,nl, xvt11,zyd,nzy, 1) 
-        call interdp ( v628t1,zld,nl, xvt21,zyd,nzy, 1)      
-        call interdp ( v636t1,zld,nl, xvt31,zyd,nzy, 1)      
-        call interdp ( v627t1,zld,nl, xvt41,zyd,nzy, 1)      
-
-
-c end                                           
-	return                                         
-	end                                            
Index: unk/LMDZ.MARS/libf/phymars/lubksb_dp.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/lubksb_dp.F	(revision 497)
+++ 	(revision )
@@ -1,38 +1,0 @@
-      subroutine lubksb_dp(a,n,np,indx,b)                              
-
-c     jul 2011 malv+fgg
-
-      implicit none
-
-      integer n,np
-      real*8 a(np,np),b(n) 
-      integer indx(n)
-
-      real*8 sum
-      integer ii, ll, i, j
-
-      ii=0                                                              
-      do 12 i=1,n                                                             
-        ll=indx(i)                                                            
-        sum=b(ll)                                                             
-        b(ll)=b(i)                                                            
-        if (ii.ne.0)then                                                      
-          do 11 j=ii,i-1                                                      
-            sum=sum-a(i,j)*b(j)                                               
-11        continue                                                            
-        else if (sum.ne.0.0) then                       
-          ii=i                                                                
-        endif                                                                 
-        b(i)=sum                                                              
-12    continue                                                                
-      do 14 i=n,1,-1                                                          
-        sum=b(i)                                                              
-        if(i.lt.n)then                                                        
-          do 13 j=i+1,n                                                       
-            sum=sum-a(i,j)*b(j)                                               
-13        continue                                                            
-        endif                                                                 
-        b(i)=sum/a(i,i)                                                       
-14    continue                                                                
-      return                                                                  
-      end                                                                     
Index: unk/LMDZ.MARS/libf/phymars/ludcmp_dp.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/ludcmp_dp.F	(revision 497)
+++ 	(revision )
@@ -1,73 +1,0 @@
-      subroutine ludcmp_dp(a,n,np,indx,d)
-
-c       jul 2011 malv+fgg
-
-      implicit none
-
-      integer n, np
-      real*8 a(np,np), d
-      integer indx(n)
-      
-      integer nmax, i, j, k, imax
-      real*8 tiny
-      parameter (nmax=100,tiny=1.0d-20)                                       
-      real*8 vv(nmax), aamax, sum, dum
-
-
-      d=1.0d0
-      do 12 i=1,n                                                             
-        aamax=0.0d0
-        do 11 j=1,n                                                           
-          if (abs(a(i,j)).gt.aamax) aamax=abs(a(i,j))                         
-11      continue                                                              
-        if (aamax.eq.0.0) pause 'singular matrix.'                          
-        vv(i)=1.0d0/aamax                          
-12    continue                                                                
-      do 19 j=1,n                                                             
-        if (j.gt.1) then                                                      
-          do 14 i=1,j-1                                                       
-            sum=a(i,j)                                                        
-            if (i.gt.1)then                                                   
-              do 13 k=1,i-1                                                   
-                sum=sum-a(i,k)*a(k,j)                                         
-13            continue                                                        
-              a(i,j)=sum                                                      
-            endif                                                             
-14        continue                                                            
-        endif                                                                 
-        aamax=0.0d0                                                           
-        do 16 i=j,n                                                           
-          sum=a(i,j)                                                          
-          if (j.gt.1)then                                                     
-            do 15 k=1,j-1                                                     
-              sum=sum-a(i,k)*a(k,j)                                           
-15          continue                                                          
-            a(i,j)=sum                                                        
-          endif                                                               
-          dum=vv(i)*abs(sum)                                                  
-          if (dum.ge.aamax) then                                              
-            imax=i                                                            
-            aamax=dum                                                         
-          endif                                                               
-16      continue                                                              
-        if (j.ne.imax)then                                                    
-          do 17 k=1,n                                                         
-            dum=a(imax,k)                                                     
-            a(imax,k)=a(j,k)                                                  
-            a(j,k)=dum                                                        
-17        continue                                                            
-          d=-d                                                                
-          vv(imax)=vv(j)                                                      
-        endif                                                                 
-        indx(j)=imax                                                          
-        if(j.ne.n)then                                                        
-          if(a(j,j).eq.0.0)a(j,j)=tiny                                     
-          dum=1.0d0/a(j,j)                                                  
-          do 18 i=j+1,n                                                       
-            a(i,j)=a(i,j)*dum                                                 
-18        continue                                                            
-        endif                                                                 
-19    continue                                                                
-      if(a(n,n).eq.0.0)a(n,n)=tiny                                     
-      return                                                                  
-      end                                                                     
Index: unk/LMDZ.MARS/libf/phymars/mat_oper.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/mat_oper.F	(revision 497)
+++ 	(revision )
@@ -1,771 +1,0 @@
-c set of subroutines for the cz*.for programs:
-!	subroutine unit(a,n)
-!       subroutine vector(v,cte,n)
-!	subroutine diagop(a,v,n)
-!	subroutine diago(a,v,n)             diagonal matrix with v
-!	subroutine dyago(a,v,n)             diagonal matrix with inverse of v
-!	subroutine invdiag(a,b,n)           inverse of diagonal matrix 
-!	subroutine sypvvv(a,b,c,d,n)        suma y prod de 3 vectores, muy comun
-!	subroutine sypvmv(v,w,b,u,n)        suma y prod de 3 vectores, muy comun
-!	subroutine mulmvv(w,b,u,v,n)        prod matriz vector vector
-!	subroutine muymvv(w,b,u,v,n)        prod matriz (inv.vector) vector
-!	subroutine samem (a,m,n)
-!	subroutine samemcore (a,m,n,n-2)    extract core of matrix
-!	subroutine samemsp (a,m,n)
-!	subroutine samevsp (v,w,n)
-!	subroutine samev (v,w,n)
-!	subroutine samevcore (v,w,n,n-2)    extract core of vector
-! no	subroutine operaux (a,n,  b,c,d,e, ll,mm,dd,maux1,maux2) 
-! no	subroutine invmcore (a,acore,n,  dd,ll,mm) 
-!	subroutine mulmv(a,b,c,n)
-!	subroutine mulvmv(a,u,b,v,n)
-!	subroutine mulmm(a,b,c,n)
-!	subroutine summm(a,b,c,n)
-!	subroutine resmm(a,b,c,n)
-!	subroutine mulvv(a,b,c,n)
-!	subroutine sumvv(a,b,c,n)
-!	subroutine sumvvv(a,b,c,d,n)
-!	subroutine resvv(a,b,c,n)
-!	subroutine zerom(a,n)
-!	subroutine zeromsp (a,n)
-!	subroutine zero4m(a,b,c,d,n)
-!	subroutine zero4msp(a,b,c,d,n)
-!	subroutine zero3m(a,b,c,n)
-!	subroutine zero3msp(a,b,c,n)
-!	subroutine zero2m(a,b,n)
-!	subroutine zero2msp(a,b,n)
-!	subroutine zerov(a,n)
-!	subroutine zerovdim3(a,n1,n2,n3)  ! sustituye a zerojt de cristina
-!	subroutine zero4v(a,b,c,d,n)
-!	subroutine zero3v(a,b,c,n)
-!	subroutine zero2v(a,b,n)
-!	subroutine zerovsp(a,n)
-!	subroutine zero4vsp(a,b,c,d,n)
-!	subroutine zero3vsp(a,b,c,n)
-!	subroutine zero2vsp(a,b,n)
-!
-!
-!
-!   May-05 Sustituimos todos los zerojt de cristina por las subrutinas
-!          genericas zerov***
-!
-c	***********************************************************************
-	subroutine unit(a,n)
-c	store the unit value in the diagonal of a 
-c	***********************************************************************
-	real*8 a(n,n)
-	integer n,i,j,k
-	do 1,i=2,n-1
-	  do 2,j=2,n-1
-	    if(i.eq.j) then
-	      a(i,j) = 1.d0
-	    else
-	      a(i,j)=0.0d0
-	    end if
- 2	  continue
- 1	continue
-	do k=1,n
-	  a(n,k) = 0.0d0
-	  a(1,k) = 0.0d0
-	  a(k,1) = 0.0d0
-	  a(k,n) = 0.0d0
-	end do
-	return
-	end
-
-!       subroutine vector(v,cte,n)
-c	***********************************************************************
-	subroutine vector(v,cte,n)
-c	build a vector by storing the value cte in all its elements
-c	***********************************************************************
-	real*8 v(n),cte
-	integer n,i
-	do 1,i=1,n
-	  v(i) = cte
- 1	continue
-	return
-	end
-c	***********************************************************************
-	subroutine diagop(a,v,n)
-c	store the core of v in the diagonal elements of the square matrix a
-c	***********************************************************************
-	real*8 a(n,n),v(n+2)
-	integer n,i,j,k
-	do 1,i=2,n-1
-	  do 2,j=2,n-1
-	    if(i.eq.j) then
-	      a(i,j) = v(i+1)
-	    else
-	      a(i,j)=0.0d0
-	    end if
- 2	  continue
- 1	continue
-	do k=1,n
-	  a(n,k) = 0.0d0
-	  a(1,k) = 0.0d0
-	  a(k,1) = 0.0d0
-	  a(k,n) = 0.0d0
-	end do
-	return
-	end
-c	***********************************************************************
-	subroutine diago(a,v,n)
-c	store the vector v in the diagonal elements of the square matrix a
-c	***********************************************************************
-	implicit none
-
-	integer n,i,j,k
-	real*8 a(n,n),v(n)
-
-	do 1,i=2,n-1
-	  do 2,j=2,n-1
-	    if(i.eq.j) then
-	      a(i,j) = v(i)
-	    else
-	      a(i,j)=0.0d0
-	    end if
- 2	  continue
- 1	continue
-	do k=1,n
-	  a(n,k) = 0.0d0
-	  a(1,k) = 0.0d0
-	  a(k,1) = 0.0d0
-	  a(k,n) = 0.0d0
-	end do
-	return
-	end  
-c	***********************************************************************
-	subroutine dyago(a,v,n)
-c	store the inverse of v in the diagonal elements of the square matrix a
-c	***********************************************************************
-	implicit none
-
-	integer n,i,j,k
-	real*8 a(n,n),v(n)
-
-	do 1,i=2,n-1
-	  do 2,j=2,n-1
-	    if(i.eq.j) then
-	      a(i,j) = 1.d0/v(i)
-	    else
-	      a(i,j)=0.0d0
-	    end if
- 2	  continue
- 1	continue
-	do k=1,n
-	  a(n,k) = 0.0d0
-	  a(1,k) = 0.0d0
-	  a(k,1) = 0.0d0
-	  a(k,n) = 0.0d0
-	end do
-	return
-	end
-
-c	***********************************************************************
-	subroutine samem (a,m,n)
-c	store the matrix m in the matrix a 
-c	***********************************************************************
-	real*8 a(n,n),m(n,n)
-	integer n,i,j,k
-	do 1,i=2,n-1
-	  do 2,j=2,n-1
-	      a(i,j) = m(i,j)  
-2	  continue
-1	continue 	
-	do k=1,n
-	  a(n,k) = 0.0d0
-	  a(1,k) = 0.0d0
-	  a(k,1) = 0.0d0
-	  a(k,n) = 0.0d0
-	end do
-	return
-	end 
-c	***********************************************************************
-	subroutine samemcore (a,b,m,n)
-c	store the matrix m in the matrix a 
-c	***********************************************************************
-	real*8 a(m,m),b(n,n)
-	integer n,i,j,k
-	if ( m.ne.(n-2) ) stop 'Error in dimensions  (m.ne.n-2) '
-	do 1,i=2,n-1
-	  do 2,j=2,n-1
-	      a(i,j) = b(i,j)  
-2	  continue
-1	continue 	
-	return
-	end 
-c	***********************************************************************
-	subroutine samemsp (a,m,n)
-c	store the matrix m in the matrix a 
-c	***********************************************************************
-	real*4 a(n,n),m(n,n)
-	integer n,i,j,k
-	do 1,i=2,n-1
-	  do 2,j=2,n-1
-	      a(i,j) = m(i,j)  
-2	  continue
-1	continue 	
-	do k=1,n
-	  a(n,k) = 0.0
-	  a(1,k) = 0.0
-	  a(k,1) = 0.0
-	  a(k,n) = 0.0
-	end do
-	return
-	end 
-c	***********************************************************************
-	subroutine samevsp (v,w,n)
-c	store the vector w in the vector v 
-c	***********************************************************************
-	real*4 v(n),w(n)
-	integer n,i
-	do 1,i=2,n-1
-	      v(i) = w(i) 
- 1	continue
-	v(1) = 0.0
-	v(n) = 0.0
-	return
-	end
-c	***********************************************************************
-	subroutine samev (v,w,n)
-c	store the vector w in the vector v 
-c	***********************************************************************
-	real*8 v(n),w(n)
-	integer n,i
-	do 1,i=2,n-1
-	      v(i) = w(i) 
- 1	continue
-	v(1) = 0.0d0
-	v(n) = 0.0d0
-	return
-	end
-c	***********************************************************************
-	subroutine samevcore (v,w,m,n)
-c	store the vector w in the vector v 
-c	***********************************************************************
-	real*8 v(m),w(n)
-	integer n,i
-	if (m.ne.(n-2)) stop ' Error in dimensions (m.ne.n-2) '
-	do 1,i=2,n-1
-	      v(i) = w(i) 
- 1	continue
-	return
-	end
-!c	***********************************************************************
-!	subroutine operaux (a,n,  b,c,d,e, ll,mm,dd,maux1,maux2) 
-!c	***********************************************************************
-!	real*8 a(n,n),b(n,n),c(n,n),d(n,n),e(n,n) 
-!	real*8 maux1(n,n),maux2(n,n),ll(n),mm(n),dd
-!	integer n
-!	call mulmm(a,c,e,n)
-!	call unit(maux1,n)
-!	call resmm(maux2,maux1,a,n)			! maux2 = 1 - c e
-!	call mynvdpnd(maux2,n,dd,ll,mm)			! maux2 = 1 / (1-ce) 
-!	call mulmm(a,c,d,n)
-!	call resmm(maux1,b,a,n)				! a = b - c d
-!	call mulmm(a,maux2,maux1,n) 			! a = cax2 * (b-cd) 
-!	return 
-!	end
-!c	***********************************************************************
-!	subroutine invmcore (a,acore,n,  dd,ll,mm) 
-!c	***********************************************************************
-!	real*8 a(n,n), acore(n-2,n-2)
-!	real*8 ll(n-2),mm(n-2),dd
-!	integer i,n,j,k
-!
-!	do i=2,n-1
-!	  do j=2,n-1
-!	    acore(i-1,j-1) = a(i,j)
-!	  end do
-!	end do
-!	call mynvdpnd (acore,n-2,dd,ll,mm)		
-!	do i=2,n-1
-!	  do j=2,n-1
-!	    a(i,j) = acore(i-1,j-1)
-!	  end do
-!	end do
-!	do k=1,n
-!	  a(1,k) = 0.d0
-!	  a(n,k) = 0.d0
-!	  a(k,1) = 0.d0
-!	  a(k,n) = 0.d0
-!	end do
-!
-!	return 
-!	end
-c	***********************************************************************
-	subroutine mulmv(a,b,c,n)
-c	do a(i)=b(i,j)*c(j). a, b, and c must be distint
-c	***********************************************************************
-	implicit none
-
-	integer n,i,j
-	real*8 a(n),b(n,n),c(n),sum
-
-	do 1,i=2,n-1
-	  sum=0.0d0
-	  do 2,j=2,n-1
-	    sum=sum+ (b(i,j)) * (c(j))
- 2	  continue
-	  a(i)=sum
- 1	continue
-	a(1) = 0.0d0
-	a(n) = 0.0d0
-	return
-	end
-
-
-
-cc	***********************************************************************
-	subroutine muymmv(w,b,c,v,n)
-c       c(i,j) is diagonall and will be inverted. Let us call Z(i)=c(i,i)^(-1)
-c	Z(i) and v(i) are vectors. multiply first Z(i) and v(i) 
-c	them multiply b and the previous product. w(i)=b(i,j)*(Z(j)+v(j))
-c	***********************************************************************
-	real*8 w(n),b(n,n),c(n,n),v(n), sum
-	integer n,i,j,k
-	do 1,i=2,n-1
-	  sum=0.0d0
-	  do 2,j=2,n-1
-	    sum=sum+ (b(i,j)) * (v(j)/c(j,j))
- 2	  continue
-	  w(i)=sum
- 1	continue
-	w(1) = 0.0d0
-	w(n) = 0.0d0
-	return
-	end
-cc	***********************************************************************
-	subroutine muymvv(w,b,u,v,n)
-c       u(i) is to be inverted. Let us call Z=u^(-1)
-c	Z(i) and v(i) are vectors. multiply first Z(i) and v(i) 
-c	them multiply b and the previous product. w(i)=b(i,j)*(Z(j)+v(j))
-c	***********************************************************************
-	real*8 w(n),u(n),b(n,n),v(n), sum
-	integer n,i,j,k
-	do 1,i=2,n-1
-	  sum=0.0d0
-	  do 2,j=2,n-1
-	    sum=sum+ (b(i,j)) * (v(j)/u(j))
- 2	  continue
-	  w(i)=sum
- 1	continue
-	w(1) = 0.0d0
-	w(n) = 0.0d0
-	return
-	end
-c	***********************************************************************
-	subroutine mulmvv(w,b,u,v,n)
-c	u(i) and v(i) are vectors. multiply first u(i) and v(i) 
-c	them multiply b and the previous product. w(i)=b(i,j)*(u(j)+v(j))
-c	***********************************************************************
-	real*8 w(n),u(n),b(n,n),v(n), sum
-	integer n,i,j,k
-	do 1,i=2,n-1
-	  sum=0.0d0
-	  do 2,j=2,n-1
-	    sum=sum+ (b(i,j)) * (u(j)+v(j))
- 2	  continue
-	  w(i)=sum
- 1	continue
-	w(1) = 0.0d0
-	w(n) = 0.0d0
-	return
-	end
-c	***********************************************************************
-	subroutine mulvmv(a,u,b,v,n)
-c	u(i) and v(i) are vectors. store u(i) and v(i) in the diagonal 
-c	elements of square matrixes. then do a(i,j)= u(i,i)*b(i,j)*v(j,j)
-c	***********************************************************************
-	real*8 a(n,n),u(n),b(n,n),v(n)
-	integer n,i,j,k
-	do i=2,n-1
-	  do j=2,n-1
-	    a(i,j)=(b(i,j)) * (v(j))
-	  end do
-	end do
-	do i=2,n-1
-	  do j=2,n-1
-	    a(i,j)=(u(i)) * (a(i,j))
-	  end do
-	end do
-	do k=1,n
-	  a(1,k) = 0.d0
-	  a(n,k) = 0.d0
-	  a(k,1) = 0.d0
-	  a(k,n) = 0.d0
-	end do
-
-	return
-	end
-c	***********************************************************************
-	subroutine mulmm(a,b,c,n)
-c	***********************************************************************
-	real*8 a(n,n), b(n,n), c(n,n)
-	integer n,i,j,k
-
-!	do i=2,n-1
-!	  do j=2,n-1
-!	    a(i,j)= 0.d00
-!	    do k=2,n-1
-!		a(i,j) = a(i,j) + b(i,k) * c(k,j)
-!	    end do
-!	  end do
-!	end do
-	do j=2,n-1
-	   do i=2,n-1
-	      a(i,j)=0.d0
-	   enddo
-	   do k=2,n-1
-	      do i=2,n-1
-		 a(i,j)=a(i,j)+b(i,k)*c(k,j)
-	      enddo
-	   enddo
-	enddo
-	do k=1,n
-	  a(n,k) = 0.0d0
-	  a(1,k) = 0.0d0
-	  a(k,1) = 0.0d0
-	  a(k,n) = 0.0d0
-	end do
-
-	return
-	end
-c	***********************************************************************
-	subroutine summm(a,b,c,n)
-c	***********************************************************************
-	real*8 a(n,n), b(n,n), c(n,n)
-	integer n,i,j,k
-
-	do i=2,n-1
-	  do j=2,n-1
-	    a(i,j)= b(i,j) + c(i,j)
-	  end do
-	end do
-	do k=1,n
-	  a(n,k) = 0.0d0
-	  a(1,k) = 0.0d0
-	  a(k,1) = 0.0d0
-	  a(k,n) = 0.0d0
-	end do
-
-	return
-	end
-c	***********************************************************************
-	subroutine resmm(a,b,c,n)
-c	***********************************************************************
-	real*8 a(n,n), b(n,n), c(n,n)
-	integer n,i,j,k
-
-	do i=2,n-1
-	  do j=2,n-1
-	    a(i,j)= b(i,j) - c(i,j)
-	  end do
-	end do
-	do k=1,n
-	  a(n,k) = 0.0d0
-	  a(1,k) = 0.0d0
-	  a(k,1) = 0.0d0
-	  a(k,n) = 0.0d0
-	end do
-
-	return
-	end
-c	***********************************************************************
-	subroutine mulvv(a,b,c,n)
-c	a(i)=b(i)*c(i)
-c	***********************************************************************
-	real*8 a(n),b(n),c(n)
-	integer n,i
-	do 1,i=2,n-1
-	  a(i)= (b(i)) * (c(i))
- 1	continue
-	a(1) = 0.0d0
-	a(n) = 0.0d0
-	return
-	end
-c	***********************************************************************
-	subroutine sumvv(a,b,c,n)
-c	a(i)=b(i)+c(i)
-c	***********************************************************************
-	implicit none
-
-	integer n,i
-	real*8 a(n),b(n),c(n)
-
-	do 1,i=2,n-1
-	  a(i)= (b(i)) + (c(i))
- 1	continue
-	a(1) = 0.0d0
-	a(n) = 0.0d0
-	return
-	end
-
-c	***********************************************************************
-	subroutine sumvvv(a,b,c,d,n)
-c	a(i)=b(i)+c(i)+d(i)
-c	***********************************************************************
-	real*8 a(n),b(n),c(n),d(n)
-	integer n,i
-	do 1,i=2,n-1
-	  a(i)= b(i) + c(i) + d(i)
- 1	continue
-	a(1) = 0.0d0
-	a(n) = 0.0d0
-	return
-	end
-c	***********************************************************************
-	subroutine resvv(a,b,c,n)
-c	a(i)=b(i)-c(i)
-c	***********************************************************************
-	real*8 a(n),b(n),c(n)
-	integer n,i
-	do 1,i=2,n-1
-	  a(i)= (b(i)) - (c(i))
- 1	continue
-	a(1) = 0.0d0
-	a(n) = 0.0d0
-	return
-	end
-c	***********************************************************************
-	subroutine zerom(a,n)
-c	a(i,j)= 0.0
-c	***********************************************************************
-
-	implicit none
-
-	integer n,i,j
-	real*8 a(n,n)
-
-	do 1,i=1,n
-	  do 2,j=1,n
-	    a(i,j) = 0.0d0
- 2	  continue
- 1	continue
-	return
-	end
-c	***********************************************************************
-	subroutine zeromsp (a,n)
-c	a(i,j)= 0.0
-c	***********************************************************************
-	real*4 a(n,n)
-	integer n,i,j
-	do 1,i=1,n
-	  do 2,j=1,n
-	    a(i,j) = 0.0
- 2	  continue
- 1	continue
-	return
-	end
-c	***********************************************************************
-	subroutine zero4m(a,b,c,d,n)
-c	a(i,j) = b(i,j) = c(i,j) = d(i,j) = 0.0 
-c	***********************************************************************
-	real*8 a(n,n), b(n,n), c(n,n), d(n,n)
-	integer n,i,j
-	do 1,i=1,n
-	  do 2,j=1,n
-	    a(i,j) = 0.0d0
-	    b(i,j) = 0.0d0
-	    c(i,j) = 0.0d0
-	    d(i,j) = 0.0d0
- 2	  continue
- 1	continue
-	return
-	end
-c	***********************************************************************
-	subroutine zero4msp(a,b,c,d,n)
-c	a(i,j) = b(i,j) = c(i,j) = d(i,j) = 0.0 
-c	***********************************************************************
-	real*4 a(n,n), b(n,n), c(n,n), d(n,n)
-	integer n,i,j
-	do 1,i=1,n
-	  do 2,j=1,n
-	    a(i,j) = 0.0
-	    b(i,j) = 0.0
-	    c(i,j) = 0.0
-	    d(i,j) = 0.0
- 2	  continue
- 1	continue
-	return
-	end
-c	***********************************************************************
-	subroutine zero3m(a,b,c,n)
-c	a(i,j) = b(i,j) = c(i,j) = 0.0 
-c	**********************************************************************
-	real*8 a(n,n), b(n,n), c(n,n)
-	integer n,i,j
-	do 1,i=1,n
-	  do 2,j=1,n
-	    a(i,j) = 0.0d0
-	    b(i,j) = 0.0d0
-	    c(i,j) = 0.0d0
- 2	  continue
- 1	continue
-	return
-	end
-c	***********************************************************************
-	subroutine zero3msp(a,b,c,n)
-c	a(i,j) = b(i,j) = c(i,j) = 0.0 
-c	***********************************************************************
-	real*4 a(n,n), b(n,n), c(n,n)
-	integer n,i,j
-	do 1,i=1,n
-	  do 2,j=1,n
-	    a(i,j) = 0.0
-	    b(i,j) = 0.0
-	    c(i,j) = 0.0
- 2	  continue
- 1	continue
-	return
-	end
-c	***********************************************************************
-	subroutine zero2m(a,b,n)
-c	a(i,j) = b(i,j) = 0.0 
-c	***********************************************************************
-	real*8 a(n,n), b(n,n)
-	integer n,i,j
-	do 1,i=1,n
-	  do 2,j=1,n
-	    a(i,j) = 0.0d0
-	    b(i,j) = 0.0d0
- 2	  continue
- 1	continue
-	return
-	end
-c	***********************************************************************
-	subroutine zero2msp(a,b,n)
-c	a(i,j) = b(i,j) = 0.0 
-c	***********************************************************************
-	real*4 a(n,n), b(n,n)
-	integer n,i,j
-	do 1,i=1,n
-	  do 2,j=1,n
-	    a(i,j) = 0.0
-	    b(i,j) = 0.0
- 2	  continue
- 1	continue
-	return
-	end
-c	***********************************************************************
-	subroutine zerov(a,n)
-c	a(i)= 0.0
-c	***********************************************************************
-	real*8 a(n)
-	integer n,i
-	do 1,i=1,n
-	    a(i) = 0.0d0
- 1	continue
-	return
-	end
-c	***********************************************************************
-	subroutine zero4v(a,b,c,d,n)
-c	a(i) = b(i) = c(i) = d(i,j) = 0.0
-c	***********************************************************************
-	real*8 a(n), b(n), c(n), d(n)
-	integer n,i
-	do 1,i=1,n
-	    a(i) = 0.0d0
-	    b(i) = 0.0d0
-	    c(i) = 0.0d0
-	    d(i) = 0.0d0
- 1	continue
-	return
-	end
-c	***********************************************************************
-	subroutine zero3v(a,b,c,n)
-c	a(i) = b(i) = c(i) = 0.0
-c	***********************************************************************
-	real*8 a(n), b(n), c(n) 
-	integer n,i
-	do 1,i=1,n
-	    a(i) = 0.0d0
-	    b(i) = 0.0d0
-	    c(i) = 0.0d0
- 1	continue
-	return
-	end
-c	***********************************************************************
-	subroutine zero2v(a,b,n)
-c	a(i) = b(i) = 0.0
-c	***********************************************************************
-	real*8 a(n), b(n) 
-	integer n,i
-	do 1,i=1,n
-	    a(i) = 0.0d0
-	    b(i) = 0.0d0
- 1	continue
-	return
-	end
-c	***********************************************************************
-	subroutine zerovsp(a,n)
-c	a(i)= 0.0
-c	***********************************************************************
-	real*4 a(n)
-	integer n,i
-	do 1,i=1,n
-	    a(i) = 0.0
- 1	continue
-	return
-	end
-c	***********************************************************************
-	subroutine zero4vsp(a,b,c,d,n)
-c	a(i) = b(i) = c(i) = d(i) = 0.0
-c	***********************************************************************
-	real*4 a(n), b(n), c(n), d(n)
-	integer n,i
-	do 1,i=1,n
-	    a(i) = 0.0
-	    b(i) = 0.0
-	    c(i) = 0.0
-	    d(i) = 0.0
- 1	continue
-	return
-	end
-c	***********************************************************************
-	subroutine zero3vsp(a,b,c,n)
-c	a(i) = b(i) = c(i) = 0.0
-c	**********************************************************************
-	real*4 a(n), b(n), c(n)
-	integer n,i
-	do 1,i=1,n
-	    a(i) = 0.0
-	    b(i) = 0.0
-	    c(i) = 0.0
- 1	continue
-	return
-	end
-c	***********************************************************************
-	subroutine zero2vsp(a,b,n)
-c	a(i) = b(i) = 0.0
-c	***********************************************************************
-	real*4 a(n), b(n) 
-	integer n,i
-	do 1,i=1,n
-	    a(i) = 0.0
-	    b(i) = 0.0
- 1	continue
-	return
-	end
-c	***********************************************************************
-	!subroutine zerojt(a,n1,n2,n3)
-	subroutine zerovdim3(a,n1,n2,n3)  ! sustituye a zerojt de cristina
-c	a(i,j,k)= 0.0 
-c	jt(icol,nisos,nb+1,n)
-c	***********************************************************************
-!	real*4 a(9,34,n)
-!	integer n,i,j,k,icol,ic
-	real*4 a(n1,n2,n3)
-	integer n1,n2,n3,i,j,k
-
-	 do 2,i=1,n1
-	  do 3,j=1,n2
-	    do 4,k=1,n3
-		a(i,j,k) = 0.0
- 4	    continue
- 3	  continue
- 2	 continue
-
-	return
-	end
-c	***********************************************************************
Index: unk/LMDZ.MARS/libf/phymars/maxdp.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/maxdp.F	(revision 497)
+++ 	(revision )
@@ -1,17 +1,0 @@
-cccccccccccc
-c	subroutina para calcular el maximo de los valores de una variable a
-c	en dble precision
-	subroutine maxdp(a,n,ymax)
-c       jul 2011 malv+fgg
-cccccccccccc
-	implicit none
-	integer n,i
-	real*8 a(n), ymax
-
-	ymax = a(1)
-	do i=2,n
-	 if (a(i).gt.ymax) ymax=a(i)
-	end do
-
-	return
-	end
Index: unk/LMDZ.MARS/libf/phymars/maxdp_2.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/maxdp_2.F	(revision 497)
+++ 	(revision )
@@ -1,22 +1,0 @@
-c	subroutina para calcular el maximo de los valores de una variable
-c	en double precision
-	subroutine maxdp_2(a,n,ymax,imax)
-c
-c       jul 2011 malv+fgg
-
-	implicit none
-	integer n, i, imax
-	real*8  a(n), y, ymax
-
-	imax=0
-	y=-1.7d+38
-	do i=1,n
-	     if(a(i).gt.y) then
-		y=a(i)
-		imax=i
-	     end if
-	end do
-	ymax=y
-!	type *,'imax,ymax',imax,ymax
-	return
-	end
Index: unk/LMDZ.MARS/libf/phymars/maxdp_limits.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/maxdp_limits.F	(revision 497)
+++ 	(revision )
@@ -1,24 +1,0 @@
-cccccccccccccc
-c	subroutina para calcular el maximo de los valores de una variable
-c	de doble precision. Simlar a maxdp salvo la adicion de limites 
-
-	subroutine maxdp_limits ( a,n,ymax, n1,n2 )
-
-c       jul 2011 malv
-cccccccccccccc
-
-        implicit none
-	integer n, i, n1,n2
-	real*8 a(n),ymax
-
-	if ( n1 .gt. n2 ) stop 'MAXDP_LIMITS. Error: n1 > n2 '
-	if ( n1 .lt. 1 ) stop 'MAXDP_LIMTIS. Error: n1 < 2 '
-	if ( n2 .gt. n ) stop 'MAXDP_LIMITS. Error: n2 > n '
-
-	ymax=a(n1)
-	do i=n1+1,n2                    ! Si n1=n2 este bucle no se ejecuta
-	 if (a(i).gt.ymax) ymax=a(i)
-	end do
-
-	return
-	end
Index: unk/LMDZ.MARS/libf/phymars/maxsp.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/maxsp.F	(revision 497)
+++ 	(revision )
@@ -1,14 +1,0 @@
-c	subroutina para calcular el maximo de los valores de una variable
-c	en simple precision
-
-c       jul 2011 malv+fgg
-
-	subroutine maxsp(a,n,ymax)
-	real a(n)
-
-	ymax=-1.0e+34
-	do i=1,n
-	 if(a(i).gt.ymax)ymax=a(i)
-	end do
-	return
-	end
Index: unk/LMDZ.MARS/libf/phymars/mindp.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/mindp.F	(revision 497)
+++ 	(revision )
@@ -1,17 +1,0 @@
-ccccccccccc
-c	subroutina para calcular el minimo de los valores de una variable
-c	de doble precision
-	subroutine mindp ( a,n,ymin )
-c       jul 2011 malv+fgg
-ccccccccccc
-        implicit none
-	integer n, i
-	real*8 a(n),ymin
-
-	ymin=a(1)
-	do i=2,n
-	 if (a(i).lt.ymin) ymin=a(i)
-	end do
-
-	return
-	end
Index: unk/LMDZ.MARS/libf/phymars/mindp_limits.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/mindp_limits.F	(revision 497)
+++ 	(revision )
@@ -1,24 +1,0 @@
-cccccccccccccc
-c	subroutina para calcular el minimo de los valores de una variable
-c	de doble precision. Simlar a mindp salvo la adicion de limites 
-
-	subroutine mindp_limits ( a,n,ymin, n1,n2 )
-
-c       jul 2011 malv+fgg
-cccccccccccccc
-
-        implicit none
-	integer n, i, n1,n2
-	real*8 a(n),ymin
-
-	if ( n1 .gt. n2 ) stop 'MINDP_LIMITS. Error: n1 > n2 '
-	if ( n1 .lt. 1 ) stop 'MINDP_LIMITS. Error: n1 < 2 '
-	if ( n2 .gt. n ) stop 'MINDP_LIMITS. Error: n2 > n '
-
-	ymin=a(n1)
-	do i=n1+1,n2
-	 if (a(i).lt.ymin) ymin=a(i)
-	end do
-
-	return
-	end
Index: unk/LMDZ.MARS/libf/phymars/minsp.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/minsp.F	(revision 497)
+++ 	(revision )
@@ -1,15 +1,0 @@
-c	subroutina para calcular el minimo de los valores de una variable
-c	de simple precision 
-
-c       jul 2011 malv+fgg
-
-	subroutine minsp(a,n,ymin)
-	real a(n)
-
-	y=1.0d+34
-	do i=1,n
-	 if(a(i).lt.y)y=a(i)
-	end do
-	ymin=y
-	return
-	end
Index: unk/LMDZ.MARS/libf/phymars/mzcf.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/mzcf.F	(revision 497)
+++ 	(revision )
@@ -1,320 +1,0 @@
-c***********************************************************************
-c************************ [valverde.marte.mod2] mzcf.for ***************
-                                                
-	subroutine mzcf( tauinf,tau, c,cup,cdw,vc,taugr,           
-     @   	ib,isot,icfout,itableout )            
-                                                
-c	a.k.murphy method to avoid extrapolation in the curtis matrix         
-c	feb-89 	    m. angel 	granada                 
-c	25-sept-96  cristina 	dejar las matrices en doble precision           
-c	jan 98		malv	version para mz1d                
-c       jul 2011 malv+fgg       adapted to LMD-MGCM
-c***********************************************************************
-                                                
-	implicit none                                  
-
-        include 'comcstfi.h'
-	include 'nltedefs.h'          
-	include 'nlte_atm.h'        
-	include 'nlte_data.h'       
-        include 'tcr_15um.h'
-	include 'nlte_curtis.h'        
-                                                
-c arguments                                     
-	real*8		c(nl,nl), cup(nl,nl), cdw(nl,nl)	! o   
-	real*8 		vc(nl), taugr(nl)       ! o       
-	real*8 		tau(nl,nl)		! i                     
-	real*8		tauinf(nl)	! i                      
-	integer		ib		! i                            
-	integer 	isot		! i                          
-	integer		icfout, itableout	! i               
-                                                
-c external                                      
-	external 	bandid                               
-	character*2 	bandid                            
-                                                
-c local variables                               
-	integer 	i, in, ir, iw                         
-	real*8		cfup(nl,nl), cfdw(nl,nl)               
-	real*8		a(nl,nl), cf(nl,nl)                    
-	character	isotcode*2, bcode*2                  
-                                                
-c formats                                       
- 101	format(i1)                                 
- 202	format(i2)                                 
- 180	format(a80)                                
- 181	format(a80)                                
-c***********************************************************************
-                                                
- 	if (isot.eq.1)  isotcode = '26'               
- 	if (isot.eq.2)  isotcode = '28'               
- 	if (isot.eq.3)  isotcode = '36'               
- 	if (isot.eq.4)  isotcode = '27'               
- 	if (isot.eq.5)  isotcode = 'co'               
-	bcode = bandid( ib )                           
-                                                
-!	write (*,*)  ' '                                               
-                                                
-	do in=1,nl                                     
-                                                
-         do ir=1,nl                             
-                                                
-          cf(in,ir) = 0.0d0                     
-          cfup(in,ir) = 0.0d0                   
-          cfdw(in,ir) = 0.0d0                   
-          c(in,ir) = 0.0d0                      
-          cup(in,ir) = 0.0d0                    
-          cdw(in,ir) = 0.0d0                    
-          a(in,ir) = 0.0d0                      
-                                                
-         end do                                 
-                                                
-         vc(in) = 0.0d0                         
-         taugr(in) = 0.0d0                      
-                                                
-        end do                                  
-                                                
-                                                
-c	the next lines are a reduced and equivalent way of calculating        
-c	the c(in,ir) elements for n=2,nl1 and r=1,nl  
-                                                
-                                                
-c	do in=2,nl1                                   
-c	do ir=1,nl                                    
-c	if(ir.eq.1)then                               
-c	c(in,ir)=tau(in-1,1)-tau(in+1,1)              
-c	elseif(ir.eq.nl)then                          
-c	c(in,ir)=tau(in+1,nl1)-tauinf(in+1)-tau(in-1,nl1)+tauinf(in-1)        
-c	else                                          
-c	c(in,ir)=tau(in+1,ir-1)-tau(in+1,ir)-tau(in-1,ir-1)+tau(in-1,ir)      
-c	end if                                        
-c	c(in,ir)=c(in,ir)*pi*deltanu(ib)/(2.*deltaz*1.0e5)	       
-c	end do                                        
-c	end do	                                       
-c	go to 1000                                    
-                                                
-c calculation of the matrix cfup(nl,nl)         
-                                                
-        cfup(1,1) = 1.d0 - tau(1,1)             
-                                                
-        do in=2,nl                              
-        do ir=1,in                              
-                                                
-        if (ir.eq.1) then                       
-           cfup(in,ir) = tau(in,ir) - tau(in,1)        
-        elseif (ir.eq.in) then                  
-           cfup(in,ir) = 1.d0 - tau(in,ir-1)           
-        else                                    
-           cfup(in,ir) = tau(in,ir) - tau(in,ir-1)     
-        end if                                  
-                                                
-        end do                                  
-        end do                                  
-                                                
-! contribution to upwards fluxes from bb at bottom :        
-        do in=1,nl                              
-          taugr(in) =  tau(in,1)                
-        enddo                                   
-                                                
-c calculation of the matrix cfdw(nl,nl)         
-                                                
-        cfdw(nl,nl) = 1.d0 - tauinf(nl)         
-                                                
-        do in=1,nl-1                            
-        do ir=in,nl                             
-                                                
-        if (ir.eq.in) then                      
-           cfdw(in,ir) = 1.d0 - tau(in,ir)             
-        elseif (ir.eq.nl) then                  
-           cfdw(in,ir) = tau(in,ir-1) - tauinf(in)     
-        else                                    
-           cfdw(in,ir) = tau(in,ir-1) - tau(in,ir)     
-        end if                                  
-                                                
-        end do                                  
-        end do                                  
-                                                
-                                                
-c calculation of the matrix cf(nl,nl)           
-                                                
-	do in=1,nl                                     
-	do ir=1,nl                                     
-                                                
-	if (ir.eq.1) then                              
-	    ! version con l_bb(tg)  =  l_bb(t(1))=j(1) (see also vc below)     
-	    !	cf(in,ir) = tau(in,ir)                   
-	    ! version con l_bb(tg) =/= l_bb(t(1))=j(1) (see also vc below)     
-		cf(in,ir) = tau(in,ir) - tau(in,1)            
-	elseif (ir.eq.nl) then                         
-		cf(in,ir) = tauinf(in) - tau(in,ir-1)         
-	else                                           
-		cf(in,ir) = tau(in,ir) - tau(in,ir-1)         
-	end if                                         
-                                                
-	end do                                         
-	end do                                         
-                                                
-                                                
-c  definition of the a(nl,nl) matrix            
-                                                
-	do in=2,nl-1                                   
-	  do ir=1,nl                                      
-		if (ir.eq.in+1) a(in,ir) = -1.d0              
-		if (ir.eq.in-1) a(in,ir) = +1.d0              
-	        a(in,ir) = a(in,ir) / ( 2.d0*deltaz*1.d5 )         
-	  end do                                       
-	end do                                         
-! this is not needed anymore in the akm scheme  
-!	a(1,1) = +3.d0                                
-!	a(1,2) = -4.d0                                
-!	a(1,3) = +1.d0                                
-!	a(nl,nl)   = -3.d0                            
-!	a(nl,nl1) = +4.d0                             
-!	a(nl,nl2) = -1.d0                             
-                                                
-c calculation of the final curtis matrix ("reduced" by murphy's method) 
-                                                
-	if (isot.ne.5) then                            
-	  do in=1,nl                                   
-	   do ir=1,nl                                  
-	    cf(in,ir) = cf(in,ir) * pi*deltanu(isot,ib)            
-	    cfup(in,ir) = cfup(in,ir) * pi*deltanu(isot,ib)        
-	    cfdw(in,ir) = cfdw(in,ir) * pi*deltanu(isot,ib)        
-	   end do                                      
-	   taugr(in) = taugr(in) * pi*deltanu(isot,ib) 
-	  end do                                       
-	else                                           
-	  do in=1,nl                                   
-	   do ir=1,nl                                  
-	    cf(in,ir) = cf(in,ir) * pi*deltanuco       
-	   enddo                                       
-	   taugr(in) = taugr(in) * pi*deltanuco        
-	  enddo                                        
-	endif                                          
-                                                
-	do in=2,nl-1                                   
-                                                
-	  do ir=1,nl                                   
-                                                
-	    do i=1,nl                                  
-	      ! only c contains the matrix a. matrixes cup,cdw dont because
-	      ! these two will be used for flux calculations, not  
-	      ! only for flux divergencies             
-                                                
-	      c(in,ir) = c(in,ir) + a(in,i) * cf(i,ir) 
-		! from this matrix we will extract (see below) the        
-		! nl2 x nl2 "core" for the "reduced" final curtis matrix. 
-                                                
-	    end do                                     
-	    cup(in,ir) = cfup(in,ir)                   
-	    cdw(in,ir) = cfdw(in,ir)                   
-                                                
-	  end do			                                    
-	  ! version con l_bb(tg)  =  l_bb(t(1))=j(1)  (see cf above)           
-	  !vc(in) = c(in,1)                            
-	  ! version con l_bb(tg) =/= l_bb(t(1))=j(1)  (see cf above)           
-	  vc(in) =  pi*deltanu(isot,ib)/( 2.d0*deltaz*1.d5 ) *     
-     @  		( tau(in-1,1) - tau(in+1,1) )         
-                                                
-	end do			                                      
-		                                              
- 5	continue                                     
-                                                
-!	write (*,*)  'mztf/1/ c(2,*) =', (c(2,i), i=1,nl)              
-                                                
-!	call elimin_dibuja(c,nl,itableout)            
-                                                
-c ventana del smoothing de c es nw=3 y de vc es 5 (puesto en lisa):     
-c subroutine elimin_mz4(c,vc,ilayer,nl,nan,iw, nw)          
-                                                
-	iw = nan                                       
-	if (isot.eq.4)  iw = 5                         
-	call elimin_mz1d (c,vc,0,iw,itableout,nw)      
-                                                
-! upper boundary condition                      
-!   j'(nl) = j'(nl1) ==> j(nl) = 2j(nl1) - j(nl2) ==>       
-	do in=2,nl-1                                   
-	  c(in,nl-2) = c(in,nl-2) - c(in,nl)           
-	  c(in,nl-1) = c(in,nl-1) + 2.d0*c(in,nl)      
-	  cup(in,nl-2) = cup(in,nl-2) - cup(in,nl)     
-	  cup(in,nl-1) = cup(in,nl-1) + 2.d0*cup(in,nl)            
-	  cdw(in,nl-2) = cdw(in,nl-2) - cdw(in,nl)     
-	  cdw(in,nl-1) = cdw(in,nl-1) + 2.d0*cdw(in,nl)            
-	end do			                                      
-!   j(nl) = j(nl1) ==>                          
-!	do in=2,nl1                                   
-!	  c(in,nl1) = c(in,nl1) + c(in,nl)            
-!	end do			                                     
-                                                
-! 1000	continue                                 
-        
-	if (icfout.eq.1) then                          
-                                                
-! 	 if (ib.eq.1 .or. ib.eq.12 .or. ib.eq.16 .or. ib.eq.18) then  
-!		codmatrx = codmatrx_fb                        
-!	 else                                           
-!		codmatrx = codmatrx_hot                       
-!	 end if                                         
-                                                
-!	 if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5    
-!     @        .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
-                                                
-! 	   open ( 1, access='sequential', form='unformatted', file=           
-!     @    dircurtis//'cfl'//isotcode//dn//ibcode1//codmatrx//'.dat')         
-! 	   open ( 2, access='sequential', form='unformatted', file=           
-!     @    dircurtis//'cflup'//isotcode//dn//ibcode1//codmatrx//'.dat')       
-! 	   open ( 3, access='sequential', form='unformatted', file=           
-!     @    dircurtis//'cfldw'//isotcode//dn//ibcode1//codmatrx//'.dat')       
-                                                
-!	 else                                          
-                                                
-! 	   open ( 1, access='sequential', form='unformatted', file=           
-!     @    dircurtis//'cfl'//isotcode//dn//ibcode2//codmatrx//'.dat')         
-! 	   open ( 2, access='sequential', form='unformatted', file=           
-!     @    dircurtis//'cflup'//isotcode//dn//ibcode2//codmatrx//'.dat')       
-! 	   open ( 3, access='sequential', form='unformatted', file=           
-!     @    dircurtis//'cfldw'//isotcode//dn//ibcode2//codmatrx//'.dat')       
-                                                
-!	 endif                                         
-                                                
-!	    write(1) dummy                             
-!	    write(1)' format: (vc(n),(ch(n,r),r=2,nl-1),n=2,nl-1)' 
-!	    do in=2,nl-1                               
-!	     write(1) vc(in), (c(in,ir)  , ir=2,nl-1 )		           
-	! es mas importante la precision que ocupar mucho espacio asi que      
-	! escribiremos las matrices en doble precision y por tanto en          
-	! [lib]readc_mz4.for no hay que reconvertirlas a doble precision.      
-		! ch is stored in single prec. to save storage space.     
-!	    end do                                     
-                                                
-!	    write(2) dummy                             
-!	    write(2)' format: (cfup(n,r),r=1,nl), n=1,nl)'         
-!	    do in=1,nl                                 
-!	     write(2) ( cup(in,ir)  , ir=1,nl )		      
-!	    end do                                     
-                                                
-!	    write(3) dummy                             
-!	    write(3)' format: (cfdw(n,r),r=1,nl), n=1,nl)'         
-!	    do in=1,nl                                 
-!	     write(3) (cdw(in,ir)  , ir=1,nl )		       
-!	    end do                                     
-                                                
-!	   if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5  
-!     @        .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
-!	     write (*,'(1x,30hcurtis matrix written out in: ,a50)' )           
-!     @     dircurtis//'cfl'//isotcode//dn//ibcode1//codmatrx//'.dat'         
-!	   else                                        
-!	     write (*,'(1x,30hcurtis matrix written out in: ,a50)' )           
-!     @     dircurtis//'cfl'//isotcode//dn//ibcode2//codmatrx//'.dat'         
-!	   endif                                       
-                                                
-	else                                           
-	                                               
-	 ! write (*,*)  ' no curtis matrix output file ', char(10)     
-                                                
-	end if                                         
-                                                
-                                                
-c end                                           
-	return                                         
-	end   
Index: unk/LMDZ.MARS/libf/phymars/mzcud.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/mzcud.F	(revision 497)
+++ 	(revision )
@@ -1,355 +1,0 @@
-c***********************************************************************
-                                                
-	subroutine mzcud( tauinf,tau, c,cup,cdw,vc,taugr,           
-     @   	ib,isot,icfout,itableout )           
- 
-c       old times       mlp     first version of mzcf                
-c	a.k.murphy method to avoid extrapolation in the curtis matrix         
-c	feb-89 	        malv 	AKM method to avoid extrapolation in C.M.
-c	25-sept-96  cristina 	dejar las matrices en doble precision 
-c	jan 98		malv	version para mz1d                
-c	oct 01		malv	update version for fluxes for hb and fb
-c       jul 2011        malv+fgg Adapted to LMD-MGCM
-c***********************************************************************
-                                                
-	implicit none                                  
-                 
-        include 'comcstfi.h'
-	include 'nltedefs.h'          
-	include 'nlte_atm.h'        
-	include 'nlte_data.h'       
-        include 'tcr_15um.h'
-	include 'nlte_curtis.h'        
-                                                
-c arguments                                     
-	real*8		c(nl,nl), cup(nl,nl), cdw(nl,nl)	! o   
-	real*8 		vc(nl), taugr(nl)       ! o       
-	real*8 		tau(nl,nl)		! i                     
-	real*8		tauinf(nl)	! i                      
-	integer		ib		! i                            
-	integer 	isot		! i                          
-	integer		icfout, itableout	! i               
-                                                
-c external                                      
-	external 	bandid                               
-	character*2 	bandid                            
-                                                
-c local variables                               
-	integer 	i, in, ir, iw, itblout                         
-	real*8		cfup(nl,nl), cfdw(nl,nl)               
-	real*8		a(nl,nl), cf(nl,nl)                    
-	character	isotcode*2, bcode*2                  
-                                                
-c formats                                       
- 101	format(i1)                                 
- 202	format(i2)                                 
- 180	format(a80)                                
- 181	format(a80)                                
-c***********************************************************************
-                                                
- 	if (isot.eq.1)  isotcode = '26'               
- 	if (isot.eq.2)  isotcode = '28'               
- 	if (isot.eq.3)  isotcode = '36'               
- 	if (isot.eq.4)  isotcode = '27'               
- 	if (isot.eq.5)  isotcode = 'co'               
-	bcode = bandid( ib )                           
-                                                
-!	write (*,*)  ' '                                               
-                                                
-	do in=1,nl                                     
-                                                
-         do ir=1,nl                             
-                                                
-          cf(in,ir) = 0.0d0                     
-          cfup(in,ir) = 0.0d0                   
-          cfdw(in,ir) = 0.0d0                   
-          c(in,ir) = 0.0d0                      
-          cup(in,ir) = 0.0d0                    
-          cdw(in,ir) = 0.0d0                    
-          a(in,ir) = 0.0d0                      
-                                                
-         end do                                 
-                                                
-         vc(in) = 0.0d0                         
-         taugr(in) = 0.0d0                      
-                                                
-        end do                                  
-                                                
-                                                
-c	the next lines are a reduced and equivalent way of calculating        
-c	the c(in,ir) elements for n=2,nl1 and r=1,nl  
-                                                
-                                                
-c	do in=2,nl1                                   
-c	do ir=1,nl                                    
-c	if(ir.eq.1)then                               
-c	c(in,ir)=tau(in-1,1)-tau(in+1,1)              
-c	elseif(ir.eq.nl)then                          
-c	c(in,ir)=tau(in+1,nl1)-tauinf(in+1)-tau(in-1,nl1)+tauinf(in-1)        
-c	else                                          
-c	c(in,ir)=tau(in+1,ir-1)-tau(in+1,ir)-tau(in-1,ir-1)+tau(in-1,ir)      
-c	end if                                        
-c	c(in,ir)=c(in,ir)*pi*deltanu(ib)/(2.*deltaz*1.0e5)	       
-c	end do                                        
-c	end do	                                       
-c	go to 1000                                    
-                                                
-c calculation of the matrix cfup(nl,nl)         
-                                                
-        cfup(1,1) = 1.d0 - tau(1,1)             
-                                                
-        do in=2,nl                              
-        do ir=1,in                              
-                                                
-        if (ir.eq.1) then                       
-           cfup(in,ir) = tau(in,ir) - tau(in,1)        
-        elseif (ir.eq.in) then                  
-           cfup(in,ir) = 1.d0 - tau(in,ir-1)           
-        else                                    
-           cfup(in,ir) = tau(in,ir) - tau(in,ir-1)     
-        end if                                  
-                                                
-        end do                                  
-        end do                                  
-                                                
-! contribution to upwards fluxes from bb at bottom :        
-        do in=1,nl                              
-          taugr(in) =  tau(in,1)                
-        enddo                                   
-                                                
-c calculation of the matrix cfdw(nl,nl)         
-                                                
-        cfdw(nl,nl) = 1.d0 - tauinf(nl)         
-                                                
-        do in=1,nl-1                            
-        do ir=in,nl                             
-                                                
-        if (ir.eq.in) then                      
-           cfdw(in,ir) = 1.d0 - tau(in,ir)             
-        elseif (ir.eq.nl) then                  
-           cfdw(in,ir) = tau(in,ir-1) - tauinf(in)     
-        else                                    
-           cfdw(in,ir) = tau(in,ir-1) - tau(in,ir)     
-        end if                                  
-                                                
-        end do                                  
-        end do                                  
-                                                
-                                                
-c calculation of the matrix cf(nl,nl)           
-                                                
-	do in=1,nl                                     
-	do ir=1,nl                                     
-                                                
-	if (ir.eq.1) then                              
-	    ! version con l_bb(tg)  =  l_bb(t(1))=j(1) (see also vc below)     
-	    !	cf(in,ir) = tau(in,ir)                   
-	    ! version con l_bb(tg) =/= l_bb(t(1))=j(1) (see also vc below)     
-		cf(in,ir) = tau(in,ir) - tau(in,1)            
-	elseif (ir.eq.nl) then                         
-		cf(in,ir) = tauinf(in) - tau(in,ir-1)         
-	else                                           
-		cf(in,ir) = tau(in,ir) - tau(in,ir-1)         
-	end if                                         
-                                                
-	end do                                         
-	end do                                         
-                                                
-                                                
-c  definition of the a(nl,nl) matrix            
-                                                
-	do in=2,nl-1                                   
-	  do ir=1,nl                                      
-		if (ir.eq.in+1) a(in,ir) = -1.d0              
-		if (ir.eq.in-1) a(in,ir) = +1.d0              
-	        a(in,ir) = a(in,ir) / ( 2.d0*deltaz*1.d5 )         
-	  end do                                       
-	end do                                         
-! this is not needed anymore in the akm scheme  
-!	a(1,1) = +3.d0                                
-!	a(1,2) = -4.d0                                
-!	a(1,3) = +1.d0                                
-!	a(nl,nl)   = -3.d0                            
-!	a(nl,nl1) = +4.d0                             
-!	a(nl,nl2) = -1.d0                             
-                                                
-c calculation of the final curtis matrix ("reduced" by murphy's method) 
-                                                
-	if (isot.ne.5) then                            
-	  do in=1,nl                                   
-	   do ir=1,nl                                  
-	    cf(in,ir) = cf(in,ir) * pi*deltanu(isot,ib)            
-	    cfup(in,ir) = cfup(in,ir) * pi*deltanu(isot,ib)        
-	    cfdw(in,ir) = cfdw(in,ir) * pi*deltanu(isot,ib)        
-	   end do                                      
-	   taugr(in) = taugr(in) * pi*deltanu(isot,ib) 
-	  end do                                       
-	else                                           
-	  do in=1,nl                                   
-	   do ir=1,nl                                  
-	    cf(in,ir) = cf(in,ir) * pi*deltanuco       
-	   enddo                                       
-	   taugr(in) = taugr(in) * pi*deltanuco        
-	  enddo                                        
-	endif                                          
-                                                
-	do in=2,nl-1                                   
-                                                
-	  do ir=1,nl                                   
-                                                
-	    do i=1,nl                                  
-	      ! only c contains the matrix a. matrixes cup,cdw dont because
-	      ! these two will be used for flux calculations, not  
-	      ! only for flux divergencies             
-                                                
-	      c(in,ir) = c(in,ir) + a(in,i) * cf(i,ir) 
-		! from this matrix we will extract (see below) the        
-		! nl2 x nl2 "core" for the "reduced" final curtis matrix. 
-                                                
-	    end do                                     
-	    cup(in,ir) = cfup(in,ir)                   
-	    cdw(in,ir) = cfdw(in,ir)                   
-                                                
-	  end do			                                    
-	  ! version con l_bb(tg)  =  l_bb(t(1))=j(1)  (see cf above)           
-	  !vc(in) = c(in,1)                            
-	  ! version con l_bb(tg) =/= l_bb(t(1))=j(1)  (see cf above)           
-	  if (isot.ne.5) then                            
-	     vc(in) =  pi*deltanu(isot,ib)/( 2.d0*deltaz*1.d5 ) *     
-     @  		( tau(in-1,1) - tau(in+1,1) )         
-          else
-	     vc(in) =  pi*deltanuco/( 2.d0*deltaz*1.d5 ) *     
-     @  		( tau(in-1,1) - tau(in+1,1) )         
-          endif
-                                    
-	end do			                                      
-		                                              
- 5	continue                                     
-                                                
-!	write (*,*)  'mztf/1/ c(2,*) =', (c(2,i), i=1,nl)              
-                                                
-!	call elimin_dibuja(c,nl,itableout)            
-                                                
-c ventana del smoothing de c es nw=3 y de vc es 5 (puesto en lisa):     
-c subroutine elimin_mz4(c,vc,ilayer,nl,nan,iw, nw)          
-                                                
-	iw = nan                                       
-	if (isot.eq.4)  iw = 5     ! eliminates values < 1.d-19
-	if (itableout.eq.30) then 
-           itblout = 0 
-        else 
-           itblout = itableout
-        endif
-        call elimin_mz1d (c,vc,0,iw,itblout,nw)      
-                                                
-! upper boundary condition                      
-!   j'(nl) = j'(nl1) ==> j(nl) = 2j(nl1) - j(nl2) ==>       
-	do in=2,nl-1                                   
-	  c(in,nl-2) = c(in,nl-2) - c(in,nl)           
-	  c(in,nl-1) = c(in,nl-1) + 2.d0*c(in,nl)      
-	  cup(in,nl-2) = cup(in,nl-2) - cup(in,nl)     
-	  cup(in,nl-1) = cup(in,nl-1) + 2.d0*cup(in,nl)            
-	  cdw(in,nl-2) = cdw(in,nl-2) - cdw(in,nl)     
-	  cdw(in,nl-1) = cdw(in,nl-1) + 2.d0*cdw(in,nl)            
-	end do			                                      
-!   j(nl) = j(nl1) ==>                          
-!	do in=2,nl1                                   
-!	  c(in,nl1) = c(in,nl1) + c(in,nl)            
-!	end do			                                     
-                                                
-! 1000	continue                                 
-                                                
-
-	if (icfout.eq.1) then                          
-                                                
-!	   if (ib.eq.1 .or. ib.eq.12 .or. ib.eq.16 .or. ib.eq.18) then     
-!		codmatrx = codmatrx_fb                        
-!	   else                                           
-!		codmatrx = codmatrx_hot                       
-!	   end if                                         
-!	   if (ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5    
-!     @        .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then
-!             ibcode2 = '0'//ibcode1
-!           else 
-!             write ( ibcode2, 202) ib
-!           endif
-                                                
-! 	   open ( 1, access='sequential', form='unformatted', file=           
-!     @    dircurtis//'cfl'//isotcode//dn//ibcode2//codmatrx//'.dat')         
-! 	   open ( 2, access='sequential', form='unformatted', file=           
-!     @    dircurtis//'cflup'//isotcode//dn//ibcode2//codmatrx//'.dat')       
-! 	   open ( 3, access='sequential', form='unformatted', file=           
-!     @    dircurtis//'cfldw'//isotcode//dn//ibcode2//codmatrx//'.dat')       
-! 	   open ( 4, access='sequential', form='unformatted', file=           
-!     @    dircurtis//'cflgr'//isotcode//dn//ibcode2//codmatrx//'.dat')       
-                                                
-!	    write(1) dummy                             
-!	    write(1) ' format: (vc(n),(ch(n,r),r=2,nl-1),n=2,nl-1)' 
-!	    do in=2,nl-1                               
-!	     write(1) vc(in), (c(in,ir)  , ir=2,nl-1 )		           
-!!             write (*,*) in, vc(in)
-!	    end do                                     
-                                                
-!	    write(2) dummy                             
-!	    write(2)' format: (cfup(n,r),r=1,nl), n=1,nl)'  
-!	    do in=1,nl                                 
-!	     write(2) ( cup(in,ir)  , ir=1,nl )		      
-!	    end do                                     
-                                                
-!	    write(3) dummy                             
-!	    write(3)' format: (cfdw(n,r),r=1,nl), n=1,nl)'         
-!	    do in=1,nl                                 
-!	     write(3) (cdw(in,ir)  , ir=1,nl )		       
-!	    end do                                     
-                                                
-!	    write(4) dummy   
-!	    write(4)' format: (taugr(n), n=1,nl)'         
-!	    do in=1,nl                                 
-!	     write(4) (taugr(in), ir=1,nl )		       
-!	    end do                 
-!            !write (*,*) ' Last value in file: ', taugr(nl)
-
-!	   write (*,'(1x,30hcurtis matrix written out in: ,a,a,a,a)' )
-!     @     dircurtis//'cfl'//isotcode//dn//ibcode2//codmatrx//'.dat',
-!     @     dircurtis//'cflup'//isotcode//dn//ibcode2//codmatrx//'.dat',
-!     @     dircurtis//'cfldw'//isotcode//dn//ibcode2//codmatrx//'.dat',
-!     @     dircurtis//'cflgr'//isotcode//dn//ibcode2//codmatrx//'.dat'
-                                                
-!           close (1)
-!           close (2)
-!           close (3)
-!           close (4)
-
-	else                                           
-	                                               
-	 ! write (*,*)  ' no curtis matrix output file ', char(10)     
-                                                
-	end if                                         
-
-	if (itableout.eq.30) then      ! Force output of C.M. in ascii file 
-
-!	   if (ib.eq.1 .or. ib.eq.12 .or. ib.eq.16 .or. ib.eq.18) then     
-!		codmatrx = codmatrx_fb                        
-!	   else                                           
-!		codmatrx = codmatrx_hot                       
-!	   end if                                         
-!	   if (ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5    
-!     @        .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then
-!             ibcode2 = '0'//ibcode1
-!           else 
-!             write ( ibcode2, 202) ib
-!           endif
-
-! 	   open (10, file=           
-!     &      dircurtis//'table'//isotcode//dn//ibcode2//codmatrx//'.dat')
-!            write(10,*) nl, ' = number of layers '
-!            write(10,*) ' format: (vc(n),(ch(n,r),r=2,nl-1),n=2,nl-1)'
-!            do in=2,nl-1
-!              write(10,*) vc(in), (c(in,ir)  , ir=2,nl-1 )
-!            enddo
-!           close (10)                              
-        endif
-                               
-c end                                           
-	return                                         
-	end   
Index: unk/LMDZ.MARS/libf/phymars/mzescape.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/mzescape.F	(revision 497)
+++ 	(revision )
@@ -1,599 +1,0 @@
-c***********************************************************************
-c	mzescape.f                                    
-c***********************************************************************
-c                                               
-c	program  for calculating atmospheric escape functions, from           
-c       a calculation of transmittances and derivatives of these ones   
-                               
-	subroutine mzescape(ig,taustar,tauinf,tauii, ib,isot, iirw,iimu)       
-
-c       jul 2011        malv+fgg   adapted to LMD-MGCM                        
-c       nov 99          malv    adapt mztf to compute taustar (pg.23b-ma
-c       nov 98          malv    allow for overlaping in the lorentz line
-c	jan 98		malv	version for mz1d. based on curtis/mztf.for   
-c       17-jul-96	mlp&crs	change the calculation of mr.     
-c				evitar: divide por cero. anhadiendo: ff    
-c	oct-92		malv 	correct s(t) dependence for all histogr bands
-c	june-92		malv	proper lower levels for laser bands         
-c	may-92		malv 	new temperature dependence for laser bands  
-c     @    991 		malv 	boxing for the averaged absorber amount and t
-c	 ?		malv	extension up to 200 km altitude in mars 
-c       13-nov-86	mlp	include the temperature weighted to match 
-c				the eqw in the strong doppler limit.       
-c***********************************************************************
-                                                            
-	implicit none                                  
-                                                            
-	include 'nltedefs.h'          
-	include 'nlte_atm.h'        
-	include 'nlte_data.h'       
-	include 'nlte_curtis.h'        
-        include 'tcr_15um.h'
-	include 'nlte_results.h'  
-                                                            
-                                                            
-c arguments          
-        integer         ig      ! ADDED FOR TRACEBACK
-	real*8 		taustar(nl)     ! o                   
-	real*8 		tauinf(nl)      ! o                   
-	real*8 		tauii(nl)       ! o                   
-	integer		ib					! i 
-	integer		isot					! i
-	integer		iirw					! i
-	integer		iimu					! i
-                                                            
-                                                            
-c local variables and constants                 
-	integer 	i, in, ir, im, k,j                      
-	integer 	nmu                                   
- 	parameter 	(nmu = 8)                          
-!	real*8 		tauinf(nl)                           
-	real*8 		con(nzy), coninf                       
-	real*8 		c1, c2, ccc                           
-	real*8 		t1, t2                                
-	real*8 		p1, p2                                
-	real*8		mr1, mr2                               
-	real*8 		st1, st2                              
-	real*8 		c1box(70), c2box(70)                  
-	real*8		ff			! to avoid too small numbers
-	real*8		tvtbs(nzy)                              
-	real*8 		st, beta, ts, eqwmu                   
-	real*8 		mu(nmu), amu(nmu)                     
-	real*8  	zld(nl), zyd(nzy)                               
-	real*8 		correc                                
-	real 		deltanux		! width of vib-rot band (cm-1)
-	character	isotcode*2	                          
-	real*8          maximum                        
-        real*8          csL, psL, Desp, wsL     ! for Strong Lorentz limit
-                                                            
-c formats                                       
- 111	format(a1)                                 
- 112	format(a2)                                 
- 101	format(i1)                                 
- 202	format(i2)                                 
- 180	format(a80)                                
- 181	format(a80)                                
-c***********************************************************************
-                                                            
-c some needed values                            
-!	rl=sqrt(log(2.d0))                             
-!	pi2 = 3.14159265358989d0                       
-	beta = 1.8d0                                   
-!	imrco = 0.9865                                 
-                                                            
-c  esto es para que las subroutines de mztfsub calculen we  
-c  de la forma apropiada para mztf, no para fot 
-	icls=icls_mztf                                 
-                                                            
-c codigos para filenames                        
-!	if (isot .eq. 1)  isotcode = '26'              
-!	if (isot .eq. 2)  isotcode = '28'              
-!	if (isot .eq. 3)  isotcode = '36'              
-!	if (isot .eq. 4)  isotcode = '27'              
-!	if (isot .eq. 5)  isotcode = '62'              
-!	if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5     
-!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
-!!		encode(2,101,ibcode1)ib                       
-!		write ( ibcode1, 101) ib                       
-!	else                                           
-!!		encode(2,202,ibcode2)ib
-!                write (ibcode2, 202) ib
-!	endif                                          
-!	write (*,'( 30h calculating curtis matrix :  ,2x,         
-!     @    	8h band = ,i2,2x, 11h isotope = ,i2)') ib, isot         
-                                                            
-c integration in angle !!!!!!!!!!!!!!!!!!!!     
-                                                            
-c------- diffusivity approx.                    
-	if (iimu.eq.1) then                            
-!	  write (*,*)  ' diffusivity approx. beta = ',beta             
-	  mu(1) = 1.0d0                                
-	  amu(1)= 1.0d0                                
-c-------data for 8 points integration           
-	elseif (iimu.eq.4) then                        
-	  write (*,*)' 4 points for the gauss-legendre angle quadrature.'
-	  mu(1)=(1.0d0+0.339981043584856)/2.0d0 	      
-	  mu(2)=(1.0d0-0.339981043584856)/2.0d0 	      
-	  mu(3)=(1.0d0+0.861136311594053)/2.0d0        
-	  mu(4)=(1.0d0-0.861136311594053)/2.0d0 	      
-	  amu(1)=0.652145154862546 	                   
-	  amu(2)=amu(1) 	                              
-	  amu(3)=0.347854845137454 	                   
-	  amu(4)=amu(3)                                
-	  beta=1.0d0                                   
-c-------data for 8 points integration           
-	elseif(iimu.eq.8) then                         
-	  write (*,*)' 8 points for the gauss-legendre angle quadrature.'
-	  mu(1)=(1.0d0+0.183434642495650)/2.0d0        
-	  mu(2)=(1.0d0-0.183434642495650)/2.0d0        
-	  mu(3)=(1.0d0+0.525532409916329)/2.0d0        
-	  mu(4)=(1.0d0-0.525532409916329)/2.0d0        
-	  mu(5)=(1.0d0+0.796666477413627)/2.0d0        
-	  mu(6)=(1.0d0-0.796666477413627)/2.0d0        
-	  mu(7)=(1.0d0+0.960289856497536)/2.0d0        
-	  mu(8)=(1.0d0-0.960289856497536)/2.0d0        
-	  amu(1)=0.362683783378362                     
-	  amu(2)=amu(1)                                
-	  amu(3)=0.313706645877887                     
-	  amu(4)=amu(3)                                
-	  amu(5)=0.222381034453374                     
-	  amu(6)=amu(5)                                
-	  amu(7)=0.101228536290376                     
-	  amu(8)=amu(7)                                
-	  beta=1.0d0                                   
-	end if                                         
-c!!!!!!!!!!!!!!!!!!!!!!!                        
-                                                            
-ccc                                             
-ccc  determine abundances included in the absorber amount   
-ccc                                             
-                                                            
-c first, set up the grid ready for interpolation.           
-	do i=1,nzy                                      
-	  zyd(i) = dble(zy(i))                         
-	enddo                                          
-	do i=1,nl                                      
-	  zld(i) = dble(zl(i))                         
-	enddo                                          
-                                                            
-c vibr. temp of the bending mode :              
-        if (isot.eq.1) call interdp ( tvtbs,zyd,nzy, v626t1,zld,nl, 1 )  
-        if (isot.eq.2) call interdp ( tvtbs,zyd,nzy, v628t1,zld,nl, 1 )  
-        if (isot.eq.3) call interdp ( tvtbs,zyd,nzy, v636t1,zld,nl, 1 )  
-        if (isot.eq.4) call interdp ( tvtbs,zyd,nzy, v627t1,zld,nl, 1 )  
-                                                            
-c 2nd: correccion a la n10(i) (cantidad de absorbente en el lower state)
-c por similitud a la que se hace en cza.for     
-                                                            
-	do i=1,nzy                                      
-	  if (isot.eq.5) then                          
-	    con(i) = dble( coy(i) * imrco )            
-	  else                                         
-	    con(i) =  dble( co2y(i) * imr(isot) )      
-	    correc = 2.d0 * dexp( dble(-ee*elow(isot,2))/tvtbs(i) )            
-	    con(i) = con(i) * ( 1.d0 - correc )        
-	  endif                                        
-c-----------------------------------------------------------------------
-c mlp & cristina. 17 july 1996                  
-c change the calculation of mr. it is used for calculating partial press
-c alpha = alpha(self,co2)*pp +alpha(n2)*(pt-pp) 
-c for an isotope, if mr is obtained by co2*imr(iso)/nt we are considerin
-c collisions with other co2 isotopes (including the major one, 626)     
-c as if they were with n2. assuming mr as co2/nt, we consider collisions
-c of type 628-626 as of 626-626 instead of as 626-n2.       
-c	  mrx(i)=con(i)/ntx(i) ! old malv             
-                                                            
-!	  mrx(i)= dble(co2x(i)/ntx(i))	! mlp & crs    
-                                                            
-c jan 98:                                       
-c esta modif de mlp implica anular el correc (deberia revisar esto)     
-	  mr(i) = dble(co2y(i)/nty(i))	! malv, jan 98  
-                                                            
-c-----------------------------------------------------------------------
-                                                            
-	end do                                         
-                                                            
-! como  beta y 1.d5 son comunes a todas las weighted absorber amounts,  
-! los simplificamos:                            
-!	coninf = beta * 1.d5 * dble( con(n) / log( con(n-1) / con(n) ) )      
-	coninf = dble( con(nzy) / log( con(nzy-1) / con(nzy) ) )      
-                                                            
-!	write (*,*)  ' coninf =', coninf                               
-                                                            
-ccc                                             
-ccc  temp dependence of the band strength and   
-ccc  nlte correction factor for the absorber amount         
-ccc                                             
-	call mztf_correccion ( coninf, con, ib, isot, 0 ) 
-                                                            
-ccc                                             
-ccc reads histogrammed spectral data (strength for lte and vmr=1)       
-ccc                                             
-	!hfile1 = dirspec//'hi'//dn        ! Ya no distinguimos entre d/n
-!!	hfile1 = dirspec//'hid'            ! (see why in his.for)
-!        hfile1='hid'
-!!	if (ib.eq.13 .or. ib.eq.14 ) hfile1 = dirspec//'his'       
-!        if (ib.eq.13 .or. ib.eq.14 ) hfile1 = 'his'  
-                                                            
-!	if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5     
-!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
-!	   if (isot.eq.1) hisfile = hfile1//'26-'//ibcode1//'.dat' 
-!	   if (isot.eq.2) hisfile = hfile1//'28-'//ibcode1//'.dat' 
-!	   if (isot.eq.3) hisfile = hfile1//'36-'//ibcode1//'.dat' 
-!	   if (isot.eq.4) hisfile = hfile1//'27-'//ibcode1//'.dat' 
-!	   if (isot.eq.5) hisfile = hfile1//'62-'//ibcode1//'.dat' 
-!	else                                           
-!	   if (isot.eq.1) hisfile = hfile1//'26-'//ibcode2//'.dat' 
-!	   if (isot.eq.2) hisfile = hfile1//'28-'//ibcode2//'.dat' 
-!	   if (isot.eq.3) hisfile = hfile1//'36-'//ibcode2//'.dat' 
-!	   if (isot.eq.4) hisfile = hfile1//'27-'//ibcode2//'.dat' 
-!	   if (isot.eq.5) hisfile = hfile1//'62-'//ibcode2//'.dat' 
-!	endif                                          
-	!write (*,*) ' /MZESCAPE/ hisfile: ', hisfile                         
-                                                            
-! the argument to rhist is to make this compatible with mztf_comp.f,    
-! which is a useful modification of mztf.f (to change strengths of bands
-!	call rhist (1.0)                               
-        if(ib.eq.1) then
-	   if(isot.eq.1) then !Case 1
-	      mm=mm_c1
-	      nbox=nbox_c1
-	      tmin=tmin_c1
-	      tmax=tmax_c1
-	      do i=1,nbox_max
-		 no(i)=no_c1(i)
-		 dist(i)=dist_c1(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c1(j,i)
-		    xls1(j,i)=xls1_c1(j,i)
-		    xln1(j,i)=xln1_c1(j,i)
-		    xld1(j,i)=xld1_c1(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c1(j)
-	      enddo
-	   else if(isot.eq.2) then !Case 2
-	      mm=mm_c2
-	      nbox=nbox_c2
-	      tmin=tmin_c2
-	      tmax=tmax_c2
-	      do i=1,nbox_max
-		 no(i)=no_c2(i)
-		 dist(i)=dist_c2(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c2(j,i)
-		    xls1(j,i)=xls1_c2(j,i)
-		    xln1(j,i)=xln1_c2(j,i)
-		    xld1(j,i)=xld1_c2(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c2(j)
-	      enddo
-	   else if(isot.eq.3) then !Case 3
-	      mm=mm_c3
-	      nbox=nbox_c3
-	      tmin=tmin_c3
-	      tmax=tmax_c3
-	      do i=1,nbox_max
-		 no(i)=no_c3(i)
-		 dist(i)=dist_c3(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c3(j,i)
-		    xls1(j,i)=xls1_c3(j,i)
-		    xln1(j,i)=xln1_c3(j,i)
-		    xld1(j,i)=xld1_c3(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c3(j)
-	      enddo
-	   else if(isot.eq.4) then !Case 4
-	      mm=mm_c4
-	      nbox=nbox_c4
-	      tmin=tmin_c4
-	      tmax=tmax_c4
-	      do i=1,nbox_max
-		 no(i)=no_c4(i)
-		 dist(i)=dist_c4(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c4(j,i)
-		    xls1(j,i)=xls1_c4(j,i)
-		    xln1(j,i)=xln1_c4(j,i)
-		    xld1(j,i)=xld1_c4(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c4(j)
-	      enddo
-	   else
-	      write(*,*)'isot must be 2,3 or 4 for ib=1!!'
-	      write(*,*)'stop at mzescape/312'
-	      stop
-	   endif
-	else if (ib.eq.2) then
-	   if(isot.eq.1) then	!Case 5
-	      mm=mm_c5
-	      nbox=nbox_c5
-	      tmin=tmin_c5
-	      tmax=tmax_c5
-	      do i=1,nbox_max
-		 no(i)=no_c5(i)
-		 dist(i)=dist_c5(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c5(j,i)
-		    xls1(j,i)=xls1_c5(j,i)
-		    xln1(j,i)=xln1_c5(j,i)
-		    xld1(j,i)=xld1_c5(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c5(j)
-	      enddo
-	   else
-	      write(*,*)'isot must be 1 for ib=2!!'
-	      write(*,*)'stop at mzescape/336'
-	      stop
-	   endif
-	else if (ib.eq.3) then
-	   if(isot.eq.1) then	!Case 6
-	      mm=mm_c6
-	      nbox=nbox_c6
-	      tmin=tmin_c6
-	      tmax=tmax_c6
-	      do i=1,nbox_max
-		 no(i)=no_c6(i)
-		 dist(i)=dist_c6(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c6(j,i)
-		    xls1(j,i)=xls1_c6(j,i)
-		    xln1(j,i)=xln1_c6(j,i)
-		    xld1(j,i)=xld1_c6(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c6(j)
-	      enddo
-	   else
-	      write(*,*)'isot must be 1 for ib=3!!'
-	      write(*,*)'stop at mzescape/360'
-	      stop
-	   endif
-	else if (ib.eq.4) then
-	   if(isot.eq.1) then	!Case 7
-	      mm=mm_c7
-	      nbox=nbox_c7
-	      tmin=tmin_c7
-	      tmax=tmax_c7
-	      do i=1,nbox_max
-		 no(i)=no_c7(i)
-		 dist(i)=dist_c7(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c7(j,i)
-		    xls1(j,i)=xls1_c7(j,i)
-		    xln1(j,i)=xln1_c7(j,i)
-		    xld1(j,i)=xld1_c7(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c7(j)
-	      enddo
-	   else
-	      write(*,*)'isot must be 1 for ib=4!!'
-	      write(*,*)'stop at mzescape/384'
-	      stop
-	   endif
-	else 
-	   write(*,*)'ib must be 1,2,3 or 4!!'
-	   write(*,*)'stop at mzescape/389'
-	endif                                                    
-	if (isot.ne.5) deltanux = deltanu(isot,ib)     
-	if (isot.eq.5) deltanux = deltanuco            
-                                                            
-c******                                         
-c****** calculation of tauinf(nl)               
-c******                                         
-	call initial                                   
-                                                            
-	ff=1.0e10                                      
-                                                            
-	do i=nl,1,-1                                   
-                                                            
-	  if(i.eq.nl)then                              
-                                                            
-		call intz (zl(i),c2,p2,mr2,t2, con)           
-		do kr=1,nbox                                  
-		 ta(kr)=t2                                    
-	  	end do                                      
-!	write (*,*)  ' i, t2 =', i, t2                                 
-		call interstrength (st2,t2,ka,ta)             
-		aa = p2 * coninf * mr2 * (st2 * ff)           
-		bb = p2 * coninf * st2                        
-		cc = coninf * st2                             
-		dd = t2 * coninf * st2                        
-		do kr=1,nbox                                  
-	          ccbox(kr) = coninf * ka(kr)          
-		  ddbox(kr) = t2 * ccbox(kr)                  
-!		  c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5   
-		  c2box(kr) = c2 * ka(kr) * dble(deltaz)      
-		end do                                        
-!		c2 = c2 * st2 * beta * dble(deltaz) * 1.d5   
-		c2 = c2 * st2 * dble(deltaz)                  
-                                                            
-	  else                                         
-		call intz (zl(i),c1,p1,mr1,t1, con)           
-		do kr=1,nbox                                  
-		 ta(kr)=t1                                    
-	  	end do                                      
-!	write (*,*)  ' i, t1 =', i, t1                                 
-		call interstrength (st1,t1,ka,ta)             
-		do kr=1,nbox                                  
-!		  c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5   
-		  c1box(kr) = c1 * ka(kr) * dble(deltaz)      
-		end do                                        
-!		c1 = c1 * st1 * beta * dble(deltaz) * 1.d5   
-		c1 = c1 * st1 * dble(deltaz)                  
-		aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0       
-		bb = bb + ( p1*c1 + p2*c2 ) / 2.d0            
-		cc = cc + ( c1 + c2 ) / 2.d0                  
-		ccc = ( c1 + c2 ) / 2.d0                      
-		dd = dd + ( t1*c1 + t2*c2 ) / 2.d0            
-		do kr=1,nbox                                  
-	          ccbox(kr) = ccbox(kr) + 
-     @                         ( c1box(kr) + c2box(kr) )/2.d0       
-		  ddbox(kr) = ddbox(kr) + 
-     @                         ( t1*c1box(kr)+t2*c2box(kr) )/2.d0
-		end do                                        
-                                                            
-		mr2 = mr1                                     
-		c2=c1                                         
-		do kr=1,nbox	                                 
-		  c2box(kr) = c1box(kr)                       
-		end do                                        
-		t2=t1                                         
-		p2=p1                                         
-	  end if                                       
-                                                            
-	  pt = bb / cc                                 
-	  pp = aa / (cc*ff)                            
-                                                            
-!	  ta=dd/cc                                    
-!	  tdop = ta                                   
-	  ts = dd/cc                                   
-          do kr=1,nbox                          
-   	    ta(kr) = ddbox(kr) / ccbox(kr)          
-	  end do                                       
-!	write (*,*)  ' i, ts =', i, ts                                 
-	  call interstrength(st,ts,ka,ta)              
-!	  call intershape(alsa,alna,alda,tdop)        
-	  call intershape(alsa,alna,alda,ta)           
-                                                            
-*	  ua = cc/st                                  
-                                                            
-c  	next loop calculates the eqw for an especified path ua,pp,pt,ta     
-                                                            
-	  eqwmu = 0.0d0                                
-	  do im = 1,iimu                               
-	    eqw=0.0d0                                  
-            do  kr=1,nbox                       
-		ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im)       
-                if(ua(kr).lt.0.)write(*,*)'mzescape/480',ua(kr),
-     $               ccbox(kr),ka(kr),beta,mu(im),kr,im,i,nl
-
-	        call findw (ig,iirw, 0, csL,psL, Desp, wsL)                       
-		if ( i_supersat .eq. 0 ) then                 
-	          eqw=eqw+no(kr)*w                     
-		else                                          
-		   eqw = w + (no(kr)-1) * ( asat_box*dist(kr) )           
-		endif                                         
-	    end do                                     
-	    eqwmu = eqwmu + eqw * mu(im)*amu(im)       
-	  end do                                       
-                                                            
-! 	  tauinf(i) = exp( - eqwmu / dble(deltanux) )            
-	  tauinf(i) = 1.d0 - eqwmu / dble(deltanux)    
-	  if (tauinf(i).lt.0.d0) tauinf(i) = 0.0d0     
-                                                            
-	  if (i.eq.nl) then                            
-	     taustar(i) = 0.0d0                        
-	  else                                         
-	     taustar(i) = dble(deltanux) * (tauinf(i+1)-tauinf(i)) 
-!     ~            / ( beta * cc * 1.d5 )       
-     ~            / ( beta * ccc * 1.d5 )       
-	  endif                                        
-                                                            
-	end do  ! i continue                           
-                                                            
-                                                            
-c******                                         
-c****** calculation of tau(in,ir) for n<=r      
-c******                                         
-                                                            
-        do 1 in=1,nl-1                          
-                                                            
-          call initial                          
-                                                            
-          call intz (zl(in), c1,p1,mr1,t1, con) 
-          do kr=1,nbox                          
-            ta(kr) = t1                         
-          end do                                
-          call interstrength (st1,t1,ka,ta)     
-          do kr=1,nbox                          
-            c1box(kr) = c1 * ka(kr) * dble(deltaz)          
-          end do                                
-          c1 = c1 * st1 * dble(deltaz)          
-                                                            
-          call intz (zl(in+1), c2,p2,mr2,t2, con)           
-          do kr=1,nbox                          
-            ta(kr) = t2                         
-          end do                                
-          call interstrength (st2,t2,ka,ta)     
-          do kr=1,nbox                          
-            c2box(kr) = c2 * ka(kr) * dble(deltaz)          
-          end do                                
-          c2 = c2 * st2 * dble(deltaz)          
-                                                            
-          aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0           
-          bb = bb + ( p1*c1 + p2*c2 ) / 2.d0    
-          cc = cc + ( c1 + c2 ) / 2.d0          
-          dd = dd + ( t1*c1 + t2*c2 ) / 2.d0    
-          do kr=1,nbox                          
-            ccbox(kr) = ccbox(kr) + (c1box(kr)+c2box(kr))/2.d0          
-            ddbox(kr) = ddbox(kr) + (t1*c1box(kr)+t2*c2box(kr))/2.d0    
-          end do                                
-                                                            
-          mr1=mr2                               
-          t1=t2                                 
-          c1=c2                                 
-          p1=p2                                 
-          do kr=1,nbox                          
-            c1box(kr) = c2box(kr)               
-          end do                                
-          pt = bb / cc                          
-          pp = aa / (cc * ff)                   
-          ts = dd/cc                            
-          do kr=1,nbox                          
-            ta(kr) = ddbox(kr) / ccbox(kr)      
-          end do                                
-          call interstrength(st,ts,ka,ta)       
-          call intershape(alsa,alna,alda,ta)    
-                                                            
-          eqwmu = 0.0d0                         
-          do im = 1,iimu                        
-            eqw=0.0d0                           
-            do kr=1,nbox      
-               ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im)
-               if(ua(kr).lt.0.)write(*,*)'mzescape/566',ua(kr),
-     $              ccbox(kr),ka(kr),beta,mu(im),kr,im,i,nl
-
-               call findw (ig,iirw, 0, csL,psL, Desp, wsL)      
-               if ( i_supersat .eq. 0 ) then               
-                  eqw=eqw+no(kr)*w                          
-               else                                        
-                  eqw = w + (no(kr)-1) * ( asat_box*dist(kr) )         
-               endif                                       
-            end do                              
-            eqwmu = eqwmu + eqw * mu(im)*amu(im)            
-          end do                                
-                                                            
-          tauii(in) = exp( - eqwmu / dble(deltanux) )                         
-          !write (*,*) 'i,tauii=',in,tauii(in)  
-
- 1      continue                                
-        tauii(nl) = 1.0d0
-                           
-                                                            
-c end                                           
-	return                                         
-	end                                            
-
-
-
-
-
-
-
-
-
-
Index: unk/LMDZ.MARS/libf/phymars/mzescape_fb.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/mzescape_fb.F	(revision 497)
+++ 	(revision )
@@ -1,47 +1,0 @@
-c***********************************************************************
-	subroutine mzescape_fb(ig)                       
-                                                            
-c 	computes the escape functions of the most important 15um bands       
-c       this calls mzescape ( taustar,tauinf,tauii,  ib,isot, iirw,iimu 
-                                                            
-c 	nov 99 	malv		based on cm15um_fb.f           
-c       jul 2011 malv+fgg       adapted to LMD-MGCM
-c***********************************************************************
-                                                            
-	implicit none                                  
-                                                            
-	include 'nltedefs.h'          
-	include 'nlte_matrix.h'      
-        include 'nlte_atm.h' 
-	include 'tcr_15um.h'
-                                                            
-c local variables                               
-	integer 	i, ib, ik, istyle                     
-	integer         ig !ADDED FOR TRACEBACK
-	real*8          tau_factor                     
-	real*8          aux(nl), aux2(nl), aux3(nl)    
-                                                            
-c***********************************************************************
-                                                            
-	call mzescape ( ig,taustar21,tauinf210,tauii210, 1, 2,irw_mztf,imu ) 
-	call mzescape ( ig,taustar31,tauinf310,tauii310, 1, 3,irw_mztf,imu )
-	call mzescape ( ig,taustar41,tauinf410,tauii410, 1, 4,irw_mztf,imu )
-                                                            
-	istyle = 2                                     
-	call mzescape_normaliz ( taustar21, istyle )   
-	call mzescape_normaliz ( taustar31, istyle )   
-	call mzescape_normaliz ( taustar41, istyle )   
-                                                            
-                                                            
-c end                                           
-	return                                         
-	end                                            
-                                                            
-                                                            
-                                                            
-                                                            
-                                                            
-                                                            
-                                                            
-                                                            
-                                                            
Index: unk/LMDZ.MARS/libf/phymars/mzescape_fh.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/mzescape_fh.F	(revision 497)
+++ 	(revision )
@@ -1,52 +1,0 @@
-c***********************************************************************
-	subroutine mzescape_fh(ig)                     
-              
-c       jul 2011 malv+fgg                                
-c***********************************************************************
-                                                            
-	implicit none                                  
-                                                            
-	include 'nltedefs.h'          
-	include 'nlte_matrix.h'      
-        include 'nlte_atm.h' 
-	include 'tcr_15um.h'
-                                                            
-c local variables                               
-	integer 	i, ib, ik, istyle
-	integer         ig  ! ADDED FOR TRACEBACK
-	real*8          tau_factor                     
-	real*8          aux(nl), aux2(nl), aux3(nl)    
-                                                            
-c***********************************************************************
-                                                            
-        call zero4v( aux, taustar12,tauinf121,tauii121, nl)
-        do ik=1,3                               
-          ib=ik+1                               
-	  call mzescape ( ig,aux,aux2,aux3, ib, 1,irw_mztf,imu )         
-          tau_factor = 1.d0                     
-	  if (ik.eq.1) tau_factor = dble(667.75/618.03)            
-          if (ik.eq.3) tau_factor = dble(667.75/720.806)    
-	  do i=1,nl                                    
-            taustar12(i) = taustar12(i) + aux(i) * tau_factor           
-            tauinf121(i) = tauinf121(i) + aux2(i) * tau_factor          
-            tauii121(i) = tauii121(i) + aux3(i) * tau_factor            
-	  enddo                                        
-	enddo                                          
-                                                            
-	istyle = 2                                     
-	call mzescape_normaliz ( taustar12, istyle )   
-                                                            
-                                                           
-                                                            
-c end                                           
-	return                                         
-	end                                            
-                                                            
-                                                            
-                                                            
-                                                            
-                                                            
-                                                            
-                                                            
-                                                            
-                                                            
Index: unk/LMDZ.MARS/libf/phymars/mzescape_normaliz.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/mzescape_normaliz.F	(revision 497)
+++ 	(revision )
@@ -1,83 +1,0 @@
-c***********************************************************************
-c	mzescape_normaliz.f                           
-c***********************************************************************
-c                                               
-c	program  for correcting some strange values and for normalizing       
-c       the atmospheric escape functions computed by mzescape_15um.f    
-c       possibilities according to istyle (see mzescape_15um.f).        
-c                                               
-                                                            
-	subroutine mzescape_normaliz ( taustar, istyle )           
-                                                            
-                                                            
-c       dic 99          malv    first version   
-c       jul 2011 malv+fgg       Adapted to LMD-MGCM
-c***********************************************************************
-                                                            
-	implicit none                                  
-	include 'nltedefs.h'          
-                                                            
-                                                            
-c arguments                                     
-	real*8 		taustar(nl)     ! o                   
-	integer         istyle          ! i            
-                                                            
-c local variables and constants                 
-	integer 	i, imaximum                           
-	real*8          maximum                        
-                                                            
-c***********************************************************************
-                                                            
-!                                               
-! correcting strange values at top, eliminating local maxima, etc...    
-!                                               
-	taustar(nl) = taustar(nl-1)                    
-                                                            
-	if ( istyle .eq. 1 ) then                      
-	  imaximum = nl                                
-	  maximum = taustar(nl)                        
-	  do i=1,nl-1                                  
-	    if (taustar(i).gt.maximum) taustar(i) = taustar(nl)    
-	  enddo                                        
-	elseif ( istyle .eq. 2 ) then                  
-	  imaximum = nl                                
-	  maximum = taustar(nl)                        
-	  do i=nl-1,1,-1                               
-	    if (taustar(i).gt.maximum) then            
-	       maximum = taustar(i)                    
-	       imaximum = i                            
-	    endif                                      
-	  enddo                                        
-	  do i=imaximum,nl                             
-	    if (taustar(i).lt.maximum) taustar(i) = maximum        
-	  enddo                                        
-	endif                                          
-                                                            
-!                                               
-! normalizing                                   
-!                                               
-	do i=1,nl                                      
-	  taustar(i) = taustar(i) / maximum            
-	enddo                                          
-                                                            
-                                                            
-c end                                           
-	return                                         
-	end                                            
-                                                            
-                                                            
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
Index: unk/LMDZ.MARS/libf/phymars/mztf_correccion.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/mztf_correccion.F	(revision 497)
+++ 	(revision )
@@ -1,306 +1,0 @@
-c***********************************************************************
-                                                
-        subroutine mztf_correccion (coninf, con, ib, isot, icurt_pop)  
-                                                
-c including the dependence of the absort. coeff. on temp., vibr. temp., 
-c function, etc.., when neccessary. imr is already corrected in his.for 
-c we follow pg.39b-43a (l5):                    
-c  tvt1 is the vibr temp of the upper level     
-c  tvt  is the vibr temp of the transition itself           
-c  tvtbs is the vibr temp of the bending mode (used in qv)  
-c  for fundamental bands, they are not used at the moment.  
-c  for the 15 fh and sh bands, only tvt0 is used at the moment.         
-c  for the laser band, all of them are used following pg. 41a -l5- :    
-c    we need s(z) and we can read s(tk) from the histogram (also called 
-c    what we have to calculate now is the factor s(z)/s(tk) or following
-c    l5 notebook notation, s_nlte/s_lte.        
-c           s_nlte/s_lte = xfactor = xlower * xqv * xes     
-                                                
-c  icurt_pop = 30 -> Output of populations of the 0200,0220,1000 states
-c            = otro -> no output of these populations
-
-c       oct 92          malv                    
-c       jan 98		malv		version for mz1d          
-c       jul 2011        malv+fgg        adapted to LMD-MGCM
-c***********************************************************************
-                                                
-	implicit none                                  
-                                                
-        include 'nltedefs.h'   
-        include 'nlte_atm.h' 
-        include 'nlte_data.h'
-        include 'nlte_results.h'   
-	include 'nlte_curtis.h'        
-                                                
-c arguments                                     
-	integer		ib, isot                              
-	integer 	icurt_pop           ! output of Fermi states population
-	real*8		con(nzy), coninf                        
-                                                
-! local variables                               
-	integer 	i                                     
-        real*8	tvt0(nzy),tvt1(nzy),tvtbs(nzy), zld(nl),zyd(nzy) 	       
-	real	xalfa, xbeta, xtv1000, xtv0200, xtv0220, xfactor      
-	real	xqv, xnu_trans, xtv_trans, xes, xlower    
-c***********************************************************************
-                                  
-        xfactor = 1.0
-
-        do i=1,nzy
-          zyd(i) = dble(zy(i))
-        enddo
-	do i=1,nl                                      
-          zld(i) = dble( zl(i) )                
-        end do                                  
-                                                
-! tvtbs is the bending mode of the molecule. used in xqv.   
-	if (isot.eq.1) call interdp (tvtbs,zyd,nzy, v626t1,zld,nl, 1 )  
-	if (isot.eq.2) call interdp (tvtbs,zyd,nzy, v628t1,zld,nl, 1 )  
-	if (isot.eq.3) call interdp (tvtbs,zyd,nzy, v636t1,zld,nl, 1 )  
-	if (isot.eq.4) call interdp (tvtbs,zyd,nzy, v627t1,zld,nl, 1 )  
-	if (isot.eq.5) call interdp (tvtbs,zyd,nzy, vcot1,zld,nl, 1 )   
-
-! tvt0 is the lower level of the transition. used in xlower.            
-	if (ib.eq.2 .or. ib.eq.3 .or. ib.eq.4 .or. ib.eq.15) then  
-	  if (isot.eq.1) call interdp (tvt0,zyd,nzy, v626t1,zld,nl, 1 ) 
-	  if (isot.eq.2) call interdp (tvt0,zyd,nzy, v628t1,zld,nl, 1 ) 
-	  if (isot.eq.3) call interdp (tvt0,zyd,nzy, v636t1,zld,nl, 1 ) 
-	  if (isot.eq.4) call interdp (tvt0,zyd,nzy, v627t1,zld,nl, 1 ) 
-	elseif (ib.eq.6 .or. ib.eq.8 .or. ib.eq.10     
-     @	        .or. ib.eq.13 .or. ib.eq.14                  
-     @    	.or. ib.eq.17 .or. ib.eq.19 .or. ib.eq.20) then          
-	  if (isot.eq.1) call interdp ( tvt0,zyd,nzy, v626t2,zld,nl, 1 )
-	  if (isot.eq.2) call interdp ( tvt0,zyd,nzy, v628t2,zld,nl, 1 )
-	  if (isot.eq.3) call interdp ( tvt0,zyd,nzy, v636t2,zld,nl, 1 )
-	  if (isot.eq.4) then  
-		call interdp ( tvt0,zyd,nzy, v627t2,zld,nl, 1 )
-	  endif                                        
-	else                                           
-	  do i=1,nzy                                    
-	    tvt0(i) = dble( ty(i) )                    
-	  end do                                       
-	end if                                         
-                                                
-c tvt is the vt of the transition. used in xes. 
-c since xes=1.0 except for the laser bands, tvt is only needed for  them
-c but it is actually calculated from the tv of the upper and lower level
-c of the transition. hence, only tvt1 remains to be read for the laser b
-c tvt1 is the upper level of the transition.    
-	if (ib.eq.13 .or. ib.eq.14) then 
-	  if (isot.eq.1) call interdp ( tvt1,zyd,nzy, v626t4,zld,nl, 1 )
-	  if (isot.eq.2) call interdp ( tvt1,zyd,nzy, v628t4,zld,nl, 1 ) 
-	  if (isot.eq.3) call interdp ( tvt1,zyd,nzy, v636t4,zld,nl, 1 )
-	  if (isot.eq.4) call interdp ( tvt1,zyd,nzy, v627t4,zld,nl, 1 )
-	end if
-                                                
-c  here we weight the absorber amount by a factor which compensate the l
-c  value of the strength read from hitran. we use that factor in order t
-c  correct the product s*m when we later multiply those two variables.  
-                                                
-!        if ( isot.eq.1 .and. icurt_pop.eq.30 ) then 
-!           open (30, file='020populations.dat')
-!           write (30,*) ' z  tv(020) tv0200 tv0220 tv1000 '
-!        endif
-
-	do i=1,nzy                                      
-                                                
-	  if (isot.eq.1) then                  
-
-	    !!! vt of the 3 levels in (020)  (see pag. 36a-sn1 for this)       
-	    xalfa = 1.d0/2.d0* exp( dble(-ee*(nu12_1000-nu(1,2))/ty(i)) )      
-	    xbeta = 1.d0/2.d0* exp( dble(-ee*(nu12_0200-nu(1,2))/ty(i)) )      
-	    xtv0200 = dble( - ee * nu12_0200 ) /       
-     @        ( log( xbeta/(1.d0+xalfa+xbeta) ) - 
-     @                      dble(ee*nu(1,2))/tvt0(i) )    
-	    xtv0220 = dble( - ee * nu(1,2) ) /         
-     @        ( log( 1.d0/(1.d0+xalfa+xbeta) ) - 
-     @                      dble(ee*nu(1,2))/tvt0(i) )     
-	    xtv1000 = dble( - ee * nu12_1000 ) /       
-     @        ( log( xalfa/(1.d0+xalfa+xbeta) ) - 
-     @                      dble(ee*nu(1,2))/tvt0(i) )
-            !!! correccion 8-Nov-04 (see pag.9b-Marte4-)
-	    xtv0200 = dble( - ee * nu12_0200 /       
-     @       ( log(4.*xbeta/(1.d0+xalfa+xbeta)) - ee*nu(1,2)/tvt0(i) ) )    
-	    xtv0220 = dble( - ee * nu(1,2) /         
-     @        ( log(2./(1.d0+xalfa+xbeta)) - ee*nu(1,2)/tvt0(i) ) )     
-	    xtv1000 = dble( - ee * nu12_1000 /       
-     @       ( log(4.*xalfa/(1.d0+xalfa+xbeta)) - ee*nu(1,2)/tvt0(i) ) )
-
-!            if ( icurt_pop.eq.30 ) then 
-!               write (30,'( 1x,f7.2, 3x,f8.3, 2x,3(1x,f8.3) )')
-!     @           zx(i), tvt0(i), xtv0200, xtv0220, xtv1000 
-!            endif
-               
-	    !!! xlower and xes for the band            
-	    if (ib.eq.19) then                         
-	      xlower = exp( dble(ee*elow(isot,ib)) *   
-     @    			( 1.d0/dble(ty(i))-1.d0/xtv0200 ) )        
-	      xes = 1.0d0                              
-	    elseif (ib.eq.17) then                     
-	      xlower = exp( dble(ee*elow(isot,ib)) *   
-     @    			( 1.d0/dble(ty(i))-1.d0/xtv1000 ) )        
-	      xes = 1.0d0                              
-	    elseif (ib.eq.20) then                     
-	      xlower = exp( dble(ee*elow(isot,ib)) *   
-     @    			( 1.d0/dble(ty(i))-1.d0/xtv0220 ) )        
-	      xes = 1.0d0                              
-	    elseif (ib.eq.14) then                     
-	      xlower = exp( dble(ee*nu12_1000) *       
-     @    			( 1.d0/dble(ty(i))-1.d0/xtv1000 ) )        
-	      xnu_trans = dble( nu(1,4)-nu12_1000 )    
-	      xtv_trans = xnu_trans / dble(nu(1,4)/tvt1(i)-
-     @                      nu12_1000/xtv1000)  
-	      xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) /  
-     @    		(1.d0-exp( dble(-ee*xnu_trans/ty(i)) ))     
-	    elseif (ib.eq.13) then                     
-	      xlower = exp( dble(ee*nu12_0200) *       
-     @    			( 1.d0/dble(ty(i))-1.d0/xtv0200 ) )        
-	      xnu_trans = dble(nu(1,4)-nu12_0200)      
-	      xtv_trans = xnu_trans / dble(nu(1,4)/tvt1(i)-
-     @                      nu12_0200/xtv0200)  
-	      xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) /  
-     @    		(1.d0-exp( dble(-ee*xnu_trans/ty(i)) ))     
-	    else                                       
-	      xlower = exp( dble(ee*elow(isot,ib)) *   
-     @    			( 1.d0/dble(ty(i))-1.d0/tvt0(i) ) )        
-	      xes = 1.0d0                              
-	    end if                                     
-	    xqv = (1.d0-exp( dble(-ee*667.3801/tvtbs(i)) )) /      
-     @    	      (1.d0-exp( dble(-ee*667.3801/ty(i)) )) 
-	    xfactor = xlower * xqv**2.d0 * xes         
-	                                               
-	  elseif (isot.eq.2) then                      
-                                                
-	    xalfa = 1.d0/2.d0* exp( dble(-ee*(nu22_1000-nu(2,2))/
-     @                      ty(i)) )      
-	    xbeta = 1.d0/2.d0* exp( dble(-ee*(nu22_0200-nu(2,2))/
-     @                      ty(i)) )      
-	    xtv0200 = dble( - ee * nu22_0200 ) /       
-     @        ( log( xbeta/(1.d0+xalfa+xbeta) ) - dble(ee*nu(2,2))/
-     @                      tvt0(i) )    
-	    xtv1000 = dble( - ee * nu22_1000 ) /       
-     @        ( log( xalfa/(1.d0+xalfa+xbeta) ) - dble(ee*nu(2,2))/
-     @                      tvt0(i) )    
-                                                
-	    if (ib.eq.14) then                         
-	      xlower = exp( dble(ee*nu22_1000) *       
-     @    			( 1.d0/dble(ty(i))-1.d0/xtv1000 ) )        
-	      xnu_trans = dble(nu(2,4)-nu22_1000)      
-	      xtv_trans = xnu_trans / dble(nu(2,4)/tvt1(i)-nu22_1000/
-     @                      xtv1000)  
-	      xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) /  
-     @    		(1.d0-exp( dble(-ee*xnu_trans/ty(i)) ))     
-	    elseif (ib.eq.13) then                     
-	      xlower = exp( dble(ee*nu22_0200) *       
-     @    			( 1.d0/dble(ty(i))-1.d0/xtv0200 ) )        
-	      xnu_trans = dble( nu(2,4)-nu22_0200 )    
-	      xtv_trans = xnu_trans / dble(nu(2,4)/tvt1(i)-nu22_0200/
-     @                      xtv0200)  
-	      xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) /  
-     @    		(1.d0-exp( dble(-ee*xnu_trans/ty(i)) ))     
-	    else                                       
-	      xlower = exp( dble(ee*elow(isot,ib)) *   
-     @    			( 1.d0/dble(ty(i))-1.d0/tvt0(i) ) )        
-	      xes = 1.0d0                              
-	    end if                                     
-	    xqv = (1.d0-exp( dble(-ee*662.3734/tvtbs(i)) )) /      
-     @    	      (1.d0-exp( dble(-ee*662.3734/ty(i))  ))            
-	    xfactor = xlower * xqv**2.d0 * xes         
-                                                
-	  elseif (isot.eq.3) then                      
-                                                
-	    xalfa = 1.d0/2.d0* exp( dble(-ee*(nu32_1000-nu(3,2))/
-     @                      ty(i)) )      
-	    xbeta = 1.d0/2.d0* exp( dble(-ee*(nu32_0200-nu(3,2))/
-     @                      ty(i)) )      
-	    xtv0200 = dble( - ee * nu32_0200 ) /       
-     @        ( log( xbeta/(1.d0+xalfa+xbeta) ) - dble(ee*nu(3,2))/
-     @                      tvt0(i) )    
-	    xtv1000 = dble( - ee * nu32_1000 ) /       
-     @        ( log( xalfa/(1.d0+xalfa+xbeta) ) - dble(ee*nu(3,2))/
-     @                      tvt0(i) )    
-                                                
-	    if (ib.eq.14) then                         
-	      xlower = exp( dble(ee*nu32_1000) *       
-     @    			( 1.d0/dble(ty(i))-1.d0/xtv1000 ) )        
-	      xnu_trans = dble( nu(3,4)-nu32_1000 )    
-	      xtv_trans = xnu_trans / dble(nu(3,4)/tvt1(i)-nu32_1000/
-     @                      xtv1000)  
-	      xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) /  
-     @    		(1.d0-exp( dble(-ee*xnu_trans/ty(i)) ))     
-	    elseif (ib.eq.13) then                     
-	      xlower = exp( dble(ee*nu32_0200) *       
-     @    			( 1.d0/dble(ty(i))-1.d0/xtv0200 ) )        
-	      xnu_trans = dble( nu(3,4)-nu32_0200 )    
-	      xtv_trans = xnu_trans / dble(nu(3,4)/tvt1(i)-nu32_0200/
-     @                      xtv0200)  
-	      xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) /  
-     @    		(1.d0-exp( dble(-ee*xnu_trans/ty(i)) ))     
-	    else                                       
-	      xlower = exp( dble(ee*elow(isot,ib)) *   
-     @    			( 1.d0/dble(ty(i))-1.d0/tvt0(i) ) )        
-	      xes = 1.0d0                              
-	    end if                                     
-	    xqv = (1.d0-exp( dble(-ee*648.4784/tvtbs(i)) )) /      
-     @    	      (1.d0-exp( dble(-ee*648.4784/ty(i))  ))            
-	    xfactor = xlower * xqv**2.d0 * xes         
-                                                
-	  elseif (isot.eq.4) then                      
-                                                
-	    xalfa = 1.d0/2.d0* exp( dble(-ee*(nu42_1000-nu(4,2))/
-     @                      ty(i)) )      
-	    xbeta = 1.d0/2.d0* exp( dble(-ee*(nu42_0200-nu(4,2))/
-     @                      ty(i)) )      
-	    xtv0200 = dble( - ee * nu42_0200 ) /       
-     @        ( log( xbeta/(1.d0+xalfa+xbeta) ) - dble(ee*nu(4,2))/
-     @                      tvt0(i) )    
-	    xtv1000 = dble( - ee * nu42_1000 ) /       
-     @        ( log( xalfa/(1.d0+xalfa+xbeta) ) - dble(ee*nu(4,2))/
-     @                      tvt0(i) )    
-                                                
-	    if (ib.eq.14) then                         
-	      xlower = exp( dble(ee*nu42_1000) *       
-     @    			( 1.d0/dble(ty(i))-1.d0/xtv1000 ) )        
-	      xnu_trans = dble( nu(4,4)-nu42_1000 )    
-	      xtv_trans = xnu_trans / dble(nu(4,4)/tvt1(i)-nu42_1000/
-     @                      xtv1000)  
-	      xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) /  
-     @    		(1.d0-exp( dble(-ee*xnu_trans/ty(i)) ))     
-	    elseif (ib.eq.13) then                     
-	      xlower = exp( dble(ee*nu42_0200) *       
-     $  ( 1.d0/dble(ty(i))-1.d0/xtv0200 ) )     
-	      xnu_trans = dble( nu(4,4)-nu42_0200 )    
-	      xtv_trans = xnu_trans / dble(nu(4,4)/tvt1(i)-nu42_0200/
-     @                      xtv0200)  
-	      xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) /  
-     @    		(1.d0-exp( dble(-ee*xnu_trans/ty(i)) ))     
-	    else                                       
-	      xlower = exp( dble(ee*elow(isot,ib)) *   
-     @    			( 1.d0/dble(ty(i))-1.d0/tvt0(i) ) )        
-	      xes = 1.0d0                              
-	    end if                                     
-	    xqv = (1.d0-exp( dble(-ee*664.7289/tvtbs(i)) )) /      
-     @    	      (1.d0-exp( dble(-ee*664.7289/ty(i))  ))            
-	    xfactor = xlower * xqv**2.d0 * xes         
-                                                
-	  elseif (isot.eq.5 .and. ib.eq.1) then        
-		                                              
-	    xlower = 1.d0                              
-	    xes = 1.0d0                                
-	    xqv = (1.d0-exp( dble(-ee*nuco_10/tvtbs(i)) )) /          
-     @    	      (1.d0-exp( dble(-ee*nuco_10/ty(i))  ))    
-	    xfactor = xlower * xqv * xes         
-                                                
-	  end if                                       
-                                                
-	  con(i) = con(i) * xfactor                    
-	  if (i.eq.nzy) coninf = coninf * xfactor       
-                                                
-	end do                                         
-                    
-!        if ( isot.eq.1 .and. icurt_pop.eq.30 ) then 
-!           close (30)
-!        endif
-                            
-	return                                         
-	end                                            
Index: unk/LMDZ.MARS/libf/phymars/mztf_overlap.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/mztf_overlap.F	(revision 497)
+++ 	(revision )
@@ -1,774 +1,0 @@
-c***********************************************************************
-c	mztf.f                                        
-c***********************************************************************
-c                       
-c	program  for calculating atmospheric transmittances       
-c	to be used in the calculation of curtis matrix coefficients           
-            
-	subroutine mztf ( ig,cf,cfup,cfdw,vc,taugr, ib,isot,          
-     @  	iirw,iimu,itauout,icfout,itableout )   
-            
-c	i*out = 1	output of data          
-c	i*out = 0	no output   
-c
-c       jul 2011        malv+fgg adapted to LMD-MGCM           
-c       nov 98          mavl    allow for overlaping in the lorentz line
-c	jan 98		malv	version for mz1d. based on curtis/mztf.for   
-c       17-jul-96	mlp&crs	change the calculation of mr.     
-c				evitar: divide por cero. anhadiendo: ff    
-c	oct-92		malv 	correct s(t) dependence for all histogr bands           
-c	june-92		malv	proper lower levels for laser bands         
-c	may-92		malv 	new temperature dependence for laser bands  
-c     @    991 		malv 	boxing for the averaged absorber amount and t            
-c	 ?		malv	extension up to 200 km altitude in mars          
-c       13-nov-86	mlp	include the temperature weighted to match         
-c				the eqw in the strong doppler limit.       
-c***********************************************************************
-            
-	implicit none      
-            
-	include 'nltedefs.h'          
-	include 'nlte_atm.h'        
-	include 'nlte_data.h'       
-	include 'nlte_curtis.h'        
-        include 'tcr_15um.h'
-	include 'nlte_results.h'  
-            
-            
-c arguments             
-        integer         ig   !ADDED FOR TRACEBACK
-	real*8  	cf(nl,nl), cfup(nl,nl), cfdw(nl,nl)	! o.          
-	real*8		vc(nl),  taugr(nl)		        ! o        
-	integer		ib					! i    
-	integer		isot					! i  
-	integer		iirw					! i  
-	integer		iimu					! i  
-	integer		itauout					! i           
-	integer		icfout					! i            
-	integer		itableout				! i          
-            
-c local variables and constants     
-	integer 	i, in, ir, im, k ,j         
-	integer 	nmu           
- 	parameter 	(nmu = 8)  
-	real*8 		tau(nl,nl)    
-	real*8 		tauinf(nl)    
-	real*8 		con(nzy), coninf           
-	real*8 		c1, c2        
-	real*8 		t1, t2        
-	real*8 		p1, p2        
-	real*8		mr1, mr2       
-	real*8 		st1, st2      
-	real*8 		c1box(70), c2box(70)      
-	real*8		ff		! to avoid too small numbers      
-	real*8		tvtbs(nzy)      
-	real*8 		st, beta, ts, eqwmu       
-	real*8 		mu(nmu), amu(nmu)         
-	real*8  	zld(nl), zyd(nzy)      
-	real*8 		correc        
-	real 		deltanux	! width of vib-rot band (cm-1) 
-!	character	isotcode*2
-        integer         idummy
-        real*8          Desp,wsL
-       
-c formats   
-! 111	format(a1)         
-! 112	format(a2)         
- 101	format(i1)         
- 202	format(i2)         
-! 180	format(a80)        
-! 181	format(a80)        
-c***********************************************************************
-            
-c some needed values    
-!	rl=sqrt(log(2.d0))     
-!	pi2 = 3.14159265358989d0           
-	beta = 1.8d0           
-        idummy = 0
-        Desp = 0.d0
-        wsL = 0.d0
-
-c  esto es para que las subroutines de mztfsub calculen we  
-c  de la forma apropiada para mztf, no para fot 
-	icls=icls_mztf         
-            
-c codigos para filenames            
-!	if (isot .eq. 1)  isotcode = '26'  
-!	if (isot .eq. 2)  isotcode = '28'  
-!	if (isot .eq. 3)  isotcode = '36'  
-!	if (isot .eq. 4)  isotcode = '27'  
-!	if (isot .eq. 5)  isotcode = '62'  
-!	if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5     
-!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
-!		write (ibcode1,101) ib           
-!	else       
-!		write (ibcode2,202) ib           
-!	endif      
-!	write (*,'( 30h calculating curtis matrix :  ,2x,         
-!     @    	8h band = ,i2,2x, 11h isotope = ,i2)') ib, isot         
-            
-c integration in angle !!!!!!!!!!!!!!!!!!!!     
-            
-c------- diffusivity approx.        
-	if (iimu.eq.1) then    
-!	  write (*,*)  ' diffusivity approx. beta = ',beta 
-	  mu(1) = 1.0d0        
-	  amu(1)= 1.0d0        
-c-------data for 8 points integration           
-	elseif (iimu.eq.4) then            
-	  write (*,*)' 4 points for the gauss-legendre angle quadrature.'
-	  mu(1)=(1.0d0+0.339981043584856)/2.0d0 	      
-	  mu(2)=(1.0d0-0.339981043584856)/2.0d0 	      
-	  mu(3)=(1.0d0+0.861136311594053)/2.0d0        
-	  mu(4)=(1.0d0-0.861136311594053)/2.0d0 	      
-	  amu(1)=0.652145154862546 	       
-	  amu(2)=amu(1) 	      
-	  amu(3)=0.347854845137454 	       
-	  amu(4)=amu(3)        
-	  beta=1.0d0           
-c-------data for 8 points integration           
-	elseif(iimu.eq.8) then             
-	  write (*,*)' 8 points for the gauss-legendre angle quadrature.'
-	  mu(1)=(1.0d0+0.183434642495650)/2.0d0        
-	  mu(2)=(1.0d0-0.183434642495650)/2.0d0        
-	  mu(3)=(1.0d0+0.525532409916329)/2.0d0        
-	  mu(4)=(1.0d0-0.525532409916329)/2.0d0        
-	  mu(5)=(1.0d0+0.796666477413627)/2.0d0        
-	  mu(6)=(1.0d0-0.796666477413627)/2.0d0        
-	  mu(7)=(1.0d0+0.960289856497536)/2.0d0        
-	  mu(8)=(1.0d0-0.960289856497536)/2.0d0        
-	  amu(1)=0.362683783378362         
-	  amu(2)=amu(1)        
-	  amu(3)=0.313706645877887         
-	  amu(4)=amu(3)        
-	  amu(5)=0.222381034453374         
-	  amu(6)=amu(5)        
-	  amu(7)=0.101228536290376         
-	  amu(8)=amu(7)        
-	  beta=1.0d0           
-	end if     
-c!!!!!!!!!!!!!!!!!!!!!!!            
-            
-ccc         
-ccc  determine abundances included in the absorber amount   
-ccc         
-            
-c first, set up the grid ready for interpolation.           
-	do i=1,nzy              
-	  zyd(i) = dble(zy(i))             
-	enddo      
-	do i=1,nl              
-	  zld(i) = dble(zl(i))             
-	enddo      
-            
-            
-c 2nd: correccion a la n10(i) (cantidad de absorbente en el lower state)
-c por similitud a la que se hace en cza.for     
-            
-	do i=1,nzy              
-	  if (isot.eq.5) then  
-	    con(i) = dble( coy(i) * imrco )            
-	  else     
-	    con(i) =  dble( co2y(i) * imr(isot) )      
-c vibr. temp of the bending mode :  
-        if (isot.eq.1) call interdp ( tvtbs,zyd,nzy, v626t1,zld,nl, 1 )  
-        if (isot.eq.2) call interdp ( tvtbs,zyd,nzy, v628t1,zld,nl, 1 )  
-        if (isot.eq.3) call interdp ( tvtbs,zyd,nzy, v636t1,zld,nl, 1 )  
-        if (isot.eq.4) call interdp ( tvtbs,zyd,nzy, v627t1,zld,nl, 1 )  
-	    correc = 2.d0 * dexp( dble(-ee*elow(isot,2))/tvtbs(i) )            
-	    con(i) = con(i) * ( 1.d0 - correc )        
-	  endif    
-c-----------------------------------------------------------------------
-c mlp & cristina. 17 july 1996      
-c change the calculation of mr. it is used for calculating partial press
-c alpha = alpha(self,co2)*pp +alpha(n2)*(pt-pp) 
-c for an isotope, if mr is obtained by co2*imr(iso)/nt we are considerin
-c collisions with other co2 isotopes (including the major one, 626)     
-c as if they were with n2. assuming mr as co2/nt, we consider collisions
-c of type 628-626 as of 626-626 instead of as 626-n2.       
-c	  mrx(i)=con(i)/ntx(i) ! old malv 
-            
-!	  mrx(i)= dble(co2x(i)/ntx(i))	! mlp & crs    
-            
-c jan 98:   
-c esta modif de mlp implica anular el correc (deberia revisar esto)     
-	  mr(i) = dble(co2y(i)/nty(i))	! malv, jan 98  
-            
-c-----------------------------------------------------------------------
-            
-	end do     
-            
-! como  beta y 1.d5 son comunes a todas las weighted absorber amounts,  
-! los simplificamos:    
-!	coninf = beta * 1.d5 * dble( con(n) / log( con(n-1) / con(n) ) )      
-	coninf = dble( con(nzy) / log( con(nzy-1) / con(nzy) ) )      
-            
-!	write (*,*)  ' coninf =', coninf       
-            
-ccc         
-ccc  temp dependence of the band strength and   
-ccc  nlte correction factor for the absorber amount         
-ccc         
-	call mztf_correccion ( coninf, con, ib, isot, itableout ) 
-            
-ccc         
-ccc reads histogrammed spectral data (strength for lte and vmr=1)       
-ccc         
-	!hfile1 = dirspec//'hi'//dn   ! ya no distinguimos entre d/n     
-!!	hfile1 = dirspec//'hid'       ! (see why in his.for)
-!        hfile='hid'
-!!	if (ib.eq.13 .or. ib.eq.14 ) hfile1 = dirspec//'his'
-!        if (ib.eq.13 .or. ib.eq.14 ) hfile1 = 'his'
-!            
-!	if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5     
-!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
-!	   if (isot.eq.1) hisfile = hfile1//'26-'//ibcode1//'.dat' 
-!	   if (isot.eq.2) hisfile = hfile1//'28-'//ibcode1//'.dat' 
-!	   if (isot.eq.3) hisfile = hfile1//'36-'//ibcode1//'.dat' 
-!	   if (isot.eq.4) hisfile = hfile1//'27-'//ibcode1//'.dat' 
-!	   if (isot.eq.5) hisfile = hfile1//'62-'//ibcode1//'.dat' 
-!	else       
-!	   if (isot.eq.1) hisfile = hfile1//'26-'//ibcode2//'.dat' 
-!	   if (isot.eq.2) hisfile = hfile1//'28-'//ibcode2//'.dat' 
-!	   if (isot.eq.3) hisfile = hfile1//'36-'//ibcode2//'.dat' 
-!	   if (isot.eq.4) hisfile = hfile1//'27-'//ibcode2//'.dat' 
-!	   if (isot.eq.5) hisfile = hfile1//'62-'//ibcode2//'.dat' 
-!	endif      
-!	write (*,*) 'hisfile: ', hisfile       
-            
-! the argument to rhist is to make this compatible with mztf_comp.f,    
-! which is a useful modification of mztf.f (to change strengths of bands
-!	call rhist (1.0)       
-        if(ib.eq.1) then
-	   if(isot.eq.1) then !Case 1
-	      mm=mm_c1
-	      nbox=nbox_c1
-	      tmin=tmin_c1
-	      tmax=tmax_c1
-	      do i=1,nbox_max
-		 no(i)=no_c1(i)
-		 dist(i)=dist_c1(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c1(j,i)
-		    xls1(j,i)=xls1_c1(j,i)
-		    xln1(j,i)=xln1_c1(j,i)
-		    xld1(j,i)=xld1_c1(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c1(j)
-	      enddo
-	   else if(isot.eq.2) then !Case 2
-	      mm=mm_c2
-	      nbox=nbox_c2
-	      tmin=tmin_c2
-	      tmax=tmax_c2
-	      do i=1,nbox_max
-		 no(i)=no_c2(i)
-		 dist(i)=dist_c2(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c2(j,i)
-		    xls1(j,i)=xls1_c2(j,i)
-		    xln1(j,i)=xln1_c2(j,i)
-		    xld1(j,i)=xld1_c2(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c2(j)
-	      enddo
-	   else if(isot.eq.3) then !Case 3
-	      mm=mm_c3
-	      nbox=nbox_c3
-	      tmin=tmin_c3
-	      tmax=tmax_c3
-	      do i=1,nbox_max
-		 no(i)=no_c3(i)
-		 dist(i)=dist_c3(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c3(j,i)
-		    xls1(j,i)=xls1_c3(j,i)
-		    xln1(j,i)=xln1_c3(j,i)
-		    xld1(j,i)=xld1_c3(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c3(j)
-	      enddo
-	   else if(isot.eq.4) then !Case 4
-	      mm=mm_c4
-	      nbox=nbox_c4
-	      tmin=tmin_c4
-	      tmax=tmax_c4
-	      do i=1,nbox_max
-		 no(i)=no_c4(i)
-		 dist(i)=dist_c4(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c4(j,i)
-		    xls1(j,i)=xls1_c4(j,i)
-		    xln1(j,i)=xln1_c4(j,i)
-		    xld1(j,i)=xld1_c4(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c4(j)
-	      enddo
-	   else
-	      write(*,*)'isot must be 2,3 or 4 for ib=1!!'
-	      write(*,*)'stop at mztf_overlap/317'
-	      stop
-	   endif
-	else if (ib.eq.2) then
-	   if(isot.eq.1) then	!Case 5
-	      mm=mm_c5
-	      nbox=nbox_c5
-	      tmin=tmin_c5
-	      tmax=tmax_c5
-	      do i=1,nbox_max
-		 no(i)=no_c5(i)
-		 dist(i)=dist_c5(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c5(j,i)
-		    xls1(j,i)=xls1_c5(j,i)
-		    xln1(j,i)=xln1_c5(j,i)
-		    xld1(j,i)=xld1_c5(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c5(j)
-	      enddo
-	   else
-	      write(*,*)'isot must be 1 for ib=2!!'
-	      write(*,*)'stop at mztf_overlap/341'
-	      stop
-	   endif
-	else if (ib.eq.3) then
-	   if(isot.eq.1) then	!Case 6
-	      mm=mm_c6
-	      nbox=nbox_c6
-	      tmin=tmin_c6
-	      tmax=tmax_c6
-	      do i=1,nbox_max
-		 no(i)=no_c6(i)
-		 dist(i)=dist_c6(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c6(j,i)
-		    xls1(j,i)=xls1_c6(j,i)
-		    xln1(j,i)=xln1_c6(j,i)
-		    xld1(j,i)=xld1_c6(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c6(j)
-	      enddo
-	   else
-	      write(*,*)'isot must be 1 for ib=3!!'
-	      write(*,*)'stop at mztf_overlap/365'
-	      stop
-	   endif
-	else if (ib.eq.4) then
-	   if(isot.eq.1) then	!Case 7
-	      mm=mm_c7
-	      nbox=nbox_c7
-	      tmin=tmin_c7
-	      tmax=tmax_c7
-	      do i=1,nbox_max
-		 no(i)=no_c7(i)
-		 dist(i)=dist_c7(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c7(j,i)
-		    xls1(j,i)=xls1_c7(j,i)
-		    xln1(j,i)=xln1_c7(j,i)
-		    xld1(j,i)=xld1_c7(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c7(j)
-	      enddo
-	   else
-	      write(*,*)'isot must be 1 for ib=4!!'
-	      write(*,*)'stop at mztf_overlap/389'
-	      stop
-	   endif
-	else 
-	   write(*,*)'ib must be 1,2,3 or 4!!'
-	   write(*,*)'stop at mztf_overlap/394'
-	endif
-            
-	if (isot.ne.5) deltanux = deltanu(isot,ib)     
-	if (isot.eq.5) deltanux = deltanuco            
-            
-c******     
-c****** calculation of tauinf(nl)   
-c******     
-	call initial           
-            
-	ff=1.0e10              
-            
-	do i=nl,1,-1           
-            
-	  if(i.eq.nl)then      
-            
-		call intz (zl(i),c2,p2,mr2,t2, con)           
-		do kr=1,nbox          
-		 ta(kr)=t2            
-	  	end do              
-!	write (*,*)  ' i, t2 =', i, t2         
-		call interstrength (st2,t2,ka,ta) 
-		aa = p2 * coninf * mr2 * (st2 * ff)           
-		bb = p2 * coninf * st2            
-		cc = coninf * st2     
-		dd = t2 * coninf * st2            
-		do kr=1,nbox          
-	          ccbox(kr) = coninf * ka(kr)          
-		  ddbox(kr) = t2 * ccbox(kr)      
-!		  c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5   
-		  c2box(kr) = c2 * ka(kr) * dble(deltaz)      
-		end do    
-!		c2 = c2 * st2 * beta * dble(deltaz) * 1.d5   
-		c2 = c2 * st2 * dble(deltaz)      
-            
-	  else     
-		call intz (zl(i),c1,p1,mr1,t1, con)           
-		do kr=1,nbox          
-		 ta(kr)=t1            
-	  	end do              
-!	write (*,*)  ' i, t1 =', i, t1         
-		call interstrength (st1,t1,ka,ta) 
-		do kr=1,nbox          
-!		  c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5   
-		  c1box(kr) = c1 * ka(kr) * dble(deltaz)      
-		end do    
-!		c1 = c1 * st1 * beta * dble(deltaz) * 1.d5   
-		c1 = c1 * st1 * dble(deltaz)      
-		aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0       
-		bb = bb + ( p1*c1 + p2*c2 ) / 2.d0            
-		cc = cc + ( c1 + c2 ) / 2.d0      
-		dd = dd + ( t1*c1 + t2*c2 ) / 2.d0            
-		do kr=1,nbox          
-	          ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) )/2.d0       
-		  ddbox(kr) = ddbox(kr) + ( t1*c1box(kr)+t2*c2box(kr) )/2.d0          
-		end do    
-            
-		mr2 = mr1             
-		c2=c1     
-		do kr=1,nbox	         
-		  c2box(kr) = c1box(kr)           
-		end do    
-		t2=t1     
-		p2=p1     
-	  end if   
-            
-	  pt = bb / cc         
-	  pp = aa / (cc*ff)    
-            
-!	  ta=dd/cc            
-!	  tdop = ta           
-	  ts = dd/cc           
-          do kr=1,nbox  
-   	    ta(kr) = ddbox(kr) / ccbox(kr)          
-	  end do   
-!	write (*,*)  ' i, ts =', i, ts         
-	  call interstrength(st,ts,ka,ta)  
-!	  call intershape(alsa,alna,alda,tdop)        
-	  call intershape(alsa,alna,alda,ta)           
-            
-*	  ua = cc/st          
-            
-c  	next loop calculates the eqw for an especified path ua,pp,pt,ta     
-            
-	  eqwmu = 0.0d0        
-	  do im = 1,iimu       
-	    eqw=0.0d0          
-            do  kr=1,nbox           
-		ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im)  
-                if(ua(kr).lt.0.)write(*,*)'mztf_overlap/483',ua(kr),
-     $               ccbox(kr),ka(kr),beta,mu(im),kr,im,i,nl
-
-	        call findw(ig,iirw, idummy,c1,p1,Desp,wsL)           
-		if ( i_supersat .eq. 0 ) then     
-	          eqw=eqw+no(kr)*w         
-		else      
-		   eqw = w + (no(kr)-1) * ( asat_box*dist(kr) )           
-		endif     
-	    end do             
-	    eqwmu = eqwmu + eqw * mu(im)*amu(im)       
-	  end do   
-            
- 	  tauinf(i) = exp( - eqwmu / dble(deltanux) ) 
-            
-	end do  ! i continue   
-            
-!	if ( isot.eq.1 .and. ib.eq.2 ) then           
-!		write (*,*)  ' tauinf(nl) = ', tauinf(nl)         
-!		write (*,*)  ' tauinf(1) = ', tauinf(1)           
-!	endif     
-            
-c******     
-c****** calculation of tau(in,ir) for n<=r      
-c******     
-            
-	do 1 in=1,nl-1         
-            
- 	call initial          
-	call intz (zl(in), c1,p1,mr1,t1, con)          
-	do kr=1,nbox           
-	  ta(kr) = t1          
-	end do     
-	call interstrength (st1,t1,ka,ta)  
-	do kr=1,nbox           
-!	  c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5    
-	  c1box(kr) = c1 * ka(kr) * dble(deltaz)       
-	end do     
-!	c1 = c1 * st1 * beta * dble(deltaz) * 1.d5    
-	c1 = c1 * st1 * dble(deltaz)       
-            
-	do 2 ir=in,nl-1        
-            
-	if (ir.eq.in) then     
-	  tau(in,ir) = 1.d0    
-	  goto 2   
-	end if     
-            
-	call intz (zl(ir), c2,p2,mr2,t2, con)          
-	do kr=1,nbox           
-	  ta(kr) = t2          
-	end do     
-	call interstrength (st2,t2,ka,ta)  
-	do kr=1,nbox           
-!	  c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5    
-	  c2box(kr) = c2 * ka(kr) * dble(deltaz)       
-	end do     
-!	c2 = c2 * st2 * beta * dble(deltaz) * 1.e5    
-	c2 = c2 * st2 * dble(deltaz)       
-            
-c	aa = aa + ( p1*mr1*c1 + p2*mr2*c2 ) / 2.d0    
-	aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0        
-	bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 
-	cc = cc + ( c1 + c2 ) / 2.d0       
-	dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 
-	do kr=1,nbox           
-	  ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) ) /2.d0  
-	  ddbox(kr) = ddbox(kr) + ( t1*c1box(kr) + t2*c2box(kr) ) /2.d0        
-	end do     
-            
-	mr1=mr2    
-	t1=t2      
-	c1=c2      
-	p1=p2      
-	do kr=1,nbox	          
-	  c1box(kr) = c2box(kr)            
-	end do     
-            
-	pt = bb / cc           
-	pp = aa / (cc * ff)    
-            
-*	ta=dd/cc              
-*	tdop = ta             
-	ts = dd/cc             
-        do kr=1,nbox    
-   	    ta(kr) = ddbox(kr) / ccbox(kr)          
-	end do     
-	call interstrength(st,ts,ka,ta)    
-	call intershape(alsa,alna,alda,ta) 
-*	ua = cc/st            
-            
-c  	next loop calculates the eqw for an especified path ua,pp,pt,ta     
-            
-	eqwmu = 0.0d0          
-	do im = 1,iimu         
-	  eqw=0.0d0            
-          do kr=1,nbox  
-		ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im)       
-                if(ua(kr).lt.0.)write(*,*)'mztf_overlap/581',ua(kr),
-     $               ccbox(kr),ka(kr),beta,mu(im),kr,im,i,nl
-
-	        call findw(ig,iirw, idummy,c1,p1,Desp,wsL)           
-		if ( i_supersat .eq. 0 ) then     
-	          eqw=eqw+no(kr)*w         
-		else      
-		   eqw = w + (no(kr)-1) * ( asat_box*dist(kr) )           
-		endif     
-	  end do   
-	  eqwmu = eqwmu + eqw * mu(im)*amu(im)         
-	end do     
-            
- 	tau(in,ir) = exp( - eqwmu / dble(deltanux) )  
-            
- 2	continue             
-            
- 1	continue             
-            
-!	if ( isot.eq.1 .and. ib.eq.2 ) then           
-!		write (*,*)  ' tau(1,*) , *=1,20 '    
-!		write (*,*)  ( sngl(tau(1,k)), k=1,20 )           
-!	endif     
-            
-            
-c**********             
-c**********  calculation of tau(in,ir) for n>r  
-c**********             
-            
-	in=nl      
-            
-	call initial           
-	call intz (zl(in), c1,p1,mr1,t1, con)          
-	do kr=1,nbox           
-	  ta(kr) = t1          
-	end do     
-	call interstrength (st1,t1,ka,ta)  
-	do kr=1,nbox           
-!	  c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5    
-	  c1box(kr) = c1 * ka(kr) * dble(deltaz)       
-	end do     
-!	c1 = c1 * st1 * beta * dble(deltaz) * 1.d5    
-	c1 = c1 * st1 * dble(deltaz)       
-            
-	do 4 ir=in-1,1,-1      
-            
-	call intz (zl(ir), c2,p2,mr2,t2, con)          
-	do kr=1,nbox           
-	  ta(kr) = t2          
-	end do     
-	call interstrength (st2,t2,ka,ta)  
-	do kr=1,nbox           
-!	  c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5    
-	  c2box(kr) = c2 * ka(kr) * dble(deltaz)       
-	end do     
-!	c2 = c2 * st2 * beta * dble(deltaz) * 1.d5    
-	c2 = c2 * st2 * dble(deltaz)       
-            
-	aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0        
-	bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 
-	cc = cc + ( c1 + c2 ) / 2.d0       
-	dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 
-	do kr=1,nbox           
-	  ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) ) /2.d0  
-	  ddbox(kr) = ddbox(kr) + ( t1*c1box(kr) + t2*c2box(kr) ) /2.d0        
-	end do     
-            
-	mr1=mr2    
-	c1=c2      
-	t1=t2      
-	p1=p2      
-	do kr=1,nbox           
-	  c1box(kr) = c2box(kr)            
-	end do     
-            
-	pt = bb / cc           
-	pp = aa / (cc * ff)    
-	ts = dd / cc           
-	do kr=1,nbox           
-	  ta(kr) = ddbox(kr) / ccbox(kr)   
-	end do     
-	call interstrength (st,ts,ka,ta)   
-	call intershape (alsa,alna,alda,ta)            
-            
-*	ua = cc/st            
-            
-c  	next loop calculates the eqw for an especified path ua,pp,pt,ta     
-            
-	eqwmu = 0.0d0          
-	do im = 1,iimu         
-	  eqw=0.0d0            
-          do kr=1,nbox  
-		ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im)
-                if(ua(kr).lt.0.)write(*,*)'mztf_overlap/674',ua(kr),
-     $               ccbox(kr),ka(kr),beta,mu(im),kr,im,i,nl
-
-	        call findw(ig,iirw, idummy,c1,p1,Desp,wsL)           
-		if ( i_supersat .eq. 0 ) then     
-	          eqw=eqw+no(kr)*w         
-		else      
-		   eqw = w + (no(kr)-1) * ( asat_box*dist(kr) )           
-		endif     
-	  end do   
-	  eqwmu = eqwmu + eqw * mu(im)*amu(im)         
-	end do     
-            
- 	tau(in,ir) = exp( - eqwmu / dble(deltanux) )  
-            
- 4	continue             
-            
-c           
-c due to the simmetry of the transmittances     
-c           
- 	do in=nl-1,2,-1       
-	  do ir=in-1,1,-1      
-		tau(in,ir) = tau(ir,in)           
-	  end do   
-	end do     
-            
-            
-ccc         
-ccc  writing out transmittances     
-ccc         
-	if (itauout.eq.1) then             
-            
-!	        if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5         
-!     @    	 .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then     
-!  	         open( 1, file=          
-!     @    	   dircurtis//'taul'//isotcode//dn//ibcode1//'.dat',     
-!     @    	   access='sequential', form='unformatted' ) 
-!	        else           
-!  	         open( 1, file=          
-!     @    	   dircurtis//'taul'//isotcode//dn//ibcode2//'.dat',     
-!     @    	   access='sequential', form='unformatted' ) 
-!	        endif          
-            
-!		write(1) dummy        
-!		write(1)' format: (tauinf(n),(tau(n,r),r=1,nl),n=1,nl)'   
-!		do in=1,nl            
-!		    write (1) tauinf(in), ( tau(in,ir), ir=1,nl )         
-!		end do    
-!		close(unit=1)         
-            
-	elseif (itauout.eq.2) then         
-  	         
-!	   if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5  
-!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then	     
-!	     open( 1, file=    
-!     @        dircurtis//'taul'//isotcode//dn//ibcode1//'.dat')     
-!	   else    
-!	     open( 1, file=    
-!     @        dircurtis//'taul'//isotcode//dn//ibcode2//'.dat')     
-!	   endif   
-            
-!		!write(1,*) dummy     
-!		!write(1,*) 'tij for curtis matrix calculations '         
-!		!write(1,*)' cira mars model atmosphere '     
-!		write(1,*)' beta= ',beta,'deltanu= ',deltanux 
-!		write(1,*)' number of elements (in,ir)= ',nl,nl           
-!		write(1,*)' format: (tauinf(in),(tau(in,ir),ir=1,nl),in=1,nl)'
-	           
-!		do in=1,nl            
-!		    write (1,*) tauinf(in)        
-!		    do ir=1,nl        
-!			write(1,*) tau(in,ir)            
-!		    end do            
-!		end do    
-!		close(unit=1)         
-            
-!	   if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5  
-!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
-!	      write (*,'(1x, 31htransmitances written out in: ,a22)')          
-!     @    	'taul'//isotcode//dn//ibcode1    
-!	   else    
-!	      write (*,'(1x, 31htransmitances written out in: ,a22)')          
-!     @    	'taul'//isotcode//dn//ibcode2    
-!	   endif   
-            
-	end if     
-            
-c cleaning of transmittances        
-!	call elimin_tau(tau,tauinf,nl,nan,itableout,nw,dummy,     
-!     @    					isotcode,dn,ibcode2)        
-            
-c construction of the curtis matrix 
-            
-	call mzcf ( tauinf,tau, cf,cfup,cfdw, vc,taugr,            
-     @   	ib,isot,icfout,itableout )            
-            
-            
-c end       
-	return     
-	end        
Index: unk/LMDZ.MARS/libf/phymars/mztfsub_overlap.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/mztfsub_overlap.F	(revision 497)
+++ 	(revision )
@@ -1,947 +1,0 @@
-c***********************************************************************
-c	File with all subroutines required by mztf      
-c                                               
-c 	jan 98	malv 		basado en mztfsub_solar        
-c       jul 2011 malv+fgg   adapted to LMD-MGCM
-c                                               
-c contiene:                                     
-c       initial                                 
-c       intershape                              
-c       interstrength                           
-c       intz                                    
-c       rhist                                   
-c       interh                                  
-c       we                                      
-c       simrul                                 
-c       fi                                      
-c       f                                       
-c       findw                                   
-c       voigtf                                  
-c***********************************************************************
-                                                
-c       ****************************************************************
-	subroutine initial                             
-                                                
-c	ma & crs	!evita troubles 16-july-96           
-c       ****************************************************************
-                                                
-	implicit none                                  
-                                                
-	include 'nltedefs.h'          
-	include 'nlte_curtis.h'        
-                                                
-c local variables                               
-	integer 	i                                     
-                                                
-c	***************                               
-                                                
-	eqw = 0.0d00                                   
-	aa = 0.0d00                                    
-	bb = 0.0d00                                    
-	cc = 0.0d00                                    
-	dd = 0.0d00                                    
-                                                
-	do i=1,nbox                                    
-	  ua(i) = 0.0d0                                
-	  ccbox(i) = 0.0d0                             
-	  ddbox(i) = 0.0d0                             
-	end do                                         
-                                                
-	return                                         
-	end                                            
-                                                
-c	**********************************************************************
-	subroutine intershape(alsx,alnx,adx,xtemp)     
-c	interpolates the line shape parameters at a temperature xtemp from    
-c	input histogram data.                         
-c	**********************************************************************
-                                                
-	implicit none                                  
-                                                
-	include 'nltedefs.h'          
-	include 'nlte_curtis.h'        
-                                                
-c arguments                                     
-	real*8 alsx(nbox_max),alnx(nbox_max),adx(nbox_max),xtemp(nbox_max)     
-                                                
-c local variables                               
-	integer 	i, k                                  
-                                                
-c	***********                                   
-                                                
-!	write (*,*)  'intershape  xtemp =', xtemp                      
-                                                
-	do 1, k=1,nbox     
-	  if (xtemp(k).gt.tmax) then 
-	       write (*,*) ' WARNING !  Tpath,tmax= ',xtemp(k),tmax
-               xtemp(k) = tmax        
-          endif
-	  if (xtemp(k).lt.tmin) then
-	       write (*,*) ' WARNING !  Tpath,tmin= ',xtemp(k),tmin
-               xtemp(k) = tmin        
-          endif   
-               
-	  i = 1                                        
-	  do while (i.le.mm)                           
-	    i = i + 1                                  
-                                                
-	    if (abs(xtemp(k)-thist(i)) .lt. 1.0d-4) then   !evita troubles     
-	      alsx(k)=xls1(i,k)     !16-july-1996      
-	      alnx(k)=xln1(i,k)                        
-	      adx(k)=xld1(i,k)                         
-	      goto 1                                   
-	    elseif ( thist(i) .le. xtemp(k) ) then     
-	      alsx(k) = (( xls1(i,k)*(thist(i-1)-xtemp(k)) +       
-     @     	xls1(i-1,k)*(xtemp(k)-thist(i)) )) / (thist(i-1)-thist(i))
-	      alnx(k) = (( xln1(i,k)*(thist(i-1)-xtemp(k)) +       
-     @     	xln1(i-1,k)*(xtemp(k)-thist(i)) )) / (thist(i-1)-thist(i))
-	      adx(k)  = (( xld1(i,k)*(thist(i-1)-xtemp(k)) +       
-     @     	xld1(i-1,k)*(xtemp(k)-thist(i)) )) / (thist(i-1)-thist(i))
-	      goto 1                                   
-	    end if                                     
-	  end do                                       
-	write (*,*)  
-     @         ' error in xtemp(k). it should be between tmin and tmax'
-1	continue                                      
-                                                
- 	return                                        
-	end                                            
-c	**********************************************************************
-	subroutine interstrength (stx, ts, sx, xtemp)  
-c	interpolates the line strength at a temperature xtemp from            
-c	input histogram data.                         
-c	**********************************************************************
-                                                
-	implicit none                                  
-                                                
-	include 'nltedefs.h'          
-	include 'nlte_curtis.h'        
-                                                
-c arguments                                     
-	real*8 		stx		! output, total band strength    
-	real*8		ts		! input, temp for stx              
-	real*8		sx(nbox_max)	! output, strength for each box  
-	real*8		xtemp(nbox_max) ! input, temp for sx        
-                                                
-c local variables                               
-	integer 	i, k                                  
-                                                
-c	***********                                   
-                                                
-	do 1, k=1,nbox                                 
-!          if(xtemp(k).lt.ts)then
-!             write(*,*)'***********************'
-!             write(*,*)'mztfsub_overlap/EEEEEEH!',xtemp(k),ts,k
-!             write(*,*)'***********************'
-!          endif
-	  if (xtemp(k).gt.tmax) xtemp(k) = tmax        
-	  if (xtemp(k).lt.tmin) xtemp(k) = tmin        
-	  i = 1                                        
-	  do while (i.le.mm-1)                         
-	    i = i + 1         
-!            write(*,*)'mztfsub_overlap/136',i,xtemp(k),thist(i)
-	    if ( abs(xtemp(k)-thist(i)) .lt. 1.0d-4 ) then         
-	      sx(k) = sk1(i,k)                         
-!              write(*,*)'mztfsub_overlap/139',sx(k),k,i
-	      goto 1                                   
-	    elseif ( thist(i) .le. xtemp(k) ) then     
-	      sx(k) = ( sk1(i,k)*(thist(i-1)-xtemp(k)) + sk1(i-1,k)*           
-     @	      (xtemp(k)-thist(i)) ) / (thist(i-1)-thist(i))  
-!              write(*,*)'mztfsub_overlap/144',sx(k),k,i
-	      goto 1                                   
-	    end if                                     
-	  end do                                       
-	  write (*,*)  ' error in xtemp(kr) =', xtemp(k),               
-     @     	'. it should be between '                    
-	  write (*,*)  ' tmin =',tmin, '   and   tmax =',tmax           
-	  stop                                         
-1 	continue                                     
-                                                
-	stx = 0.d0                                     
-	if (ts.gt.tmax) ts = dble( tmax )              
-	if (ts.lt.tmin) ts = dble( tmin )              
-	i = 1                                          
-	do while (i.le.mm-1)                           
-	  i = i + 1                                    
-!          write(*,*)'mztfsub_overlap/160',i,ts,thist(i)
-	  if ( abs(ts-thist(i)) .lt. 1.0d-4 ) then     
-	    do k=1,nbox                                
-	      stx = stx + no(k) * sk1(i,k)    
-!              write(*,*)'mztfsub_overlap/164',stx
-	    end do                                     
-	    return                                     
-	  elseif ( thist(i) .le. ts ) then             
-	    do k=1,nbox                                
-	      stx = stx + no(k) * (( sk1(i,k)*(thist(i-1)-ts) +    
-     @     	sk1(i-1,k)*(ts-thist(i)) )) / (thist(i-1)-thist(i))      
-!              write(*,*)'mztfsub_overlap/171',stx
-	    end do                                     
-!            stop
-	    return                                     
-	  end if                                       
-	end do  
-                                                
- 	return                                        
-	end                                            
-c	**********************************************************************
-	subroutine intz(h,aco2,ap,amr,at, con)         
-c	return interp. concentration, pressure,mixing ratio and temperature   
-c	for a input height h                          
-c	**********************************************************************
-                                                
-	implicit none                                  
-	include 'nltedefs.h'          
-	include 'nlte_atm.h'        
-	include 'nlte_curtis.h'        
-                                                
-c arguments                                     
-	real		h			! i 
-	real*8		con(nzy)		! i                          
-	real*8		aco2, ap, at, amr	! o                  
-                                                
-c local variables                               
-	integer		k                                     
-                                                
-c	************                                  
-                                                
-	if ( ( h.lt.zy(1) ).and.( h.le.-1.e-5 ) ) then 
-	  write (*,*) ' zp= ',h,' zy(1)= ',zy(1)                         
-	  stop'from intz: error in interpolation, z < minimum height'
-	elseif (h.gt.zy(nzy)) then                      
-	  write (*,*) ' zp= ',h,' zy(nzy)= ',zy(nzy)                       
-	  stop'from intz: error in interpolation, z > maximum height'
-	end if                                         
-                                                
-	if (h.eq.zy(nzy)) then                          
-	  	ap  = dble( py(nzy)  )                       
-	  	aco2= con(nzy)                               
-		at  = dble( ty(nzy)  )                         
-		amr = dble( mr(nzy) )                          
-		return                                        
-	end if                                         
-                                                
-	do k=1,nzy-1                                    
-		if( abs( h-zy(k) ).le.( 1.e-5 ) ) then        
-		  	ap  = dble( py(k)  )                       
-		  	aco2= con(k)                               
-			at  = dble( ty(k)  )                         
-			amr = dble( mr(k) )                          
-			return                                       
-		elseif(h.gt.zy(k).and.h.lt.zy(k+1))then       
-		ap = dble( exp( log(py(k)) + log(py(k+1)/py(k)) *         
-     @     		(h-zy(k)) / (zy(k+1)-zy(k)) ) )             
-		aco2 = exp( log(con(k)) + log( con(k+1)/con(k) ) *        
-     @     		(h-zy(k)) / (zy(k+1)-zy(k)) )               
-	 	at = dble( ty(k)+(ty(k+1)-ty(k))*(h-zy(k))/
-     @                  (zy(k+1)-zy(k)) )
-		amr = dble( mr(k)+(mr(k+1)-mr(k))*(h-zy(k))/
-     @                  (zy(k+1)-zy(k)) ) 
-			return                                       
-		end if                                        
-	end do                                         
-                                                
-	return                                         
-	end                                            
-                                                
-c	*******************************************************************   
-                                                
-	subroutine rhist (factor_comp)                 
-                                                
-c	reads histogram data arrays created by ~/spectral/his.for 
-c       malv   nov-98    add average distance between lines for overlapp
-                                                
-c	*******************************************************************   
-                                                
-                                                
-	implicit none                                  
-                                                
-	include 'nltedefs.h'          
-	include 'nlte_curtis.h' 
-        include 'datafile.h'
-                                                
-c arguments                                     
-	real            factor_comp                    
-                                                
-c local variables                               
-	integer 	j, r                                  
-	real*8          sk1_aux, xls1_aux, xln1_aux, xld1_aux,weight,nu0      
-        character       tonto*50
-
-c formats                                       
-!  100 	format(80a1)         ! Esto es si fuese       byte   dummy(80)
-  100 	format(a80)          ! Esto es si fuese       character dummy*80
-  150 	format(a50)          ! Esto es si fuese       character dummy*80
-                                                
-c	***************                               
-
-	open(unit=3,
-     $       file=trim(datafile)//'/NLTEDAT/'
-     $       //hisfile(1:len_trim(hisfile)),status='old')
-	!read(3,100) dummy                              
-	read(3,150) tonto                              
-	read(3,*) weight                               
-	read(3,*) mm                                   
-	read(3,*) nu0                                  
-	read(3,*) nbox                                 
-	!read(3,'(a)') dumm                           
-	read(3,'(a)') tonto   
-                        
-        if ( nbox .gt. nbox_max ) then 
-           write (*,*) ' nbox too large in input file ', hisfile
-           stop ' Check maximum number nbox_max in mz1d.par '
-        endif
- 	do 1 j=1,mm  ! for each temperature           
-	  read(3,*) thist(j)   
-	  do r=1,nbox            ! for each box        
-	   read(3,*) no(r), sk1(j,r), xls1(j,r),xln1(j,r),xld1(j,r),           
-     @     	dist(r)                                      
-c	    xld1(j,r)=xld1(j,r)*0.83255  !0.83255=sqrt(log(2))    
-	  enddo                                        
- 1	continue                                     
-	tmax=thist(1)                                  
-	tmin=thist(mm)                                 
-                                                
-	!close(unit=3,dispose='save')                   
-	close(unit=3)                   
-                                                
-	                                               
- 	do 2 j=1,mm                                   
-	   do r=1,nbox                                 
-	     sk1(j,r) = sk1(j,r) * factor_comp         
-	   enddo                                       
-2	continue                                      
-                                                
-                                                
-	return                                         
-	end                                            
-                                                
-c       ****************************************************************
-        subroutine interh( sx, alsx, alnx, adx, xtemp, xtdop )          
-                                                
-c       interpolates a histogram at temperature xtemp from input histogr
-                                                
-c	jan 98	malv 	version para mz1d basada en el inth de solar10:  
-c			mz5/curtis/mztfsub_solar.f                  
-c       ****************************************************************
-                                                
-        implicit none                           
-                                                
-	include 'nltedefs.h'          
-	include 'nlte_curtis.h'        
-                                                
-c arguments                                     
-        real*8  	sx(nbox_max)		! o                    
-	real*8		xtemp		! i                             
-	real*8		alsx(nbox_max)	! o                           
-	real*8		alnx(nbox_max)	! o                           
-	real*8 		adx(nbox_max)		! o                          
-	real*8		xtdop		! i                             
-                                                
-c local variables                               
-	integer 	i, j, k                               
-                                                
-c	************                                  
-             
-
-        if (xtemp.gt.thist(1)) then             
-!          write (*,*) ' xtemp-path, thist(1)max: ', 
-!     @                xtemp,thist(1)          
-          xtemp = thist(1)                      
-        elseif (xtemp.lt.thist(nhist)) then     
-!          write (*,*) ' xtemp-path, thist(nhist)min: ', 
-!     @                xtemp,thist(nhist)  
-          xtemp = thist(nhist)                  
-        end if                                  
-                                                
-        i=0                                     
-1	i=i+1                                         
-	if (abs(xtemp-thist(i)) .lt. 1.0d-4) goto 2
-        if (thist(i).lt.xtemp) goto 2           
-        goto 1                                  
-2	j=i    
-
-!        write (*,*) 'InterH/ j, xtemp, th(1),th(nh)', 
-!     @         j, xtemp, thist(1),thist(nhist) 
-
-        if (j.gt.1) then 
-         do k=1,nbox                           
-          sx(k) = ( sk1(j,k) * (thist(j-1)-xtemp) + sk1(j-1,k) *        
-     @          (xtemp-thist(j)) ) / (thist(j-1)-thist(j))  
-	 enddo
-        elseif (j.eq.1) then
-         do k=1,nbox                           
-          sx(k) = sk1(1,k) 
-	 enddo                                      
-        endif
-                                                
-        if (xtdop.gt.thist(1)) then             
-!          write (*,*)  ' xtdop-path, thist(1)max: ', 
-!     @          xtdop,thist(1)          
-          xtdop = thist(1)                      
-        elseif (xtdop.lt.thist(nhist)) then     
-!          write (*,*)  ' xtdop-path, thist(nhist)min: ', 
-!     @          xtdop,thist(nhist)  
-          xtdop = thist(nhist)                  
-        end if                                  
-                                                
-        i=0                                     
-4       i=i+1                                   
-	if (abs(xtdop-thist(i)) .lt. 1.0d-4) goto 5
-        if (thist(i).lt.xtdop) goto 5           
-        goto 4                                  
-5       j=i                                     
-
-!        write (*,*) 'InterH/ j, xtdop', 
-!     @         j, xtdop 
-
-        if (j.gt.1) then 
-         do k=1,nbox                           
-          alsx(k) = ( xls1(j,k) * (thist(j-1)-xtdop) + xls1(j-1,k)*     
-     @      (xtdop-thist(j)) ) / (thist(j-1)-thist(j))          
-          alnx(k) = ( xln1(j,k) * (thist(j-1)-xtdop) + xln1(j-1,k)*     
-     @      (xtdop-thist(j)) ) / (thist(j-1)-thist(j))      
-          adx(k)  = ( xld1(j,k) * (thist(j-1)-xtdop) + xld1(j-1,k)*     
-     @      (xtdop-thist(j)) ) / (thist(j-1)-thist(j))      
-         enddo                                
-        elseif (j.eq.1) then
-         do k=1,nbox
-           alsx(k) = xls1(1,k) 
-           alnx(k) = xln1(1,k)
-           adx(k)  = xld1(j,k)
-         enddo
-        endif
-                                                
-c end                                           
-        return                                  
-        end                                     
-                                                
-c	**********************************************************************
-	real*8 function we(ig,me,pe,pl, idummy, nt_local,p_local, Desp, wsL)  
-c	icls=5 -->para mztf                           
-c	icls=1,2,3-->para fot, line shape (v=1,l=2,d=3) (only use if wr=2)    
-c	calculates an approximate equivalent width for an error estimate.     
-c                                               
-c	ioverlap = 0  ....... no correction for overlaping        
-c       1  ....... "lisat" first correction (see overlap_box.
-c       2  .......    "      "    "  plus "supersaturation"  
-                                           
-c       idummy=0   do nothing
-c              1   write out some values for diagnostics
-c              2   correct the Strong Lorentz behaviour for SZA>90
-c              3   casos 1 & 2
-     
-c       malv   nov-98    add overlaping's corrections       
-c	**********************************************************************
-                                                
-	implicit none                                  
-                                                
-	include 'nltedefs.h'          
-	include 'nlte_curtis.h'        
-        include 'tcr_15um.h'
-                                                
-c arguments                 
-        integer         ig    ! ADDED FOR TRACEBACK
-	real*8		me    ! I. path's absorber amount  
-        real*8          pe    ! I. path's presion total
-        real*8          pl    ! I. path's partial pressure of CO2
-        real*8          nt_local ! I. needed for strong limit of Lorentz profil
-        real*8          p_local  ! I.    "          "              "
-        integer         idummy   ! I. indica varias opciones
-        real*8          wsL      ! O. need this for strong Lorentz correction
-        real*8          Desp     ! I. need this for strong Lorentz correction
-
-c local variables                               
-	integer 	i                                     
-	real*8 		y,x,wl,wd                    
-	real*8		cn(0:7),dn(0:7)                        
-	real*8 		pi, xx                                
-	real*8          f_sat_box                      
-	real*8          dv_sat_box, dv_corte_box       
-	real*8          area_core_box, area_wing_box   
-        real*8          wlgood , parentesis , xlor
-        real*8          wsl_grad
-  
-	                                               
-c data blocks                                   
-	data cn/9.99998291698d-1,-3.53508187098d-1,9.60267807976d-2,           
-     @     	-2.04969011013d-2,3.43927368627d-3,-4.27593051557d-4,    
-     @     	3.42209457833d-5,-1.28380804108d-6/          
-	data dn/1.99999898289,5.774919878d-1,-5.05367549898d-1,    
-     @     	8.21896973657d-1,-2.5222672453,6.1007027481, 
-     @     	-8.51001627836,4.6535116765/                 
-                                                
-c	***********                                   
-                                                
-c	equivalent width of atmospheric line.         
-                                                
-	pi = acos(-1.d0)                               
-
-        if ( idummy.gt.9 )
-     @     write (*,*) ' S, m, alsa, pp =', ka(kr), me, alsa(kr), pl
-
-    	y=ka(kr)*me                                
-!	x=y/(2.0*pi*(alsa(kr)*pl+alna(kr)*(pe-pl)))    
-	x=y/(2.0d0*pi* alsa(kr)*pl)		!+alna(kr)*(pe-pl)))           
-
-! Strong limit of Lorentz profile:  WL = 2 SQRT( S * m * alsa*pl )
-! Para anular esto, comentar las siguientes 5 lineas
-!        if ( x .gt. 1.e6 ) then 
-!           wl = 2.0*sqrt( y * alsa(kr)*pl )
-!        else
-!	   wl=y/sqrt(1.0d0+pi*x/2.0d0)                        
-!        endif
-
-	wl=y/sqrt(1.0d0+pi*x/2.0d0)                        
-
-        if (wl .le. 0.d0) then 
-           write(*,*)'mztfsub_overlap/496',ig,y,ka(kr),me,kr
-           stop'WE/Lorentz EQW zero or negative!/498'!,ig
-        endif
-
-        if ( idummy.gt.9 ) 
-     @     write (*,*) ' y, x =', y, x
-
-        xlor = x
-        if ( (idummy.eq.2 .or. idummy.eq.12) .and. xlor.gt.1e5 ) then
-                                         ! en caso que estemos en el regimen
-                                         ! Strong Lorentz y la presion local 
-                                         ! vaya disminuyendo, corregimos la EQW
-                                         ! con un gradiente analitico (notebook)
-           wsL = 2.0*sqrt( y * alsa(kr)*pl ) 
-           wsl_grad = - 2.d0 * ka(kr)*alsa(kr) * nt_local*p_local / wsL
-           wlgood = w_strongLor_prev(kr) + wsl_grad * Desp
-           if (idummy.eq.12) 
-     @        write (*,*) ' W(wrong), W_SL, W_SL prev, W_SL corrected=', 
-     @          wl, wsL, w_strongLor_prev(kr), wlgood
-           wl = wlgood
-        endif
-        ! wsL = wl  pero esto no lo hacemos todavia, porque necesitamos 
-        !           el valor que ahora mismo tiene wsL para corregir la
-        !           expresion R&W below
-
-!        write (*,*) 'WE arguments me,pe,pl =', me,pe,pl
-!        write (*,*) 'WE/ wl,ka(kr),alsa(kr) =', 
-!     @       wl, ka(kr),alsa(kr)
-
-
-!>>>>>>>
- 500    format (a,i3,3(2x,1pe15.8))
- 600    format (a,2(2x,1pe16.9))
- 700    format (a,3(1x,1pe16.9))
-!        if (kr.eq.8 .or. kr.eq.13) then  
-!           write (*,500) 'WE/kr,m,pt,pl=', kr, me, pe, pl
-!           write (*,700) '  /aln,als,d_x=', alna(kr),alsa(kr),
-!     @                2.0*pi*( alsa(kr)*pl + alna(kr)*(pe-pl) )
-!           write (*,600) '  /alsa*p_CO2, alna*p_n2 :', 
-!     @             alsa(kr)*pl, alna(kr)*(pe-pl)
-!           write (*,600) '  a*p, S =', 
-!     @                 alsa(kr)*pl + alna(kr)*(pe-pl)  , ka(kr)
-!           write (*,600) '  /S*m, x =', y, x
-!           write (*,600) '  /aprox, WL =',  
-!     @         2.*sqrt( y*( alsa(kr)*pl+alna(kr)*(pe-pl) ) ), WL
-!        endif
-	!                                              
-	! corrections to lorentz eqw due to overlaping and super-saturation    
-	!                                              
-                                                
-	i_supersat = 0                                 
-                                                
-	if ( icls.eq.5 .and. ioverlap.gt.0 ) then      
-	   ! for the moment, only consider overlaping for mztf.f, not fot.f    
-                                                
-	   ! definition of saturation in the lisat model           
-	   !                                           
-	   asat_box = 0.99d0                           
-	   f_sat_box = 2.d0 * x                        
-	   xx = f_sat_box / log( 1./(1-asat_box) )     
-	   if ( xx .lt. 1.0d0 ) then                   
-	      dv_sat_box = 0.0d0                       
-	      asat_box = 1.0d0 - exp( - f_sat_box )    
-	   else                                        
-	      dv_sat_box = alsa(kr) * sqrt( xx - 1.0d0 )           
-	      ! approximation: only use of alsa in mars and venus  
-	   endif                                       
-                                                
-	   ! area of saturated line                    
-	   !                                           
-	   area_core_box = 2.d0 * dv_sat_box * asat_box            
-	   area_wing_box = 0.5d0 * ( wl - area_core_box )          
-	   dv_corte_box = dv_sat_box + 2.d0*area_wing_box/asat_box 
-	                                               
-	   ! super-saturation or simple overlaping?    
-	   !                                           
-!	   i_supersat = 0                             
-	   xx = dv_sat_box - ( 0.5d0 * dist(kr) )      
-	   if ( xx .ge. 0.0       ! definition of supersaturation  
-     @     	.and. dv_sat_box .gt. 0.0     ! definition of saturation 
-     @  	.and. (dist(kr).gt.0.0) )   ! box contains more than 1 line 
-     @	 		            ! and not too far apart       
-     @          then                                         
-                                                
-	      i_supersat = 1                           
-                                                
-	   else                                        
-	   ! no super-saturation, then use "lisat + first correction", i.e.,   
-	   ! correct for line products                 
-	   !                                           
-                                                
-	      wl = wl                                  
-                                                
-	   endif                                       
-                                                
-	end if      ! end of overlaping loop           
-
-	if (icls.eq.2) then 
-           we = wl              
-           return
-        endif
-
-cc  doppler limit:    
-        if ( idummy.gt.9 ) 
-     @     write (*,*) ' S*m, alf_dop =', y, alda(kr)*sqrt(pi)
-
-        x = y / (alda(kr)*sqrt(pi))  
-        if ( x.lt.1.e-10 ) then  ! to avoid underflow
-           wd = y
-	else
-	   wd=alda(kr)*sqrt(4.0*pi*x**2*(1.0+log(1.0+x))/(4.0+pi*x**2))
-        endif
-        if ( idummy.gt.9 )
-     @     write (*,*) ' wd =', wd
-                                     
-cc  doppler weak limit                          
-c	wd = ka(kr) * me                              
-                                                
-cc  good doppler                                
-	if(icls.eq.5) then	!para mztf                  
-	 !write (*,*) 'para mztf, icls=',icls                           
-	 if (x.lt.5.) then                             
-	  wd = 0.d0                                    
-	  do i=0,7                                     
-	    wd = wd + cn(i) * x**i                     
-	  end do                                       
-	  wd = alda(kr) * x * sqrt(pi) * wd            
-	 elseif (x.gt.5.) then                         
-	  wd = 0.d0                                    
-	  do i=0,7                                     
-	    wd = wd + dn(i) / (log(x))**i              
-	  end do                                       
-	  wd = alda(kr) * sqrt(log(x)) * wd            
-	 else                                          
-		stop ' x should not be less than zero'        
-	 end if                                        
-	end if                                         
-                                                
-
-	if ( i_supersat .eq. 0 ) then                  
-
-           parentesis = wl**2+wd**2-(wd*wl/y)**2
-				! changed +(wd*wl/y)**2 to -...14-3-84      
-
-           if ( parentesis .lt. 0.0 ) then 
-             if ((idummy.eq.2 .or. idummy.eq.12) .and. xlor.gt.1e5) then
-               parentesis = wl**2+wd**2-(wd*wsL/y)**2
-                                ! este cambio puede ser necesario cuando se hace
-                                ! correccion Strong Lor, para evitar valores
-                                ! negativos del parentesis en sqrt( )
-             else
-               stop ' WE/ Error en las EQW  wl,wl,y '
-             endif
-           endif
-
-	   we = sqrt( parentesis )
-!	   write (*,*)  ' from we: xdop,alda,wd', sngl(x),alda(kr),sngl(wd)
-!	   write (*,*)  ' from we: we', we                             
-
-	else                                           
-
-	   we = wl                                     
-	  ! if there is supersaturation we can ignore wd completely;           
-	  ! mztf.f will compute the eqw of the whole box afterwards            
-
-	endif                                          
-                                                
-	if (icls.eq.3) we = wd                         
-
-        if ( idummy.gt.9 )
-     @     write (*,*) ' wl,wd,w =', wl,wd,we
-
-        wsL = wl 
-
-	return                                         
-	end                                            
-                                                
-                                                
-c	**********************************************************************
-	real*8 function simrul(a,b,fsim,c,acc)         
-c	adaptively integrates fsim from a to b, within the criterion acc.     
-c	**********************************************************************
-        
-        implicit none
-                          
-	real*8 res,a,b,g0,g1,g2,g3,g4,d,a0,a1,a2,h,x,acc,c,fsim
-        real*8 s1(70),s2(70),s3(70)
-        real*8 c1, c2
-	integer*4 m,n,j                                
-                                                
-	res=0.                                         
-	c=0.                                           
-	m=0                                            
-	n=0                                            
-	j=30                                           
-	g0=fsim(a)                                     
-	g2=fsim((a+b)/2.)                              
-	g4=fsim(b)                                     
-	a0=(b-a)*(g0+4.0*g2+g4)/2.0                    
-    1	d=2.0**n                                  
-	h=(b-a)/(4.0*d)                                
-	x=a+(4.0*m+1.0)*h                              
-	g1=fsim(x)                                     
-	g3=fsim(x+2.0*h)                               
-	a1=h*(g0+4.0*g1+g2)                            
-	a2=h*(g2+4.0*g3+g4)                            
-	if ( abs(a1+a2-a0).gt.(acc/d)) goto 2          
-	res=res+(16.0*(a1+a2)-a0)/45.0                 
-	m=m+1                                          
-	c=a+m*(b-a)/d                                  
-    6	if (m.eq.(2*(m/2))) goto 4                
-	if ((m.ne.1).or.(n.ne.0)) goto 5               
-    8	simrul=res                                
-	return                                         
-    2	m=2*m                                     
-	n=n+1                                          
-	if (n.gt.j) goto 3                             
-	a0=a1                                          
-	s1(n)=a2                                       
-	s2(n)=g3                                       
-	s3(n)=g4                                       
-	g4=g2                                          
-	g2=g1                                          
-	goto 1                                         
-    3	c1=c-(b-a)/d                              
-	c2=c+(b-a)/d                                   
-	write(2,7) c1,c,c2,fsim(c1),fsim(c),fsim(c2)    
-	write(*,7) c1,c,c2,fsim(c1),fsim(c),fsim(c2)      
-    7	format(2x,17hsimrule fails at ,/,3e15.6,/,3e15.6)     
-	goto 8                                         
-    5	a0=s1(n)                                  
-	g0=g4                                          
-	g2=s2(n)                                       
-	g4=s3(n)                                       
-	goto 1                                         
-    4	m=m/2                                     
-	n=n-1                                          
-	goto 6                                         
-	end                                            
-                                                
-c	**********************************************************************
-	subroutine findw(ig,iirw,idummy,c1,p1, Desp, wsL)                         
-c	this routine sets up accuracy criteria and calls simrule between limit
-c	that depend on the number of atmospheric and cell paths. it gives eqw.
-
-c       Add correction for EQW in Strong Lorentz regime and SZA>90 
-c	**********************************************************************
-                                                
-	implicit none                                  
-	include 'nltedefs.h'          
-	include 'nlte_curtis.h'        
-                                                
-c arguments                
-        integer         ig       ! ADDED FOR TRACEBACK
-	integer		iirw        
-        integer         idummy   ! I. indica varias opciones
-        real*8          c1       ! I. needed for strong limit of Lorentz profil
-        real*8          p1       ! I.    "          "              "
-        real*8          wsL      ! O. need this for strong Lorentz correction
-        real*8          Desp     ! I. need this for strong Lorentz correction
-                                                
-c local variables                               
-	real*8 		ept,eps,xa                            
-	real*8		acc,  c                                
-	real*8 		we                                    
-	real*8		f, fi, simrul                          
-                                                
-	external f,fi                                  
-                                                
-c	********** *********** *********                                     
-
-	if(icls.eq.5) then	!para mztf                  
-!           if(ig.eq.1682)write(*,*)'mztfsub_overlap/768',ua(kr),iirw
-           if (iirw.eq.2) then  !iirw=icf=2 ==> we use the w&r formula      
-		w = we(ig,ua(kr),pt,pp, idummy, c1,p1, Desp, wsL )  
-		return                                        
-	   end if                                      
-	   ept=we(ig,ua(kr),pt,pp, idummy,c1,p1, Desp, wsL)
-	else            	!para fot               
-	   if (iirw.eq.2) then		! icf=2 ==> we use the w&r formula 
-		w = we(ig,sl_ua,pt,pp, idummy,c1,p1, Desp, wsL)
-		return                                        
-	   end if                                      
-	   ept=we(ig,sl_ua,pt,pp, idummy,c1,p1, Desp, wsL)                    
-	end if                                         
-                                                
-c the next block is a modification to avoid nul we.         
-c this situation appears for weak lines and low path temperature, but   
-c there is not any loss of accuracy. first july 1986        
-	if (ept.eq.0.) then 	! for weak lines sometimes we=0       
-		ept=1.0e-18                                   
-		write (*,*)  'ept =',ept                                       
-		write (*,*) 'from we: we=0.0'                                  
-		return                                        
-	end if                                         
-                                                
-	acc = 4.d0                                     
-	acc = 10.d0**(-acc)                            
-                                                
-	eps = acc * ept 		!accuracy 10-4 atmospheric eqw.  
-    	xa=0.5*ept/f(0.d0)  !width of doppler shifted atmospheric line.    
-    	w=2.0*(simrul(0.0d0,xa,f,c,eps)+simrul(0.1d0,1.0/xa,fi,c,eps))     
-!no shift.                                      
-                                                
-    	return                                     
-	end                                            
-                                                
-                                                
-c	**********************************************************************
-	double precision function fi(y)                
-c	returns the value of f(1/y)                   
-c	**********************************************************************
-                                                
-	implicit none                                  
-	real*8 f, y                                    
-                                                
-	fi=f(1.0/y)/y**2                               
-	return                                         
-	end                                            
-                                                
-                                                
-c	**********************************************************************
-	double precision function f(nu)                
-c	calculates 1-exp(-k(nu)u) for all series paths or combinations thereof
-c	**********************************************************************
-                                                
-	implicit none                                  
-	include 'nltedefs.h'          
-	include 'nlte_curtis.h'        
-                                                
-	double precision tra,xa,ya,za,yy,nu            
-	double precision voigtf                        
-	tra=1.0d0                                      
-                                                
-    	yy=1.0d0/alda(kr)                          
-	xa=nu*yy                                       
-	ya= ( alsa(kr)*pp + alna(kr)*(pt-pp) ) * yy			 
-	za=ka(kr)*yy                                   
-                                                
-	if(icls.eq.5) then	!para mztf                  
-	  ! write (*,*) 'icls=',icls                                    
-	   tra=za*ua(kr)*voigtf(sngl(xa),sngl(ya))     
-	else
-	   tra=za*sl_ua*voigtf(sngl(xa),sngl(ya))         
-        end if                                         
-                                                
-	if (tra.gt.50.0) then                          
-	tra=1.0				!2.0e-22 overflow cut-off.          
-	else if (tra.gt.1.0e-4) then                   
-	tra=1.0-exp(-tra)                              
-	end if                                         
-                                                
-	f=tra                                          
-	return                                         
-	end                                            
-                                                
-c	**********************************************************************
-	double precision function voigtf(x1,y)         
-c	computes voigt function for any value of x1 and any +ve value of y.   
-c	where possible uses modified lorentz and modified doppler approximatio
-c	otherwise uses a rearranged rybicki routine.  
-c	c(n) = exp(-(n/h)**2)/(pi*sqrt(pi)), with h = 2.5 .       
-c	accurate to better than 1 in 10000.           
-c	**********************************************************************
-
-        implicit none
-
-        real x1, y
-        real x, xx, xxyy, xh,xhxh, yh,yhyh, f1,f2, p, q, xn,xnxn, voig
-                       
-	real*8 b,g0,g1,g2,g3,g4,d1,d2,d3,d4,c          
-        integer*4 n                             
-                                                
-	dimension c(10)                                
-	complex xp,xpp,z                               
-                                                
-	data c(1)/0.15303405/                          
-	data c(2)/0.94694928e-1/                       
-	data c(3)/0.42549174e-1/                       
-	data c(4)/0.13882935e-1/                       
-	data c(5)/0.32892528e-2/                       
-	data c(6)/0.56589906e-3/                       
-	data c(7)/0.70697890e-4/                       
-	data c(8)/0.64135678e-5/                       
-	data c(9)/0.42249221e-6/                       
-	data c(10)/0.20209868e-7/                      
-                                                
-	x=abs(x1)                                      
-	if (x.gt.7.2) goto 1                           
-	if ((y+x*0.3).gt.5.4) goto 1                   
-	if (y.gt.0.01) goto 3                          
-	if (x.lt.2.1) goto 2                           
-	goto 3                                         
-c	here uses modified lorentz approx.            
-    1	xx=x*x                                    
-	xxyy=xx+y*y                                    
-	b=xx/xxyy                                      
-	voigtf=y*(1.+(2.*b-0.5+(0.75-(9.-12.*b)*b)/xxyy)/          
-     *	xxyy)/(xxyy*3.141592654)                 
-	return                                         
-c	here uses modified doppler approx.            
-    2	xx=x*x                                    
-	voigtf=0.56418958*exp(-xx)*(1.-y*(1.-0.5*y)*(1.1289-xx*(1.1623+        
-     *	xx*(0.080812+xx*(0.13854-xx*(0.033605-0.0073972*xx))))))         
-	return                                         
-c	here uses a rearranged rybicki routine.       
-    3	xh=2.5*x                                  
-	xhxh=xh*xh                                     
-	yh=2.5*y                                       
-	yhyh=yh*yh                                     
-	f1=xhxh+yhyh                                   
-	f2=f1-0.5*yhyh                                 
-	if (y.lt.0.1) goto 20                          
-	p=-y*7.8539816				!7.8539816=2.5*pi            
-	q=x*7.8539816                                  
-	xpp=cmplx(p,q)                                 
-	z=cexp(xpp)                                    
-	d1=xh*aimag(z)                                 
-	d2=-d1                                         
-	d3=yh*(1.-real(z))                             
-	d4=-d3+2.*yh                                   
-	voig=0.17958712*(d1+d3)/f1                     
-	goto 30                                        
-   20	p=x*7.8539816                             
-	q=y*7.8539816                                  
-	xp=cmplx(p,q)                                  
-	z=ccos(xp)                                     
-	d1=xh*aimag(z)                                 
-	d2=-d1                                         
-	d3=yh*(1.-real(z))                             
-	d4=-d3+2.*yh                                   
-	voig=0.56418958*exp(y*y-x*x)*cos(2.*x*y)+0.17958712*(d1+d3)/f1         
-   30	xn=0.                                     
-	    do 55 n=1,10,2                             
-	    xn=xn+1.                                   
-	    xnxn=xn*xn                                 
-	    g1=xh-xn                                   
-	    g2=g1*(xh+xn)                              
-	    g3=0.5*g2*g2                               
-	    voig=voig+c(n)*(d2*(g2+yhyh)+d4*(f1+xnxn))/(g3+yhyh*(f2+xnxn))     
-	    xn=xn+1.                                   
-	    xnxn=xn*xn                                 
-	    g1=xh-xn                                   
-	    g2=g1*(xh+xn)                              
-	    g3=0.5*g2*g2                               
-	    voig=voig+c(n+1)*(d1*(g2+yhyh)+d3*(f1+xnxn))/
-     @                       (g3+yhyh*(f2+xnxn))   
-   55	    continue                              
-	voigtf=voig                                    
-	return                                         
-	end                                            
Index: unk/LMDZ.MARS/libf/phymars/mztud.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/mztud.F	(revision 497)
+++ 	(revision )
@@ -1,789 +1,0 @@
-c***********************************************************************
-c	mztf.f                                        
-c***********************************************************************
-
-	subroutine mztud ( ig,cf,cfup,cfdw,vc,taugr, ib,isot,          
-     @  	iirw,iimu,itauout,icfout,itableout )   
-            
-c	program  for calculating atmospheric transmittances       
-c	to be used in the calculation of curtis matrix coefficients           
-c	i*out = 1	output of data 
-c	i*out = 0	no output   
-c       itableout = 30  output de toda la C.M. y el VC y las poblaciones de los
-c                         estados 626(020), esta opcion nueva se añade porque 
-c                         itableout=1 saca o bien solamente de 5 en 5 capas 
-c                         o bien los elementos de C.M. desde una cierta capa 
-c                         (consultese elimin_mz1d.f que es quien lo hace); lo
-c                         de las poblaciones (020) lo hace mztf_correcion.f
-
-c       jul 2011        malv+fgg Adapted to LMD-MGCM  
-c       jan 07          malv    Add new vertical fine grid zy, similar to zx
-c       sep-oct 01      malv    update for fluxes for hb and fb, adapt to Linux
-c       nov 98          mavl    allow for overlaping in the lorentz line
-c	jan 98		malv	version for mz1d. based on curtis/mztf.for   
-c       17-jul-96	mlp&crs	change the calculation of mr.     
-c				evitar: divide por cero. anhadiendo: ff    
-c	oct-92		malv 	correct s(t) dependence for all histogr bands
-c	june-92		malv	proper lower levels for laser bands         
-c	may-92		malv 	new temperature dependence for laser bands  
-c     @    991 		malv 	boxing for the averaged absorber amount and t
-c	 ?		malv	extension up to 200 km altitude in mars
-c       13-nov-86	mlp	include the temperature weighted to match
-c				the eqw in the strong doppler limit.       
-c***********************************************************************
-            
-	implicit none      
-            
-	include 'nltedefs.h'          
-	include 'nlte_atm.h'        
-	include 'nlte_data.h'       
-	include 'nlte_curtis.h'        
-        include 'tcr_15um.h'      
-	include 'nlte_results.h'  
-                         
-c arguments             
-	integer         ig  !ADDED FOR TRACEBACK
-	real*8  	cf(nl,nl), cfup(nl,nl), cfdw(nl,nl)	! o    
-	real*8		vc(nl),  taugr(nl)		        ! o        
-	integer		ib					! i    
-	integer		isot					! i  
-	integer		iirw					! i  
-	integer		iimu					! i  
-	integer		itauout					! i           
-	integer		icfout					! i            
-	integer		itableout				! i          
-            
-c local variables and constants     
-	integer 	i, in, ir, im, k,j
-	integer 	nmu           
- 	parameter 	(nmu = 8)  
-	real*8 		tau(nl,nl)    
-	real*8 		tauinf(nl)    
-	real*8 		con(nzy), coninf           
-	real*8 		c1, c2        
-	real*8 		t1, t2        
-	real*8 		p1, p2        
-	real*8		mr1, mr2       
-	real*8 		st1, st2      
-	real*8 		c1box(70), c2box(70)      
-	real*8		ff		! to avoid too small numbers      
-	real*8		tvtbs(nzy)      
-	real*8 		st, beta, ts, eqwmu       
-	real*8 		mu(nmu), amu(nmu)         
-	real*8  	zld(nl), zyd(nzy)
-	real*8 		correc        
-	real 		deltanux	! width of vib-rot band (cm-1)    
-	character	isotcode*2 
-	integer         idummy
-	real*8          Desp,wsL
-       
-c formats   
- 111	format(a1)         
- 112	format(a2)         
- 101	format(i1)         
- 202	format(i2)         
- 180	format(a80)        
- 181	format(a80)        
-c***********************************************************************
-            
-c some needed values    
-!	rl=sqrt(log(2.d0))     
-!	pi2 = 3.14159265358989d0           
-	beta = 1.8d0           
-!	beta = 1.0d0           
-	idummy = 0
-	Desp = 0.0d0
-	wsL = 0.0d0
-
-	!write (*,*) ' MZTUD/ iirw = ', iirw
-
-
-c  esto es para que las subroutines de mztfsub calculen we  
-c  de la forma apropiada para mztf, no para fot 
-	icls=icls_mztf
-            
-c codigos para filenames            
-!	if (isot .eq. 1)  isotcode = '26'  
-!	if (isot .eq. 2)  isotcode = '28'  
-!	if (isot .eq. 3)  isotcode = '36'  
-!	if (isot .eq. 4)  isotcode = '27'  
-!	if (isot .eq. 5)  isotcode = '62'  
-!	if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5     
-!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
-!		write (ibcode1,101) ib           
-!	else       
-!		write (ibcode2,202) ib           
-!	endif      
-!	write (*,'( 30h calculating curtis matrix :  ,2x,         
-!     @    	8h band = ,i2,2x, 11h isotope = ,i2)') ib, isot         
-            
-c integration in angle !!!!!!!!!!!!!!!!!!!!     
-c------- diffusivity approx.        
-	if (iimu.eq.1) then    
-!	  write (*,*)  ' diffusivity approx. beta = ',beta 
-	  mu(1) = 1.0d0        
-	  amu(1)= 1.0d0        
-c-------data for 8 points integration           
-	elseif (iimu.eq.4) then            
-	  write (*,*)' 4 points for the gauss-legendre angle quadrature.'
-	  mu(1)=(1.0d0+0.339981043584856)/2.0d0 	      
-	  mu(2)=(1.0d0-0.339981043584856)/2.0d0 	      
-	  mu(3)=(1.0d0+0.861136311594053)/2.0d0        
-	  mu(4)=(1.0d0-0.861136311594053)/2.0d0 	      
-	  amu(1)=0.652145154862546 	       
-	  amu(2)=amu(1) 	      
-	  amu(3)=0.347854845137454 	       
-	  amu(4)=amu(3)        
-	  beta=1.0d0           
-c-------data for 8 points integration           
-	elseif(iimu.eq.8) then             
-	  write (*,*)' 8 points for the gauss-legendre angle quadrature.'
-	  mu(1)=(1.0d0+0.183434642495650)/2.0d0        
-	  mu(2)=(1.0d0-0.183434642495650)/2.0d0        
-	  mu(3)=(1.0d0+0.525532409916329)/2.0d0        
-	  mu(4)=(1.0d0-0.525532409916329)/2.0d0        
-	  mu(5)=(1.0d0+0.796666477413627)/2.0d0        
-	  mu(6)=(1.0d0-0.796666477413627)/2.0d0        
-	  mu(7)=(1.0d0+0.960289856497536)/2.0d0        
-	  mu(8)=(1.0d0-0.960289856497536)/2.0d0        
-	  amu(1)=0.362683783378362         
-	  amu(2)=amu(1)        
-	  amu(3)=0.313706645877887         
-	  amu(4)=amu(3)        
-	  amu(5)=0.222381034453374         
-	  amu(6)=amu(5)        
-	  amu(7)=0.101228536290376         
-	  amu(8)=amu(7)        
-	  beta=1.0d0           
-	end if     
-c!!!!!!!!!!!!!!!!!!!!!!!            
-            
-ccc         
-ccc  determine abundances included in the absorber amount   
-ccc         
-            
-c first, set up the grid ready for interpolation.           
-	do i=1,nzy              
-	  zyd(i) = dble(zy(i))             
-	enddo      
-	do i=1,nl              
-	  zld(i) = dble(zl(i))             
-	enddo      
-c vibr. temp of the bending mode :  
-        if (isot.eq.1) call interdp ( tvtbs,zyd,nzy, v626t1,zld,nl, 1 )  
-        if (isot.eq.2) call interdp ( tvtbs,zyd,nzy, v628t1,zld,nl, 1 )  
-        if (isot.eq.3) call interdp ( tvtbs,zyd,nzy, v636t1,zld,nl, 1 )  
-        if (isot.eq.4) call interdp ( tvtbs,zyd,nzy, v627t1,zld,nl, 1 )  
-        !if (isot.eq.5) call interdp ( tvtbs,zxd,nz, vcot1,zld,nl, 1 )  
-            
-c 2nd: correccion a la n10(i) (cantidad de absorbente en el lower state)
-c por similitud a la que se hace en cza.for ; esto solo se hace para CO2    
-	!write (*,*) 'imr(isot) = ', isot, imr(isot)
-	do i=1,nzy              
-	  if (isot.eq.5) then  
-	    con(i) = dble( coy(i) * imrco )            
-	  else     
-	    con(i) =  dble( co2y(i) * imr(isot) )      
-	    correc = 2.d0 * dexp( dble(-ee*elow(isot,2))/tvtbs(i) )            
-	    con(i) = con(i) * ( 1.d0 - correc )       
-!	    write (*,*) ' iz, correc, co2y(i), con(i) =', 
-!     @            i,correc,co2y(i),con(i) 
-	  endif    
-
-	    !-----------------------------------------------------------------
-	    ! mlp & cristina. 17 july 1996    change the calculation of mr.  
-	    ! it is used for calculating partial press
-	    !       alpha = alpha(self,co2)*pp +alpha(n2)*(pt-pp) 
-	    ! for an isotope, if mr is obtained by 
-	    !       co2*imr(iso)/nt 
-	    ! we are considerin collisions with other co2 isotopes 
-	    ! (including the major one, 626) as if they were with n2. 
-	    ! assuming mr as co2/nt, we consider collisions
-	    ! of type 628-626 as of 626-626 instead of as 626-n2.       
-	    !	  mrx(i)=con(i)/ntx(i) ! old malv 
-	    !	  mrx(i)= dble(co2x(i)/ntx(i))	! mlp & crs    
-
-	    ! jan 98:   
-	    ! esta modif de mlp implica anular el correc (deberia revisar esto)
-		      
-	    mr(i) = dble(co2y(i)/nty(i))	! malv, jan 98  
-
-	    !-----------------------------------------------------------------
-
-	end do     
-! como  beta y 1.d5 son comunes a todas las weighted absorber amounts,  
-! los simplificamos:    
-!	coninf = beta * 1.d5 * dble( con(n) / log( con(n-1) / con(n) ) )      
-	!write (*,*)  ' con(nz), con(nz-1)  =', con(nz), con(nz-1)        
-	coninf = dble( con(nzy) / log( con(nzy-1) / con(nzy) ) )      
-!	if(ig.eq.1682)write(*,*)'mztud/218',coninf,con(nzy),
-!	1    con(nzy-1),log(con(nzy-1)/con(nzy)),co2y(nzy),co2y(nzy-1)
-	!write (*,*)  ' coninf =', coninf       
-            
-ccc         
-ccc  temp dependence of the band strength and   
-ccc  nlte correction factor for the absorber amount         
-ccc         
-	call mztf_correccion ( coninf, con, ib, isot, itableout ) 
-!	if(ig.eq.1682)write(*,*)'mztud/227',coninf
-ccc         
-ccc reads histogrammed spectral data (strength for lte and vmr=1)       
-ccc         
-	!hfile1 = dirspec//'hi'//dn      !Ya no hacemos distincion d/n en esto
-!	hfile1 = dirspec//'hid'          !(see why in his.for)
-!	hfile1='hid'
-!!	if (ib.eq.13 .or. ib.eq.14 ) hfile1 = dirspec//'his' 
-!	if (ib.eq.13 .or. ib.eq.14 ) hfile1 = 'his' 
-            
-!	if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5     
-!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
-!	   if (isot.eq.1) hisfile = hfile1//'26-'//ibcode1//'.dat' 
-!	   if (isot.eq.2) hisfile = hfile1//'28-'//ibcode1//'.dat' 
-!	   if (isot.eq.3) hisfile = hfile1//'36-'//ibcode1//'.dat' 
-!	   if (isot.eq.4) hisfile = hfile1//'27-'//ibcode1//'.dat' 
-!	   if (isot.eq.5) hisfile = hfile1//'62-'//ibcode1//'.dat'
-!	else       
-!	   if (isot.eq.1) hisfile = hfile1//'26-'//ibcode2//'.dat' 
-!	   if (isot.eq.2) hisfile = hfile1//'28-'//ibcode2//'.dat' 
-!	   if (isot.eq.3) hisfile = hfile1//'36-'//ibcode2//'.dat' 
-!	   if (isot.eq.4) hisfile = hfile1//'27-'//ibcode2//'.dat' 
-!	   if (isot.eq.5) hisfile = hfile1//'62-'//ibcode2//'.dat' 
-!	endif      
-	if(ib.eq.1) then
-	   if(isot.eq.1) then !Case 1
-	      mm=mm_c1
-	      nbox=nbox_c1
-	      tmin=tmin_c1
-	      tmax=tmax_c1
-	      do i=1,nbox_max
-		 no(i)=no_c1(i)
-		 dist(i)=dist_c1(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c1(j,i)
-		    xls1(j,i)=xls1_c1(j,i)
-		    xln1(j,i)=xln1_c1(j,i)
-		    xld1(j,i)=xld1_c1(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c1(j)
-	      enddo
-	   else if(isot.eq.2) then !Case 2
-	      mm=mm_c2
-	      nbox=nbox_c2
-	      tmin=tmin_c2
-	      tmax=tmax_c2
-	      do i=1,nbox_max
-		 no(i)=no_c2(i)
-		 dist(i)=dist_c2(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c2(j,i)
-		    xls1(j,i)=xls1_c2(j,i)
-		    xln1(j,i)=xln1_c2(j,i)
-		    xld1(j,i)=xld1_c2(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c2(j)
-	      enddo
-	   else if(isot.eq.3) then !Case 3
-	      mm=mm_c3
-	      nbox=nbox_c3
-	      tmin=tmin_c3
-	      tmax=tmax_c3
-	      do i=1,nbox_max
-		 no(i)=no_c3(i)
-		 dist(i)=dist_c3(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c3(j,i)
-		    xls1(j,i)=xls1_c3(j,i)
-		    xln1(j,i)=xln1_c3(j,i)
-		    xld1(j,i)=xld1_c3(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c3(j)
-	      enddo
-	   else if(isot.eq.4) then !Case 4
-	      mm=mm_c4
-	      nbox=nbox_c4
-	      tmin=tmin_c4
-	      tmax=tmax_c4
-	      do i=1,nbox_max
-		 no(i)=no_c4(i)
-		 dist(i)=dist_c4(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c4(j,i)
-		    xls1(j,i)=xls1_c4(j,i)
-		    xln1(j,i)=xln1_c4(j,i)
-		    xld1(j,i)=xld1_c4(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c4(j)
-	      enddo
-	   else
-	      write(*,*)'isot must be 2,3 or 4 for ib=1!!'
-	      write(*,*)'stop at mztud/324'
-	      stop
-	   endif
-	else if (ib.eq.2) then
-	   if(isot.eq.1) then	!Case 5
-	      mm=mm_c5
-	      nbox=nbox_c5
-	      tmin=tmin_c5
-	      tmax=tmax_c5
-	      do i=1,nbox_max
-		 no(i)=no_c5(i)
-		 dist(i)=dist_c5(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c5(j,i)
-		    xls1(j,i)=xls1_c5(j,i)
-		    xln1(j,i)=xln1_c5(j,i)
-		    xld1(j,i)=xld1_c5(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c5(j)
-	      enddo
-	   else
-	      write(*,*)'isot must be 1 for ib=2!!'
-	      write(*,*)'stop at mztud/348'
-	      stop
-	   endif
-	else if (ib.eq.3) then
-	   if(isot.eq.1) then	!Case 6
-	      mm=mm_c6
-	      nbox=nbox_c6
-	      tmin=tmin_c6
-	      tmax=tmax_c6
-	      do i=1,nbox_max
-		 no(i)=no_c6(i)
-		 dist(i)=dist_c6(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c6(j,i)
-		    xls1(j,i)=xls1_c6(j,i)
-		    xln1(j,i)=xln1_c6(j,i)
-		    xld1(j,i)=xld1_c6(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c6(j)
-	      enddo
-	   else
-	      write(*,*)'isot must be 1 for ib=3!!'
-	      write(*,*)'stop at mztud/372'
-	      stop
-	   endif
-	else if (ib.eq.4) then
-	   if(isot.eq.1) then	!Case 7
-	      mm=mm_c7
-	      nbox=nbox_c7
-	      tmin=tmin_c7
-	      tmax=tmax_c7
-	      do i=1,nbox_max
-		 no(i)=no_c7(i)
-		 dist(i)=dist_c7(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c7(j,i)
-		    xls1(j,i)=xls1_c7(j,i)
-		    xln1(j,i)=xln1_c7(j,i)
-		    xld1(j,i)=xld1_c7(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c7(j)
-	      enddo
-	   else
-	      write(*,*)'isot must be 1 for ib=4!!'
-	      write(*,*)'stop at mztud/396'
-	      stop
-	   endif
-	else 
-	   write(*,*)'ib must be 1,2,3 or 4!!'
-	   write(*,*)'stop at mztud/401'
-	endif
-		 
-	      
-	   
- 
-!	write (*,*) 'hisfile: ', hisfile       
-! the argument to rhist is to make this compatible with mztf_comp.f,    
-! which is a useful modification of mztf.f (to change strengths of bands
-!	call rhist (1.0)       
-	if (isot.ne.5) deltanux = deltanu(isot,ib)     
-	if (isot.eq.5) deltanux = deltanuco            
-            
-c******     
-c****** calculation of tauinf(nl)   
-c******     
-	call initial           
-	ff=1.0e10              
-            
-	do i=nl,1,-1           
-            
-	  if(i.eq.nl)then      
-            
-		call intz (zl(i),c2,p2,mr2,t2, con)           
-		do kr=1,nbox          
-		 ta(kr)=t2            
-	  	end do              
-!	write (*,*)  ' i, t2 =', i, t2         
-		call interstrength (st2,t2,ka,ta) 
-		aa = p2 * coninf * mr2 * (st2 * ff)           
-		bb = p2 * coninf * st2            
-		cc = coninf * st2     
-		dd = t2 * coninf * st2            
-		do kr=1,nbox          
-	          ccbox(kr) = coninf * ka(kr)          
-!		  if(i.eq.nl.and.ig.eq.1682)write(*,*)'mztud/435',
-!	1	       ccbox(kr),coninf,ka(kr),kr
-		  ddbox(kr) = t2 * ccbox(kr)      
-!		  c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5   
-		  c2box(kr) = c2 * ka(kr) * dble(deltaz)      
-		end do    
-!		c2 = c2 * st2 * beta * dble(deltaz) * 1.d5   
-		c2 = c2 * st2 * dble(deltaz)      
-            
-	  else     
-		call intz (zl(i),c1,p1,mr1,t1, con)           
-		do kr=1,nbox          
-		 ta(kr)=t1            
-	  	end do              
-!	write (*,*)  ' i, t1 =', i, t1         
-		call interstrength (st1,t1,ka,ta) 
-		do kr=1,nbox          
-!		  c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5   
-		  c1box(kr) = c1 * ka(kr) * dble(deltaz)      
-		end do    
-!		c1 = c1 * st1 * beta * dble(deltaz) * 1.d5   
-		c1 = c1 * st1 * dble(deltaz)      
-		aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0       
-		bb = bb + ( p1*c1 + p2*c2 ) / 2.d0            
-		cc = cc + ( c1 + c2 ) / 2.d0      
-		dd = dd + ( t1*c1 + t2*c2 ) / 2.d0            
-		do kr=1,nbox          
-	          ccbox(kr) = ccbox(kr) + 
-     @                           ( c1box(kr) + c2box(kr) )/2.d0       
-!		  if(i.eq.nl.and.ig.eq.1682)write(*,*)'mztud/464',
-!	1	       ccbox(kr),c1box(kr),c2box(kr),kr
-		  ddbox(kr) = ddbox(kr) + 
-     @                           ( t1*c1box(kr)+t2*c2box(kr) )/2.d0 
-		end do    
-            
-		mr2 = mr1             
-		c2=c1     
-		do kr=1,nbox	         
-		  c2box(kr) = c1box(kr)           
-		end do    
-		t2=t1     
-		p2=p1     
-	  end if   
-
-	  pt = bb / cc         
-	  pp = aa / (cc*ff)    
-            
-!	  ta=dd/cc            
-!	  tdop = ta           
-	  ts = dd/cc           
-          do kr=1,nbox  
-   	    ta(kr) = ddbox(kr) / ccbox(kr)          
-	  end do   
-!	write (*,*)  ' i, ts =', i, ts         
-	  call interstrength(st,ts,ka,ta)  
-!	  call intershape(alsa,alna,alda,tdop)        
-	  call intershape(alsa,alna,alda,ta)           
-*	  ua = cc/st          
-
-c  	next loop calculates the eqw for an especified path uapp,pt,ta     
-            
-	  eqwmu = 0.0d0        
-	  do im = 1,iimu       
-	    eqw=0.0d0          
-            do  kr=1,nbox           
-		ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im)
-		if(ua(kr).lt.0.)write(*,*)'mztud/504',ua(kr),ccbox(kr),
-     $               ka(kr),beta,mu(im),kr,im,i,nl
-		call findw(ig,iirw, idummy,c1,p1,Desp,wsL)           
-		if ( i_supersat .eq. 0 ) then     
-	          eqw=eqw+no(kr)*w         
-		else      
-		   eqw = w + (no(kr)-1) * ( asat_box*dist(kr) )           
-		endif     
-	    end do             
-	    eqwmu = eqwmu + eqw * mu(im)*amu(im)       
-	  end do   
-	  
- 	  tauinf(i) = exp( - eqwmu / dble(deltanux) ) 
-            
-	end do  ! i continue   
-!	if ( isot.eq.1 .and. ib.eq.2 ) then           
-!		write (*,*)  ' tauinf(nl) = ', tauinf(nl)         
-!		write (*,*)  ' tauinf(1) = ', tauinf(1)           
-!	endif     
-            
-c******     
-c****** calculation of tau(in,ir) for n<=r      
-c******     
-        
-	do 1 in=1,nl-1         
- 	call initial          
-	call intz (zl(in), c1,p1,mr1,t1, con)          
-	do kr=1,nbox           
-	  ta(kr) = t1          
-	end do     
-	call interstrength (st1,t1,ka,ta)  
-	do kr=1,nbox           
-!	  c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5    
-	  c1box(kr) = c1 * ka(kr) * dble(deltaz)       
-	end do     
-!	c1 = c1 * st1 * beta * dble(deltaz) * 1.d5    
-	c1 = c1 * st1 * dble(deltaz)       
-            
-	do 2 ir=in,nl-1        
-            
-	if (ir.eq.in) then     
-	  tau(in,ir) = 1.d0    
-	  goto 2   
-	end if     
-            
-	call intz (zl(ir), c2,p2,mr2,t2, con)          
-	do kr=1,nbox           
-	  ta(kr) = t2          
-	end do     
-	call interstrength (st2,t2,ka,ta)  
-	do kr=1,nbox           
-!	  c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5    
-	  c2box(kr) = c2 * ka(kr) * dble(deltaz)       
-	end do     
-!	c2 = c2 * st2 * beta * dble(deltaz) * 1.e5    
-	c2 = c2 * st2 * dble(deltaz)       
-            
-c	aa = aa + ( p1*mr1*c1 + p2*mr2*c2 ) / 2.d0    
-	aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0        
-	bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 
-	cc = cc + ( c1 + c2 ) / 2.d0       
-	dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 
-	do kr=1,nbox           
-	  ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) ) /2.d0  
-	  ddbox(kr) = ddbox(kr) + ( t1*c1box(kr) + t2*c2box(kr) ) /2.d0        
-	end do     
-            
-	mr1=mr2    
-	t1=t2      
-	c1=c2      
-	p1=p2      
-	do kr=1,nbox	          
-	  c1box(kr) = c2box(kr)            
-	end do     
-            
-	pt = bb / cc           
-	pp = aa / (cc * ff)    
-            
-*	ta=dd/cc              
-*	tdop = ta             
-	ts = dd/cc             
-        do kr=1,nbox    
-   	    ta(kr) = ddbox(kr) / ccbox(kr)          
-	end do     
-	call interstrength(st,ts,ka,ta)    
-	call intershape(alsa,alna,alda,ta) 
-*	ua = cc/st            
-            
-c  	next loop calculates the eqw for an especified path ua,pp,pt,ta     
-            
-	eqwmu = 0.0d0          
-	do im = 1,iimu         
-	  eqw=0.0d0            
-          do kr=1,nbox  
-		ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im)
-		if(ua(kr).lt.0.)write(*,*)'mztud/599',ua(kr),ccbox(kr),
-     $               ka(kr),beta,mu(im),kr,im,i,nl
-
-	        call findw(ig,iirw, idummy,c1,p1,Desp,wsL)           
-		if ( i_supersat .eq. 0 ) then     
-	          eqw=eqw+no(kr)*w         
-		else      
-		   eqw = w + (no(kr)-1) * ( asat_box*dist(kr) )           
-		endif     
-	  end do   
-	  eqwmu = eqwmu + eqw * mu(im)*amu(im)         
-	end do     
-
- 	tau(in,ir) = exp( - eqwmu / dble(deltanux) )  
-            
- 2	continue             
-            
- 1	continue             
-!	if ( isot.eq.1 .and. ib.eq.2 ) then           
-!		write (*,*)  ' tau(1,*) , *=1,20 '    
-!		write (*,*)  ( sngl(tau(1,k)), k=1,20 )           
-!	endif     
-            
-            
-c**********             
-c**********  calculation of tau(in,ir) for n>r  
-c**********             
-            
-	in=nl      
-            
-	call initial           
-	call intz (zl(in), c1,p1,mr1,t1, con)          
-	do kr=1,nbox           
-	  ta(kr) = t1          
-	end do     
-	call interstrength (st1,t1,ka,ta)  
-	do kr=1,nbox           
-!	  c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5    
-	  c1box(kr) = c1 * ka(kr) * dble(deltaz)       
-	end do     
-!	c1 = c1 * st1 * beta * dble(deltaz) * 1.d5    
-	c1 = c1 * st1 * dble(deltaz)       
-            
-	do 4 ir=in-1,1,-1      
-            
-	call intz (zl(ir), c2,p2,mr2,t2, con)          
-	do kr=1,nbox           
-	  ta(kr) = t2          
-	end do     
-	call interstrength (st2,t2,ka,ta)  
-	do kr=1,nbox           
-!	  c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5    
-	  c2box(kr) = c2 * ka(kr) * dble(deltaz)       
-	end do     
-!	c2 = c2 * st2 * beta * dble(deltaz) * 1.d5    
-	c2 = c2 * st2 * dble(deltaz)       
-            
-	aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0        
-	bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 
-	cc = cc + ( c1 + c2 ) / 2.d0       
-	dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 
-	do kr=1,nbox           
-	  ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) ) /2.d0  
-	  ddbox(kr) = ddbox(kr) + ( t1*c1box(kr) + t2*c2box(kr) ) /2.d0        
-	end do     
-
-	mr1=mr2    
-	c1=c2      
-	t1=t2      
-	p1=p2      
-	do kr=1,nbox           
-	  c1box(kr) = c2box(kr)            
-	end do     
-            
-	pt = bb / cc           
-	pp = aa / (cc * ff)    
-	ts = dd / cc           
-	do kr=1,nbox           
-	  ta(kr) = ddbox(kr) / ccbox(kr)   
-	end do     
-	call interstrength (st,ts,ka,ta)   
-	call intershape (alsa,alna,alda,ta)            
-            
-*	ua = cc/st            
-            
-c  	next loop calculates the eqw for an especified path ua,pp,pt,ta     
-            
-	eqwmu = 0.0d0          
-	do im = 1,iimu         
-	  eqw=0.0d0            
-          do kr=1,nbox  
-		ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im)       
-		if(ua(kr).lt.0.)write(*,*)'mztud/691',ua(kr),ccbox(kr),
-     $               ka(kr),beta,mu(im),kr,im,i,nl
-
-	        call findw(ig,iirw, idummy,c1,p1,Desp,wsL)           
-		if ( i_supersat .eq. 0 ) then     
-	          eqw=eqw+no(kr)*w         
-		else      
-		   eqw = w + (no(kr)-1) * ( asat_box*dist(kr) )           
-		endif     
-	  end do   
-	  eqwmu = eqwmu + eqw * mu(im)*amu(im)         
-	end do     
-            
- 	tau(in,ir) = exp( - eqwmu / dble(deltanux) )  
-            
- 4	continue             
-            
-c           
-c due to the simmetry of the transmittances     
-c           
- 	do in=nl-1,2,-1       
-	  do ir=in-1,1,-1      
-		tau(in,ir) = tau(ir,in)           
-	  end do   
-	end do     
-
-            
-ccc         
-ccc  writing out transmittances     
-ccc         
-	if (itauout.eq.1) then             
-            
-!	        if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5         
-!     @    	 .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then     
-!  	         open( 1, file=          
-!     @    	   dircurtis//'taul'//isotcode//dn//ibcode1//'.dat',     
-!     @    	   access='sequential', form='unformatted' ) 
-!	        else           
-!  	         open( 1, file=          
-!     @    	   dircurtis//'taul'//isotcode//dn//ibcode2//'.dat',     
-!     @    	   access='sequential', form='unformatted' ) 
-!	        endif          
-            
-!		write(1) dummy        
-!		write(1)' format: (tauinf(n),(tau(n,r),r=1,nl),n=1,nl)'   
-!		do in=1,nl            
-!		    write (1) tauinf(in), ( tau(in,ir), ir=1,nl )         
-!		end do    
-!		close(unit=1)         
-            
-	elseif (itauout.eq.2) then         
-  	         
-!	   if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5  
-!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then	     
-!	     open( 1, file=    
-!     @        dircurtis//'taul'//isotcode//dn//ibcode1//'.dat')     
-!	   else    
-!	     open( 1, file=    
-!     @        dircurtis//'taul'//isotcode//dn//ibcode2//'.dat')     
-!	   endif   
-            
-!		!write(1,*) dummy     
-!		!write(1,*) 'tij for curtis matrix calculations '         
-!		!write(1,*)' cira mars model atmosphere '     
-!		!write(1,*)' beta= ',beta,'deltanu= ',deltanux 
-!		write(1,*) nl
-!		write(1,*)
-!     @             ' format: (tauinf(in),(tau(in,ir),ir=1,nl),in=1,nl)'
-	           
-!		do in=1,nl            
-!		    write (1,*) tauinf(in)        
-!		    write (1,*) (tau(in,ir), ir=1,nl)    
-!		end do    
-!		close(unit=1)         
-            
-!	   if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5  
-!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
-!	      write (*,'(1x, 31htransmitances written out in: ,a22)')          
-!     @    	'taul'//isotcode//dn//ibcode1    
-!	   else    
-!	      write (*,'(1x, 31htransmitances written out in: ,a22)')          
-!     @    	'taul'//isotcode//dn//ibcode2    
-!	   endif   
-            
-	end if    
-            
-c cleaning of transmittances        
-!	call elimin_tau(tau,tauinf,nl,nan,itableout,nw,dummy,     
-!     @    					isotcode,dn,ibcode2)        
-            
-c construction of the curtis matrix 
-            
-	call mzcud ( tauinf,tau, cf,cfup,cfdw, vc,taugr,            
-     @   	ib,isot,icfout,itableout )            
-            
-c end       
-	return     
-	end        
Index: unk/LMDZ.MARS/libf/phymars/mztvc.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/mztvc.F	(revision 497)
+++ 	(revision )
@@ -1,490 +1,0 @@
-c***********************************************************************
-
-	subroutine mztvc ( ig,vc, ib,isot,          
-     @  	iirw,iimu,itauout,icfout,itableout )   
-
-c       jul 2011 malv+fgg           
-c***********************************************************************
-            
-	implicit none      
-
-	include 'comcstfi.h'
-	include 'nltedefs.h'          
-	include 'nlte_atm.h'        
-	include 'nlte_data.h'       
-	include 'nlte_curtis.h'        
-	include 'tcr_15um.h'
-	include 'nlte_results.h'  
-                        
-c arguments             
-	integer         ig ! ADDED FOR TRACEBACK
-	real*8  	cf(nl,nl), cfup(nl,nl), cfdw(nl,nl)	! o    
-	real*8		vc(nl),  taugr(nl)		        ! o        
-	integer		ib					! i    
-	integer		isot					! i  
-	integer		iirw					! i  
-	integer		iimu					! i  
-	integer		itauout					! i           
-	integer		icfout					! i            
-	integer		itableout				! i          
-            
-c local variables and constants     
-	integer 	i, in, ir, im, k ,j         
-	integer 	nmu           
- 	parameter 	(nmu = 8)  
-	real*8 		tau(nl,nl)    
-	real*8 		tauinf(nl)    
-	real*8 		con(nzy), coninf           
-	real*8 		c1, c2        
-	real*8 		t1, t2        
-	real*8 		p1, p2        
-	real*8		mr1, mr2       
-	real*8 		st1, st2      
-	real*8 		c1box(70), c2box(70)      
-	real*8		ff		! to avoid too small numbers      
-	real*8		tvtbs(nzy)      
-	real*8 		st, beta, ts, eqwmu       
-	real*8 		mu(nmu), amu(nmu)         
-	real*8  	zld(nl), zyd(nzy)
-	real*8 		correc        
-	real 		deltanux	! width of vib-rot band (cm-1)    
-	character	isotcode*2 
-	integer         idummy
-	real*8          Desp,wsL
-       
-c formats   
- 111	format(a1)         
- 112	format(a2)         
- 101	format(i1)         
- 202	format(i2)         
- 180	format(a80)        
- 181	format(a80)        
-c***********************************************************************
-            
-c some needed values    
-!	rl=sqrt(log(2.d0))     
-!	pi2 = 3.14159265358989d0           
-	beta = 1.8d0           
-!	beta = 1.0d0           
-	idummy = 0
-	Desp = 0.0d0
-	wsL = 0.0d0
-
-	!write (*,*) ' MZTUD/ iirw = ', iirw
-
-
-c  esto es para que las subroutines de mztfsub calculen we  
-c  de la forma apropiada para mztf, no para fot 
-	icls=icls_mztf         
-            
-c codigos para filenames            
-!	if (isot .eq. 1)  isotcode = '26'  
-!	if (isot .eq. 2)  isotcode = '28'  
-!	if (isot .eq. 3)  isotcode = '36'  
-!	if (isot .eq. 4)  isotcode = '27'  
-!	if (isot .eq. 5)  isotcode = '62'  
-!	if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5     
-!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
-!		write (ibcode1,101) ib           
-!	else       
-!		write (ibcode2,202) ib           
-!	endif      
-!	write (*,'( 30h calculating curtis matrix :  ,2x,         
-!     @    	8h band = ,i2,2x, 11h isotope = ,i2)') ib, isot         
-            
-c integration in angle !!!!!!!!!!!!!!!!!!!!     
-            
-c------- diffusivity approx.        
-	if (iimu.eq.1) then    
-!	  write (*,*)  ' diffusivity approx. beta = ',beta 
-	  mu(1) = 1.0d0        
-	  amu(1)= 1.0d0        
-c-------data for 8 points integration           
-	elseif (iimu.eq.4) then            
-	  write (*,*)' 4 points for the gauss-legendre angle quadrature.'
-	  mu(1)=(1.0d0+0.339981043584856)/2.0d0 	      
-	  mu(2)=(1.0d0-0.339981043584856)/2.0d0 	      
-	  mu(3)=(1.0d0+0.861136311594053)/2.0d0        
-	  mu(4)=(1.0d0-0.861136311594053)/2.0d0 	      
-	  amu(1)=0.652145154862546 	       
-	  amu(2)=amu(1) 	      
-	  amu(3)=0.347854845137454 	       
-	  amu(4)=amu(3)        
-	  beta=1.0d0           
-c-------data for 8 points integration           
-	elseif(iimu.eq.8) then             
-	  write (*,*)' 8 points for the gauss-legendre angle quadrature.'
-	  mu(1)=(1.0d0+0.183434642495650)/2.0d0        
-	  mu(2)=(1.0d0-0.183434642495650)/2.0d0        
-	  mu(3)=(1.0d0+0.525532409916329)/2.0d0        
-	  mu(4)=(1.0d0-0.525532409916329)/2.0d0        
-	  mu(5)=(1.0d0+0.796666477413627)/2.0d0        
-	  mu(6)=(1.0d0-0.796666477413627)/2.0d0        
-	  mu(7)=(1.0d0+0.960289856497536)/2.0d0        
-	  mu(8)=(1.0d0-0.960289856497536)/2.0d0        
-	  amu(1)=0.362683783378362         
-	  amu(2)=amu(1)        
-	  amu(3)=0.313706645877887         
-	  amu(4)=amu(3)        
-	  amu(5)=0.222381034453374         
-	  amu(6)=amu(5)        
-	  amu(7)=0.101228536290376         
-	  amu(8)=amu(7)        
-	  beta=1.0d0           
-	end if     
-c!!!!!!!!!!!!!!!!!!!!!!!            
-            
-ccc         
-ccc  determine abundances included in the absorber amount   
-ccc         
-            
-c first, set up the grid ready for interpolation.           
-	do i=1,nzy              
-	  zyd(i) = dble(zy(i))             
-	enddo      
-	do i=1,nl              
-	  zld(i) = dble(zl(i))             
-	enddo      
-            
-c vibr. temp of the bending mode :  
-        if (isot.eq.1) call interdp ( tvtbs,zyd,nzy, v626t1,zld,nl, 1 )  
-        if (isot.eq.2) call interdp ( tvtbs,zyd,nzy, v628t1,zld,nl, 1 )  
-        if (isot.eq.3) call interdp ( tvtbs,zyd,nzy, v636t1,zld,nl, 1 )  
-        if (isot.eq.4) call interdp ( tvtbs,zyd,nzy, v627t1,zld,nl, 1 )  
-        !if (isot.eq.5) call interdp ( tvtbs,zxd,nz, vcot1,zld,nl, 1 )  
-            
-c 2nd: correccion a la n10(i) (cantidad de absorbente en el lower state)
-c por similitud a la que se hace en cza.for ; esto solo se hace para CO2    
-            
-	!write (*,*) 'imr(isot) = ', isot, imr(isot)
-	do i=1,nzy              
-	  if (isot.eq.5) then  
-	    con(i) = dble( coy(i) * imrco )            
-	  else     
-	    con(i) =  dble( co2y(i) * imr(isot) )      
-	    correc = 2.d0 * dexp( dble(-ee*elow(isot,2))/tvtbs(i) )            
-	    con(i) = con(i) * ( 1.d0 - correc )       
-!	    write (*,*) ' iz, correc, co2y(i), con(i) =', 
-!     @            i,correc,co2y(i),con(i) 
-	  endif    
-
-	    !-----------------------------------------------------------------
-	    ! mlp & cristina. 17 july 1996    change the calculation of mr.  
-	    ! it is used for calculating partial press
-	    !       alpha = alpha(self,co2)*pp +alpha(n2)*(pt-pp) 
-	    ! for an isotope, if mr is obtained by 
-	    !       co2*imr(iso)/nt 
-	    ! we are considerin collisions with other co2 isotopes 
-	    ! (including the major one, 626) as if they were with n2. 
-	    ! assuming mr as co2/nt, we consider collisions
-	    ! of type 628-626 as of 626-626 instead of as 626-n2.       
-	    !	  mrx(i)=con(i)/ntx(i) ! old malv 
-	    !	  mrx(i)= dble(co2x(i)/ntx(i))	! mlp & crs    
-
-	    ! jan 98:   
-	    ! esta modif de mlp implica anular el correc (deberia revisar esto)
-		      
-	    mr(i) = dble(co2y(i)/nty(i))	! malv, jan 98  
-
-	    !-----------------------------------------------------------------
-
-	end do     
-            
-! como  beta y 1.d5 son comunes a todas las weighted absorber amounts,  
-! los simplificamos:    
-!	coninf = beta * 1.d5 * dble( con(n) / log( con(n-1) / con(n) ) )      
-	!write (*,*)  ' con(nz), con(nz-1)  =', con(nz), con(nz-1)        
-	coninf = dble( con(nzy) / log( con(nzy-1) / con(nzy) ) )      
-	!write (*,*)  ' coninf =', coninf       
-            
-ccc         
-ccc  temp dependence of the band strength and   
-ccc  nlte correction factor for the absorber amount         
-ccc         
-	call mztf_correccion ( coninf, con, ib, isot, itableout ) 
-            
-ccc         
-ccc reads histogrammed spectral data (strength for lte and vmr=1)       
-ccc         
-	!hfile1 = dirspec//'hi'//dn      !Ya no hacemos distincion d/n en esto
-!!	hfile1 = dirspec//'hid'          !(see why in his.for)
-!	hfile1='hid'
-!!	if (ib.eq.13 .or. ib.eq.14 ) hfile1 = dirspec//'his'       
-!	if (ib.eq.13 .or. ib.eq.14 ) hfile1 = 'his'
-            
-!	if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5     
-!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
-!	   if (isot.eq.1) hisfile = hfile1//'26-'//ibcode1//'.dat' 
-!	   if (isot.eq.2) hisfile = hfile1//'28-'//ibcode1//'.dat' 
-!	   if (isot.eq.3) hisfile = hfile1//'36-'//ibcode1//'.dat' 
-!	   if (isot.eq.4) hisfile = hfile1//'27-'//ibcode1//'.dat' 
-!	   if (isot.eq.5) hisfile = hfile1//'62-'//ibcode1//'.dat' 
-!	else       
-!	   if (isot.eq.1) hisfile = hfile1//'26-'//ibcode2//'.dat' 
-!	   if (isot.eq.2) hisfile = hfile1//'28-'//ibcode2//'.dat' 
-!	   if (isot.eq.3) hisfile = hfile1//'36-'//ibcode2//'.dat' 
-!	   if (isot.eq.4) hisfile = hfile1//'27-'//ibcode2//'.dat' 
-!	   if (isot.eq.5) hisfile = hfile1//'62-'//ibcode2//'.dat' 
-!	endif      
-!	write (*,*) 'hisfile: ', hisfile       
-            
-! the argument to rhist is to make this compatible with mztf_comp.f,    
-! which is a useful modification of mztf.f (to change strengths of bands
-!	call rhist (1.0)       
-	if(ib.eq.1) then
-	   if(isot.eq.1) then !Case 1
-	      mm=mm_c1
-	      nbox=nbox_c1
-	      tmin=tmin_c1
-	      tmax=tmax_c1
-	      do i=1,nbox_max
-		 no(i)=no_c1(i)
-		 dist(i)=dist_c1(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c1(j,i)
-		    xls1(j,i)=xls1_c1(j,i)
-		    xln1(j,i)=xln1_c1(j,i)
-		    xld1(j,i)=xld1_c1(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c1(j)
-	      enddo
-	   else if(isot.eq.2) then !Case 2
-	      mm=mm_c2
-	      nbox=nbox_c2
-	      tmin=tmin_c2
-	      tmax=tmax_c2
-	      do i=1,nbox_max
-		 no(i)=no_c2(i)
-		 dist(i)=dist_c2(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c2(j,i)
-		    xls1(j,i)=xls1_c2(j,i)
-		    xln1(j,i)=xln1_c2(j,i)
-		    xld1(j,i)=xld1_c2(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c2(j)
-	      enddo
-	   else if(isot.eq.3) then !Case 3
-	      mm=mm_c3
-	      nbox=nbox_c3
-	      tmin=tmin_c3
-	      tmax=tmax_c3
-	      do i=1,nbox_max
-		 no(i)=no_c3(i)
-		 dist(i)=dist_c3(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c3(j,i)
-		    xls1(j,i)=xls1_c3(j,i)
-		    xln1(j,i)=xln1_c3(j,i)
-		    xld1(j,i)=xld1_c3(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c3(j)
-	      enddo
-	   else if(isot.eq.4) then !Case 4
-	      mm=mm_c4
-	      nbox=nbox_c4
-	      tmin=tmin_c4
-	      tmax=tmax_c4
-	      do i=1,nbox_max
-		 no(i)=no_c4(i)
-		 dist(i)=dist_c4(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c4(j,i)
-		    xls1(j,i)=xls1_c4(j,i)
-		    xln1(j,i)=xln1_c4(j,i)
-		    xld1(j,i)=xld1_c4(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c4(j)
-	      enddo
-	   else
-	      write(*,*)'isot must be 2,3 or 4 for ib=1!!'
-	      write(*,*)'stop at mztvc/310'
-	      stop
-	   endif
-	else if (ib.eq.2) then
-	   if(isot.eq.1) then	!Case 5
-	      mm=mm_c5
-	      nbox=nbox_c5
-	      tmin=tmin_c5
-	      tmax=tmax_c5
-	      do i=1,nbox_max
-		 no(i)=no_c5(i)
-		 dist(i)=dist_c5(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c5(j,i)
-		    xls1(j,i)=xls1_c5(j,i)
-		    xln1(j,i)=xln1_c5(j,i)
-		    xld1(j,i)=xld1_c5(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c5(j)
-	      enddo
-	   else
-	      write(*,*)'isot must be 1 for ib=2!!'
-	      write(*,*)'stop at mztvc/334'
-	      stop
-	   endif
-	else if (ib.eq.3) then
-	   if(isot.eq.1) then	!Case 6
-	      mm=mm_c6
-	      nbox=nbox_c6
-	      tmin=tmin_c6
-	      tmax=tmax_c6
-	      do i=1,nbox_max
-		 no(i)=no_c6(i)
-		 dist(i)=dist_c6(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c6(j,i)
-		    xls1(j,i)=xls1_c6(j,i)
-		    xln1(j,i)=xln1_c6(j,i)
-		    xld1(j,i)=xld1_c6(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c6(j)
-	      enddo
-	   else
-	      write(*,*)'isot must be 1 for ib=3!!'
-	      write(*,*)'stop at mztvc/358'
-	      stop
-	   endif
-	else if (ib.eq.4) then
-	   if(isot.eq.1) then	!Case 7
-	      mm=mm_c7
-	      nbox=nbox_c7
-	      tmin=tmin_c7
-	      tmax=tmax_c7
-	      do i=1,nbox_max
-		 no(i)=no_c7(i)
-		 dist(i)=dist_c7(i)
-		 do j=1,nhist
-		    sk1(j,i)=sk1_c7(j,i)
-		    xls1(j,i)=xls1_c7(j,i)
-		    xln1(j,i)=xln1_c7(j,i)
-		    xld1(j,i)=xld1_c7(j,i)
-		 enddo
-	      enddo
-	      do j=1,nhist 
-		 thist(j)=thist_c7(j)
-	      enddo
-	   else
-	      write(*,*)'isot must be 1 for ib=4!!'
-	      write(*,*)'stop at mztvc/382'
-	      stop
-	   endif
-	else 
-	   write(*,*)'ib must be 1,2,3 or 4!!'
-	   write(*,*)'stop at mztvc/387'
-	endif
-            
-            
-c******     
-c****** calculation of tau(1,ir) for 1<=r      
-c******     
-	call initial           
-            
-	ff=1.0e10              
-
-	in=1         
-            
-        tau(in,1) = 1.d0 
-
- 	call initial          
-	call intz (zl(in), c1,p1,mr1,t1, con)          
-	do kr=1,nbox           
-	  ta(kr) = t1          
-	end do     
-	call interstrength (st1,t1,ka,ta)  
-	do kr=1,nbox           
-	  c1box(kr) = c1 * ka(kr) * dble(deltaz)       
-	end do     
-	c1 = c1 * st1 * dble(deltaz)       
-            
-	do 2 ir=2,nl        
-            
-	call intz (zl(ir), c2,p2,mr2,t2, con)          
-	do kr=1,nbox           
-	  ta(kr) = t2          
-	end do     
-	call interstrength (st2,t2,ka,ta)  
-	do kr=1,nbox           
-	  c2box(kr) = c2 * ka(kr) * dble(deltaz)       
-	end do     
-	c2 = c2 * st2 * dble(deltaz)       
-            
-	aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0        
-	bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 
-	cc = cc + ( c1 + c2 ) / 2.d0       
-	dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 
-	do kr=1,nbox           
-	  ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) ) /2.d0  
-	  ddbox(kr) = ddbox(kr) + ( t1*c1box(kr) + t2*c2box(kr) ) /2.d0        
-	end do     
-            
-	mr1=mr2    
-	t1=t2      
-	c1=c2      
-	p1=p2      
-	do kr=1,nbox	          
-	  c1box(kr) = c2box(kr)            
-	end do     
-            
-	pt = bb / cc           
-	pp = aa / (cc * ff)    
-            
-	ts = dd/cc             
-        do kr=1,nbox    
-   	    ta(kr) = ddbox(kr) / ccbox(kr)          
-	end do     
-	call interstrength(st,ts,ka,ta)    
-	call intershape(alsa,alna,alda,ta) 
-
-            
-	eqwmu = 0.0d0          
-	do im = 1,iimu         
-	  eqw=0.0d0            
-          do kr=1,nbox  
-		ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im)
-	        call findw(ig,iirw, idummy,c1,p1,Desp,wsL)           
-		if ( i_supersat .eq. 0 ) then     
-	          eqw=eqw+no(kr)*w         
-		else      
-		   eqw = w + (no(kr)-1) * ( asat_box*dist(kr) )           
-		endif     
-	  end do   
-	  eqwmu = eqwmu + eqw * mu(im)*amu(im)         
-	end do     
-            
- 	tau(in,ir) = exp( - eqwmu / dble(deltanu(isot,ib)) )  
-            
- 2	continue             
-            
-            
-           
-c           
-c due to the simmetry of the transmittances     
-c           
- 	do in=nl,2,-1  
-		tau(in,1) = tau(1,in)           
-	end do           
-            
-        vc(1) = 0.0d0                         
-        vc(nl) = 0.0d0                         
-	do in=2,nl-1          ! poner aqui nl-1 luego          
-	  vc(in) =  pi*deltanu(isot,ib)/( 2.d0*deltaz*1.d5 ) *     
-     @  		( tau(in-1,1) - tau(in+1,1) )         
-	end do			                                      
-  
-            
-c end       
-	return     
-	end        
Index: unk/LMDZ.MARS/libf/phymars/mztvc_626fh.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/mztvc_626fh.F	(revision 497)
+++ 	(revision )
@@ -1,91 +1,0 @@
-c***********************************************************************
-                                                            
-	subroutine mztvc_626fh(ig)
-
-c       jul 2011 malv+fgg
-c***********************************************************************
-                                                            
-	implicit none                                  
-                                                            
-!!!!!!!!!!!!!!!!!!!!!!!                         
-! common variables & constants                  
-                                                            
-	include 'nltedefs.h'          
-	include 'nlte_atm.h'        
-	include 'nlte_data.h'       
-        include 'tcr_15um.h'
-	include 'nlte_matrix.h'      
-	include 'nlte_curtis.h'      
-                                                            
-!!!!!!!!!!!!!!!!!!!!!!!                         
-! arguments                                     
-                 
-        integer   ig   ! ADDED FOR TRACEBACK
-                                                            
-!!!!!!!!!!!!!!!!!!!!!!!                         
-! local variables                               
-                                                            
-	real*4 cdummy(nl,nl), csngl(nl,nl)             
-                                                            
-	real*8 cax1(nl,nl), cax2(nl,nl), cax3(nl,nl)   
-	real*8 v1(nl), v2(nl), v3(nl), cm_factor, vc_factor        
-                                                            
-	integer itauout,icfout,itableout, interpol,ismooth, isngldble          
-	integer i,j,ik,ist,isot,ib,itt                 
-                                                            
-	!character 	bandcode*2
-	character 	isotcode*2
-	!character 	codmatrx_hot*5                      
-                                                            
-!!!!!!!!!!!!!!!!!!!!!!!                         
-! external functions                            
-                                                            
-	external bandid                                
-	character*2 bandid                             
-                                                            
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!               
-! subroutines called:                           
-! 	mz4sub, dmzout, readc_mz4, readcupdw, mztf   
-                                                            
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!               
-! formatos                                      
- 132	format(i2)                                 
-                                                            
-************************************************************************
-************************************************************************
-                                                            
-	isngldble = 1		! =1 --> dble precission        
-                                                            
-	fileroot = 'cfl'                               
-                                                            
-	ist = 1                                        
-	isot = 26                                      
- 	write (isotcode,132) isot  
-                             
-        call zerov( vc121, nl )
-
-	do 11, ik=1,3                                  
-                                                            
-	  ib=ik+1                                      
-                                                            
-          call mztvc (ig,v1, ib, 1, irw_mztf, imu, 0,0,0 ) 
-                                                            
-	  do i=1,nl                                    
-                                                            
-	    if(ik.eq.1)then                            
-		vc_factor = dble(667.75/618.03)               
-	    elseif(ik.eq.2)then                        
-		vc_factor = 1.d0                              
-	    elseif(ik.eq.3)then                        
-		vc_factor = dble(667.75/720.806)              
-	    end if                                     
-                                                            
-	    vc121(i) = vc121(i) + v1(i) * vc_factor    
-
-	  end do          
-                                                            
-11	continue                                     
-                                                            
-                                                            
-	return                                         
-	end                                            
Index: /trunk/LMDZ.MARS/libf/phymars/nir_leedat.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/nir_leedat.F	(revision 498)
+++ /trunk/LMDZ.MARS/libf/phymars/nir_leedat.F	(revision 498)
@@ -0,0 +1,38 @@
+c***********************************************************************
+      subroutine NIR_leedat                              
+                                                
+c 	reads parameters for NIR NLTE calculation    
+                                                
+c 	nov 2011    fgg+malv    first version                
+c***********************************************************************
+
+      implicit none                                  
+                                                
+      include 'datafile.h'
+      include 'nirdata.h'
+                                                
+                                                
+c local variables                               
+
+      integer 	ind                      
+
+                              
+c***********************************************************************
+
+      open(43,file=trim(datafile)//'/NIRcorrection_feb2011.dat',
+     $       status='old')         
+      do ind=1,9
+         read(43,*)
+      enddo
+      
+      do ind=1,npres
+         read(43,*)pres1d(ind),corgcm(ind),oco21d(ind),p1999(ind),
+     $        alfa(ind)
+                                !Tabulated pression to Pa
+         pres1d(ind)=pres1d(ind)*100.
+      enddo
+      close(43)
+
+      return
+
+      end
Index: /trunk/LMDZ.MARS/libf/phymars/nirco2abs.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/nirco2abs.F	(revision 497)
+++ /trunk/LMDZ.MARS/libf/phymars/nirco2abs.F	(revision 498)
@@ -49,5 +49,5 @@
 #include "callkeys.h"
 #include "comdiurn.h"
-#include "NIRdata.h"
+#include "nirdata.h"
 
 c-----------------------------------------------------------------------
Index: /trunk/LMDZ.MARS/libf/phymars/nirdata.h
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/nirdata.h	(revision 498)
+++ /trunk/LMDZ.MARS/libf/phymars/nirdata.h	(revision 498)
@@ -0,0 +1,8 @@
+
+      integer npres                ! Number of pressures in NIR correction
+      parameter (npres=42)         ! table
+
+      common /NIRdata/ pres1d,corgcm,oco21d,alfa,p1999
+      real    pres1d(npres)
+      real    corgcm(npres)
+      real    oco21d(npres),alfa(npres),p1999(npres)
Index: unk/LMDZ.MARS/libf/phymars/nlte_atm.h
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/nlte_atm.h	(revision 497)
+++ 	(revision )
@@ -1,40 +1,0 @@
-c****************************************************************************
-c
-c       atmref.cmn
-c
-c       Common blocks of constants and variables for the model atmosphere
-c
-c       jan 2007 Malv+gg        Addition ions 
-c       2003    FGG             Double precision
-c       JAN 98  MALV            First version
-c****************************************************************************
-
-
-c Subgrid atmosphere interpolated from /atmx/ actually used by the some
-c modules, particularly by the NLTE ones
-c
-        common /atm_nl/ zl, t, pl, sh, nt, co2, n2, co, o3p, o2, h2, ar,
-     @    co2vmr, n2vmr, covmr, o3pvmr, o2vmr, h2vmr, arvmr,
-     @    nvmr, novmr, 
-     @    hrkday_factor
-
-        real zl(nl), t(nl), pl(nl), nt(nl),  sh(nl),
-     @    co2(nl), n2(nl), co(nl), o3p(nl), o2(nl), h2(nl), ar(nl),
-     @    co2vmr(nl), n2vmr(nl), covmr(nl), o3pvmr(nl), o2vmr(nl),
-     @    h2vmr(nl), arvmr(nl), 
-     @    nvmr(nl), novmr(nl), hrkday_factor(nl)
-
-c Subgrid atmosphere obtained from the input atmosphere and limited to the
-c NLTE grid. Only used for computing transmitances. 
-c
-        common /atm_ny/ zy, ty, py, nty, co2y, coy
-        real zy(nzy), ty(nzy), py(nzy), nty(nzy), co2y(nzy), coy(nzy)
-
-c
-	common/deltazetas/ deltaz, deltazy, 
-     @        jlowerboundary, jtopboundary
-	real    deltaz, deltazy
-	integer jlowerboundary, jtopboundary
-
-
-c****************************************************************************
Index: /trunk/LMDZ.MARS/libf/phymars/nlte_aux.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/nlte_aux.F	(revision 498)
+++ /trunk/LMDZ.MARS/libf/phymars/nlte_aux.F	(revision 498)
@@ -0,0 +1,2023 @@
+c***********************************************************************
+c     File with all subroutines required by mztf      
+c     Subroutines previously included in mztfsub_overlap.F
+c                                               
+c     jan 98	malv 		basado en mztfsub_solar        
+c     jul 2011 malv+fgg   adapted to LMD-MGCM
+c                                               
+c contiene:                                     
+c     initial                                 
+c     intershape                              
+c     interstrength                           
+c     intz                                    
+c     rhist                                   
+c     we                                      
+c     simrul                                 
+c     fi                                      
+c     f                                       
+c     findw                                   
+c     voigtf                                  
+c***********************************************************************
+                                                
+c     ****************************************************************
+      subroutine initial                             
+                                                
+c     ma & crs	!evita troubles 16-july-96           
+c     ****************************************************************
+                                                
+      implicit none                                  
+                                                
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+                                                
+c local variables                               
+      integer 	i                                     
+                                                
+c     ***************                               
+                                                
+      eqw = 0.0d00                                   
+      aa = 0.0d00                                    
+      bb = 0.0d00                                    
+      cc = 0.0d00                                    
+      dd = 0.0d00                                    
+                                                
+      do i=1,nbox                                    
+         ua(i) = 0.0d0                                
+         ccbox(i) = 0.0d0                             
+         ddbox(i) = 0.0d0                             
+      end do                                         
+                                                
+      return                                         
+      end                                            
+                                                
+c     **********************************************************************
+      subroutine intershape(alsx,alnx,adx,xtemp)     
+c     interpolates the line shape parameters at a temperature xtemp from    
+c     input histogram data.                         
+c     **********************************************************************
+                                                
+      implicit none                                  
+      
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+                                                
+c arguments                                     
+      real*8 alsx(nbox_max),alnx(nbox_max),adx(nbox_max),
+     &     xtemp(nbox_max)     
+                                                
+c local variables                               
+      integer 	i, k                                  
+                                                
+c     ***********                                   
+                                                
+!     write (*,*)  'intershape  xtemp =', xtemp                      
+                                                
+      do 1, k=1,nbox     
+         if (xtemp(k).gt.tmax) then 
+            write (*,*) ' WARNING !  Tpath,tmax= ',xtemp(k),tmax
+            xtemp(k) = tmax        
+         endif
+         if (xtemp(k).lt.tmin) then
+            write (*,*) ' WARNING !  Tpath,tmin= ',xtemp(k),tmin
+            xtemp(k) = tmin        
+         endif   
+               
+         i = 1                                        
+         do while (i.le.mm)                           
+	    i = i + 1                                  
+            
+	    if (abs(xtemp(k)-thist(i)) .lt. 1.0d-4) then !evita troubles     
+               alsx(k)=xls1(i,k) !16-july-1996      
+               alnx(k)=xln1(i,k)                        
+               adx(k)=xld1(i,k)                         
+               goto 1                                   
+	    elseif ( thist(i) .le. xtemp(k) ) then     
+               alsx(k) = (( xls1(i,k)*(thist(i-1)-xtemp(k)) +       
+     @              xls1(i-1,k)*(xtemp(k)-thist(i)) )) /
+     $              (thist(i-1)-thist(i))
+               alnx(k) = (( xln1(i,k)*(thist(i-1)-xtemp(k)) +       
+     @              xln1(i-1,k)*(xtemp(k)-thist(i)) )) /
+     $              (thist(i-1)-thist(i))
+               adx(k)  = (( xld1(i,k)*(thist(i-1)-xtemp(k)) +       
+     @              xld1(i-1,k)*(xtemp(k)-thist(i)) )) /
+     $              (thist(i-1)-thist(i))
+               goto 1                                   
+	    end if                                     
+         end do                                       
+         write (*,*)  
+     @        ' error in xtemp(k). it should be between tmin and tmax'
+ 1    continue                                      
+                                                
+      return                                        
+      end                                            
+c     **********************************************************************
+      subroutine interstrength (stx, ts, sx, xtemp)  
+c     interpolates the line strength at a temperature xtemp from            
+c     input histogram data.                         
+c     **********************************************************************
+                                                
+      implicit none                                  
+                                                
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+                                                
+c arguments                                     
+      real*8 		stx     ! output, total band strength    
+      real*8		ts      ! input, temp for stx              
+      real*8		sx(nbox_max) ! output, strength for each box  
+      real*8		xtemp(nbox_max) ! input, temp for sx        
+                                                
+c local variables                               
+      integer 	i, k                                  
+                                                
+c	***********                                   
+                                                
+      do 1, k=1,nbox                                 
+!          if(xtemp(k).lt.ts)then
+!             write(*,*)'***********************'
+!             write(*,*)'mztfsub_overlap/EEEEEEH!',xtemp(k),ts,k
+!             write(*,*)'***********************'
+!          endif
+         if (xtemp(k).gt.tmax) xtemp(k) = tmax        
+         if (xtemp(k).lt.tmin) xtemp(k) = tmin        
+         i = 1                                        
+         do while (i.le.mm-1)                         
+	    i = i + 1         
+!            write(*,*)'mztfsub_overlap/136',i,xtemp(k),thist(i)
+	    if ( abs(xtemp(k)-thist(i)) .lt. 1.0d-4 ) then         
+               sx(k) = sk1(i,k)                         
+!              write(*,*)'mztfsub_overlap/139',sx(k),k,i
+               goto 1                                   
+	    elseif ( thist(i) .le. xtemp(k) ) then     
+               sx(k) = ( sk1(i,k)*(thist(i-1)-xtemp(k)) + sk1(i-1,k)*           
+     @              (xtemp(k)-thist(i)) ) / (thist(i-1)-thist(i))  
+!              write(*,*)'mztfsub_overlap/144',sx(k),k,i
+               goto 1                                   
+	    end if                                     
+         end do                                       
+         write (*,*)  ' error in xtemp(kr) =', xtemp(k),               
+     @        '. it should be between '                    
+         write (*,*)  ' tmin =',tmin, '   and   tmax =',tmax           
+         stop                                         
+ 1    continue                                     
+                                                
+      stx = 0.d0                                     
+      if (ts.gt.tmax) ts = dble( tmax )              
+      if (ts.lt.tmin) ts = dble( tmin )              
+      i = 1                                          
+      do while (i.le.mm-1)                           
+         i = i + 1                                    
+!     write(*,*)'mztfsub_overlap/160',i,ts,thist(i)
+         if ( abs(ts-thist(i)) .lt. 1.0d-4 ) then     
+	    do k=1,nbox                                
+               stx = stx + no(k) * sk1(i,k)    
+!     write(*,*)'mztfsub_overlap/164',stx
+	    end do                                     
+	    return                                     
+         elseif ( thist(i) .le. ts ) then             
+	    do k=1,nbox                                
+               stx = stx + no(k) * (( sk1(i,k)*(thist(i-1)-ts) +    
+     @              sk1(i-1,k)*(ts-thist(i)) )) / (thist(i-1)-thist(i))      
+!              write(*,*)'mztfsub_overlap/171',stx
+	    end do                                     
+!     stop
+	    return                                     
+         end if                                       
+      end do  
+                                                
+      return                                        
+      end
+
+                                            
+c     **********************************************************************
+      subroutine intz(h,aco2,ap,amr,at, con)         
+c     return interp. concentration, pressure,mixing ratio and temperature   
+c     for a input height h                          
+c     **********************************************************************
+                                                
+      implicit none                                  
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+                                                
+c arguments                                     
+      real		h       ! i 
+      real*8		con(nzy) ! i                          
+      real*8		aco2, ap, at, amr ! o                  
+                                                
+c local variables                               
+      integer		k                                     
+                                                
+c     ************                                  
+                                                
+      if ( ( h.lt.zy(1) ).and.( h.le.-1.e-5 ) ) then 
+         write (*,*) ' zp= ',h,' zy(1)= ',zy(1)                         
+         stop'from intz: error in interpolation, z < minimum height'
+      elseif (h.gt.zy(nzy)) then                      
+         write (*,*) ' zp= ',h,' zy(nzy)= ',zy(nzy)                       
+         stop'from intz: error in interpolation, z > maximum height'
+      end if                                         
+                                                
+      if (h.eq.zy(nzy)) then                          
+         ap  = dble( py(nzy)  )                       
+         aco2= con(nzy)                               
+         at  = dble( ty(nzy)  )                         
+         amr = dble( mr(nzy) )                          
+         return                                        
+      end if                                         
+                                                
+      do k=1,nzy-1                                    
+         if( abs( h-zy(k) ).le.( 1.e-5 ) ) then        
+            ap  = dble( py(k)  )                       
+            aco2= con(k)                               
+            at  = dble( ty(k)  )                         
+            amr = dble( mr(k) )                          
+            return                                       
+         elseif(h.gt.zy(k).and.h.lt.zy(k+1))then       
+            ap = dble( exp( log(py(k)) + log(py(k+1)/py(k)) *         
+     @           (h-zy(k)) / (zy(k+1)-zy(k)) ) )             
+            aco2 = exp( log(con(k)) + log( con(k+1)/con(k) ) *        
+     @           (h-zy(k)) / (zy(k+1)-zy(k)) )               
+            at = dble( ty(k)+(ty(k+1)-ty(k))*(h-zy(k))/
+     @           (zy(k+1)-zy(k)) )
+            amr = dble( mr(k)+(mr(k+1)-mr(k))*(h-zy(k))/
+     @           (zy(k+1)-zy(k)) ) 
+            return                                       
+         end if                                        
+      end do                                         
+                                                
+      return                                         
+      end                                            
+                                                
+                                            
+                                                
+c     **********************************************************************
+      real*8 function we(ig,me,pe,plaux,idummy,nt_local,p_local,
+     $     Desp,wsL)  
+c     icls=5 -->para mztf                           
+c     icls=1,2,3-->para fot, line shape (v=1,l=2,d=3) (only use if wr=2)    
+c     calculates an approximate equivalent width for an error estimate.     
+c                                               
+c     ioverlap = 0  ....... no correction for overlaping        
+c     1  ....... "lisat" first correction (see overlap_box.
+c     2  .......    "      "    "  plus "supersaturation"  
+                                           
+c     idummy=0   do nothing
+c     1   write out some values for diagnostics
+c     2   correct the Strong Lorentz behaviour for SZA>90
+c     3   casos 1 & 2
+     
+c     malv   nov-98    add overlaping's corrections       
+c     **********************************************************************
+                                                
+      implicit none                                  
+      
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+                                                
+c arguments                 
+      integer         ig        ! ADDED FOR TRACEBACK
+      real*8		me      ! I. path's absorber amount  
+      real*8          pe        ! I. path's presion total
+      real*8          plaux     ! I. path's partial pressure of CO2
+      real*8          nt_local  ! I. needed for strong limit of Lorentz profil
+      real*8          p_local   ! I.    "          "              "
+      integer         idummy    ! I. indica varias opciones
+      real*8          wsL       ! O. need this for strong Lorentz correction
+      real*8          Desp      ! I. need this for strong Lorentz correction
+      
+c local variables                               
+      integer 	i                                     
+      real*8 		y,x,wl,wd                    
+      real*8		cn(0:7),dn(0:7)                        
+      real*8 		pi, xx                                
+      real*8          f_sat_box                      
+      real*8          dv_sat_box, dv_corte_box       
+      real*8          area_core_box, area_wing_box   
+      real*8          wlgood , parentesis , xlor
+      real*8          wsl_grad
+  
+	                                               
+c data blocks                                   
+      data cn/9.99998291698d-1,-3.53508187098d-1,9.60267807976d-2,           
+     @     -2.04969011013d-2,3.43927368627d-3,-4.27593051557d-4,    
+     @     3.42209457833d-5,-1.28380804108d-6/          
+      data dn/1.99999898289,5.774919878d-1,-5.05367549898d-1,    
+     @     8.21896973657d-1,-2.5222672453,6.1007027481, 
+     @     -8.51001627836,4.6535116765/                 
+                                                
+c     ***********                                   
+                                                
+c     equivalent width of atmospheric line.         
+                                                
+      pi = acos(-1.d0)                               
+
+      if ( idummy.gt.9 )
+     @     write (*,*) ' S, m, alsa, pp =', ka(kr), me, alsa(kr), plaux
+      
+      y=ka(kr)*me                                
+!     x=y/(2.0*pi*(alsa(kr)*pl+alna(kr)*(pe-pl)))    
+      x=y/(2.0d0*pi* alsa(kr)*plaux) !+alna(kr)*(pe-pl)))           
+
+! Strong limit of Lorentz profile:  WL = 2 SQRT( S * m * alsa*pl )
+! Para anular esto, comentar las siguientes 5 lineas
+!        if ( x .gt. 1.e6 ) then 
+!           wl = 2.0*sqrt( y * alsa(kr)*pl )
+!        else
+!	   wl=y/sqrt(1.0d0+pi*x/2.0d0)                        
+!        endif
+
+      wl=y/sqrt(1.0d0+pi*x/2.0d0)                        
+
+      if (wl .le. 0.d0) then 
+         write(*,*)'mztfsub_overlap/496',ig,y,ka(kr),me,kr
+         stop'WE/Lorentz EQW zero or negative!/498' !,ig
+      endif
+
+      if ( idummy.gt.9 ) 
+     @     write (*,*) ' y, x =', y, x
+
+      xlor = x
+      if ( (idummy.eq.2 .or. idummy.eq.12) .and. xlor.gt.1e5 ) then
+                                         ! en caso que estemos en el regimen
+                                         ! Strong Lorentz y la presion local 
+                                         ! vaya disminuyendo, corregimos la EQW
+                                         ! con un gradiente analitico (notebook)
+         wsL = 2.0*sqrt( y * alsa(kr)*plaux ) 
+         wsl_grad = - 2.d0 * ka(kr)*alsa(kr) * nt_local*p_local / wsL
+         wlgood = w_strongLor_prev(kr) + wsl_grad * Desp
+         if (idummy.eq.12) 
+     @        write (*,*) ' W(wrong), W_SL, W_SL prev, W_SL corrected=', 
+     @        wl, wsL, w_strongLor_prev(kr), wlgood
+         wl = wlgood
+      endif
+        ! wsL = wl  pero esto no lo hacemos todavia, porque necesitamos 
+        !           el valor que ahora mismo tiene wsL para corregir la
+        !           expresion R&W below
+
+!        write (*,*) 'WE arguments me,pe,pl =', me,pe,pl
+!        write (*,*) 'WE/ wl,ka(kr),alsa(kr) =', 
+!     @       wl, ka(kr),alsa(kr)
+
+
+!>>>>>>>
+ 500  format (a,i3,3(2x,1pe15.8))
+ 600  format (a,2(2x,1pe16.9))
+ 700  format (a,3(1x,1pe16.9))
+!        if (kr.eq.8 .or. kr.eq.13) then  
+!           write (*,500) 'WE/kr,m,pt,pl=', kr, me, pe, pl
+!           write (*,700) '  /aln,als,d_x=', alna(kr),alsa(kr),
+!     @                2.0*pi*( alsa(kr)*pl + alna(kr)*(pe-pl) )
+!           write (*,600) '  /alsa*p_CO2, alna*p_n2 :', 
+!     @             alsa(kr)*pl, alna(kr)*(pe-pl)
+!           write (*,600) '  a*p, S =', 
+!     @                 alsa(kr)*pl + alna(kr)*(pe-pl)  , ka(kr)
+!           write (*,600) '  /S*m, x =', y, x
+!           write (*,600) '  /aprox, WL =',  
+!     @         2.*sqrt( y*( alsa(kr)*pl+alna(kr)*(pe-pl) ) ), WL
+!        endif
+	!                                              
+	! corrections to lorentz eqw due to overlaping and super-saturation    
+	!                                              
+                                                
+      i_supersat = 0                                 
+                                                
+      if ( icls.eq.5 .and. ioverlap.gt.0 ) then      
+	   ! for the moment, only consider overlaping for mztf.f, not fot.f    
+                                                
+	   ! definition of saturation in the lisat model           
+	   !                                           
+         asat_box = 0.99d0                           
+         f_sat_box = 2.d0 * x                        
+         xx = f_sat_box / log( 1./(1-asat_box) )     
+         if ( xx .lt. 1.0d0 ) then                   
+            dv_sat_box = 0.0d0                       
+            asat_box = 1.0d0 - exp( - f_sat_box )    
+         else                                        
+            dv_sat_box = alsa(kr) * sqrt( xx - 1.0d0 )           
+	      ! approximation: only use of alsa in mars and venus  
+         endif                                       
+                                                
+	   ! area of saturated line                    
+	   !                                           
+         area_core_box = 2.d0 * dv_sat_box * asat_box            
+         area_wing_box = 0.5d0 * ( wl - area_core_box )          
+         dv_corte_box = dv_sat_box + 2.d0*area_wing_box/asat_box 
+	                                               
+	   ! super-saturation or simple overlaping?    
+	   !                                           
+!	   i_supersat = 0                             
+         xx = dv_sat_box - ( 0.5d0 * dist(kr) )      
+         if ( xx .ge. 0.0       ! definition of supersaturation  
+     @        .and. dv_sat_box .gt. 0.0 ! definition of saturation 
+     @        .and. (dist(kr).gt.0.0) ) ! box contains more than 1 line 
+     @	 		            ! and not too far apart       
+     @        then                                         
+                                                
+            i_supersat = 1                           
+                                                
+         else                                        
+	   ! no super-saturation, then use "lisat + first correction", i.e.,   
+	   ! correct for line products                 
+	   !                                           
+                                                
+            wl = wl                                  
+                                                
+         endif                                       
+                                                
+      end if                    ! end of overlaping loop           
+
+      if (icls.eq.2) then 
+         we = wl              
+         return
+      endif
+
+cc  doppler limit:    
+      if ( idummy.gt.9 ) 
+     @     write (*,*) ' S*m, alf_dop =', y, alda(kr)*sqrt(pi)
+
+      x = y / (alda(kr)*sqrt(pi))  
+      if ( x.lt.1.e-10 ) then   ! to avoid underflow
+         wd = y
+      else
+         wd=alda(kr)*sqrt(4.0*pi*x**2*(1.0+log(1.0+x))/(4.0+pi*x**2))
+      endif
+      if ( idummy.gt.9 )
+     @     write (*,*) ' wd =', wd
+                                     
+cc  doppler weak limit                          
+c	wd = ka(kr) * me                              
+                                                
+cc  good doppler                                
+      if(icls.eq.5) then	!para mztf                  
+	 !write (*,*) 'para mztf, icls=',icls                           
+	 if (x.lt.5.) then                             
+            wd = 0.d0                                    
+            do i=0,7                                     
+               wd = wd + cn(i) * x**i                     
+            end do                                       
+            wd = alda(kr) * x * sqrt(pi) * wd            
+	 elseif (x.gt.5.) then                         
+            wd = 0.d0                                    
+            do i=0,7                                     
+               wd = wd + dn(i) / (log(x))**i              
+            end do                                       
+            wd = alda(kr) * sqrt(log(x)) * wd            
+	 else                                          
+            stop ' x should not be less than zero'        
+	 end if                                        
+      end if                                         
+                                                
+
+      if ( i_supersat .eq. 0 ) then                  
+
+         parentesis = wl**2+wd**2-(wd*wl/y)**2
+				! changed +(wd*wl/y)**2 to -...14-3-84      
+
+         if ( parentesis .lt. 0.0 ) then 
+            if ((idummy.eq.2 .or. idummy.eq.12) .and. xlor.gt.1e5) then
+               parentesis = wl**2+wd**2-(wd*wsL/y)**2
+                                ! este cambio puede ser necesario cuando se hace
+                                ! correccion Strong Lor, para evitar valores
+                                ! negativos del parentesis en sqrt( )
+            else
+               stop ' WE/ Error en las EQW  wl,wl,y '
+            endif
+         endif
+
+         we = sqrt( parentesis )
+!	   write (*,*)  ' from we: xdop,alda,wd', sngl(x),alda(kr),sngl(wd)
+!	   write (*,*)  ' from we: we', we                             
+
+      else                                           
+
+         we = wl                                     
+	  ! if there is supersaturation we can ignore wd completely;           
+	  ! mztf.f will compute the eqw of the whole box afterwards            
+
+      endif                                          
+                                                
+      if (icls.eq.3) we = wd                         
+      
+      if ( idummy.gt.9 )
+     @     write (*,*) ' wl,wd,w =', wl,wd,we
+      
+      wsL = wl 
+
+      return                                         
+      end                                            
+                                                
+      
+c     **********************************************************************
+      real*8 function simrul(a,b,fsim,c,acc)         
+c     adaptively integrates fsim from a to b, within the criterion acc.     
+c     **********************************************************************
+        
+      implicit none
+                          
+      real*8 res,a,b,g0,g1,g2,g3,g4,d,a0,a1,a2,h,x,acc,c,fsim
+      real*8 s1(70),s2(70),s3(70)
+      real*8 c1, c2
+      integer*4 m,n,j                                
+                                                
+      res=0.                                         
+      c=0.                                           
+      m=0                                            
+      n=0                                            
+      j=30                                           
+      g0=fsim(a)                                     
+      g2=fsim((a+b)/2.)                              
+      g4=fsim(b)                                     
+      a0=(b-a)*(g0+4.0*g2+g4)/2.0                    
+ 1    d=2.0**n                                  
+      h=(b-a)/(4.0*d)                                
+      x=a+(4.0*m+1.0)*h                              
+      g1=fsim(x)                                     
+      g3=fsim(x+2.0*h)                               
+      a1=h*(g0+4.0*g1+g2)                            
+      a2=h*(g2+4.0*g3+g4)                            
+      if ( abs(a1+a2-a0).gt.(acc/d)) goto 2          
+      res=res+(16.0*(a1+a2)-a0)/45.0                 
+      m=m+1                                          
+      c=a+m*(b-a)/d                                  
+ 6    if (m.eq.(2*(m/2))) goto 4                
+      if ((m.ne.1).or.(n.ne.0)) goto 5               
+ 8    simrul=res                                
+      return                                         
+ 2    m=2*m                                     
+      n=n+1                                          
+      if (n.gt.j) goto 3                             
+      a0=a1                                          
+      s1(n)=a2                                       
+      s2(n)=g3                                       
+      s3(n)=g4                                       
+      g4=g2                                          
+      g2=g1                                          
+      goto 1                                         
+ 3    c1=c-(b-a)/d                              
+      c2=c+(b-a)/d                                   
+      write(2,7) c1,c,c2,fsim(c1),fsim(c),fsim(c2)    
+      write(*,7) c1,c,c2,fsim(c1),fsim(c),fsim(c2)      
+ 7    format(2x,17hsimrule fails at ,/,3e15.6,/,3e15.6)     
+      goto 8                                         
+ 5    a0=s1(n)                                  
+      g0=g4                                          
+      g2=s2(n)                                       
+      g4=s3(n)                                       
+      goto 1                                         
+ 4    m=m/2                                     
+      n=n-1                                          
+      goto 6                                         
+      end                                            
+                                                
+c     **********************************************************************
+      subroutine findw(ig,iirw,idummy,c1,p1, Desp, wsL)                         
+c     this routine sets up accuracy criteria and calls simrule between limit
+c     that depend on the number of atmospheric and cell paths. it gives eqw.
+
+c     Add correction for EQW in Strong Lorentz regime and SZA>90 
+c     **********************************************************************
+                                                
+      implicit none                                  
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+                                                
+c arguments                
+      integer         ig        ! ADDED FOR TRACEBACK
+      integer		iirw        
+      integer         idummy    ! I. indica varias opciones
+      real*8          c1        ! I. needed for strong limit of Lorentz profil
+      real*8          p1        ! I.    "          "              "
+      real*8          wsL       ! O. need this for strong Lorentz correction
+      real*8          Desp      ! I. need this for strong Lorentz correction
+      
+c local variables                               
+      real*8 		ept,eps,xa                            
+      real*8		acc,  c                                
+      real*8 		we                                    
+      real*8		f, fi, simrul                          
+                                                
+      external f,fi                                  
+                                                
+c	********** *********** *********                                     
+
+      if(icls.eq.5) then	!para mztf                  
+!           if(ig.eq.1682)write(*,*)'mztfsub_overlap/768',ua(kr),iirw
+         if (iirw.eq.2) then    !iirw=icf=2 ==> we use the w&r formula      
+            w = we(ig,ua(kr),pt,pp, idummy, c1,p1, Desp, wsL )  
+            return                                        
+         end if                                      
+         ept=we(ig,ua(kr),pt,pp, idummy,c1,p1, Desp, wsL)
+      else                      !para fot               
+         if (iirw.eq.2) then    ! icf=2 ==> we use the w&r formula 
+            w = we(ig,sl_ua,pt,pp, idummy,c1,p1, Desp, wsL)
+            return                                        
+         end if                                      
+         ept=we(ig,sl_ua,pt,pp, idummy,c1,p1, Desp, wsL)                    
+      end if                                         
+                                                
+c the next block is a modification to avoid nul we.         
+c this situation appears for weak lines and low path temperature, but   
+c there is not any loss of accuracy. first july 1986        
+      if (ept.eq.0.) then 	! for weak lines sometimes we=0       
+         ept=1.0e-18                                   
+         write (*,*)  'ept =',ept                                       
+         write (*,*) 'from we: we=0.0'                                  
+         return                                        
+      end if                                         
+                                                
+      acc = 4.d0                                     
+      acc = 10.d0**(-acc)                            
+                                                
+      eps = acc * ept 		!accuracy 10-4 atmospheric eqw.  
+      xa=0.5*ept/f(0.d0)        !width of doppler shifted atmospheric line.    
+      w=2.0*(simrul(0.0d0,xa,f,c,eps)+simrul(0.1d0,1.0/xa,fi,c,eps))     
+!no shift.                                      
+                                                
+      return                                     
+      end                                            
+                                                
+                                                
+c     **********************************************************************
+      double precision function fi(y)                
+c     returns the value of f(1/y)                   
+c     **********************************************************************
+                                                
+      implicit none                                  
+      real*8 f, y                                    
+                                                
+      fi=f(1.0/y)/y**2                               
+      return                                         
+      end                                            
+                                                
+                                                
+c     **********************************************************************
+      double precision function f(nuaux)                
+c     calculates 1-exp(-k(nu)u) for all series paths or combinations thereof
+c     **********************************************************************
+                                                
+      implicit none                                  
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+      
+      double precision tra,xa,ya,za,yy,nuaux
+      double precision voigtf                        
+      tra=1.0d0                                      
+                                                
+      yy=1.0d0/alda(kr)                          
+      xa=nuaux*yy                                       
+      ya= ( alsa(kr)*pp + alna(kr)*(pt-pp) ) * yy			 
+      za=ka(kr)*yy                                   
+                                                
+      if(icls.eq.5) then	!para mztf                  
+	  ! write (*,*) 'icls=',icls                                    
+         tra=za*ua(kr)*voigtf(sngl(xa),sngl(ya))     
+      else
+         tra=za*sl_ua*voigtf(sngl(xa),sngl(ya))         
+      end if                                         
+                                                
+      if (tra.gt.50.0) then                          
+         tra=1.0                !2.0e-22 overflow cut-off.          
+      else if (tra.gt.1.0e-4) then                   
+         tra=1.0-exp(-tra)                              
+      end if                                         
+                                                
+      f=tra                                          
+      return                                         
+      end                                            
+                                                
+c     **********************************************************************
+      double precision function voigtf(x1,y)         
+c     computes voigt function for any value of x1 and any +ve value of y.   
+c     where possible uses modified lorentz and modified doppler approximatio
+c     otherwise uses a rearranged rybicki routine.  
+c     c(n) = exp(-(n/h)**2)/(pi*sqrt(pi)), with h = 2.5 .       
+c     accurate to better than 1 in 10000.           
+c     **********************************************************************
+
+      implicit none
+      
+      real x1, y
+      real x, xx, xxyy, xh,xhxh, yh,yhyh, f1,f2, p, q, xn,xnxn, voig
+      
+      real*8 b,g0,g1,g2,g3,g4,d1,d2,d3,d4,c          
+      integer*4 n                             
+                                                
+      dimension c(10)                                
+      complex xp,xpp,z                               
+                                                
+      data c(1)/0.15303405/                          
+      data c(2)/0.94694928e-1/                       
+      data c(3)/0.42549174e-1/                       
+      data c(4)/0.13882935e-1/                       
+      data c(5)/0.32892528e-2/                       
+      data c(6)/0.56589906e-3/                       
+      data c(7)/0.70697890e-4/                       
+      data c(8)/0.64135678e-5/                       
+      data c(9)/0.42249221e-6/                       
+      data c(10)/0.20209868e-7/                      
+                                                
+      x=abs(x1)                                      
+      if (x.gt.7.2) goto 1                           
+      if ((y+x*0.3).gt.5.4) goto 1                   
+      if (y.gt.0.01) goto 3                          
+      if (x.lt.2.1) goto 2                           
+      goto 3                                         
+c     here uses modified lorentz approx.            
+ 1    xx=x*x                                    
+      xxyy=xx+y*y                                    
+      b=xx/xxyy                                      
+      voigtf=y*(1.+(2.*b-0.5+(0.75-(9.-12.*b)*b)/xxyy)/          
+     *     xxyy)/(xxyy*3.141592654)                 
+      return                                         
+c     here uses modified doppler approx.            
+ 2    xx=x*x                                    
+      voigtf=0.56418958*exp(-xx)*(1.-y*(1.-0.5*y)*(1.1289-xx*(1.1623+        
+     *     xx*(0.080812+xx*(0.13854-xx*(0.033605-0.0073972*xx))))))         
+      return                                         
+c     here uses a rearranged rybicki routine.       
+ 3    xh=2.5*x                                  
+      xhxh=xh*xh                                     
+      yh=2.5*y                                       
+      yhyh=yh*yh                                     
+      f1=xhxh+yhyh                                   
+      f2=f1-0.5*yhyh                                 
+      if (y.lt.0.1) goto 20                          
+      p=-y*7.8539816            !7.8539816=2.5*pi            
+      q=x*7.8539816                                  
+      xpp=cmplx(p,q)                                 
+      z=cexp(xpp)                                    
+      d1=xh*aimag(z)                                 
+      d2=-d1                                         
+      d3=yh*(1.-real(z))                             
+      d4=-d3+2.*yh                                   
+      voig=0.17958712*(d1+d3)/f1                     
+      goto 30                                        
+ 20   p=x*7.8539816                             
+      q=y*7.8539816                                  
+      xp=cmplx(p,q)                                  
+      z=ccos(xp)                                     
+      d1=xh*aimag(z)                                 
+      d2=-d1                                         
+      d3=yh*(1.-real(z))                             
+      d4=-d3+2.*yh                                   
+      voig=0.56418958*exp(y*y-x*x)*cos(2.*x*y)+0.17958712*(d1+d3)/f1         
+ 30   xn=0.                                     
+      do 55 n=1,10,2                             
+         xn=xn+1.                                   
+         xnxn=xn*xn                                 
+         g1=xh-xn                                   
+         g2=g1*(xh+xn)                              
+         g3=0.5*g2*g2                               
+         voig=voig+c(n)*(d2*(g2+yhyh)+d4*(f1+xnxn))/
+     &        (g3+yhyh*(f2+xnxn))     
+         xn=xn+1.                                   
+         xnxn=xn*xn                                 
+         g1=xh-xn                                   
+         g2=g1*(xh+xn)                              
+         g3=0.5*g2*g2                               
+         voig=voig+c(n+1)*(d1*(g2+yhyh)+d3*(f1+xnxn))/
+     @        (g3+yhyh*(f2+xnxn))   
+ 55   continue                              
+      voigtf=voig                                    
+      return                                         
+      end  
+
+
+
+c     **********************************************************************
+c     elimin_mz1d.F (includes smooth_cf)
+c     ************************************************************************
+      subroutine elimin_mz1d (c,vc, ilayer,nanaux,itblout, nwaux)
+
+c     Eliminate anomalous negative numbers in c(nl,nl) according to "nanaux":
+
+c     nanaux = 0 -> no eliminate 
+c	       @       -> eliminate all numbers with absol.value<abs(max(c(n,r)))/300.
+c	       2 -> eliminate all anomalous negative numbers in c(n,r).
+c	       3 -> eliminate all anomalous negative numbers far from the main
+c                   diagonal. 
+c	       8 -> eliminate all non-zero numbers outside the main diagonal,
+c		    and the contibution of lower boundary. 
+c	       9 -> eliminate all non-zero numbers outside the main diagonal. 
+c              4 -> hace un smoothing cuando la distancia de separacion entre
+c		    el valor maximo y el minimo de cf > 50 capas.
+c	       5 -> elimina valores menores que 1.0d-19
+c	       6 -> incluye los dos casos 4 y 5 
+c	       7 -> llama a lisa: smooth con width=nw & elimina mejorado
+c	       78-> incluye los dos casos 7 y 8
+c	       79-> incluye los dos casos 7 y 9
+
+c     itblout (itableout in calling program) is the option for writing 
+c     out or not the purged c(n,r) matrix: 
+c     itblout = 0 -> no write  
+c               = 1 -> write out in curtis***.out according to ilayer
+
+c     ilayer is the index for the layer selected to write out the matrix:
+c     ilayer = 0  => matrix elements written out cover all the altitudes
+c                                                     with 5 layers steps
+c              > 0  =>   "        "      "      "  are  c(ilayer,*)
+c     NOTA: 
+c       EXISTE LA POSIBILIDAD DE SACAR TODAS LAS CAPAS (TODA LA MATRIZ)
+c       UTILIZANDO itableout=30 EN MZTUD
+
+c     jul 2011        malv+fgg       adapted to LMD-MGCM
+c     Sep-04          FGG+MALV        Correct include and call parameters
+c     cristina	25-sept-1996   y  27-ene-1997
+c     JAN 98		MALV		Version for mz1d
+c     ************************************************************************
+
+      implicit none
+
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+
+      integer   nanaux,j,i,itblout,kk,k,ir,in
+      integer   ilayer,jmin, jmax,np,nwaux,ntimes,ntimes2
+!*	real*8    c(nl,nl), vc(nl), amax, cmax, cmin, cs(nl,nl), mini
+      real*8    c(nl,nl), vc(nl), amax, cmax, cmin, mini
+      real*8 aux(nl), auxs(nl)
+      character layercode*3
+
+      ntimes=0
+      ntimes2=0
+!	type *,'from elimin_mz4: nan, nw',nan,nw
+
+      if (nanaux .eq. 0) goto 200 
+
+      if(nanaux.eq.1)then
+         do i=1,nl
+            amax=1.0d-36
+            do j=1,nl
+               if(abs(c(i,j)).gt.amax)amax=abs(c(i,j))
+            end do
+            do j=1,nl
+               if(abs(c(i,j)).lt.amax/300.0d0)c(i,j)=0.0d0
+            end do
+         enddo
+      elseif(nanaux.eq.2)then
+         do i=1,nl
+            do j=1,nl
+               if( ( j.le.(i-2) .or. j.gt.(i+2) ).and.
+     @              ( c(i,j).lt.0.0d0 ) ) c(i,j)=0.0d0
+            end do
+         enddo
+      elseif(nanaux.eq.3)then
+         do i=1,nl
+            do j=1,nl
+               if (abs(i-j).ge.10) c(i,j)=0.0d0
+            end do
+         enddo
+      elseif(nanaux.eq.8)then
+         do i=1,nl
+            do j=1,i-1 
+               c(i,j)=0.0d0
+            enddo
+            do j=i+1,nl 
+               c(i,j)=0.0d0
+            enddo
+            vc(i)= 0.d0
+         enddo
+      elseif(nanaux.eq.9)then
+         do i=1,nl
+            do j=1,i-1 
+               c(i,j)=0.0d0
+            enddo
+            do j=i+1,nl 
+               c(i,j)=0.0d0
+            enddo
+         enddo
+!	elseif(nan.eq.7.or.nan.eq.78.or.nan.eq.79)then
+!		call lisa(c, vc, nl, nw)
+      end if
+      if(nanaux.eq.78)then
+         do i=1,nl
+            do j=1,i-1 
+               c(i,j)=0.0d0
+            enddo
+            do j=i+1,nl 
+               c(i,j)=0.0d0
+            enddo
+            vc(i)= 0.d0
+         enddo
+      endif
+      if(nanaux.eq.79)then
+         do i=1,nl
+            do j=1,i-1 
+               c(i,j)=0.0d0
+            enddo
+            do j=i+1,nl 
+               c(i,j)=0.0d0
+            enddo
+         enddo
+      endif
+
+      if(nanaux.eq.5.or.nanaux.eq.6)then
+         do i=1,nl
+            mini = 1.0d-19
+            do j=1,nl
+               if(abs(c(i,j)).le.mini.and.c(i,j).ne.0.d0) then
+                  ntimes2=ntimes2+1
+               end if
+               if ( abs(c(i,j)).le.mini) c(i,j)=0.d0
+            end do
+         enddo
+      end if
+
+      if(nanaux.eq.4.or.nanaux.eq.6)then
+         do i=1,nl
+            do j=1,nl
+               aux(j)=c(i,j)
+               auxs(j)=c(i,j)
+            end do
+			!call maxdp_2(aux,nl,cmax,jmax)
+            cmax=maxval(aux)
+            jmax=maxloc(aux,dim=1)
+            if(abs(jmax-i).ge.50) then
+               call smooth_cf(aux,auxs,i,nl,3)
+				!!!call smooth_cf(aux,auxs,i,nl,5)
+               ntimes=ntimes+1
+            end if
+            do j=1,nl
+               c(i,j)=auxs(j)
+            end do
+         end do
+      end if
+
+!	   type *, 'elimin_mz4: c(n,r) procesed for elimination. '
+!	   type *, ' '
+!	   if(nan.eq.4.or.nan.eq.6) type *, '    call smoothing:',ntimes
+!	   if(nan.eq.5.or.nan.eq.6) type *, '    call elimina:  ',ntimes2
+!	   if(nan.eq.7)   type *, '    from elimin: lisa w=',nw
+!	   type *, ' '
+
+
+ 200  continue
+
+c	writting out of c(n,r) in ascii file 
+
+!	if(itblout.eq.1) then
+
+!	  if (ilayer.eq.0) then
+
+!	   open (unit=2, status='new', 
+!     @    file=dircurtis//'curtis_gnu.out', recl=1024)
+!	    write(2,'(a)') 
+!     @    ' curtis matrix:     table with   1.e+7 * acf(n,r) '
+!	    write(2,114) 'n,r', ( i, i=nl,1,-5 )
+!	    do in=nl,1,-5
+!	      write(2,*)
+!	      write(2,115) in, ( c(in,ir)*1.d7, ir=nl,1,-5 )
+!	    end do 
+!	   close(2)
+
+
+!	   write (*,*)  ' '
+!	   write (*,*)  '  curtis.out has been created. '
+!	   write (*,*)  ' '
+
+!	  else
+
+!            write (layercode,132) ilayer
+!	    open (2, status='new', 
+!     @    file=dircurtis//'curtis'//layercode//'.out')
+!	    write(2,'(a)') 
+!     @    ' curtis matrix:     table with   1.e+7 * acf(n,r) '
+!	    write(2,116) ' layer x       c(',layercode,
+!     @    ',x)           c(x,', layercode,')' 
+!	    do in=nl,1,-1
+!	     if (c(ilayer,ilayer).ne.0.d0) then 
+!	      write(2,117) in, c(ilayer,in), c(in,ilayer), 
+!     @        c(ilayer,in)/c(ilayer,ilayer),
+!     @        c(in,ilayer)/c(ilayer,ilayer)
+!	     else
+!	      write(2,118) in, c(ilayer,in), c(in,ilayer)
+!	     end if
+!	    end do 
+!	    close(2)
+!	    write (*,*)  ' '
+!	    write (*,*)  dircurtis//'curtis'//layercode//'.out', 
+!     @ ' has been created.'
+!	    write (*,*) ' '
+
+!	  end if
+
+!	elseif(itblout.eq.0)then
+
+!	  continue
+
+!	else
+
+!	  write (*,*) ' error from elimin: ', 
+!     @      ' itblout should be 1 or 0;   itblout= ',itblout
+!	  stop
+
+!	end if
+	
+      return
+
+ 112  format(10x,10(i3,9x))
+ 113  format(1x,i3,2x,9(1pe9.2,2x))
+      
+ 114  format(1x,a3, 11(8x,i3))
+ 115  format( 1x,i3, 2x, 11(1pe10.3))
+ 116  format( 1x,a17,a2,a18,a2,a1 ) 
+ 117  format( 3x,i3, 4(8x,1pe10.3) )
+ 118  format( 3x,i3, 2(8x,1pe10.3) )
+ 120  format( 1x,i3, 1x,i3, 2x, 11(1pe10.3))
+
+ 132  format(i3)
+
+!  cambio: los formatos 114, 115 , 117 y 118
+!  cambio: al cambia nl de 51 a 140 hay que cambiar el formato i2-->i3
+!          y ahora en vez de 11 capas de 5 en 5, hay 28
+!
+      end
+c**************************************************************************
+      subroutine smooth_cf( c, cs, i, nl, w )
+c     hace un smoothing de c(i,*), de la contribucion de todas las capas
+c     menos de la capa en cuestion, la i.
+c     opcion w (width): el tamanho de la ventana del smoothing.
+c     output values: cs
+c**************************************************************************
+
+      implicit none
+      
+      integer  j,np,i,nl,w
+      real*8   c(nl), cs(nl)
+
+      if(w.eq.0) then
+	 do j=1,nl
+            cs(j)=c(j)
+	 end do
+         
+      elseif(w.eq.3) then
+
+!	write (*,*) 'smoothing w=3'
+	 do j=1,i-4
+            if(j.eq.1) then
+               cs(j)=c(j)
+            else
+               cs(j)=1/3.d0*(c(j-1)+c(j)+c(j+1))
+            end if
+	 end do
+	 do j=i+4,nl-1
+            if(j.eq.nl) then
+               cs(j)=c(j)
+            else
+               cs(j)=1/3.d0*(c(j-1)+c(j)+c(j+1))
+            end if
+	 end do
+      elseif(w.eq.5) then
+
+!	type *,'smoothing w=5'
+	 do j=3,i-4
+            if(j.eq.1) then
+               cs(j)=c(j)
+            else
+               cs(j)=1/5.d0*(c(j-2)+c(j-1)+c(j)+c(j+1)+c(j+2))
+            end if
+	 end do
+	 do j=i+4,nl-2
+            if(j.eq.nl) then
+               cs(j)=c(j)
+            else
+               cs(j)=1/5.d0*(c(j-2)+c(j-1)+c(j)+c(j+1)+c(j+2))
+            end if
+	 end do
+      end if
+      return
+      end
+
+
+
+c*****************************************************************************
+c     suaviza
+c*****************************************************************************
+c
+      subroutine suaviza ( x, n, ismooth, y )
+c
+c     x - input and return values 
+c     y - auxiliary vector
+c     ismooth = 0  --> no smoothing is performed
+c     ismooth = 1  --> weak smoothing (5 points, centred weighted)
+c     ismooth = 2  --> normal smoothing (3 points, evenly weighted)
+c     ismooth = 3  --> strong smoothing (5 points, evenly weighted)
+
+
+c     malv  august 1991
+c*****************************************************************************
+
+      implicit none
+
+      integer	n, imax, imin, i, ismooth
+      real*8	x(n), y(n)
+c*****************************************************************************
+
+      imin=1
+      imax=n
+
+      if (ismooth.eq.0) then
+
+         return 
+
+      elseif (ismooth.eq.1) then ! 5 points, with central weighting 
+
+         do i=imin,imax 
+	    if(i.eq.imin)then
+               y(i)=x(imin)
+	    elseif(i.eq.imax)then
+               y(i)=x(imax-1)+(x(imax-1)-x(imax-3))/2.d0
+	    elseif(i.gt.(imin+1) .and. i.lt.(imax-1) )then
+               y(i) = ( x(i+2)/4.d0 + x(i+1)/2.d0 + 2.d0*x(i)/3.d0 + 
+     &              x(i-1)/2.d0 + x(i-2)/4.d0 )* 6.d0/13.d0
+	    else
+               y(i)=(x(i+1)/2.d0+x(i)+x(i-1)/2.d0)/2.d0
+	    end if
+         end do	
+         
+      elseif (ismooth.eq.2) then ! 3 points, evenly spaced
+
+         do i=imin,imax 
+	    if(i.eq.imin)then
+               y(i)=x(imin)
+	    elseif(i.eq.imax)then
+               y(i)=x(imax-1)+(x(imax-1)-x(imax-3))/2.d0
+	    else
+               y(i) = ( x(i+1)+x(i)+x(i-1) )/3.d0
+	    end if
+         end do	
+	  
+      elseif (ismooth.eq.3) then ! 5 points, evenly spaced
+
+         do i=imin,imax 
+	    if(i.eq.imin)then
+               y(i) = x(imin)
+	    elseif(i.eq.(imin+1) .or. i.eq.(imax-1))then
+               y(i) = ( x(i+1)+x(i)+x(i-1) )/3.d0 
+	    elseif(i.eq.imax)then
+               y(i) = ( x(imax-1) + x(imax-1) + x(imax-2) ) / 3.d0
+	    else
+               y(i) = ( x(i+2)+x(i+1)+x(i)+x(i-1)+x(i-2) )/5.d0
+	    end if
+         end do	
+
+      else
+
+         write (*,*) ' Error in suaviza.f   Wrong ismooth value.'
+         stop
+
+      endif
+
+c rehago el cambio, para devolver x(i)
+      do i=imin,imax 
+         x(i)=y(i)
+      end do
+
+      return
+      end
+
+
+
+
+c*****************************************************************************
+c     LUdec.F (includes lubksb_dp and ludcmp_dp subroutines)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c Solution of linear equation without inverting matrix
+c using LU decomposition: 
+c        AA * xx = bb         AA, bb: known
+c                                 xx: to be found
+c AA and bb are not modified in this subroutine
+c                               
+c MALV , Sep 2007
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      subroutine LUdec(xx,aa,bb,m,n)
+
+      implicit none
+
+! Arguments 
+      integer,intent(in) ::     m, n
+      real*8,intent(in) ::      aa(m,m), bb(m)
+      real*8,intent(out) ::     xx(m)
+
+
+! Local variables
+      real*8      a(n,n), b(n), x(n), d
+      integer    i, j, indx(n)      
+
+
+! Subrutinas utilizadas
+!     ludcmp_dp, lubksb_dp
+
+!!!!!!!!!!!!!!! Comienza el programa !!!!!!!!!!!!!!
+      
+      do i=1,n
+        b(i) = bb(i+1)
+        do j=1,n
+           a(i,j) = aa(i+1,j+1)
+        enddo
+      enddo
+
+      ! Descomposicion de auxm1
+      call ludcmp_dp ( a, n, n, indx, d)
+
+      ! Sustituciones foward y backwards para hallar la solucion
+      do i=1,n
+           x(i) = b(i)
+      enddo
+      call lubksb_dp( a, n, n, indx, x )
+
+      do i=1,n
+        xx(i+1) = x(i)
+      enddo
+
+      return
+      end
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      subroutine ludcmp_dp(a,n,np,indx,d)
+
+c       jul 2011 malv+fgg
+
+      implicit none
+
+      integer,intent(in) :: n, np
+      real*8,intent(inout) :: a(np,np)
+      real*8,intent(out) :: d
+      integer,intent(out) :: indx(n)
+      
+      integer i, j, k, imax
+      real*8,parameter :: tiny=1.0d-20                                       
+      real*8 vv(n), aamax, sum, dum
+
+
+      d=1.0d0
+      do 12 i=1,n                                                             
+        aamax=0.0d0
+        do 11 j=1,n                                                           
+          if (abs(a(i,j)).gt.aamax) aamax=abs(a(i,j))                         
+11      continue                                                              
+        if (aamax.eq.0.0) then
+          write(*,*) 'ludcmp_dp: singular matrix!'
+          stop
+        endif                         
+        vv(i)=1.0d0/aamax                          
+12    continue                                                                
+      do 19 j=1,n                                                             
+        if (j.gt.1) then                                                      
+          do 14 i=1,j-1                                                       
+            sum=a(i,j)                                                        
+            if (i.gt.1)then                                                   
+              do 13 k=1,i-1                                                   
+                sum=sum-a(i,k)*a(k,j)                                         
+13            continue                                                        
+              a(i,j)=sum                                                      
+            endif                                                             
+14        continue                                                            
+        endif                                                                 
+        aamax=0.0d0                                                           
+        do 16 i=j,n                                                           
+          sum=a(i,j)                                                          
+          if (j.gt.1)then                                                     
+            do 15 k=1,j-1                                                     
+              sum=sum-a(i,k)*a(k,j)                                           
+15          continue                                                          
+            a(i,j)=sum                                                        
+          endif                                                               
+          dum=vv(i)*abs(sum)                                                  
+          if (dum.ge.aamax) then                                              
+            imax=i                                                            
+            aamax=dum                                                         
+          endif                                                               
+16      continue                                                              
+        if (j.ne.imax)then                                                    
+          do 17 k=1,n                                                         
+            dum=a(imax,k)                                                     
+            a(imax,k)=a(j,k)                                                  
+            a(j,k)=dum                                                        
+17        continue                                                            
+          d=-d                                                                
+          vv(imax)=vv(j)                                                      
+        endif                                                                 
+        indx(j)=imax                                                          
+        if(j.ne.n)then                                                        
+          if(a(j,j).eq.0.0)a(j,j)=tiny                                     
+          dum=1.0d0/a(j,j)                                                  
+          do 18 i=j+1,n                                                       
+            a(i,j)=a(i,j)*dum                                                 
+18        continue                                                            
+        endif                                                                 
+19    continue                                                                
+      if(a(n,n).eq.0.0)a(n,n)=tiny                                     
+      return                                                                  
+      end                                                                     
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      subroutine lubksb_dp(a,n,np,indx,b)                              
+
+c     jul 2011 malv+fgg
+
+      implicit none
+
+      integer,intent(in) :: n,np
+      real*8,intent(in) ::  a(np,np)
+      integer,intent(in) :: indx(n)
+      real*8,intent(out) :: b(n) 
+
+      real*8 sum
+      integer ii, ll, i, j
+
+      ii=0                                                              
+      do 12 i=1,n                                                             
+        ll=indx(i)                                                            
+        sum=b(ll)                                                             
+        b(ll)=b(i)                                                            
+        if (ii.ne.0)then                                                      
+          do 11 j=ii,i-1                                                      
+            sum=sum-a(i,j)*b(j)                                               
+11        continue                                                            
+        else if (sum.ne.0.0) then                       
+          ii=i                                                                
+        endif                                                                 
+        b(i)=sum                                                              
+12    continue                                                                
+      do 14 i=n,1,-1                                                          
+        sum=b(i)                                                              
+        if(i.lt.n)then                                                        
+          do 13 j=i+1,n                                                       
+            sum=sum-a(i,j)*b(j)                                               
+13        continue                                                            
+        endif                                                                 
+        b(i)=sum/a(i,i)                                                       
+14    continue                                                                
+      return                                                                  
+      end 
+
+
+
+
+c*****************************************************************************
+c     intersp
+c     ***********************************************************************
+      subroutine intersp(yy,zz,m,y,z,n,opt)
+c     interpolation soubroutine. input values: y(n) at z(n). 
+c     output values: yy(m) at zz(m). options: 1 -> lineal; 2 -> logarithmic
+
+c     jul 2011 malv+fgg
+c     ***********************************************************************
+
+      implicit none
+
+      integer	n,m,i,j,opt
+      real	zz(m),yy(m),z(n),y(n)
+      real	zmin,zzmin,zmax,zzmax
+
+!	write(*,*) ' interpolating'
+!	call minsp(z,n,zmin)
+      zmin=minval(z)
+!	call minsp(zz,m,zzmin)
+      zzmin=minval(zz)
+!	call maxsp(z,n,zmax)
+      zmax=maxval(z)
+!	call maxsp(zz,m,zzmax)
+      zzmax=maxval(zz)
+
+      if(zzmin.lt.zmin)then
+         write(*,*) 'from interp: new variable out of limits'
+         write(*,*) zzmin,'must be .ge. ',zmin
+         stop
+!	elseif(zzmax.gt.zmax)then
+!	  write(*,*)'from interp: new variable out of limits'
+!	  write(*,*)zzmax, 'must be .le. ',zmax
+!	  stop
+      end if
+
+      do 1,i=1,m
+
+         do 2,j=1,n-1
+            if(zz(i).ge.z(j).and.zz(i).lt.z(j+1)) goto 3
+ 2       continue
+c	in this case (zz(m).ge.z(n)) and j leaves the loop with j=n-1+1=n
+         if(opt.eq.1)then
+            yy(i)=y(n-1)+(y(n)-y(n-1))*(zz(i)-z(n-1))/(z(n)-z(n-1))
+         elseif(opt.eq.2)then
+            if(y(n).eq.0.0.or.y(n-1).eq.0.0)then
+               yy(i)=0.0
+            else
+               yy(i)=exp(log(y(n-1))+log(y(n)/y(n-1))*
+     @              (zz(i)-z(n-1))/(z(n)-z(n-1)))
+            end if
+         else
+            write(*,*)'from interp error: opt must be 1 or 2, opt= ',opt
+         end if
+         goto 1
+ 3       continue
+         if(opt.eq.1)then
+            yy(i)=y(j)+(y(j+1)-y(j))*(zz(i)-z(j))/(z(j+1)-z(j))
+         elseif(opt.eq.2)then
+            if(y(j+1).eq.0.0.or.y(j).eq.0.0)then
+               yy(i)=0.0
+            else
+               yy(i)=exp(log(y(j))+log(y(j+1)/y(j))*
+     @              (zz(i)-z(j))/(z(j+1)-z(j)))
+            end if
+         else
+            write(*,*)'from interp error: opt must be 1 or 2, opt= ',opt
+         end if
+ 1    continue
+
+      return
+      end
+
+
+
+c*****************************************************************************
+c     interdp
+c     ***********************************************************************
+      subroutine interdp(yy,zz,m,y,z,n,opt)
+c     interpolation soubroutine. input values: y(n) at z(n). 
+c     output values: yy(m) at zz(m). options: 1 -> lineal; 2 -> logarithmic
+c     jul 2011:  malv+fgg   Adapted to LMD-MGCM
+c     ***********************************************************************
+      implicit none
+      integer n,m,i,j,opt
+      real*8 zz(m),yy(m),z(n),y(n), zmin,zzmin,zmax,zzmax
+
+!	write (*,*) ' d interpolating '
+!	call mindp (z,n,zmin)
+      zmin=minval(z)
+!	call mindp (zz,m,zzmin)
+      zzmin=minval(zz)
+!	call maxdp (z,n,zmax)
+      zmax=maxval(z)
+!	call maxdp (zz,m,zzmax)
+      zzmax=maxval(zz)
+
+      if(zzmin.lt.zmin)then
+         write (*,*) 'from d interp: new variable out of limits'
+         write (*,*) zzmin,'must be .ge. ',zmin
+         stop
+!	elseif(zzmax.gt.zmax)then
+!		write (*,*) 'from interp: new variable out of limits'
+!		write (*,*) zzmax, 'must be .le. ',zmax
+!		stop
+      end if
+
+      do 1,i=1,m
+
+         do 2,j=1,n-1
+            if(zz(i).ge.z(j).and.zz(i).lt.z(j+1)) goto 3
+ 2       continue
+c	in this case (zz(m).eq.z(n)) and j leaves the loop with j=n-1+1=n
+         if(opt.eq.1)then
+            yy(i)=y(n-1)+(y(n)-y(n-1))*(zz(i)-z(n-1))/(z(n)-z(n-1))
+         elseif(opt.eq.2)then
+            if(y(n).eq.0.0d0.or.y(n-1).eq.0.0d0)then
+               yy(i)=0.0d0
+            else
+               yy(i)=dexp(dlog(y(n-1))+dlog(y(n)/y(n-1))*
+     @              (zz(i)-z(n-1))/(z(n)-z(n-1)))
+            end if
+         else
+            write (*,*) 
+     @           ' from d interp error: opt must be 1 or 2, opt= ',opt
+         end if
+         goto 1
+ 3       continue
+         if(opt.eq.1)then
+            yy(i)=y(j)+(y(j+1)-y(j))*(zz(i)-z(j))/(z(j+1)-z(j))
+!	write (*,*) ' '
+!	write (*,*) ' z(j),z(j+1) =', z(j),z(j+1)
+!	write (*,*) ' t(j),t(j+1) =', y(j),y(j+1)
+!	write (*,*) ' zz, tt =  ', zz(i), yy(i)
+         elseif(opt.eq.2)then
+            if(y(j+1).eq.0.0d0.or.y(j).eq.0.0d0)then
+               yy(i)=0.0d0
+            else
+               yy(i)=dexp(dlog(y(j))+dlog(y(j+1)/y(j))*
+     @              (zz(i)-z(j))/(z(j+1)-z(j)))
+            end if
+         else
+            write (*,*) ' from interp error: opt must be 1 or 2, opt= ',
+     @           opt
+         end if
+ 1    continue
+      return
+      end
+
+
+c*****************************************************************************
+c     interdp_limits.F
+c     ***********************************************************************
+
+      subroutine interdp_limits ( yy,zz,m, i1,i2, y,z,n, j1,j2, opt)
+
+c     Interpolation soubroutine. 
+c     Returns values between indexes i1 & i2, donde  1 =< i1 =< i2 =< m
+c     Solo usan los indices de los inputs entre j1,j2, 1 =< j1 =< j2 =< n    
+c     Input values: y(n) , z(n)  (solo se usan los valores entre j1,j2)
+c                     zz(m) (solo se necesita entre i1,i2)
+c     Output values: yy(m) (solo se calculan entre i1,i2)
+c     Options:    opt=1 -> lineal ,,  opt=2 -> logarithmic
+c     Difference with interdp:  
+c          here interpolation proceeds between indexes i1,i2 only 
+c	   if i1=1 & i2=m, both subroutines are exactly the same
+c          thus previous calls to interdp or interdp2 could be easily replaced
+
+c     JAN 98 	MALV 		Version for mz1d
+c     jul 2011 malv+fgg       Adapted to LMD-MGCM
+c     ***********************************************************************
+
+      implicit none
+
+! Arguments 
+      integer 	n,m             ! I. Dimensions
+      integer 	i1, i2, j1, j2, opt ! I
+      real*8 		zz(m),yy(m) ! O
+      real*8		z(n),y(n) ! I
+
+! Local variables
+      integer 	i,j
+      real*8 		zmin,zzmin,zmax,zzmax
+
+c     *******************************
+
+!	type *, ' d interpolating '
+!	call mindp_limits (z,n,zmin, j1,j2)
+      zmin=minval(z(j1:j2))
+!	call mindp_limits (zz,m,zzmin, i1,i2)
+      zzmin=minval(zz(i1:i2))
+!	call maxdp_limits (z,n,zmax, j1,j2)
+      zmax=maxval(z(j1:j2))
+!	call maxdp_limits (zz,m,zzmax, i1,i2)
+      zzmax=maxval(zz(i1:i2))
+
+      if(zzmin.lt.zmin)then
+         write (*,*) 'from d interp: new variable out of limits'
+         write (*,*) zzmin,'must be .ge. ',zmin
+         stop
+!	elseif(zzmax.gt.zmax)then
+!		type *,'from interp: new variable out of limits'
+!		type *,zzmax, 'must be .le. ',zmax
+!		stop
+      end if
+
+      do 1,i=i1,i2
+
+         do 2,j=j1,j2-1
+            if(zz(i).ge.z(j).and.zz(i).lt.z(j+1)) goto 3
+ 2       continue
+c	in this case (zz(i2).eq.z(j2)) and j leaves the loop with j=j2-1+1=j2
+         if(opt.eq.1)then
+            yy(i)=y(j2-1)+(y(j2)-y(j2-1))*
+     $           (zz(i)-z(j2-1))/(z(j2)-z(j2-1))
+         elseif(opt.eq.2)then
+            if(y(j2).eq.0.0d0.or.y(j2-1).eq.0.0d0)then
+               yy(i)=0.0d0
+            else
+               yy(i)=exp(log(y(j2-1))+log(y(j2)/y(j2-1))*
+     @              (zz(i)-z(j2-1))/(z(j2)-z(j2-1)))
+            end if
+         else
+            write (*,*) ' d interp : opt must be 1 or 2, opt= ',opt
+         end if
+         goto 1
+ 3       continue
+         if(opt.eq.1)then
+            yy(i)=y(j)+(y(j+1)-y(j))*(zz(i)-z(j))/(z(j+1)-z(j))
+!	type *, ' '
+!	type *, ' z(j),z(j+1) =', z(j),z(j+1)
+!	type *, ' t(j),t(j+1) =', y(j),y(j+1)
+!	type *, ' zz, tt =  ', zz(i), yy(i)
+         elseif(opt.eq.2)then
+            if(y(j+1).eq.0.0d0.or.y(j).eq.0.0d0)then
+               yy(i)=0.0d0
+            else
+               yy(i)=exp(log(y(j))+log(y(j+1)/y(j))*
+     @              (zz(i)-z(j))/(z(j+1)-z(j)))
+            end if
+         else
+            write (*,*) ' interp : opt must be 1 or 2, opt= ',opt
+         end if
+ 1    continue
+      return
+      end
+
+
+
+
+c*****************************************************************************
+c     Subroutines previously included in tcrco2_subrut.F
+c***********************************************************************
+c     tcrco2_subrut.f                              
+c                                               
+c     jan 98 	malv    version for mz1d. copied from solar10/mz4sub.f         
+c     jul 2011 malv+fgg   adapted to LMD-MGCM
+c***********************************************************************
+                                                
+************************************************************************
+                                                
+      subroutine dinterconnection ( v, vt )          
+                                                
+*  input: vib. temp. from che*.for programs, vt(nl)         
+*  output: test vibrational temp. for other che*.for, v(nl) 
+! iconex_smooth=1  ==>  with smoothing          
+! iconex_smooth=0  ==>  without smoothing       
+! iconex_tk=40  ==>  with forced lte up to 40 km            
+! iconex_tk=20  ==>  with forced lte up to 20 km            
+************************************************************************
+                                                
+      implicit none                           
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+                                                
+c argumentos                                    
+      real*8 vt(nl), v(nl)                           
+                                                
+c local variables                               
+      integer 	i                                     
+                                                
+c   *************                               
+                                                
+      do i=1,nl                                      
+         v(i) = vt(i)                                 
+      end do                                         
+                                                
+! lo siguiente se utilizaba en solar10, pero es mejor introducirlo en   
+! la driver. por ahora no lo uso todavia.       
+!	call fluctua(v,iconex_fluctua)                
+!	call smooth_nl(v,iconex_smooth,nl)               
+!	call forzar_tk(v,iconex_tk)                   
+                                                
+      return                                         
+      end                  
+                                                
+c***********************************************************************
+      function planckdp(tp,xnu)                      
+c     returns the black body function at wavenumber xnu and temperature t.  
+c***********************************************************************
+                                                
+      implicit none                                  
+
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+
+!        common/datis/ pi, vlight, ee, hplanck, gamma, ab,
+!     @       n_avog, GG, R0, cte_sb, kboltzman,  raddeg
+!        real*8  pi, vlight, ee, hplanck, gamma, ab,
+!     @       n_avog, GG, R0, cte_sb, kboltzman,  raddeg
+
+      real*8 planckdp                                
+      real*8 xnu                                     
+      real tp                                        
+                                                
+      planckdp = gamma*xnu**3.0 / exp( ee*xnu/dble(tp) )             
+      !erg cm-2.sr-1/cm-1.                           
+                                                
+      return                                         
+      end                                            
+
+c     ****************************************************************
+      function bandid (ib)                           
+c     returns the 2 character code of the band            
+c     ****************************************************************
+      implicit none                           
+        
+      integer ib                              
+      character*2 bandid                      
+                                                
+ 132  format(i2)                              
+!     encode (2,132,bandid) ib                
+      write ( bandid, 132) ib                
+                                                
+      if ( ib .eq. 1 ) bandid = '01'          
+      if ( ib .eq. 2 ) bandid = '02'          
+      if ( ib .eq. 3 ) bandid = '03'          
+      if ( ib .eq. 4 ) bandid = '04'          
+      if ( ib .eq. 5 ) bandid = '05'          
+      if ( ib .eq. 6 ) bandid = '06'          
+      if ( ib .eq. 7 ) bandid = '07'          
+      if ( ib .eq. 8 ) bandid = '08'          
+      if ( ib .eq. 9 ) bandid = '09'          
+      if ( ib .eq. 0 ) bandid = '00'          
+                                                
+c end                                           
+      return                                  
+      end   
+
+
+
+c*****************************************************************************
+c     Subroutines previously included in mat_oper.F
+c*****************************************************************************
+c set of subroutines for the cz*.for programs:
+!     subroutine unit(a,n)
+!     subroutine diago(a,v,n)             diagonal matrix with v
+!     subroutine invdiag(a,b,n)           inverse of diagonal matrix 
+!     subroutine sypvvv(a,b,c,d,n)        suma y prod de 3 vectores, muy comun
+!     subroutine sypvmv(v,w,b,u,n)        suma y prod de 3 vectores, muy comun
+!     subroutine mulmvv(w,b,u,v,n)        prod matriz vector vector
+!     subroutine muymvv(w,b,u,v,n)        prod matriz (inv.vector) vector
+!     subroutine samem (a,m,n)
+!     subroutine mulmv(a,b,c,n)
+!     subroutine mulmm(a,b,c,n)
+!     subroutine resmm(a,b,c,n)
+!     subroutine mulvv(a,b,c,n)
+!     subroutine sumvv(a,b,c,n)
+!     subroutine zerom(a,n)
+!     subroutine zero4m(a,b,c,d,n)
+!     subroutine zero3m(a,b,c,n)
+!     subroutine zero2m(a,b,n)
+!     subroutine zerov(a,n)
+!     subroutine zero4v(a,b,c,d,n)
+!     subroutine zero3v(a,b,c,n)
+!     subroutine zero2v(a,b,n)
+
+!
+!
+!   May-05 Sustituimos todos los zerojt de cristina por las subrutinas
+!          genericas zerov***
+!
+c     ***********************************************************************
+      subroutine unit(a,n)
+c     store the unit value in the diagonal of a 
+c     ***********************************************************************
+      real*8 a(n,n)
+      integer n,i,j,k
+      do 1,i=2,n-1
+         do 2,j=2,n-1
+	    if(i.eq.j) then
+               a(i,j) = 1.d0
+	    else
+               a(i,j)=0.0d0
+	    end if
+ 2       continue
+ 1    continue
+      do k=1,n
+         a(n,k) = 0.0d0
+         a(1,k) = 0.0d0
+         a(k,1) = 0.0d0
+         a(k,n) = 0.0d0
+      end do
+      return
+      end
+
+c     ***********************************************************************
+      subroutine diago(a,v,n)
+c     store the vector v in the diagonal elements of the square matrix a
+c     ***********************************************************************
+      implicit none
+
+      integer n,i,j,k
+      real*8 a(n,n),v(n)
+
+      do 1,i=2,n-1
+         do 2,j=2,n-1
+	    if(i.eq.j) then
+               a(i,j) = v(i)
+	    else
+               a(i,j)=0.0d0
+	    end if
+ 2       continue
+ 1    continue
+      do k=1,n
+         a(n,k) = 0.0d0
+         a(1,k) = 0.0d0
+         a(k,1) = 0.0d0
+         a(k,n) = 0.0d0
+      end do
+      return
+      end  
+
+c     ***********************************************************************
+      subroutine samem (a,m,n)
+c     store the matrix m in the matrix a 
+c     ***********************************************************************
+      real*8 a(n,n),m(n,n)
+      integer n,i,j,k
+      do 1,i=2,n-1
+         do 2,j=2,n-1
+            a(i,j) = m(i,j)  
+ 2       continue
+ 1    continue 	
+      do k=1,n
+         a(n,k) = 0.0d0
+         a(1,k) = 0.0d0
+         a(k,1) = 0.0d0
+         a(k,n) = 0.0d0
+      end do
+      return
+      end 
+c     ***********************************************************************
+      subroutine mulmv(a,b,c,n)
+c     do a(i)=b(i,j)*c(j). a, b, and c must be distint
+c     ***********************************************************************
+      implicit none
+
+      integer n,i,j
+      real*8 a(n),b(n,n),c(n),sum
+
+      do 1,i=2,n-1
+         sum=0.0d0
+         do 2,j=2,n-1
+	    sum=sum+ (b(i,j)) * (c(j))
+ 2       continue
+         a(i)=sum
+ 1    continue
+      a(1) = 0.0d0
+      a(n) = 0.0d0
+      return
+      end
+
+c     ***********************************************************************
+      subroutine mulmm(a,b,c,n)
+c     ***********************************************************************
+      real*8 a(n,n), b(n,n), c(n,n)
+      integer n,i,j,k
+
+!	do i=2,n-1
+!	  do j=2,n-1
+!	    a(i,j)= 0.d00
+!	    do k=2,n-1
+!		a(i,j) = a(i,j) + b(i,k) * c(k,j)
+!	    end do
+!	  end do
+!	end do
+      do j=2,n-1
+         do i=2,n-1
+            a(i,j)=0.d0
+         enddo
+         do k=2,n-1
+            do i=2,n-1
+               a(i,j)=a(i,j)+b(i,k)*c(k,j)
+            enddo
+         enddo
+      enddo
+      do k=1,n
+         a(n,k) = 0.0d0
+         a(1,k) = 0.0d0
+         a(k,1) = 0.0d0
+         a(k,n) = 0.0d0
+      end do
+
+      return
+      end
+
+c     ***********************************************************************
+      subroutine resmm(a,b,c,n)
+c     ***********************************************************************
+      real*8 a(n,n), b(n,n), c(n,n)
+      integer n,i,j,k
+
+      do i=2,n-1
+         do j=2,n-1
+	    a(i,j)= b(i,j) - c(i,j)
+         end do
+      end do
+      do k=1,n
+         a(n,k) = 0.0d0
+         a(1,k) = 0.0d0
+         a(k,1) = 0.0d0
+         a(k,n) = 0.0d0
+      end do
+
+      return
+      end
+
+c     ***********************************************************************
+      subroutine sumvv(a,b,c,n)
+c     a(i)=b(i)+c(i)
+c     ***********************************************************************
+      implicit none
+
+      integer n,i
+      real*8 a(n),b(n),c(n)
+
+      do 1,i=2,n-1
+         a(i)= (b(i)) + (c(i))
+ 1    continue
+      a(1) = 0.0d0
+      a(n) = 0.0d0
+      return
+      end
+
+c     ***********************************************************************
+      subroutine zerom(a,n)
+c     a(i,j)= 0.0
+c     ***********************************************************************
+
+      implicit none
+
+      integer n,i,j
+      real*8 a(n,n)
+
+      do 1,i=1,n
+         do 2,j=1,n
+	    a(i,j) = 0.0d0
+ 2       continue
+ 1    continue
+      return
+      end
+
+c     ***********************************************************************
+      subroutine zero4m(a,b,c,d,n)
+c     a(i,j) = b(i,j) = c(i,j) = d(i,j) = 0.0 
+c     ***********************************************************************
+      real*8 a(n,n), b(n,n), c(n,n), d(n,n)
+      integer n,i,j
+      do 1,i=1,n
+         do 2,j=1,n
+	    a(i,j) = 0.0d0
+	    b(i,j) = 0.0d0
+	    c(i,j) = 0.0d0
+	    d(i,j) = 0.0d0
+ 2       continue
+ 1    continue
+      return
+      end
+
+c     ***********************************************************************
+      subroutine zero3m(a,b,c,n)
+c     a(i,j) = b(i,j) = c(i,j) = 0.0 
+c     **********************************************************************
+      real*8 a(n,n), b(n,n), c(n,n)
+      integer n,i,j
+      do 1,i=1,n
+         do 2,j=1,n
+	    a(i,j) = 0.0d0
+	    b(i,j) = 0.0d0
+	    c(i,j) = 0.0d0
+ 2       continue
+ 1    continue
+      return
+      end
+
+c     ***********************************************************************
+      subroutine zero2m(a,b,n)
+c     a(i,j) = b(i,j) = 0.0 
+c     ***********************************************************************
+      real*8 a(n,n), b(n,n)
+      integer n,i,j
+      do 1,i=1,n
+         do 2,j=1,n
+	    a(i,j) = 0.0d0
+	    b(i,j) = 0.0d0
+ 2       continue
+ 1    continue
+      return
+      end
+c     ***********************************************************************
+      subroutine zerov(a,n)
+c     a(i)= 0.0
+c     ***********************************************************************
+      real*8 a(n)
+      integer n,i
+      do 1,i=1,n
+         a(i) = 0.0d0
+ 1    continue
+      return
+      end
+c     ***********************************************************************
+      subroutine zero4v(a,b,c,d,n)
+c     a(i) = b(i) = c(i) = d(i,j) = 0.0
+c     ***********************************************************************
+      real*8 a(n), b(n), c(n), d(n)
+      integer n,i
+      do 1,i=1,n
+         a(i) = 0.0d0
+         b(i) = 0.0d0
+         c(i) = 0.0d0
+         d(i) = 0.0d0
+ 1    continue
+      return
+      end
+c     ***********************************************************************
+      subroutine zero3v(a,b,c,n)
+c     a(i) = b(i) = c(i) = 0.0
+c     ***********************************************************************
+      real*8 a(n), b(n), c(n) 
+      integer n,i
+      do 1,i=1,n
+         a(i) = 0.0d0
+         b(i) = 0.0d0
+         c(i) = 0.0d0
+ 1    continue
+      return
+      end
+c     ***********************************************************************
+      subroutine zero2v(a,b,n)
+c     a(i) = b(i) = 0.0
+c     ***********************************************************************
+      real*8 a(n), b(n) 
+      integer n,i
+      do 1,i=1,n
+         a(i) = 0.0d0
+         b(i) = 0.0d0
+ 1    continue
+      return
+      end
+
+
Index: /trunk/LMDZ.MARS/libf/phymars/nlte_calc.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/nlte_calc.F	(revision 498)
+++ /trunk/LMDZ.MARS/libf/phymars/nlte_calc.F	(revision 498)
@@ -0,0 +1,4088 @@
+c***********************************************************************
+c     mzescape.f                                    
+c***********************************************************************
+c                                               
+c     program  for calculating atmospheric escape functions, from           
+c     a calculation of transmittances and derivatives of these ones   
+      
+      subroutine mzescape(ig,taustar,tauinf,tauii, ib,isot, iirw,iimu)       
+
+c     jul 2011        malv+fgg   adapted to LMD-MGCM                        
+c     nov 99          malv    adapt mztf to compute taustar (pg.23b-ma
+c     nov 98          malv    allow for overlaping in the lorentz line
+c     jan 98		malv	version for mz1d. based on curtis/mztf.for   
+c     17-jul-96	mlp&crs	change the calculation of mr.     
+c     evitar: divide por cero. anhadiendo: ff    
+c     oct-92		malv 	correct s(t) dependence for all histogr bands
+c     june-92		malv	proper lower levels for laser bands         
+c     may-92		malv 	new temperature dependence for laser bands  
+c     @    991 		malv 	boxing for the averaged absorber amount and t
+c     ?		malv	extension up to 200 km altitude in mars 
+c     13-nov-86	mlp	include the temperature weighted to match 
+c				the eqw in the strong doppler limit.       
+c***********************************************************************
+                                                            
+      implicit none                                  
+                                                            
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+      
+                                                            
+c arguments          
+      integer         ig        ! ADDED FOR TRACEBACK
+      real*8 		taustar(nl) ! o                   
+      real*8 		tauinf(nl) ! o                   
+      real*8 		tauii(nl) ! o                   
+      integer		ib      ! i 
+      integer		isot    ! i
+      integer		iirw    ! i
+      integer		iimu    ! i
+                                                            
+                                                            
+c local variables and constants                 
+      integer 	i, in, ir, im, k,j                      
+      integer 	nmu                                   
+      parameter 	(nmu = 8)                          
+!     real*8 		tauinf(nl)                           
+      real*8 		con(nzy), coninf                       
+      real*8 		c1, c2, ccc                           
+      real*8 		t1, t2                                
+      real*8 		p1, p2                                
+      real*8		mr1, mr2                               
+      real*8 		st1, st2                              
+      real*8 		c1box(70), c2box(70)                  
+      real*8		ff      ! to avoid too small numbers
+      real*8		tvtbs(nzy)                              
+      real*8 		st, beta, ts, eqwmu                   
+      real*8 		mu(nmu), amu(nmu)                     
+      real*8  	zld(nl), zyd(nzy)                               
+      real*8 		correc                                
+      real 		deltanux ! width of vib-rot band (cm-1)
+      character	isotcode*2	                          
+      real*8          maximum                        
+      real*8          csL, psL, Desp, wsL ! for Strong Lorentz limit
+                                                            
+c formats                                       
+ 111  format(a1)                                 
+ 112  format(a2)                                 
+ 101  format(i1)                                 
+ 202  format(i2)                                 
+ 180  format(a80)                                
+ 181  format(a80)                                
+c***********************************************************************
+                                                            
+c some needed values                            
+!     rl=sqrt(log(2.d0))                             
+!     pi2 = 3.14159265358989d0                       
+      beta = 1.8d0                                   
+!     imrco = 0.9865                                 
+      
+c  esto es para que las subroutines de mztfsub calculen we  
+c  de la forma apropiada para mztf, no para fot 
+      icls=icls_mztf                                 
+                                                            
+c codigos para filenames                        
+!     if (isot .eq. 1)  isotcode = '26'              
+!     if (isot .eq. 2)  isotcode = '28'              
+!     if (isot .eq. 3)  isotcode = '36'              
+!     if (isot .eq. 4)  isotcode = '27'              
+!     if (isot .eq. 5)  isotcode = '62'              
+!     if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5     
+!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
+!!		encode(2,101,ibcode1)ib                       
+!     write ( ibcode1, 101) ib                       
+!     else                                           
+!!		encode(2,202,ibcode2)ib
+!     write (ibcode2, 202) ib
+!     endif                                          
+!     write (*,'( 30h calculating curtis matrix :  ,2x,         
+!     @    	8h band = ,i2,2x, 11h isotope = ,i2)') ib, isot         
+                                                            
+c integration in angle !!!!!!!!!!!!!!!!!!!!     
+                                                            
+c------- diffusivity approx.                    
+      if (iimu.eq.1) then                            
+!	  write (*,*)  ' diffusivity approx. beta = ',beta             
+         mu(1) = 1.0d0                                
+         amu(1)= 1.0d0                                
+c-------data for 8 points integration           
+      elseif (iimu.eq.4) then                        
+         write (*,*)' 4 points for the gauss-legendre angle quadrature.'
+         mu(1)=(1.0d0+0.339981043584856)/2.0d0 	      
+         mu(2)=(1.0d0-0.339981043584856)/2.0d0 	      
+         mu(3)=(1.0d0+0.861136311594053)/2.0d0        
+         mu(4)=(1.0d0-0.861136311594053)/2.0d0 	      
+         amu(1)=0.652145154862546 	                   
+         amu(2)=amu(1) 	                              
+         amu(3)=0.347854845137454 	                   
+         amu(4)=amu(3)                                
+         beta=1.0d0                                   
+c-------data for 8 points integration           
+      elseif(iimu.eq.8) then                         
+         write (*,*)' 8 points for the gauss-legendre angle quadrature.'
+         mu(1)=(1.0d0+0.183434642495650)/2.0d0        
+         mu(2)=(1.0d0-0.183434642495650)/2.0d0        
+         mu(3)=(1.0d0+0.525532409916329)/2.0d0        
+         mu(4)=(1.0d0-0.525532409916329)/2.0d0        
+         mu(5)=(1.0d0+0.796666477413627)/2.0d0        
+         mu(6)=(1.0d0-0.796666477413627)/2.0d0        
+         mu(7)=(1.0d0+0.960289856497536)/2.0d0        
+         mu(8)=(1.0d0-0.960289856497536)/2.0d0        
+         amu(1)=0.362683783378362                     
+         amu(2)=amu(1)                                
+         amu(3)=0.313706645877887                     
+         amu(4)=amu(3)                                
+         amu(5)=0.222381034453374                     
+         amu(6)=amu(5)                                
+         amu(7)=0.101228536290376                     
+         amu(8)=amu(7)                                
+         beta=1.0d0                                   
+      end if                                         
+c!!!!!!!!!!!!!!!!!!!!!!!                        
+                                                            
+ccc                                             
+ccc  determine abundances included in the absorber amount   
+ccc                                             
+                                                            
+c first, set up the grid ready for interpolation.           
+      do i=1,nzy                                      
+         zyd(i) = dble(zy(i))                         
+      enddo                                          
+      do i=1,nl                                      
+         zld(i) = dble(zl(i))                         
+      enddo                                          
+                                                            
+c vibr. temp of the bending mode :              
+      if (isot.eq.1) call interdp ( tvtbs,zyd,nzy, v626t1,zld,nl, 1 )  
+      if (isot.eq.2) call interdp ( tvtbs,zyd,nzy, v628t1,zld,nl, 1 )  
+      if (isot.eq.3) call interdp ( tvtbs,zyd,nzy, v636t1,zld,nl, 1 )  
+      if (isot.eq.4) call interdp ( tvtbs,zyd,nzy, v627t1,zld,nl, 1 )  
+      
+c 2nd: correccion a la n10(i) (cantidad de absorbente en el lower state)
+c por similitud a la que se hace en cza.for     
+                                                            
+      do i=1,nzy                                      
+         if (isot.eq.5) then                          
+	    con(i) = dble( coy(i) * imrco )            
+         else                                         
+	    con(i) =  dble( co2y(i) * imr(isot) )      
+	    correc = 2.d0 * dexp( dble(-ee*elow(isot,2))/tvtbs(i) )            
+	    con(i) = con(i) * ( 1.d0 - correc )        
+         endif                                        
+c-----------------------------------------------------------------------
+c mlp & cristina. 17 july 1996                  
+c change the calculation of mr. it is used for calculating partial press
+c alpha = alpha(self,co2)*pp +alpha(n2)*(pt-pp) 
+c for an isotope, if mr is obtained by co2*imr(iso)/nt we are considerin
+c collisions with other co2 isotopes (including the major one, 626)     
+c as if they were with n2. assuming mr as co2/nt, we consider collisions
+c of type 628-626 as of 626-626 instead of as 626-n2.       
+c	  mrx(i)=con(i)/ntx(i) ! old malv             
+                                                            
+!	  mrx(i)= dble(co2x(i)/ntx(i))	! mlp & crs    
+                                                            
+c jan 98:                                       
+c esta modif de mlp implica anular el correc (deberia revisar esto)     
+         mr(i) = dble(co2y(i)/nty(i)) ! malv, jan 98  
+                                                            
+c-----------------------------------------------------------------------
+                                                            
+      end do                                         
+                                                            
+! como  beta y 1.d5 son comunes a todas las weighted absorber amounts,  
+! los simplificamos:                            
+!	coninf = beta * 1.d5 * dble( con(n) / log( con(n-1) / con(n) ) )      
+      coninf = dble( con(nzy) / log( con(nzy-1) / con(nzy) ) )      
+                                                            
+!	write (*,*)  ' coninf =', coninf                               
+                                                            
+ccc                                             
+ccc  temp dependence of the band strength and   
+ccc  nlte correction factor for the absorber amount         
+ccc                                             
+      call mztf_correccion ( coninf, con, ib, isot, 0 ) 
+                                                            
+ccc                                             
+ccc reads histogrammed spectral data (strength for lte and vmr=1)       
+ccc                                             
+	!hfile1 = dirspec//'hi'//dn        ! Ya no distinguimos entre d/n
+!!	hfile1 = dirspec//'hid'            ! (see why in his.for)
+!        hfile1='hid'
+!!	if (ib.eq.13 .or. ib.eq.14 ) hfile1 = dirspec//'his'       
+!        if (ib.eq.13 .or. ib.eq.14 ) hfile1 = 'his'  
+                                                            
+!	if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5     
+!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
+!	   if (isot.eq.1) hisfile = hfile1//'26-'//ibcode1//'.dat' 
+!	   if (isot.eq.2) hisfile = hfile1//'28-'//ibcode1//'.dat' 
+!	   if (isot.eq.3) hisfile = hfile1//'36-'//ibcode1//'.dat' 
+!	   if (isot.eq.4) hisfile = hfile1//'27-'//ibcode1//'.dat' 
+!	   if (isot.eq.5) hisfile = hfile1//'62-'//ibcode1//'.dat' 
+!	else                                           
+!	   if (isot.eq.1) hisfile = hfile1//'26-'//ibcode2//'.dat' 
+!	   if (isot.eq.2) hisfile = hfile1//'28-'//ibcode2//'.dat' 
+!	   if (isot.eq.3) hisfile = hfile1//'36-'//ibcode2//'.dat' 
+!	   if (isot.eq.4) hisfile = hfile1//'27-'//ibcode2//'.dat' 
+!	   if (isot.eq.5) hisfile = hfile1//'62-'//ibcode2//'.dat' 
+!	endif                                          
+	!write (*,*) ' /MZESCAPE/ hisfile: ', hisfile                         
+                                                            
+! the argument to rhist is to make this compatible with mztf_comp.f,    
+! which is a useful modification of mztf.f (to change strengths of bands
+!	call rhist (1.0)                               
+      if(ib.eq.1) then
+         if(isot.eq.1) then     !Case 1
+            mm=mm_c1
+            nbox=nbox_c1
+            tmin=tmin_c1
+            tmax=tmax_c1
+            do i=1,nbox_max
+               no(i)=no_c1(i)
+               dist(i)=dist_c1(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c1(j,i)
+                  xls1(j,i)=xls1_c1(j,i)
+                  xln1(j,i)=xln1_c1(j,i)
+                  xld1(j,i)=xld1_c1(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c1(j)
+            enddo
+         else if(isot.eq.2) then !Case 2
+            mm=mm_c2
+            nbox=nbox_c2
+            tmin=tmin_c2
+            tmax=tmax_c2
+            do i=1,nbox_max
+               no(i)=no_c2(i)
+               dist(i)=dist_c2(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c2(j,i)
+                  xls1(j,i)=xls1_c2(j,i)
+                  xln1(j,i)=xln1_c2(j,i)
+                  xld1(j,i)=xld1_c2(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c2(j)
+            enddo
+         else if(isot.eq.3) then !Case 3
+            mm=mm_c3
+            nbox=nbox_c3
+            tmin=tmin_c3
+            tmax=tmax_c3
+            do i=1,nbox_max
+               no(i)=no_c3(i)
+               dist(i)=dist_c3(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c3(j,i)
+                  xls1(j,i)=xls1_c3(j,i)
+                  xln1(j,i)=xln1_c3(j,i)
+                  xld1(j,i)=xld1_c3(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c3(j)
+            enddo
+         else if(isot.eq.4) then !Case 4
+            mm=mm_c4
+            nbox=nbox_c4
+            tmin=tmin_c4
+            tmax=tmax_c4
+            do i=1,nbox_max
+               no(i)=no_c4(i)
+               dist(i)=dist_c4(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c4(j,i)
+                  xls1(j,i)=xls1_c4(j,i)
+                  xln1(j,i)=xln1_c4(j,i)
+                  xld1(j,i)=xld1_c4(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c4(j)
+            enddo
+         else
+            write(*,*)'isot must be 2,3 or 4 for ib=1!!'
+            write(*,*)'stop at mzescape/312'
+            stop
+         endif
+      else if (ib.eq.2) then
+         if(isot.eq.1) then	!Case 5
+            mm=mm_c5
+            nbox=nbox_c5
+            tmin=tmin_c5
+            tmax=tmax_c5
+            do i=1,nbox_max
+               no(i)=no_c5(i)
+               dist(i)=dist_c5(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c5(j,i)
+                  xls1(j,i)=xls1_c5(j,i)
+                  xln1(j,i)=xln1_c5(j,i)
+                  xld1(j,i)=xld1_c5(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c5(j)
+            enddo
+         else
+            write(*,*)'isot must be 1 for ib=2!!'
+            write(*,*)'stop at mzescape/336'
+            stop
+         endif
+      else if (ib.eq.3) then
+         if(isot.eq.1) then	!Case 6
+            mm=mm_c6
+            nbox=nbox_c6
+            tmin=tmin_c6
+            tmax=tmax_c6
+            do i=1,nbox_max
+               no(i)=no_c6(i)
+               dist(i)=dist_c6(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c6(j,i)
+                  xls1(j,i)=xls1_c6(j,i)
+                  xln1(j,i)=xln1_c6(j,i)
+                  xld1(j,i)=xld1_c6(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c6(j)
+            enddo
+         else
+            write(*,*)'isot must be 1 for ib=3!!'
+            write(*,*)'stop at mzescape/360'
+            stop
+         endif
+      else if (ib.eq.4) then
+         if(isot.eq.1) then	!Case 7
+            mm=mm_c7
+            nbox=nbox_c7
+            tmin=tmin_c7
+            tmax=tmax_c7
+            do i=1,nbox_max
+               no(i)=no_c7(i)
+               dist(i)=dist_c7(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c7(j,i)
+                  xls1(j,i)=xls1_c7(j,i)
+                  xln1(j,i)=xln1_c7(j,i)
+                  xld1(j,i)=xld1_c7(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c7(j)
+            enddo
+         else
+            write(*,*)'isot must be 1 for ib=4!!'
+            write(*,*)'stop at mzescape/384'
+            stop
+         endif
+      else 
+         write(*,*)'ib must be 1,2,3 or 4!!'
+         write(*,*)'stop at mzescape/389'
+      endif                                                    
+      if (isot.ne.5) deltanux = deltanu(isot,ib)     
+      if (isot.eq.5) deltanux = deltanuco            
+      
+c******                                         
+c****** calculation of tauinf(nl)               
+c******                                         
+      call initial                                   
+                                                            
+      ff=1.0e10                                      
+                                                            
+      do i=nl,1,-1                                   
+                                                            
+         if(i.eq.nl)then                              
+                                                            
+            call intz (zl(i),c2,p2,mr2,t2, con)           
+            do kr=1,nbox                                  
+               ta(kr)=t2                                    
+            end do                                      
+!	write (*,*)  ' i, t2 =', i, t2                                 
+            call interstrength (st2,t2,ka,ta)             
+            aa = p2 * coninf * mr2 * (st2 * ff)           
+            bb = p2 * coninf * st2                        
+            cc = coninf * st2                             
+            dd = t2 * coninf * st2                        
+            do kr=1,nbox                                  
+               ccbox(kr) = coninf * ka(kr)          
+               ddbox(kr) = t2 * ccbox(kr)                  
+!		  c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5   
+               c2box(kr) = c2 * ka(kr) * dble(deltaz)      
+            end do                                        
+!		c2 = c2 * st2 * beta * dble(deltaz) * 1.d5   
+            c2 = c2 * st2 * dble(deltaz)                  
+                                                            
+         else                                         
+            call intz (zl(i),c1,p1,mr1,t1, con)           
+            do kr=1,nbox                                  
+               ta(kr)=t1                                    
+            end do                                      
+!	write (*,*)  ' i, t1 =', i, t1                                 
+            call interstrength (st1,t1,ka,ta)             
+            do kr=1,nbox                                  
+!		  c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5   
+               c1box(kr) = c1 * ka(kr) * dble(deltaz)      
+            end do                                        
+!		c1 = c1 * st1 * beta * dble(deltaz) * 1.d5   
+            c1 = c1 * st1 * dble(deltaz)                  
+            aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0       
+            bb = bb + ( p1*c1 + p2*c2 ) / 2.d0            
+            cc = cc + ( c1 + c2 ) / 2.d0                  
+            ccc = ( c1 + c2 ) / 2.d0                      
+            dd = dd + ( t1*c1 + t2*c2 ) / 2.d0            
+            do kr=1,nbox                                  
+               ccbox(kr) = ccbox(kr) + 
+     @              ( c1box(kr) + c2box(kr) )/2.d0       
+               ddbox(kr) = ddbox(kr) + 
+     @              ( t1*c1box(kr)+t2*c2box(kr) )/2.d0
+            end do                                        
+                                                            
+            mr2 = mr1                                     
+            c2=c1                                         
+            do kr=1,nbox	                                 
+               c2box(kr) = c1box(kr)                       
+            end do                                        
+            t2=t1                                         
+            p2=p1                                         
+         end if                                       
+                                                            
+         pt = bb / cc                                 
+         pp = aa / (cc*ff)                            
+                                                            
+!	  ta=dd/cc                                    
+!	  tdop = ta                                   
+         ts = dd/cc                                   
+         do kr=1,nbox                          
+   	    ta(kr) = ddbox(kr) / ccbox(kr)          
+         end do                                       
+!	write (*,*)  ' i, ts =', i, ts                                 
+         call interstrength(st,ts,ka,ta)              
+!	  call intershape(alsa,alna,alda,tdop)        
+         call intershape(alsa,alna,alda,ta)           
+                                                            
+*	  ua = cc/st                                  
+                                                            
+c  	next loop calculates the eqw for an especified path ua,pp,pt,ta     
+                                                            
+         eqwmu = 0.0d0                                
+         do im = 1,iimu                               
+	    eqw=0.0d0                                  
+            do  kr=1,nbox                       
+               ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im)       
+               if(ua(kr).lt.0.)write(*,*)'mzescape/480',ua(kr),
+     $              ccbox(kr),ka(kr),beta,mu(im),kr,im,i,nl
+
+               call findw (ig,iirw, 0, csL,psL, Desp, wsL)                       
+               if ( i_supersat .eq. 0 ) then                 
+	          eqw=eqw+no(kr)*w                     
+               else                                          
+                  eqw = w + (no(kr)-1) * ( asat_box*dist(kr) )           
+               endif                                         
+	    end do                                     
+	    eqwmu = eqwmu + eqw * mu(im)*amu(im)       
+         end do                                       
+                                                            
+! 	  tauinf(i) = exp( - eqwmu / dble(deltanux) )            
+         tauinf(i) = 1.d0 - eqwmu / dble(deltanux)    
+         if (tauinf(i).lt.0.d0) tauinf(i) = 0.0d0     
+                                                            
+         if (i.eq.nl) then                            
+            taustar(i) = 0.0d0                        
+         else                                         
+            taustar(i) = dble(deltanux) * (tauinf(i+1)-tauinf(i)) 
+!     ~            / ( beta * cc * 1.d5 )       
+     ~           / ( beta * ccc * 1.d5 )       
+         endif                                        
+                                                            
+      end do                    ! i continue                           
+                                                            
+                                                            
+c******                                         
+c****** calculation of tau(in,ir) for n<=r      
+c******                                         
+                                                            
+      do 1 in=1,nl-1                          
+                                                            
+         call initial                          
+                                                            
+         call intz (zl(in), c1,p1,mr1,t1, con) 
+         do kr=1,nbox                          
+            ta(kr) = t1                         
+         end do                                
+         call interstrength (st1,t1,ka,ta)     
+         do kr=1,nbox                          
+            c1box(kr) = c1 * ka(kr) * dble(deltaz)          
+         end do                                
+         c1 = c1 * st1 * dble(deltaz)          
+                                                            
+         call intz (zl(in+1), c2,p2,mr2,t2, con)           
+         do kr=1,nbox                          
+            ta(kr) = t2                         
+         end do                                
+         call interstrength (st2,t2,ka,ta)     
+         do kr=1,nbox                          
+            c2box(kr) = c2 * ka(kr) * dble(deltaz)          
+         end do                                
+         c2 = c2 * st2 * dble(deltaz)          
+                                                            
+         aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0           
+         bb = bb + ( p1*c1 + p2*c2 ) / 2.d0    
+         cc = cc + ( c1 + c2 ) / 2.d0          
+         dd = dd + ( t1*c1 + t2*c2 ) / 2.d0    
+         do kr=1,nbox                          
+            ccbox(kr) = ccbox(kr) + (c1box(kr)+c2box(kr))/2.d0          
+            ddbox(kr) = ddbox(kr) + (t1*c1box(kr)+t2*c2box(kr))/2.d0    
+         end do                                
+                                                            
+         mr1=mr2                               
+         t1=t2                                 
+         c1=c2                                 
+         p1=p2                                 
+         do kr=1,nbox                          
+            c1box(kr) = c2box(kr)               
+         end do                                
+         pt = bb / cc                          
+         pp = aa / (cc * ff)                   
+         ts = dd/cc                            
+         do kr=1,nbox                          
+            ta(kr) = ddbox(kr) / ccbox(kr)      
+         end do                                
+         call interstrength(st,ts,ka,ta)       
+         call intershape(alsa,alna,alda,ta)    
+                                                            
+         eqwmu = 0.0d0                         
+         do im = 1,iimu                        
+            eqw=0.0d0                           
+            do kr=1,nbox      
+               ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im)
+               if(ua(kr).lt.0.)write(*,*)'mzescape/566',ua(kr),
+     $              ccbox(kr),ka(kr),beta,mu(im),kr,im,i,nl
+               
+               call findw (ig,iirw, 0, csL,psL, Desp, wsL)      
+               if ( i_supersat .eq. 0 ) then               
+                  eqw=eqw+no(kr)*w                          
+               else                                        
+                  eqw = w + (no(kr)-1) * ( asat_box*dist(kr) )         
+               endif                                       
+            end do                              
+            eqwmu = eqwmu + eqw * mu(im)*amu(im)            
+         end do                                
+                                                            
+          tauii(in) = exp( - eqwmu / dble(deltanux) )                         
+          !write (*,*) 'i,tauii=',in,tauii(in)  
+
+ 1     continue                                
+       tauii(nl) = 1.0d0
+                           
+                                                            
+c end                                           
+       return                                         
+       end   
+
+
+
+c***********************************************************************
+c     mzescape_normaliz.f                           
+c***********************************************************************
+c                                               
+c     program  for correcting some strange values and for normalizing       
+c     the atmospheric escape functions computed by mzescape_15um.f    
+c     possibilities according to istyle (see mzescape_15um.f).        
+c                                               
+                                                            
+      subroutine mzescape_normaliz ( taustar, istyle )           
+                                                            
+                                                            
+c     dic 99          malv    first version   
+c     jul 2011 malv+fgg       Adapted to LMD-MGCM
+c***********************************************************************
+                                                            
+      implicit none                                  
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+                                                            
+                                                            
+c arguments                                     
+      real*8 		taustar(nl) ! o                   
+      integer         istyle    ! i            
+                                                            
+c local variables and constants                 
+      integer 	i, imaximum                           
+      real*8          maximum                        
+                                                            
+c***********************************************************************
+                                                            
+!                                               
+! correcting strange values at top, eliminating local maxima, etc...    
+!                                               
+      taustar(nl) = taustar(nl-1)                    
+                                                            
+      if ( istyle .eq. 1 ) then                      
+         imaximum = nl                                
+         maximum = taustar(nl)                        
+         do i=1,nl-1                                  
+	    if (taustar(i).gt.maximum) taustar(i) = taustar(nl)    
+         enddo                                        
+      elseif ( istyle .eq. 2 ) then                  
+         imaximum = nl                                
+         maximum = taustar(nl)                        
+         do i=nl-1,1,-1                               
+	    if (taustar(i).gt.maximum) then            
+	       maximum = taustar(i)                    
+	       imaximum = i                            
+	    endif                                      
+         enddo                                        
+         do i=imaximum,nl                             
+	    if (taustar(i).lt.maximum) taustar(i) = maximum        
+         enddo                                        
+      endif                                          
+                                                            
+!                                               
+! normalizing                                   
+!                                               
+      do i=1,nl                                      
+         taustar(i) = taustar(i) / maximum            
+      enddo                                          
+                                                            
+                                                            
+c end                                           
+      return                                         
+      end 
+
+
+
+c***********************************************************************
+c     mzescape_fb.f                           
+c***********************************************************************
+      subroutine mzescape_fb(ig)                       
+                                                            
+c     computes the escape functions of the most important 15um bands       
+c     this calls mzescape ( taustar,tauinf,tauii,  ib,isot, iirw,iimu 
+                                                            
+c     nov 99 	malv		based on cm15um_fb.f           
+c     jul 2011 malv+fgg       adapted to LMD-MGCM
+c***********************************************************************
+                                                            
+      implicit none                                  
+                                                            
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+                                                            
+c local variables                               
+      integer 	i, ib, ik, istyle                     
+      integer         ig        !ADDED FOR TRACEBACK
+      real*8          tau_factor                     
+      real*8          aux(nl), aux2(nl), aux3(nl)    
+                                                            
+c***********************************************************************
+                                                            
+      call mzescape (ig,taustar21,tauinf210,tauii210,1,2,irw_mztf,imu) 
+      call mzescape (ig,taustar31,tauinf310,tauii310,1,3,irw_mztf,imu)
+      call mzescape (ig,taustar41,tauinf410,tauii410,1,4,irw_mztf,imu)
+                                                            
+      istyle = 2                                     
+      call mzescape_normaliz ( taustar21, istyle )   
+      call mzescape_normaliz ( taustar31, istyle )   
+      call mzescape_normaliz ( taustar41, istyle )   
+                                                            
+                                                            
+c end                                           
+      return                                         
+      end 
+
+
+
+c***********************************************************************
+c     mzescape_fh.f  
+c***********************************************************************
+      subroutine mzescape_fh(ig)                     
+              
+c     jul 2011 malv+fgg                                
+c***********************************************************************
+                                                            
+      implicit none                                  
+                                                            
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+                                                            
+c local variables                               
+      integer 	i, ib, ik, istyle
+      integer         ig        ! ADDED FOR TRACEBACK
+      real*8          tau_factor                     
+      real*8          aux(nl), aux2(nl), aux3(nl)    
+                                                            
+c***********************************************************************
+                                                            
+      call zero4v( aux, taustar12,tauinf121,tauii121, nl)
+      do ik=1,3                               
+         ib=ik+1                               
+         call mzescape ( ig,aux,aux2,aux3, ib, 1,irw_mztf,imu )         
+         tau_factor = 1.d0                     
+         if (ik.eq.1) tau_factor = dble(667.75/618.03)            
+         if (ik.eq.3) tau_factor = dble(667.75/720.806)    
+         do i=1,nl                                    
+            taustar12(i) = taustar12(i) + aux(i) * tau_factor           
+            tauinf121(i) = tauinf121(i) + aux2(i) * tau_factor          
+            tauii121(i) = tauii121(i) + aux3(i) * tau_factor            
+         enddo                                        
+      enddo                                          
+                                                            
+      istyle = 2                                     
+      call mzescape_normaliz ( taustar12, istyle )   
+                                                            
+                                                           
+                                                            
+c end                                           
+      return                                         
+      end 
+
+
+
+
+
+c***********************************************************************
+c     mztud.f                                        
+c***********************************************************************
+
+      subroutine mztud ( ig,cf,cfup,cfdw,vc,taugr, ib,isot,          
+     @     iirw,iimu,itauout,icfout,itableout )   
+            
+c     program  for calculating atmospheric transmittances       
+c     to be used in the calculation of curtis matrix coefficients           
+c     i*out = 1	output of data 
+c     i*out = 0	no output   
+c     itableout = 30  output de toda la C.M. y el VC y las poblaciones de los
+c                         estados 626(020), esta opcion nueva se añade porque 
+c                         itableout=1 saca o bien solamente de 5 en 5 capas 
+c                         o bien los elementos de C.M. desde una cierta capa 
+c                         (consultese elimin_mz1d.f que es quien lo hace); lo
+c                         de las poblaciones (020) lo hace mztf_correcion.f
+
+c     jul 2011        malv+fgg Adapted to LMD-MGCM  
+c     jan 07          malv    Add new vertical fine grid zy, similar to zx
+c     sep-oct 01      malv    update for fluxes for hb and fb, adapt to Linux
+c     nov 98          mavl    allow for overlaping in the lorentz line
+c     jan 98		malv	version for mz1d. based on curtis/mztf.for   
+c     17-jul-96	mlp&crs	change the calculation of mr.     
+c				evitar: divide por cero. anhadiendo: ff    
+c     oct-92		malv 	correct s(t) dependence for all histogr bands
+c     june-92		malv	proper lower levels for laser bands         
+c     may-92		malv 	new temperature dependence for laser bands  
+c     @    991 		malv 	boxing for the averaged absorber amount and t
+c     ?		malv	extension up to 200 km altitude in mars
+c     13-nov-86	mlp	include the temperature weighted to match
+c				the eqw in the strong doppler limit.       
+c***********************************************************************
+            
+      implicit none      
+            
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+                         
+c arguments             
+      integer         ig        !ADDED FOR TRACEBACK
+      real*8  	cf(nl,nl), cfup(nl,nl), cfdw(nl,nl) ! o    
+      real*8		vc(nl),  taugr(nl) ! o        
+      integer		ib      ! i    
+      integer		isot    ! i  
+      integer		iirw    ! i  
+      integer		iimu    ! i  
+      integer		itauout ! i           
+      integer		icfout  ! i            
+      integer		itableout ! i          
+            
+c local variables and constants     
+      integer 	i, in, ir, im, k,j
+      integer 	nmu           
+      parameter 	(nmu = 8)  
+      real*8 		tau(nl,nl)    
+      real*8 		tauinf(nl)    
+      real*8 		con(nzy), coninf           
+      real*8 		c1, c2        
+      real*8 		t1, t2        
+      real*8 		p1, p2        
+      real*8		mr1, mr2       
+      real*8 		st1, st2      
+      real*8 		c1box(70), c2box(70)      
+      real*8		ff      ! to avoid too small numbers      
+      real*8		tvtbs(nzy)      
+      real*8 		st, beta, ts, eqwmu       
+      real*8 		mu(nmu), amu(nmu)         
+      real*8  	zld(nl), zyd(nzy)
+      real*8 		correc        
+      real 		deltanux ! width of vib-rot band (cm-1)    
+      character	isotcode*2 
+      integer         idummy
+      real*8          Desp,wsL
+       
+c formats   
+ 111  format(a1)         
+ 112  format(a2)         
+ 101  format(i1)         
+ 202  format(i2)         
+ 180  format(a80)        
+ 181  format(a80)        
+c***********************************************************************
+            
+c some needed values    
+!     rl=sqrt(log(2.d0))     
+!     pi2 = 3.14159265358989d0           
+      beta = 1.8d0           
+!     beta = 1.0d0           
+      idummy = 0
+      Desp = 0.0d0
+      wsL = 0.0d0
+      
+!	write (*,*) ' MZTUD/ iirw = ', iirw
+
+
+c  esto es para que las subroutines de mztfsub calculen we  
+c  de la forma apropiada para mztf, no para fot 
+      icls=icls_mztf
+            
+c codigos para filenames            
+!     if (isot .eq. 1)  isotcode = '26'  
+!     if (isot .eq. 2)  isotcode = '28'  
+!     if (isot .eq. 3)  isotcode = '36'  
+!     if (isot .eq. 4)  isotcode = '27'  
+!     if (isot .eq. 5)  isotcode = '62'  
+!     if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5     
+!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
+!     write (ibcode1,101) ib           
+!     else       
+!     write (ibcode2,202) ib           
+!     endif      
+!     write (*,'( 30h calculating curtis matrix :  ,2x,         
+!     @    	8h band = ,i2,2x, 11h isotope = ,i2)') ib, isot         
+            
+c integration in angle !!!!!!!!!!!!!!!!!!!!     
+c------- diffusivity approx.        
+      if (iimu.eq.1) then    
+!	  write (*,*)  ' diffusivity approx. beta = ',beta 
+         mu(1) = 1.0d0        
+         amu(1)= 1.0d0        
+c-------data for 8 points integration           
+      elseif (iimu.eq.4) then            
+         write (*,*)' 4 points for the gauss-legendre angle quadrature.'
+         mu(1)=(1.0d0+0.339981043584856)/2.0d0 	      
+         mu(2)=(1.0d0-0.339981043584856)/2.0d0 	      
+         mu(3)=(1.0d0+0.861136311594053)/2.0d0        
+         mu(4)=(1.0d0-0.861136311594053)/2.0d0 	      
+         amu(1)=0.652145154862546 	       
+         amu(2)=amu(1) 	      
+         amu(3)=0.347854845137454 	       
+         amu(4)=amu(3)        
+         beta=1.0d0           
+c-------data for 8 points integration           
+      elseif(iimu.eq.8) then             
+         write (*,*)' 8 points for the gauss-legendre angle quadrature.'
+         mu(1)=(1.0d0+0.183434642495650)/2.0d0        
+         mu(2)=(1.0d0-0.183434642495650)/2.0d0        
+         mu(3)=(1.0d0+0.525532409916329)/2.0d0        
+         mu(4)=(1.0d0-0.525532409916329)/2.0d0        
+         mu(5)=(1.0d0+0.796666477413627)/2.0d0        
+         mu(6)=(1.0d0-0.796666477413627)/2.0d0        
+         mu(7)=(1.0d0+0.960289856497536)/2.0d0        
+         mu(8)=(1.0d0-0.960289856497536)/2.0d0        
+         amu(1)=0.362683783378362         
+         amu(2)=amu(1)        
+         amu(3)=0.313706645877887         
+         amu(4)=amu(3)        
+         amu(5)=0.222381034453374         
+         amu(6)=amu(5)        
+         amu(7)=0.101228536290376         
+         amu(8)=amu(7)        
+         beta=1.0d0           
+      end if     
+c!!!!!!!!!!!!!!!!!!!!!!!            
+            
+ccc         
+ccc  determine abundances included in the absorber amount   
+ccc         
+            
+c first, set up the grid ready for interpolation.           
+      do i=1,nzy              
+         zyd(i) = dble(zy(i))             
+      enddo      
+      do i=1,nl              
+         zld(i) = dble(zl(i))             
+      enddo      
+c vibr. temp of the bending mode :  
+      if (isot.eq.1) call interdp ( tvtbs,zyd,nzy, v626t1,zld,nl, 1 )  
+      if (isot.eq.2) call interdp ( tvtbs,zyd,nzy, v628t1,zld,nl, 1 )  
+      if (isot.eq.3) call interdp ( tvtbs,zyd,nzy, v636t1,zld,nl, 1 )  
+      if (isot.eq.4) call interdp ( tvtbs,zyd,nzy, v627t1,zld,nl, 1 )  
+        !if (isot.eq.5) call interdp ( tvtbs,zxd,nz, vcot1,zld,nl, 1 )  
+        
+c 2nd: correccion a la n10(i) (cantidad de absorbente en el lower state)
+c por similitud a la que se hace en cza.for ; esto solo se hace para CO2    
+	!write (*,*) 'imr(isot) = ', isot, imr(isot)
+      do i=1,nzy              
+         if (isot.eq.5) then  
+	    con(i) = dble( coy(i) * imrco )            
+         else     
+	    con(i) =  dble( co2y(i) * imr(isot) )      
+	    correc = 2.d0 * dexp( dble(-ee*elow(isot,2))/tvtbs(i) )            
+	    con(i) = con(i) * ( 1.d0 - correc )       
+!	    write (*,*) ' iz, correc, co2y(i), con(i) =', 
+!     @            i,correc,co2y(i),con(i) 
+         endif    
+
+	    !-----------------------------------------------------------------
+	    ! mlp & cristina. 17 july 1996    change the calculation of mr.  
+	    ! it is used for calculating partial press
+	    !       alpha = alpha(self,co2)*pp +alpha(n2)*(pt-pp) 
+	    ! for an isotope, if mr is obtained by 
+	    !       co2*imr(iso)/nt 
+	    ! we are considerin collisions with other co2 isotopes 
+	    ! (including the major one, 626) as if they were with n2. 
+	    ! assuming mr as co2/nt, we consider collisions
+	    ! of type 628-626 as of 626-626 instead of as 626-n2.       
+	    !	  mrx(i)=con(i)/ntx(i) ! old malv 
+	    !	  mrx(i)= dble(co2x(i)/ntx(i))	! mlp & crs    
+
+	    ! jan 98:   
+	    ! esta modif de mlp implica anular el correc (deberia revisar esto)
+		      
+         mr(i) = dble(co2y(i)/nty(i)) ! malv, jan 98  
+
+	    !-----------------------------------------------------------------
+
+      end do     
+
+! como  beta y 1.d5 son comunes a todas las weighted absorber amounts,  
+! los simplificamos:    
+!	coninf = beta * 1.d5 * dble( con(n) / log( con(n-1) / con(n) ) )      
+	!write (*,*)  ' con(nz), con(nz-1)  =', con(nz), con(nz-1)        
+      coninf = dble( con(nzy) / log( con(nzy-1) / con(nzy) ) )      
+	!write (*,*)  ' coninf =', coninf       
+            
+ccc         
+ccc  temp dependence of the band strength and   
+ccc  nlte correction factor for the absorber amount         
+ccc         
+      call mztf_correccion ( coninf, con, ib, isot, itableout ) 
+ccc         
+ccc reads histogrammed spectral data (strength for lte and vmr=1)       
+ccc         
+	!hfile1 = dirspec//'hi'//dn      !Ya no hacemos distincion d/n en esto
+!	hfile1 = dirspec//'hid'          !(see why in his.for)
+!	hfile1='hid'
+!!	if (ib.eq.13 .or. ib.eq.14 ) hfile1 = dirspec//'his' 
+!	if (ib.eq.13 .or. ib.eq.14 ) hfile1 = 'his' 
+            
+!	if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5     
+!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
+!	   if (isot.eq.1) hisfile = hfile1//'26-'//ibcode1//'.dat' 
+!	   if (isot.eq.2) hisfile = hfile1//'28-'//ibcode1//'.dat' 
+!	   if (isot.eq.3) hisfile = hfile1//'36-'//ibcode1//'.dat' 
+!	   if (isot.eq.4) hisfile = hfile1//'27-'//ibcode1//'.dat' 
+!	   if (isot.eq.5) hisfile = hfile1//'62-'//ibcode1//'.dat'
+!	else       
+!	   if (isot.eq.1) hisfile = hfile1//'26-'//ibcode2//'.dat' 
+!	   if (isot.eq.2) hisfile = hfile1//'28-'//ibcode2//'.dat' 
+!	   if (isot.eq.3) hisfile = hfile1//'36-'//ibcode2//'.dat' 
+!	   if (isot.eq.4) hisfile = hfile1//'27-'//ibcode2//'.dat' 
+!	   if (isot.eq.5) hisfile = hfile1//'62-'//ibcode2//'.dat' 
+!	endif      
+      if(ib.eq.1) then
+         if(isot.eq.1) then     !Case 1
+            mm=mm_c1
+            nbox=nbox_c1
+            tmin=tmin_c1
+            tmax=tmax_c1
+            do i=1,nbox_max
+               no(i)=no_c1(i)
+               dist(i)=dist_c1(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c1(j,i)
+                  xls1(j,i)=xls1_c1(j,i)
+                  xln1(j,i)=xln1_c1(j,i)
+                  xld1(j,i)=xld1_c1(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c1(j)
+            enddo
+         else if(isot.eq.2) then !Case 2
+            mm=mm_c2
+            nbox=nbox_c2
+            tmin=tmin_c2
+            tmax=tmax_c2
+            do i=1,nbox_max
+               no(i)=no_c2(i)
+               dist(i)=dist_c2(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c2(j,i)
+                  xls1(j,i)=xls1_c2(j,i)
+                  xln1(j,i)=xln1_c2(j,i)
+                  xld1(j,i)=xld1_c2(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c2(j)
+            enddo
+         else if(isot.eq.3) then !Case 3
+            mm=mm_c3
+            nbox=nbox_c3
+            tmin=tmin_c3
+            tmax=tmax_c3
+            do i=1,nbox_max
+               no(i)=no_c3(i)
+               dist(i)=dist_c3(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c3(j,i)
+                  xls1(j,i)=xls1_c3(j,i)
+                  xln1(j,i)=xln1_c3(j,i)
+                  xld1(j,i)=xld1_c3(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c3(j)
+            enddo
+         else if(isot.eq.4) then !Case 4
+            mm=mm_c4
+            nbox=nbox_c4
+            tmin=tmin_c4
+            tmax=tmax_c4
+            do i=1,nbox_max
+               no(i)=no_c4(i)
+               dist(i)=dist_c4(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c4(j,i)
+                  xls1(j,i)=xls1_c4(j,i)
+                  xln1(j,i)=xln1_c4(j,i)
+                  xld1(j,i)=xld1_c4(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c4(j)
+            enddo
+         else
+            write(*,*)'isot must be 2,3 or 4 for ib=1!!'
+            write(*,*)'stop at mztud/324'
+            stop
+         endif
+      else if (ib.eq.2) then
+         if(isot.eq.1) then	!Case 5
+            mm=mm_c5
+            nbox=nbox_c5
+            tmin=tmin_c5
+            tmax=tmax_c5
+            do i=1,nbox_max
+               no(i)=no_c5(i)
+               dist(i)=dist_c5(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c5(j,i)
+                  xls1(j,i)=xls1_c5(j,i)
+                  xln1(j,i)=xln1_c5(j,i)
+                  xld1(j,i)=xld1_c5(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c5(j)
+            enddo
+         else
+            write(*,*)'isot must be 1 for ib=2!!'
+            write(*,*)'stop at mztud/348'
+            stop
+         endif
+      else if (ib.eq.3) then
+         if(isot.eq.1) then	!Case 6
+            mm=mm_c6
+            nbox=nbox_c6
+            tmin=tmin_c6
+            tmax=tmax_c6
+            do i=1,nbox_max
+               no(i)=no_c6(i)
+               dist(i)=dist_c6(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c6(j,i)
+                  xls1(j,i)=xls1_c6(j,i)
+                  xln1(j,i)=xln1_c6(j,i)
+                  xld1(j,i)=xld1_c6(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c6(j)
+            enddo
+         else
+            write(*,*)'isot must be 1 for ib=3!!'
+            write(*,*)'stop at mztud/372'
+            stop
+         endif
+      else if (ib.eq.4) then
+         if(isot.eq.1) then	!Case 7
+            mm=mm_c7
+            nbox=nbox_c7
+            tmin=tmin_c7
+            tmax=tmax_c7
+            do i=1,nbox_max
+               no(i)=no_c7(i)
+               dist(i)=dist_c7(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c7(j,i)
+                  xls1(j,i)=xls1_c7(j,i)
+                  xln1(j,i)=xln1_c7(j,i)
+                  xld1(j,i)=xld1_c7(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c7(j)
+            enddo
+         else
+            write(*,*)'isot must be 1 for ib=4!!'
+            write(*,*)'stop at mztud/396'
+            stop
+         endif
+      else 
+         write(*,*)'ib must be 1,2,3 or 4!!'
+         write(*,*)'stop at mztud/401'
+      endif
+		 
+	      
+	   
+ 
+!	write (*,*) 'hisfile: ', hisfile       
+! the argument to rhist is to make this compatible with mztf_comp.f,    
+! which is a useful modification of mztf.f (to change strengths of bands
+!	call rhist (1.0)       
+      if (isot.ne.5) deltanux = deltanu(isot,ib)     
+      if (isot.eq.5) deltanux = deltanuco            
+      
+c******     
+c****** calculation of tauinf(nl)   
+c******     
+      call initial           
+      ff=1.0e10              
+            
+      do i=nl,1,-1           
+            
+         if(i.eq.nl)then      
+            
+            call intz (zl(i),c2,p2,mr2,t2, con)           
+            do kr=1,nbox          
+               ta(kr)=t2            
+            end do              
+!	write (*,*)  ' i, t2 =', i, t2         
+            call interstrength (st2,t2,ka,ta) 
+            aa = p2 * coninf * mr2 * (st2 * ff)           
+            bb = p2 * coninf * st2            
+            cc = coninf * st2     
+            dd = t2 * coninf * st2            
+            do kr=1,nbox          
+               ccbox(kr) = coninf * ka(kr)          
+               ddbox(kr) = t2 * ccbox(kr)      
+!		  c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5   
+               c2box(kr) = c2 * ka(kr) * dble(deltaz)      
+            end do    
+!		c2 = c2 * st2 * beta * dble(deltaz) * 1.d5   
+            c2 = c2 * st2 * dble(deltaz)      
+            
+         else     
+            call intz (zl(i),c1,p1,mr1,t1, con)           
+            do kr=1,nbox          
+               ta(kr)=t1            
+            end do              
+!	write (*,*)  ' i, t1 =', i, t1         
+            call interstrength (st1,t1,ka,ta) 
+            do kr=1,nbox          
+!		  c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5   
+               c1box(kr) = c1 * ka(kr) * dble(deltaz)      
+            end do    
+!		c1 = c1 * st1 * beta * dble(deltaz) * 1.d5   
+            c1 = c1 * st1 * dble(deltaz)      
+            aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0       
+            bb = bb + ( p1*c1 + p2*c2 ) / 2.d0            
+            cc = cc + ( c1 + c2 ) / 2.d0      
+            dd = dd + ( t1*c1 + t2*c2 ) / 2.d0            
+            do kr=1,nbox          
+               ccbox(kr) = ccbox(kr) + 
+     @              ( c1box(kr) + c2box(kr) )/2.d0       
+               ddbox(kr) = ddbox(kr) + 
+     @              ( t1*c1box(kr)+t2*c2box(kr) )/2.d0 
+            end do    
+            
+            mr2 = mr1             
+            c2=c1     
+            do kr=1,nbox	         
+               c2box(kr) = c1box(kr)           
+            end do    
+            t2=t1     
+            p2=p1     
+         end if   
+
+         pt = bb / cc         
+         pp = aa / (cc*ff)    
+            
+!	  ta=dd/cc            
+!	  tdop = ta           
+         ts = dd/cc           
+         do kr=1,nbox  
+   	    ta(kr) = ddbox(kr) / ccbox(kr)          
+         end do   
+!	write (*,*)  ' i, ts =', i, ts         
+         call interstrength(st,ts,ka,ta)  
+!	  call intershape(alsa,alna,alda,tdop)        
+         call intershape(alsa,alna,alda,ta)           
+*	  ua = cc/st          
+
+c  	next loop calculates the eqw for an especified path uapp,pt,ta     
+            
+         eqwmu = 0.0d0        
+         do im = 1,iimu       
+	    eqw=0.0d0          
+            do  kr=1,nbox           
+               ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im)
+               if(ua(kr).lt.0.)write(*,*)'mztud/504',ua(kr),ccbox(kr),
+     $              ka(kr),beta,mu(im),kr,im,i,nl
+               call findw(ig,iirw, idummy,c1,p1,Desp,wsL)           
+               if ( i_supersat .eq. 0 ) then     
+	          eqw=eqw+no(kr)*w         
+               else      
+                  eqw = w + (no(kr)-1) * ( asat_box*dist(kr) )           
+               endif     
+	    end do             
+	    eqwmu = eqwmu + eqw * mu(im)*amu(im)       
+         end do   
+	  
+         tauinf(i) = exp( - eqwmu / dble(deltanux) ) 
+            
+      end do               
+!	if ( isot.eq.1 .and. ib.eq.2 ) then           
+!		write (*,*)  ' tauinf(nl) = ', tauinf(nl)         
+!		write (*,*)  ' tauinf(1) = ', tauinf(1)           
+!	endif     
+            
+c******     
+c****** calculation of tau(in,ir) for n<=r      
+c******     
+        
+      do 1 in=1,nl-1         
+         call initial          
+         call intz (zl(in), c1,p1,mr1,t1, con)          
+         do kr=1,nbox           
+            ta(kr) = t1          
+         end do     
+         call interstrength (st1,t1,ka,ta)  
+         do kr=1,nbox           
+!     c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5    
+            c1box(kr) = c1 * ka(kr) * dble(deltaz)       
+         end do     
+!     c1 = c1 * st1 * beta * dble(deltaz) * 1.d5    
+         c1 = c1 * st1 * dble(deltaz)       
+            
+         do 2 ir=in,nl-1        
+            
+            if (ir.eq.in) then     
+               tau(in,ir) = 1.d0    
+               goto 2   
+            end if     
+            
+            call intz (zl(ir), c2,p2,mr2,t2, con)          
+            do kr=1,nbox           
+               ta(kr) = t2          
+            end do     
+            call interstrength (st2,t2,ka,ta)  
+            do kr=1,nbox           
+!	  c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5    
+               c2box(kr) = c2 * ka(kr) * dble(deltaz)       
+            end do     
+!	c2 = c2 * st2 * beta * dble(deltaz) * 1.e5    
+            c2 = c2 * st2 * dble(deltaz)       
+            
+c	aa = aa + ( p1*mr1*c1 + p2*mr2*c2 ) / 2.d0    
+            aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0        
+            bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 
+            cc = cc + ( c1 + c2 ) / 2.d0       
+            dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 
+            do kr=1,nbox           
+               ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) ) /2.d0  
+               ddbox(kr) = ddbox(kr) + 
+     $              ( t1*c1box(kr) + t2*c2box(kr) ) /2.d0        
+            end do     
+            
+            mr1=mr2    
+            t1=t2      
+            c1=c2      
+            p1=p2      
+            do kr=1,nbox	          
+               c1box(kr) = c2box(kr)            
+            end do     
+            
+            pt = bb / cc           
+            pp = aa / (cc * ff)    
+            
+*	ta=dd/cc              
+*	tdop = ta             
+            ts = dd/cc             
+            do kr=1,nbox    
+               ta(kr) = ddbox(kr) / ccbox(kr)          
+            end do     
+            call interstrength(st,ts,ka,ta)    
+            call intershape(alsa,alna,alda,ta) 
+*	ua = cc/st            
+            
+c  	next loop calculates the eqw for an especified path ua,pp,pt,ta     
+            
+            eqwmu = 0.0d0          
+            do im = 1,iimu         
+               eqw=0.0d0            
+               do kr=1,nbox  
+                  ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im)
+
+                  call findw(ig,iirw, idummy,c1,p1,Desp,wsL)           
+                  if ( i_supersat .eq. 0 ) then     
+                     eqw=eqw+no(kr)*w         
+                  else      
+                     eqw = w + (no(kr)-1) * ( asat_box*dist(kr) )           
+                  endif     
+               end do   
+               eqwmu = eqwmu + eqw * mu(im)*amu(im)         
+            end do     
+
+            tau(in,ir) = exp( - eqwmu / dble(deltanux) )  
+            
+ 2       continue             
+            
+ 1    continue             
+!	if ( isot.eq.1 .and. ib.eq.2 ) then           
+!		write (*,*)  ' tau(1,*) , *=1,20 '    
+!		write (*,*)  ( sngl(tau(1,k)), k=1,20 )           
+!	endif     
+            
+            
+c**********             
+c**********  calculation of tau(in,ir) for n>r  
+c**********             
+            
+      in=nl      
+            
+      call initial           
+      call intz (zl(in), c1,p1,mr1,t1, con)          
+      do kr=1,nbox           
+         ta(kr) = t1          
+      end do     
+      call interstrength (st1,t1,ka,ta)  
+      do kr=1,nbox           
+!	  c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5    
+         c1box(kr) = c1 * ka(kr) * dble(deltaz)       
+      end do     
+!	c1 = c1 * st1 * beta * dble(deltaz) * 1.d5    
+      c1 = c1 * st1 * dble(deltaz)       
+            
+      do 4 ir=in-1,1,-1      
+            
+         call intz (zl(ir), c2,p2,mr2,t2, con)          
+         do kr=1,nbox           
+            ta(kr) = t2          
+         end do     
+         call interstrength (st2,t2,ka,ta)  
+         do kr=1,nbox           
+!	  c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5    
+            c2box(kr) = c2 * ka(kr) * dble(deltaz)       
+         end do     
+!	c2 = c2 * st2 * beta * dble(deltaz) * 1.d5    
+         c2 = c2 * st2 * dble(deltaz)       
+            
+         aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0        
+         bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 
+         cc = cc + ( c1 + c2 ) / 2.d0       
+         dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 
+         do kr=1,nbox           
+            ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) ) /2.d0  
+            ddbox(kr) = ddbox(kr) + 
+     $           ( t1*c1box(kr) + t2*c2box(kr) ) /2.d0        
+         end do     
+         
+         mr1=mr2    
+         c1=c2      
+         t1=t2      
+         p1=p2      
+         do kr=1,nbox           
+            c1box(kr) = c2box(kr)            
+         end do     
+         
+         pt = bb / cc           
+         pp = aa / (cc * ff)    
+         ts = dd / cc           
+         do kr=1,nbox           
+            ta(kr) = ddbox(kr) / ccbox(kr)   
+         end do     
+         call interstrength (st,ts,ka,ta)   
+         call intershape (alsa,alna,alda,ta)            
+            
+*	ua = cc/st            
+            
+c  	next loop calculates the eqw for an especified path ua,pp,pt,ta     
+            
+         eqwmu = 0.0d0          
+         do im = 1,iimu         
+            eqw=0.0d0            
+            do kr=1,nbox  
+               ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im)       
+               if(ua(kr).lt.0.)write(*,*)'mztud/691',ua(kr),ccbox(kr),
+     $              ka(kr),beta,mu(im),kr,im,i,nl
+
+               call findw(ig,iirw, idummy,c1,p1,Desp,wsL)           
+               if ( i_supersat .eq. 0 ) then     
+	          eqw=eqw+no(kr)*w         
+               else      
+                  eqw = w + (no(kr)-1) * ( asat_box*dist(kr) )           
+               endif     
+            end do   
+            eqwmu = eqwmu + eqw * mu(im)*amu(im)         
+         end do     
+            
+         tau(in,ir) = exp( - eqwmu / dble(deltanux) )  
+         
+ 4    continue             
+            
+c           
+c due to the simmetry of the transmittances     
+c           
+      do in=nl-1,2,-1       
+         do ir=in-1,1,-1      
+            tau(in,ir) = tau(ir,in)           
+         end do   
+      end do     
+
+            
+ccc         
+ccc  writing out transmittances     
+ccc         
+      if (itauout.eq.1) then             
+            
+!	        if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5         
+!     @    	 .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then     
+!  	         open( 1, file=          
+!     @    	   dircurtis//'taul'//isotcode//dn//ibcode1//'.dat',     
+!     @    	   access='sequential', form='unformatted' ) 
+!	        else           
+!  	         open( 1, file=          
+!     @    	   dircurtis//'taul'//isotcode//dn//ibcode2//'.dat',     
+!     @    	   access='sequential', form='unformatted' ) 
+!	        endif          
+            
+!		write(1) dummy        
+!		write(1)' format: (tauinf(n),(tau(n,r),r=1,nl),n=1,nl)'   
+!		do in=1,nl            
+!		    write (1) tauinf(in), ( tau(in,ir), ir=1,nl )         
+!		end do    
+!		close(unit=1)         
+            
+      elseif (itauout.eq.2) then         
+  	         
+!	   if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5  
+!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then	     
+!	     open( 1, file=    
+!     @        dircurtis//'taul'//isotcode//dn//ibcode1//'.dat')     
+!	   else    
+!	     open( 1, file=    
+!     @        dircurtis//'taul'//isotcode//dn//ibcode2//'.dat')     
+!	   endif   
+            
+!		!write(1,*) dummy     
+!		!write(1,*) 'tij for curtis matrix calculations '         
+!		!write(1,*)' cira mars model atmosphere '     
+!		!write(1,*)' beta= ',beta,'deltanu= ',deltanux 
+!		write(1,*) nl
+!		write(1,*)
+!     @             ' format: (tauinf(in),(tau(in,ir),ir=1,nl),in=1,nl)'
+	           
+!		do in=1,nl            
+!		    write (1,*) tauinf(in)        
+!		    write (1,*) (tau(in,ir), ir=1,nl)    
+!		end do    
+!		close(unit=1)         
+            
+!	   if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5  
+!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
+!	      write (*,'(1x, 31htransmitances written out in: ,a22)')          
+!     @    	'taul'//isotcode//dn//ibcode1    
+!	   else    
+!	      write (*,'(1x, 31htransmitances written out in: ,a22)')          
+!     @    	'taul'//isotcode//dn//ibcode2    
+!	   endif   
+            
+      end if    
+            
+c cleaning of transmittances        
+!	call elimin_tau(tau,tauinf,nl,nan,itableout,nw,dummy,     
+!     @    					isotcode,dn,ibcode2)        
+            
+c construction of the curtis matrix 
+      
+      call mzcud ( tauinf,tau, cf,cfup,cfdw, vc,taugr,            
+     @     ib,isot,icfout,itableout )            
+            
+c end       
+      return     
+      end
+
+
+
+
+
+c***********************************************************************
+c     mzcud.f  
+c***********************************************************************
+                                                
+      subroutine mzcud( tauinf,tau, c,cup,cdw,vc,taugr,           
+     @     ib,isot,icfout,itableout )           
+ 
+c     old times       mlp     first version of mzcf                
+c     a.k.murphy method to avoid extrapolation in the curtis matrix         
+c     feb-89 	        malv 	AKM method to avoid extrapolation in C.M.
+c     25-sept-96  cristina 	dejar las matrices en doble precision 
+c     jan 98		malv	version para mz1d                
+c     oct 01		malv	update version for fluxes for hb and fb
+c     jul 2011        malv+fgg Adapted to LMD-MGCM
+c***********************************************************************
+                                                
+      implicit none                                  
+                 
+      include 'comcstfi.h'
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+
+c arguments                                     
+      real*8		c(nl,nl), cup(nl,nl), cdw(nl,nl) ! o   
+      real*8 		vc(nl), taugr(nl) ! o       
+      real*8 		tau(nl,nl) ! i                     
+      real*8		tauinf(nl) ! i                      
+      integer		ib      ! i                            
+      integer 	isot		! i                          
+      integer		icfout, itableout ! i               
+                                                
+c external                                      
+      external 	bandid                               
+      character*2 	bandid                            
+                                                
+c local variables                               
+      integer 	i, in, ir, iw, itblout                         
+      real*8		cfup(nl,nl), cfdw(nl,nl)               
+      real*8		a(nl,nl), cf(nl,nl)                    
+      character	isotcode*2, bcode*2                  
+                                                
+c formats                                       
+ 101  format(i1)                                 
+ 202  format(i2)                                 
+ 180  format(a80)                                
+ 181  format(a80)                                
+c***********************************************************************
+                                                
+      if (isot.eq.1)  isotcode = '26'               
+      if (isot.eq.2)  isotcode = '28'               
+      if (isot.eq.3)  isotcode = '36'               
+      if (isot.eq.4)  isotcode = '27'               
+      if (isot.eq.5)  isotcode = 'co'               
+      bcode = bandid( ib )                           
+                                                
+!	write (*,*)  ' '                                               
+                                                
+      do in=1,nl                                     
+                                                
+         do ir=1,nl                             
+                                                
+            cf(in,ir) = 0.0d0                     
+            cfup(in,ir) = 0.0d0                   
+            cfdw(in,ir) = 0.0d0                   
+            c(in,ir) = 0.0d0                      
+            cup(in,ir) = 0.0d0                    
+            cdw(in,ir) = 0.0d0                    
+            a(in,ir) = 0.0d0                      
+                                                
+         end do                                 
+                                                
+         vc(in) = 0.0d0                         
+         taugr(in) = 0.0d0                      
+                                                
+      end do                                  
+                                                
+                                                
+c	the next lines are a reduced and equivalent way of calculating        
+c	the c(in,ir) elements for n=2,nl1 and r=1,nl  
+                                                
+                                                
+c	do in=2,nl1                                   
+c	do ir=1,nl                                    
+c	if(ir.eq.1)then                               
+c	c(in,ir)=tau(in-1,1)-tau(in+1,1)              
+c	elseif(ir.eq.nl)then                          
+c	c(in,ir)=tau(in+1,nl1)-tauinf(in+1)-tau(in-1,nl1)+tauinf(in-1)        
+c	else                                          
+c	c(in,ir)=tau(in+1,ir-1)-tau(in+1,ir)-tau(in-1,ir-1)+tau(in-1,ir)      
+c	end if                                        
+c	c(in,ir)=c(in,ir)*pi*deltanu(ib)/(2.*deltaz*1.0e5)	       
+c	end do                                        
+c	end do	                                       
+c	go to 1000                                    
+                                                
+c calculation of the matrix cfup(nl,nl)         
+                                                
+      cfup(1,1) = 1.d0 - tau(1,1)             
+                                                
+      do in=2,nl                              
+         do ir=1,in                              
+                                                
+            if (ir.eq.1) then                       
+               cfup(in,ir) = tau(in,ir) - tau(in,1)        
+            elseif (ir.eq.in) then                  
+               cfup(in,ir) = 1.d0 - tau(in,ir-1)           
+            else                                    
+               cfup(in,ir) = tau(in,ir) - tau(in,ir-1)     
+            end if                                  
+                                                
+         end do                                  
+      end do                                  
+                                                
+! contribution to upwards fluxes from bb at bottom :        
+      do in=1,nl                              
+         taugr(in) =  tau(in,1)                
+      enddo                                   
+                                                
+c calculation of the matrix cfdw(nl,nl)         
+                                                
+      cfdw(nl,nl) = 1.d0 - tauinf(nl)         
+                                                
+      do in=1,nl-1                            
+         do ir=in,nl                             
+                                                
+            if (ir.eq.in) then                      
+               cfdw(in,ir) = 1.d0 - tau(in,ir)             
+            elseif (ir.eq.nl) then                  
+               cfdw(in,ir) = tau(in,ir-1) - tauinf(in)     
+            else                                    
+               cfdw(in,ir) = tau(in,ir-1) - tau(in,ir)     
+            end if                                  
+                                                
+         end do                                  
+      end do                                  
+                                                
+                                                
+c calculation of the matrix cf(nl,nl)           
+                                                
+      do in=1,nl                                     
+         do ir=1,nl                                     
+                                                
+            if (ir.eq.1) then                              
+	    ! version con l_bb(tg)  =  l_bb(t(1))=j(1) (see also vc below)     
+	    !	cf(in,ir) = tau(in,ir)                   
+	    ! version con l_bb(tg) =/= l_bb(t(1))=j(1) (see also vc below)     
+               cf(in,ir) = tau(in,ir) - tau(in,1)            
+            elseif (ir.eq.nl) then                         
+               cf(in,ir) = tauinf(in) - tau(in,ir-1)         
+            else                                           
+               cf(in,ir) = tau(in,ir) - tau(in,ir-1)         
+            end if                                         
+                                                
+         end do                                         
+      end do                                         
+                                                
+                                                
+c  definition of the a(nl,nl) matrix            
+                                                
+      do in=2,nl-1                                   
+         do ir=1,nl                                      
+            if (ir.eq.in+1) a(in,ir) = -1.d0              
+            if (ir.eq.in-1) a(in,ir) = +1.d0              
+            a(in,ir) = a(in,ir) / ( 2.d0*deltaz*1.d5 )         
+         end do                                       
+      end do                                         
+! this is not needed anymore in the akm scheme  
+!	a(1,1) = +3.d0                                
+!	a(1,2) = -4.d0                                
+!	a(1,3) = +1.d0                                
+!	a(nl,nl)   = -3.d0                            
+!	a(nl,nl1) = +4.d0                             
+!	a(nl,nl2) = -1.d0                             
+                                                
+c calculation of the final curtis matrix ("reduced" by murphy's method) 
+                                                
+      if (isot.ne.5) then                            
+         do in=1,nl                                   
+            do ir=1,nl                                  
+               cf(in,ir) = cf(in,ir) * pi*deltanu(isot,ib)            
+               cfup(in,ir) = cfup(in,ir) * pi*deltanu(isot,ib)        
+               cfdw(in,ir) = cfdw(in,ir) * pi*deltanu(isot,ib)        
+            end do                                      
+            taugr(in) = taugr(in) * pi*deltanu(isot,ib) 
+         end do                                       
+      else                                           
+         do in=1,nl                                   
+            do ir=1,nl                                  
+               cf(in,ir) = cf(in,ir) * pi*deltanuco       
+            enddo                                       
+            taugr(in) = taugr(in) * pi*deltanuco        
+         enddo                                        
+      endif                                          
+                                                
+      do in=2,nl-1                                   
+                                                
+         do ir=1,nl                                   
+                                                
+	    do i=1,nl                                  
+	      ! only c contains the matrix a. matrixes cup,cdw dont because
+	      ! these two will be used for flux calculations, not  
+	      ! only for flux divergencies             
+                                                
+               c(in,ir) = c(in,ir) + a(in,i) * cf(i,ir) 
+		! from this matrix we will extract (see below) the        
+		! nl2 x nl2 "core" for the "reduced" final curtis matrix. 
+                                                
+	    end do                                     
+	    cup(in,ir) = cfup(in,ir)                   
+	    cdw(in,ir) = cfdw(in,ir)                   
+                                                
+         end do			                                    
+	  ! version con l_bb(tg)  =  l_bb(t(1))=j(1)  (see cf above)           
+	  !vc(in) = c(in,1)                            
+	  ! version con l_bb(tg) =/= l_bb(t(1))=j(1)  (see cf above)           
+         if (isot.ne.5) then                            
+            vc(in) =  pi*deltanu(isot,ib)/( 2.d0*deltaz*1.d5 ) *     
+     @           ( tau(in-1,1) - tau(in+1,1) )         
+         else
+            vc(in) =  pi*deltanuco/( 2.d0*deltaz*1.d5 ) *     
+     @           ( tau(in-1,1) - tau(in+1,1) )         
+         endif
+                                    
+      end do			                                      
+		                                              
+ 5    continue                                     
+                                                
+!	write (*,*)  'mztf/1/ c(2,*) =', (c(2,i), i=1,nl)              
+                                                
+!	call elimin_dibuja(c,nl,itableout)            
+                                                
+c ventana del smoothing de c es nw=3 y de vc es 5 (puesto en lisa):     
+c subroutine elimin_mz4(c,vc,ilayer,nl,nan,iw, nw)          
+                                                
+      iw = nan                                       
+      if (isot.eq.4)  iw = 5    ! eliminates values < 1.d-19
+      if (itableout.eq.30) then 
+         itblout = 0 
+      else 
+         itblout = itableout
+      endif
+      call elimin_mz1d (c,vc,0,iw,itblout,nw)      
+                                                
+! upper boundary condition                      
+!   j'(nl) = j'(nl1) ==> j(nl) = 2j(nl1) - j(nl2) ==>       
+      do in=2,nl-1                                   
+         c(in,nl-2) = c(in,nl-2) - c(in,nl)           
+         c(in,nl-1) = c(in,nl-1) + 2.d0*c(in,nl)      
+         cup(in,nl-2) = cup(in,nl-2) - cup(in,nl)     
+         cup(in,nl-1) = cup(in,nl-1) + 2.d0*cup(in,nl)            
+         cdw(in,nl-2) = cdw(in,nl-2) - cdw(in,nl)     
+         cdw(in,nl-1) = cdw(in,nl-1) + 2.d0*cdw(in,nl)            
+      end do			                                      
+!   j(nl) = j(nl1) ==>                          
+!	do in=2,nl1                                   
+!	  c(in,nl1) = c(in,nl1) + c(in,nl)            
+!	end do			                                     
+                                                
+! 1000	continue                                 
+                                                
+
+      if (icfout.eq.1) then                          
+                                                
+!	   if (ib.eq.1 .or. ib.eq.12 .or. ib.eq.16 .or. ib.eq.18) then     
+!		codmatrx = codmatrx_fb                        
+!	   else                                           
+!		codmatrx = codmatrx_hot                       
+!	   end if                                         
+!	   if (ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5    
+!     @        .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then
+!             ibcode2 = '0'//ibcode1
+!           else 
+!             write ( ibcode2, 202) ib
+!           endif
+                                                
+! 	   open ( 1, access='sequential', form='unformatted', file=           
+!     @    dircurtis//'cfl'//isotcode//dn//ibcode2//codmatrx//'.dat')         
+! 	   open ( 2, access='sequential', form='unformatted', file=           
+!     @    dircurtis//'cflup'//isotcode//dn//ibcode2//codmatrx//'.dat')       
+! 	   open ( 3, access='sequential', form='unformatted', file=           
+!     @    dircurtis//'cfldw'//isotcode//dn//ibcode2//codmatrx//'.dat')       
+! 	   open ( 4, access='sequential', form='unformatted', file=           
+!     @    dircurtis//'cflgr'//isotcode//dn//ibcode2//codmatrx//'.dat')       
+                                                
+!	    write(1) dummy                             
+!	    write(1) ' format: (vc(n),(ch(n,r),r=2,nl-1),n=2,nl-1)' 
+!	    do in=2,nl-1                               
+!	     write(1) vc(in), (c(in,ir)  , ir=2,nl-1 )		           
+!!             write (*,*) in, vc(in)
+!	    end do                                     
+                                                
+!	    write(2) dummy                             
+!	    write(2)' format: (cfup(n,r),r=1,nl), n=1,nl)'  
+!	    do in=1,nl                                 
+!	     write(2) ( cup(in,ir)  , ir=1,nl )		      
+!	    end do                                     
+                                                
+!	    write(3) dummy                             
+!	    write(3)' format: (cfdw(n,r),r=1,nl), n=1,nl)'         
+!	    do in=1,nl                                 
+!	     write(3) (cdw(in,ir)  , ir=1,nl )		       
+!	    end do                                     
+                                                
+!	    write(4) dummy   
+!	    write(4)' format: (taugr(n), n=1,nl)'         
+!	    do in=1,nl                                 
+!	     write(4) (taugr(in), ir=1,nl )		       
+!	    end do                 
+!            !write (*,*) ' Last value in file: ', taugr(nl)
+
+!	   write (*,'(1x,30hcurtis matrix written out in: ,a,a,a,a)' )
+!     @     dircurtis//'cfl'//isotcode//dn//ibcode2//codmatrx//'.dat',
+!     @     dircurtis//'cflup'//isotcode//dn//ibcode2//codmatrx//'.dat',
+!     @     dircurtis//'cfldw'//isotcode//dn//ibcode2//codmatrx//'.dat',
+!     @     dircurtis//'cflgr'//isotcode//dn//ibcode2//codmatrx//'.dat'
+                                                
+!           close (1)
+!           close (2)
+!           close (3)
+!           close (4)
+
+      else                                           
+	                                               
+	 ! write (*,*)  ' no curtis matrix output file ', char(10)     
+                                                
+      end if                                         
+
+      if (itableout.eq.30) then ! Force output of C.M. in ascii file 
+
+!	   if (ib.eq.1 .or. ib.eq.12 .or. ib.eq.16 .or. ib.eq.18) then     
+!		codmatrx = codmatrx_fb                        
+!	   else                                           
+!		codmatrx = codmatrx_hot                       
+!	   end if                                         
+!	   if (ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5    
+!     @        .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then
+!             ibcode2 = '0'//ibcode1
+!           else 
+!             write ( ibcode2, 202) ib
+!           endif
+
+! 	   open (10, file=           
+!     &      dircurtis//'table'//isotcode//dn//ibcode2//codmatrx//'.dat')
+!            write(10,*) nl, ' = number of layers '
+!            write(10,*) ' format: (vc(n),(ch(n,r),r=2,nl-1),n=2,nl-1)'
+!            do in=2,nl-1
+!              write(10,*) vc(in), (c(in,ir)  , ir=2,nl-1 )
+!            enddo
+!           close (10)                              
+      endif
+                               
+c end                                           
+      return                                         
+      end  
+
+
+
+
+
+c***********************************************************************
+c     mztvc
+c***********************************************************************
+
+      subroutine mztvc ( ig,vc, ib,isot,          
+     @     iirw,iimu,itauout,icfout,itableout )   
+
+c     jul 2011 malv+fgg           
+c***********************************************************************
+            
+      implicit none      
+      
+      include 'comcstfi.h'
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+
+c arguments             
+      integer         ig        ! ADDED FOR TRACEBACK
+      real*8  	cf(nl,nl), cfup(nl,nl), cfdw(nl,nl) ! o    
+      real*8		vc(nl),  taugr(nl) ! o        
+      integer		ib      ! i    
+      integer		isot    ! i  
+      integer		iirw    ! i  
+      integer		iimu    ! i  
+      integer		itauout ! i           
+      integer		icfout  ! i            
+      integer		itableout ! i          
+            
+c local variables and constants     
+      integer 	i, in, ir, im, k ,j         
+      integer 	nmu           
+      parameter 	(nmu = 8)  
+      real*8 		tau(nl,nl)    
+      real*8 		tauinf(nl)    
+      real*8 		con(nzy), coninf           
+      real*8 		c1, c2        
+      real*8 		t1, t2        
+      real*8 		p1, p2        
+      real*8		mr1, mr2       
+      real*8 		st1, st2      
+      real*8 		c1box(70), c2box(70)      
+      real*8		ff      ! to avoid too small numbers      
+      real*8		tvtbs(nzy)      
+      real*8 		st, beta, ts, eqwmu       
+      real*8 		mu(nmu), amu(nmu)         
+      real*8  	zld(nl), zyd(nzy)
+      real*8 		correc        
+      real 		deltanux ! width of vib-rot band (cm-1)    
+      character	isotcode*2 
+      integer         idummy
+      real*8          Desp,wsL
+      
+c     formats   
+ 111  format(a1)         
+ 112  format(a2)         
+ 101  format(i1)         
+ 202  format(i2)         
+ 180  format(a80)        
+ 181  format(a80)        
+c***********************************************************************
+            
+c some needed values    
+!     rl=sqrt(log(2.d0))     
+!     pi2 = 3.14159265358989d0           
+      beta = 1.8d0           
+!     beta = 1.0d0           
+      idummy = 0
+      Desp = 0.0d0
+      wsL = 0.0d0
+      
+                                !write (*,*) ' MZTUD/ iirw = ', iirw
+
+
+c  esto es para que las subroutines de mztfsub calculen we  
+c  de la forma apropiada para mztf, no para fot 
+      icls=icls_mztf         
+            
+c codigos para filenames            
+!	if (isot .eq. 1)  isotcode = '26'  
+!	if (isot .eq. 2)  isotcode = '28'  
+!	if (isot .eq. 3)  isotcode = '36'  
+!	if (isot .eq. 4)  isotcode = '27'  
+!	if (isot .eq. 5)  isotcode = '62'  
+!	if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5     
+!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
+!		write (ibcode1,101) ib           
+!	else       
+!		write (ibcode2,202) ib           
+!	endif      
+!	write (*,'( 30h calculating curtis matrix :  ,2x,         
+!     @    	8h band = ,i2,2x, 11h isotope = ,i2)') ib, isot         
+            
+c integration in angle !!!!!!!!!!!!!!!!!!!!     
+            
+c------- diffusivity approx.        
+      if (iimu.eq.1) then    
+!	  write (*,*)  ' diffusivity approx. beta = ',beta 
+         mu(1) = 1.0d0        
+         amu(1)= 1.0d0        
+c-------data for 8 points integration           
+      elseif (iimu.eq.4) then            
+         write (*,*)' 4 points for the gauss-legendre angle quadrature.'
+         mu(1)=(1.0d0+0.339981043584856)/2.0d0 	      
+         mu(2)=(1.0d0-0.339981043584856)/2.0d0 	      
+         mu(3)=(1.0d0+0.861136311594053)/2.0d0        
+         mu(4)=(1.0d0-0.861136311594053)/2.0d0 	      
+         amu(1)=0.652145154862546 	       
+         amu(2)=amu(1) 	      
+         amu(3)=0.347854845137454 	       
+         amu(4)=amu(3)        
+         beta=1.0d0           
+c-------data for 8 points integration           
+      elseif(iimu.eq.8) then             
+         write (*,*)' 8 points for the gauss-legendre angle quadrature.'
+         mu(1)=(1.0d0+0.183434642495650)/2.0d0        
+         mu(2)=(1.0d0-0.183434642495650)/2.0d0        
+         mu(3)=(1.0d0+0.525532409916329)/2.0d0        
+         mu(4)=(1.0d0-0.525532409916329)/2.0d0        
+         mu(5)=(1.0d0+0.796666477413627)/2.0d0        
+         mu(6)=(1.0d0-0.796666477413627)/2.0d0        
+         mu(7)=(1.0d0+0.960289856497536)/2.0d0        
+         mu(8)=(1.0d0-0.960289856497536)/2.0d0        
+         amu(1)=0.362683783378362         
+         amu(2)=amu(1)        
+         amu(3)=0.313706645877887         
+         amu(4)=amu(3)        
+         amu(5)=0.222381034453374         
+         amu(6)=amu(5)        
+         amu(7)=0.101228536290376         
+         amu(8)=amu(7)        
+         beta=1.0d0           
+      end if     
+c!!!!!!!!!!!!!!!!!!!!!!!            
+            
+ccc         
+ccc  determine abundances included in the absorber amount   
+ccc         
+            
+c first, set up the grid ready for interpolation.           
+      do i=1,nzy              
+         zyd(i) = dble(zy(i))             
+      enddo      
+      do i=1,nl              
+         zld(i) = dble(zl(i))             
+      enddo      
+            
+c vibr. temp of the bending mode :  
+      if (isot.eq.1) call interdp ( tvtbs,zyd,nzy, v626t1,zld,nl, 1 )  
+      if (isot.eq.2) call interdp ( tvtbs,zyd,nzy, v628t1,zld,nl, 1 )  
+      if (isot.eq.3) call interdp ( tvtbs,zyd,nzy, v636t1,zld,nl, 1 )  
+      if (isot.eq.4) call interdp ( tvtbs,zyd,nzy, v627t1,zld,nl, 1 )  
+        !if (isot.eq.5) call interdp ( tvtbs,zxd,nz, vcot1,zld,nl, 1 )  
+            
+c 2nd: correccion a la n10(i) (cantidad de absorbente en el lower state)
+c por similitud a la que se hace en cza.for ; esto solo se hace para CO2    
+            
+	!write (*,*) 'imr(isot) = ', isot, imr(isot)
+      do i=1,nzy              
+         if (isot.eq.5) then  
+	    con(i) = dble( coy(i) * imrco )            
+         else     
+	    con(i) =  dble( co2y(i) * imr(isot) )      
+	    correc = 2.d0 * dexp( dble(-ee*elow(isot,2))/tvtbs(i) )            
+	    con(i) = con(i) * ( 1.d0 - correc )       
+!	    write (*,*) ' iz, correc, co2y(i), con(i) =', 
+!     @            i,correc,co2y(i),con(i) 
+         endif    
+
+	    !-----------------------------------------------------------------
+	    ! mlp & cristina. 17 july 1996    change the calculation of mr.  
+	    ! it is used for calculating partial press
+	    !       alpha = alpha(self,co2)*pp +alpha(n2)*(pt-pp) 
+	    ! for an isotope, if mr is obtained by 
+	    !       co2*imr(iso)/nt 
+	    ! we are considerin collisions with other co2 isotopes 
+	    ! (including the major one, 626) as if they were with n2. 
+	    ! assuming mr as co2/nt, we consider collisions
+	    ! of type 628-626 as of 626-626 instead of as 626-n2.       
+	    !	  mrx(i)=con(i)/ntx(i) ! old malv 
+	    !	  mrx(i)= dble(co2x(i)/ntx(i))	! mlp & crs    
+
+	    ! jan 98:   
+	    ! esta modif de mlp implica anular el correc (deberia revisar esto)
+		      
+         mr(i) = dble(co2y(i)/nty(i)) ! malv, jan 98  
+
+	    !-----------------------------------------------------------------
+
+      end do     
+            
+! como  beta y 1.d5 son comunes a todas las weighted absorber amounts,  
+! los simplificamos:    
+!	coninf = beta * 1.d5 * dble( con(n) / log( con(n-1) / con(n) ) )      
+	!write (*,*)  ' con(nz), con(nz-1)  =', con(nz), con(nz-1)        
+      coninf = dble( con(nzy) / log( con(nzy-1) / con(nzy) ) )      
+	!write (*,*)  ' coninf =', coninf       
+            
+ccc         
+ccc  temp dependence of the band strength and   
+ccc  nlte correction factor for the absorber amount         
+ccc         
+      call mztf_correccion ( coninf, con, ib, isot, itableout ) 
+            
+ccc         
+ccc reads histogrammed spectral data (strength for lte and vmr=1)       
+ccc         
+	!hfile1 = dirspec//'hi'//dn      !Ya no hacemos distincion d/n en esto
+!!	hfile1 = dirspec//'hid'          !(see why in his.for)
+!	hfile1='hid'
+!!	if (ib.eq.13 .or. ib.eq.14 ) hfile1 = dirspec//'his'       
+!	if (ib.eq.13 .or. ib.eq.14 ) hfile1 = 'his'
+            
+!	if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5     
+!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
+!	   if (isot.eq.1) hisfile = hfile1//'26-'//ibcode1//'.dat' 
+!	   if (isot.eq.2) hisfile = hfile1//'28-'//ibcode1//'.dat' 
+!	   if (isot.eq.3) hisfile = hfile1//'36-'//ibcode1//'.dat' 
+!	   if (isot.eq.4) hisfile = hfile1//'27-'//ibcode1//'.dat' 
+!	   if (isot.eq.5) hisfile = hfile1//'62-'//ibcode1//'.dat' 
+!	else       
+!	   if (isot.eq.1) hisfile = hfile1//'26-'//ibcode2//'.dat' 
+!	   if (isot.eq.2) hisfile = hfile1//'28-'//ibcode2//'.dat' 
+!	   if (isot.eq.3) hisfile = hfile1//'36-'//ibcode2//'.dat' 
+!	   if (isot.eq.4) hisfile = hfile1//'27-'//ibcode2//'.dat' 
+!	   if (isot.eq.5) hisfile = hfile1//'62-'//ibcode2//'.dat' 
+!	endif      
+!	write (*,*) 'hisfile: ', hisfile       
+            
+! the argument to rhist is to make this compatible with mztf_comp.f,    
+! which is a useful modification of mztf.f (to change strengths of bands
+!	call rhist (1.0)       
+      if(ib.eq.1) then
+         if(isot.eq.1) then     !Case 1
+            mm=mm_c1
+            nbox=nbox_c1
+            tmin=tmin_c1
+            tmax=tmax_c1
+            do i=1,nbox_max
+               no(i)=no_c1(i)
+               dist(i)=dist_c1(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c1(j,i)
+                  xls1(j,i)=xls1_c1(j,i)
+                  xln1(j,i)=xln1_c1(j,i)
+                  xld1(j,i)=xld1_c1(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c1(j)
+            enddo
+         else if(isot.eq.2) then !Case 2
+            mm=mm_c2
+            nbox=nbox_c2
+            tmin=tmin_c2
+            tmax=tmax_c2
+            do i=1,nbox_max
+               no(i)=no_c2(i)
+               dist(i)=dist_c2(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c2(j,i)
+                  xls1(j,i)=xls1_c2(j,i)
+                  xln1(j,i)=xln1_c2(j,i)
+                  xld1(j,i)=xld1_c2(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c2(j)
+            enddo
+         else if(isot.eq.3) then !Case 3
+            mm=mm_c3
+            nbox=nbox_c3
+            tmin=tmin_c3
+            tmax=tmax_c3
+            do i=1,nbox_max
+               no(i)=no_c3(i)
+               dist(i)=dist_c3(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c3(j,i)
+                  xls1(j,i)=xls1_c3(j,i)
+                  xln1(j,i)=xln1_c3(j,i)
+                  xld1(j,i)=xld1_c3(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c3(j)
+            enddo
+         else if(isot.eq.4) then !Case 4
+            mm=mm_c4
+            nbox=nbox_c4
+            tmin=tmin_c4
+            tmax=tmax_c4
+            do i=1,nbox_max
+               no(i)=no_c4(i)
+               dist(i)=dist_c4(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c4(j,i)
+                  xls1(j,i)=xls1_c4(j,i)
+                  xln1(j,i)=xln1_c4(j,i)
+                  xld1(j,i)=xld1_c4(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c4(j)
+            enddo
+         else
+            write(*,*)'isot must be 2,3 or 4 for ib=1!!'
+            write(*,*)'stop at mztvc/310'
+            stop
+         endif
+      else if (ib.eq.2) then
+         if(isot.eq.1) then	!Case 5
+            mm=mm_c5
+            nbox=nbox_c5
+            tmin=tmin_c5
+            tmax=tmax_c5
+            do i=1,nbox_max
+               no(i)=no_c5(i)
+               dist(i)=dist_c5(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c5(j,i)
+                  xls1(j,i)=xls1_c5(j,i)
+                  xln1(j,i)=xln1_c5(j,i)
+                  xld1(j,i)=xld1_c5(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c5(j)
+            enddo
+         else
+            write(*,*)'isot must be 1 for ib=2!!'
+            write(*,*)'stop at mztvc/334'
+            stop
+         endif
+      else if (ib.eq.3) then
+         if(isot.eq.1) then	!Case 6
+            mm=mm_c6
+            nbox=nbox_c6
+            tmin=tmin_c6
+            tmax=tmax_c6
+            do i=1,nbox_max
+               no(i)=no_c6(i)
+               dist(i)=dist_c6(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c6(j,i)
+                  xls1(j,i)=xls1_c6(j,i)
+                  xln1(j,i)=xln1_c6(j,i)
+                  xld1(j,i)=xld1_c6(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c6(j)
+            enddo
+         else
+            write(*,*)'isot must be 1 for ib=3!!'
+            write(*,*)'stop at mztvc/358'
+            stop
+         endif
+      else if (ib.eq.4) then
+         if(isot.eq.1) then	!Case 7
+            mm=mm_c7
+            nbox=nbox_c7
+            tmin=tmin_c7
+            tmax=tmax_c7
+            do i=1,nbox_max
+               no(i)=no_c7(i)
+               dist(i)=dist_c7(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c7(j,i)
+                  xls1(j,i)=xls1_c7(j,i)
+                  xln1(j,i)=xln1_c7(j,i)
+                  xld1(j,i)=xld1_c7(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c7(j)
+            enddo
+         else
+            write(*,*)'isot must be 1 for ib=4!!'
+            write(*,*)'stop at mztvc/382'
+            stop
+         endif
+      else 
+         write(*,*)'ib must be 1,2,3 or 4!!'
+         write(*,*)'stop at mztvc/387'
+      endif
+            
+            
+c******     
+c****** calculation of tau(1,ir) for 1<=r      
+c******     
+      call initial           
+            
+      ff=1.0e10              
+
+      in=1         
+            
+      tau(in,1) = 1.d0 
+
+      call initial          
+      call intz (zl(in), c1,p1,mr1,t1, con)          
+      do kr=1,nbox           
+         ta(kr) = t1          
+      end do     
+      call interstrength (st1,t1,ka,ta)  
+      do kr=1,nbox           
+         c1box(kr) = c1 * ka(kr) * dble(deltaz)       
+      end do     
+      c1 = c1 * st1 * dble(deltaz)       
+      
+      do 2 ir=2,nl        
+            
+         call intz (zl(ir), c2,p2,mr2,t2, con)          
+         do kr=1,nbox           
+            ta(kr) = t2          
+         end do     
+         call interstrength (st2,t2,ka,ta)  
+         do kr=1,nbox           
+            c2box(kr) = c2 * ka(kr) * dble(deltaz)       
+         end do     
+         c2 = c2 * st2 * dble(deltaz)       
+         
+         aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0        
+         bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 
+         cc = cc + ( c1 + c2 ) / 2.d0       
+         dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 
+         do kr=1,nbox           
+            ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) ) /2.d0  
+            ddbox(kr) = ddbox(kr) + 
+     $           ( t1*c1box(kr) + t2*c2box(kr) ) /2.d0        
+         end do     
+            
+         mr1=mr2    
+         t1=t2      
+         c1=c2      
+         p1=p2      
+         do kr=1,nbox	          
+            c1box(kr) = c2box(kr)            
+         end do     
+         
+         pt = bb / cc           
+         pp = aa / (cc * ff)    
+         
+         ts = dd/cc             
+         do kr=1,nbox    
+   	    ta(kr) = ddbox(kr) / ccbox(kr)          
+         end do     
+         call interstrength(st,ts,ka,ta)    
+         call intershape(alsa,alna,alda,ta) 
+         
+         
+         eqwmu = 0.0d0          
+         do im = 1,iimu         
+            eqw=0.0d0            
+            do kr=1,nbox  
+               ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im)
+               call findw(ig,iirw, idummy,c1,p1,Desp,wsL)           
+               if ( i_supersat .eq. 0 ) then     
+	          eqw=eqw+no(kr)*w         
+               else      
+                  eqw = w + (no(kr)-1) * ( asat_box*dist(kr) )           
+               endif     
+            end do   
+            eqwmu = eqwmu + eqw * mu(im)*amu(im)         
+         end do     
+            
+         tau(in,ir) = exp( - eqwmu / dble(deltanu(isot,ib)) )  
+            
+ 2    continue             
+            
+            
+           
+c           
+c due to the simmetry of the transmittances     
+c           
+      do in=nl,2,-1  
+         tau(in,1) = tau(1,in)           
+      end do           
+      
+      vc(1) = 0.0d0                         
+      vc(nl) = 0.0d0                         
+      do in=2,nl-1              ! poner aqui nl-1 luego          
+         vc(in) =  pi*deltanu(isot,ib)/( 2.d0*deltaz*1.d5 ) *     
+     @        ( tau(in-1,1) - tau(in+1,1) )         
+      end do			                                      
+      
+            
+c end       
+      return     
+      end 
+
+
+
+
+
+c***********************************************************************
+c     mztvc_626fh.F
+c***********************************************************************
+                                                            
+      subroutine mztvc_626fh(ig)
+
+c     jul 2011 malv+fgg
+c***********************************************************************
+                                                            
+      implicit none                                  
+                                                            
+!!!!!!!!!!!!!!!!!!!!!!!                         
+! common variables & constants                  
+                                                            
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+
+!!!!!!!!!!!!!!!!!!!!!!!                         
+! arguments                                     
+                 
+      integer   ig              ! ADDED FOR TRACEBACK
+                                                            
+!!!!!!!!!!!!!!!!!!!!!!!                         
+! local variables                               
+                                                            
+      real*4 cdummy(nl,nl), csngl(nl,nl)             
+      
+      real*8 cax1(nl,nl), cax2(nl,nl), cax3(nl,nl)   
+      real*8 v1(nl), v2(nl), v3(nl), cm_factor, vc_factor        
+                                                            
+      integer itauout,icfout,itableout, interpol,ismooth, isngldble          
+      integer i,j,ik,ist,isot,ib,itt                 
+                                                            
+	!character 	bandcode*2
+      character 	isotcode*2
+	!character 	codmatrx_hot*5                      
+                                                            
+!!!!!!!!!!!!!!!!!!!!!!!                         
+! external functions                            
+                                                            
+      external bandid                                
+      character*2 bandid                             
+                                                            
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!               
+! subroutines called:                           
+! 	mz4sub, dmzout, readc_mz4, readcupdw, mztf   
+                                                            
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!               
+! formatos                                      
+ 132  format(i2)                                 
+                                                            
+************************************************************************
+************************************************************************
+                                                            
+      isngldble = 1		! =1 --> dble precission        
+                                                            
+      fileroot = 'cfl'                               
+                                                            
+      ist = 1                                        
+      isot = 26                                      
+      write (isotcode,132) isot  
+                             
+      call zerov( vc121, nl )
+      
+      do 11, ik=1,3                                  
+                                                            
+         ib=ik+1                                      
+                                                            
+         call mztvc (ig,v1, ib, 1, irw_mztf, imu, 0,0,0 ) 
+                                                            
+         do i=1,nl                                    
+                                                            
+	    if(ik.eq.1)then                            
+               vc_factor = dble(667.75/618.03)               
+	    elseif(ik.eq.2)then                        
+               vc_factor = 1.d0                              
+	    elseif(ik.eq.3)then                        
+               vc_factor = dble(667.75/720.806)              
+	    end if                                     
+                                                            
+	    vc121(i) = vc121(i) + v1(i) * vc_factor    
+
+         end do          
+                                                            
+ 11   continue                                     
+                                                            
+                                                            
+      return                                         
+      end  
+
+
+
+
+
+c***********************************************************************
+c     mztf_correccion
+c***********************************************************************
+                                                
+      subroutine mztf_correccion (coninf, con, ib, isot, icurt_pop)  
+                                                
+c including the dependence of the absort. coeff. on temp., vibr. temp., 
+c function, etc.., when neccessary. imr is already corrected in his.for 
+c we follow pg.39b-43a (l5):                    
+c  tvt1 is the vibr temp of the upper level     
+c  tvt  is the vibr temp of the transition itself           
+c  tvtbs is the vibr temp of the bending mode (used in qv)  
+c  for fundamental bands, they are not used at the moment.  
+c  for the 15 fh and sh bands, only tvt0 is used at the moment.         
+c  for the laser band, all of them are used following pg. 41a -l5- :    
+c    we need s(z) and we can read s(tk) from the histogram (also called 
+c    what we have to calculate now is the factor s(z)/s(tk) or following
+c    l5 notebook notation, s_nlte/s_lte.        
+c           s_nlte/s_lte = xfactor = xlower * xqv * xes     
+                                                
+c  icurt_pop = 30 -> Output of populations of the 0200,0220,1000 states
+c            = otro -> no output of these populations
+
+c     oct 92          malv                    
+c     jan 98		malv		version for mz1d          
+c     jul 2011        malv+fgg        adapted to LMD-MGCM
+c***********************************************************************
+                                                
+      implicit none                                  
+                                                
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+                                                
+c arguments                                     
+      integer		ib, isot                              
+      integer 	icurt_pop       ! output of Fermi states population
+      real*8		con(nzy), coninf                        
+                                                
+! local variables                               
+      integer 	i                                     
+      real*8	tvt0(nzy),tvt1(nzy),tvtbs(nzy), zld(nl),zyd(nzy) 	       
+      real	xalfa, xbeta, xtv1000, xtv0200, xtv0220, xfactor      
+      real	xqv, xnu_trans, xtv_trans, xes, xlower    
+c***********************************************************************
+                                  
+      xfactor = 1.0
+
+      do i=1,nzy
+         zyd(i) = dble(zy(i))
+      enddo
+      do i=1,nl                                      
+         zld(i) = dble( zl(i) )                
+      end do                                  
+                                                
+! tvtbs is the bending mode of the molecule. used in xqv.   
+      if (isot.eq.1) call interdp (tvtbs,zyd,nzy, v626t1,zld,nl, 1 )  
+      if (isot.eq.2) call interdp (tvtbs,zyd,nzy, v628t1,zld,nl, 1 )  
+      if (isot.eq.3) call interdp (tvtbs,zyd,nzy, v636t1,zld,nl, 1 )  
+      if (isot.eq.4) call interdp (tvtbs,zyd,nzy, v627t1,zld,nl, 1 )  
+      if (isot.eq.5) call interdp (tvtbs,zyd,nzy, vcot1,zld,nl, 1 )   
+      
+! tvt0 is the lower level of the transition. used in xlower.            
+      if (ib.eq.2 .or. ib.eq.3 .or. ib.eq.4 .or. ib.eq.15) then  
+         if (isot.eq.1) call interdp (tvt0,zyd,nzy, v626t1,zld,nl, 1 ) 
+         if (isot.eq.2) call interdp (tvt0,zyd,nzy, v628t1,zld,nl, 1 ) 
+         if (isot.eq.3) call interdp (tvt0,zyd,nzy, v636t1,zld,nl, 1 ) 
+         if (isot.eq.4) call interdp (tvt0,zyd,nzy, v627t1,zld,nl, 1 ) 
+      elseif (ib.eq.6 .or. ib.eq.8 .or. ib.eq.10     
+     @        .or. ib.eq.13 .or. ib.eq.14                  
+     @        .or. ib.eq.17 .or. ib.eq.19 .or. ib.eq.20) then          
+         if (isot.eq.1) call interdp ( tvt0,zyd,nzy, v626t2,zld,nl, 1 )
+         if (isot.eq.2) call interdp ( tvt0,zyd,nzy, v628t2,zld,nl, 1 )
+         if (isot.eq.3) call interdp ( tvt0,zyd,nzy, v636t2,zld,nl, 1 )
+         if (isot.eq.4) then  
+            call interdp ( tvt0,zyd,nzy, v627t2,zld,nl, 1 )
+         endif                                        
+      else                                           
+         do i=1,nzy                                    
+	    tvt0(i) = dble( ty(i) )                    
+         end do                                       
+      end if                                         
+                                                
+c tvt is the vt of the transition. used in xes. 
+c since xes=1.0 except for the laser bands, tvt is only needed for  them
+c but it is actually calculated from the tv of the upper and lower level
+c of the transition. hence, only tvt1 remains to be read for the laser b
+c tvt1 is the upper level of the transition.    
+      if (ib.eq.13 .or. ib.eq.14) then 
+         if (isot.eq.1) call interdp ( tvt1,zyd,nzy, v626t4,zld,nl, 1 )
+         if (isot.eq.2) call interdp ( tvt1,zyd,nzy, v628t4,zld,nl, 1 ) 
+         if (isot.eq.3) call interdp ( tvt1,zyd,nzy, v636t4,zld,nl, 1 )
+         if (isot.eq.4) call interdp ( tvt1,zyd,nzy, v627t4,zld,nl, 1 )
+      end if
+      
+c  here we weight the absorber amount by a factor which compensate the l
+c  value of the strength read from hitran. we use that factor in order t
+c  correct the product s*m when we later multiply those two variables.  
+                                                
+!        if ( isot.eq.1 .and. icurt_pop.eq.30 ) then 
+!           open (30, file='020populations.dat')
+!           write (30,*) ' z  tv(020) tv0200 tv0220 tv1000 '
+!        endif
+
+      do i=1,nzy                                      
+                                                
+         if (isot.eq.1) then                  
+
+	    !!! vt of the 3 levels in (020)  (see pag. 36a-sn1 for this)       
+	    xalfa = 1.d0/2.d0* exp( dble(-ee*(nu12_1000-nu(1,2))/ty(i)) )      
+	    xbeta = 1.d0/2.d0* exp( dble(-ee*(nu12_0200-nu(1,2))/ty(i)) )      
+	    xtv0200 = dble( - ee * nu12_0200 ) /       
+     @           ( log( xbeta/(1.d0+xalfa+xbeta) ) - 
+     @           dble(ee*nu(1,2))/tvt0(i) )    
+	    xtv0220 = dble( - ee * nu(1,2) ) /         
+     @           ( log( 1.d0/(1.d0+xalfa+xbeta) ) - 
+     @           dble(ee*nu(1,2))/tvt0(i) )     
+	    xtv1000 = dble( - ee * nu12_1000 ) /       
+     @           ( log( xalfa/(1.d0+xalfa+xbeta) ) - 
+     @           dble(ee*nu(1,2))/tvt0(i) )
+            !!! correccion 8-Nov-04 (see pag.9b-Marte4-)
+	    xtv0200 = dble( - ee * nu12_0200 /       
+     @           (log(4.*xbeta/(1.d0+xalfa+xbeta))-ee*nu(1,2)/tvt0(i)))    
+	    xtv0220 = dble( - ee * nu(1,2) /         
+     @           ( log(2./(1.d0+xalfa+xbeta)) - ee*nu(1,2)/tvt0(i) ) )     
+	    xtv1000 = dble( - ee * nu12_1000 /       
+     @           ( log(4.*xalfa/(1.d0+xalfa+xbeta))-ee*nu(1,2)/tvt0(i)))
+
+!            if ( icurt_pop.eq.30 ) then 
+!               write (30,'( 1x,f7.2, 3x,f8.3, 2x,3(1x,f8.3) )')
+!     @           zx(i), tvt0(i), xtv0200, xtv0220, xtv1000 
+!            endif
+               
+	    !!! xlower and xes for the band            
+	    if (ib.eq.19) then                         
+               xlower = exp( dble(ee*elow(isot,ib)) *   
+     @              ( 1.d0/dble(ty(i))-1.d0/xtv0200 ) )        
+               xes = 1.0d0                              
+	    elseif (ib.eq.17) then                     
+               xlower = exp( dble(ee*elow(isot,ib)) *   
+     @              ( 1.d0/dble(ty(i))-1.d0/xtv1000 ) )        
+               xes = 1.0d0                              
+	    elseif (ib.eq.20) then                     
+               xlower = exp( dble(ee*elow(isot,ib)) *   
+     @              ( 1.d0/dble(ty(i))-1.d0/xtv0220 ) )        
+               xes = 1.0d0                              
+	    elseif (ib.eq.14) then                     
+               xlower = exp( dble(ee*nu12_1000) *       
+     @              ( 1.d0/dble(ty(i))-1.d0/xtv1000 ) )        
+               xnu_trans = dble( nu(1,4)-nu12_1000 )    
+               xtv_trans = xnu_trans / dble(nu(1,4)/tvt1(i)-
+     @              nu12_1000/xtv1000)  
+               xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) /  
+     @              (1.d0-exp( dble(-ee*xnu_trans/ty(i)) ))     
+	    elseif (ib.eq.13) then                     
+               xlower = exp( dble(ee*nu12_0200) *       
+     @              ( 1.d0/dble(ty(i))-1.d0/xtv0200 ) )        
+               xnu_trans = dble(nu(1,4)-nu12_0200)      
+               xtv_trans = xnu_trans / dble(nu(1,4)/tvt1(i)-
+     @              nu12_0200/xtv0200)  
+               xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) /  
+     @              (1.d0-exp( dble(-ee*xnu_trans/ty(i)) ))     
+	    else                                       
+               xlower = exp( dble(ee*elow(isot,ib)) *   
+     @              ( 1.d0/dble(ty(i))-1.d0/tvt0(i) ) )        
+               xes = 1.0d0                              
+	    end if                                     
+	    xqv = (1.d0-exp( dble(-ee*667.3801/tvtbs(i)) )) /      
+     @           (1.d0-exp( dble(-ee*667.3801/ty(i)) )) 
+	    xfactor = xlower * xqv**2.d0 * xes         
+            
+         elseif (isot.eq.2) then                      
+            
+	    xalfa = 1.d0/2.d0* exp( dble(-ee*(nu22_1000-nu(2,2))/
+     @           ty(i)) )      
+	    xbeta = 1.d0/2.d0* exp( dble(-ee*(nu22_0200-nu(2,2))/
+     @           ty(i)) )      
+	    xtv0200 = dble( - ee * nu22_0200 ) /       
+     @           ( log( xbeta/(1.d0+xalfa+xbeta) ) - dble(ee*nu(2,2))/
+     @           tvt0(i) )    
+	    xtv1000 = dble( - ee * nu22_1000 ) /       
+     @           ( log( xalfa/(1.d0+xalfa+xbeta) ) - dble(ee*nu(2,2))/
+     @           tvt0(i) )    
+                                                
+	    if (ib.eq.14) then                         
+               xlower = exp( dble(ee*nu22_1000) *       
+     @              ( 1.d0/dble(ty(i))-1.d0/xtv1000 ) )        
+               xnu_trans = dble(nu(2,4)-nu22_1000)      
+               xtv_trans = xnu_trans / dble(nu(2,4)/tvt1(i)-nu22_1000/
+     @              xtv1000)  
+               xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) /  
+     @              (1.d0-exp( dble(-ee*xnu_trans/ty(i)) ))     
+	    elseif (ib.eq.13) then                     
+               xlower = exp( dble(ee*nu22_0200) *       
+     @              ( 1.d0/dble(ty(i))-1.d0/xtv0200 ) )        
+               xnu_trans = dble( nu(2,4)-nu22_0200 )    
+               xtv_trans = xnu_trans / dble(nu(2,4)/tvt1(i)-nu22_0200/
+     @              xtv0200)  
+               xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) /  
+     @              (1.d0-exp( dble(-ee*xnu_trans/ty(i)) ))     
+	    else                                       
+               xlower = exp( dble(ee*elow(isot,ib)) *   
+     @              ( 1.d0/dble(ty(i))-1.d0/tvt0(i) ) )        
+               xes = 1.0d0                              
+	    end if                                     
+	    xqv = (1.d0-exp( dble(-ee*662.3734/tvtbs(i)) )) /      
+     @           (1.d0-exp( dble(-ee*662.3734/ty(i))  ))            
+	    xfactor = xlower * xqv**2.d0 * xes         
+            
+         elseif (isot.eq.3) then                      
+                                                
+	    xalfa = 1.d0/2.d0* exp( dble(-ee*(nu32_1000-nu(3,2))/
+     @           ty(i)) )      
+	    xbeta = 1.d0/2.d0* exp( dble(-ee*(nu32_0200-nu(3,2))/
+     @           ty(i)) )      
+	    xtv0200 = dble( - ee * nu32_0200 ) /       
+     @           ( log( xbeta/(1.d0+xalfa+xbeta) ) - dble(ee*nu(3,2))/
+     @           tvt0(i) )    
+	    xtv1000 = dble( - ee * nu32_1000 ) /       
+     @           ( log( xalfa/(1.d0+xalfa+xbeta) ) - dble(ee*nu(3,2))/
+     @           tvt0(i) )    
+            
+	    if (ib.eq.14) then                         
+               xlower = exp( dble(ee*nu32_1000) *       
+     @              ( 1.d0/dble(ty(i))-1.d0/xtv1000 ) )        
+               xnu_trans = dble( nu(3,4)-nu32_1000 )    
+               xtv_trans = xnu_trans / dble(nu(3,4)/tvt1(i)-nu32_1000/
+     @              xtv1000)  
+               xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) /  
+     @              (1.d0-exp( dble(-ee*xnu_trans/ty(i)) ))     
+	    elseif (ib.eq.13) then                     
+               xlower = exp( dble(ee*nu32_0200) *       
+     @              ( 1.d0/dble(ty(i))-1.d0/xtv0200 ) )        
+               xnu_trans = dble( nu(3,4)-nu32_0200 )    
+               xtv_trans = xnu_trans / dble(nu(3,4)/tvt1(i)-nu32_0200/
+     @              xtv0200)  
+               xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) /  
+     @              (1.d0-exp( dble(-ee*xnu_trans/ty(i)) ))     
+	    else                                       
+               xlower = exp( dble(ee*elow(isot,ib)) *   
+     @              ( 1.d0/dble(ty(i))-1.d0/tvt0(i) ) )        
+               xes = 1.0d0                              
+	    end if                                     
+	    xqv = (1.d0-exp( dble(-ee*648.4784/tvtbs(i)) )) /      
+     @           (1.d0-exp( dble(-ee*648.4784/ty(i))  ))            
+	    xfactor = xlower * xqv**2.d0 * xes         
+                                                
+         elseif (isot.eq.4) then                      
+            
+	    xalfa = 1.d0/2.d0* exp( dble(-ee*(nu42_1000-nu(4,2))/
+     @           ty(i)) )      
+	    xbeta = 1.d0/2.d0* exp( dble(-ee*(nu42_0200-nu(4,2))/
+     @           ty(i)) )      
+	    xtv0200 = dble( - ee * nu42_0200 ) /       
+     @           ( log( xbeta/(1.d0+xalfa+xbeta) ) - dble(ee*nu(4,2))/
+     @           tvt0(i) )    
+	    xtv1000 = dble( - ee * nu42_1000 ) /       
+     @           ( log( xalfa/(1.d0+xalfa+xbeta) ) - dble(ee*nu(4,2))/
+     @           tvt0(i) )    
+            
+	    if (ib.eq.14) then                         
+               xlower = exp( dble(ee*nu42_1000) *       
+     @              ( 1.d0/dble(ty(i))-1.d0/xtv1000 ) )        
+               xnu_trans = dble( nu(4,4)-nu42_1000 )    
+               xtv_trans = xnu_trans / dble(nu(4,4)/tvt1(i)-nu42_1000/
+     @              xtv1000)  
+               xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) /  
+     @              (1.d0-exp( dble(-ee*xnu_trans/ty(i)) ))     
+	    elseif (ib.eq.13) then                     
+               xlower = exp( dble(ee*nu42_0200) *       
+     $              ( 1.d0/dble(ty(i))-1.d0/xtv0200 ) )     
+               xnu_trans = dble( nu(4,4)-nu42_0200 )    
+               xtv_trans = xnu_trans / dble(nu(4,4)/tvt1(i)-nu42_0200/
+     @              xtv0200)  
+               xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) /  
+     @              (1.d0-exp( dble(-ee*xnu_trans/ty(i)) ))     
+	    else                                       
+               xlower = exp( dble(ee*elow(isot,ib)) *   
+     @              ( 1.d0/dble(ty(i))-1.d0/tvt0(i) ) )        
+               xes = 1.0d0                              
+	    end if                                     
+	    xqv = (1.d0-exp( dble(-ee*664.7289/tvtbs(i)) )) /      
+     @           (1.d0-exp( dble(-ee*664.7289/ty(i))  ))            
+	    xfactor = xlower * xqv**2.d0 * xes         
+                                                
+         elseif (isot.eq.5 .and. ib.eq.1) then        
+            
+	    xlower = 1.d0                              
+	    xes = 1.0d0                                
+	    xqv = (1.d0-exp( dble(-ee*nuco_10/tvtbs(i)) )) /          
+     @           (1.d0-exp( dble(-ee*nuco_10/ty(i))  ))    
+	    xfactor = xlower * xqv * xes         
+            
+         end if                                       
+         
+         con(i) = con(i) * xfactor                    
+         if (i.eq.nzy) coninf = coninf * xfactor       
+                                                
+      end do                                         
+                    
+!        if ( isot.eq.1 .and. icurt_pop.eq.30 ) then 
+!           close (30)
+!        endif
+                            
+      return                                         
+      end  
+
+
+
+
+
+c***********************************************************************
+c     mztf.f                                        
+c***********************************************************************
+c                       
+c     program  for calculating atmospheric transmittances       
+c     to be used in the calculation of curtis matrix coefficients           
+            
+      subroutine mztf ( ig,cf,cfup,cfdw,vc,taugr, ib,isot,          
+     @     iirw,iimu,itauout,icfout,itableout )   
+            
+c     i*out = 1	output of data          
+c     i*out = 0	no output   
+c
+c     jul 2011        malv+fgg adapted to LMD-MGCM           
+c     nov 98          mavl    allow for overlaping in the lorentz line
+c     jan 98		malv	version for mz1d. based on curtis/mztf.for   
+c     17-jul-96	mlp&crs	change the calculation of mr.     
+c				evitar: divide por cero. anhadiendo: ff    
+c     oct-92		malv 	correct s(t) dependence for all histogr bands           
+c     june-92		malv	proper lower levels for laser bands         
+c     may-92		malv 	new temperature dependence for laser bands  
+c     @    991 		malv 	boxing for the averaged absorber amount and t            
+c     ?		malv	extension up to 200 km altitude in mars          
+c     13-nov-86	mlp	include the temperature weighted to match         
+c				the eqw in the strong doppler limit.       
+c***********************************************************************
+            
+      implicit none      
+            
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+            
+            
+c arguments             
+      integer         ig        !ADDED FOR TRACEBACK
+      real*8  	cf(nl,nl), cfup(nl,nl), cfdw(nl,nl) ! o.          
+      real*8		vc(nl),  taugr(nl) ! o        
+      integer		ib      ! i    
+      integer		isot    ! i  
+      integer		iirw    ! i  
+      integer		iimu    ! i  
+      integer		itauout ! i           
+      integer		icfout  ! i            
+      integer		itableout ! i          
+            
+c local variables and constants     
+      integer 	i, in, ir, im, k ,j         
+      integer 	nmu           
+      parameter 	(nmu = 8)  
+      real*8 		tau(nl,nl)    
+      real*8 		tauinf(nl)    
+      real*8 		con(nzy), coninf           
+      real*8 		c1, c2        
+      real*8 		t1, t2        
+      real*8 		p1, p2        
+      real*8		mr1, mr2       
+      real*8 		st1, st2      
+      real*8 		c1box(70), c2box(70)      
+      real*8		ff      ! to avoid too small numbers      
+      real*8		tvtbs(nzy)      
+      real*8 		st, beta, ts, eqwmu       
+      real*8 		mu(nmu), amu(nmu)         
+      real*8  	zld(nl), zyd(nzy)      
+      real*8 		correc        
+      real 		deltanux ! width of vib-rot band (cm-1) 
+!	character	isotcode*2
+      integer         idummy
+      real*8          Desp,wsL
+       
+c formats   
+! 111	format(a1)         
+! 112	format(a2)         
+ 101  format(i1)         
+ 202  format(i2)         
+! 180	format(a80)        
+! 181	format(a80)        
+c***********************************************************************
+            
+c some needed values    
+!	rl=sqrt(log(2.d0))     
+!	pi2 = 3.14159265358989d0           
+      beta = 1.8d0           
+      idummy = 0
+      Desp = 0.d0
+      wsL = 0.d0
+
+c  esto es para que las subroutines de mztfsub calculen we  
+c  de la forma apropiada para mztf, no para fot 
+      icls=icls_mztf         
+            
+c codigos para filenames            
+!	if (isot .eq. 1)  isotcode = '26'  
+!	if (isot .eq. 2)  isotcode = '28'  
+!	if (isot .eq. 3)  isotcode = '36'  
+!	if (isot .eq. 4)  isotcode = '27'  
+!	if (isot .eq. 5)  isotcode = '62'  
+!	if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5     
+!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
+!		write (ibcode1,101) ib           
+!	else       
+!		write (ibcode2,202) ib           
+!	endif      
+!	write (*,'( 30h calculating curtis matrix :  ,2x,         
+!     @    	8h band = ,i2,2x, 11h isotope = ,i2)') ib, isot         
+            
+c integration in angle !!!!!!!!!!!!!!!!!!!!     
+            
+c------- diffusivity approx.        
+      if (iimu.eq.1) then    
+!	  write (*,*)  ' diffusivity approx. beta = ',beta 
+         mu(1) = 1.0d0        
+         amu(1)= 1.0d0        
+c-------data for 8 points integration           
+      elseif (iimu.eq.4) then            
+         write (*,*)' 4 points for the gauss-legendre angle quadrature.'
+         mu(1)=(1.0d0+0.339981043584856)/2.0d0 	      
+         mu(2)=(1.0d0-0.339981043584856)/2.0d0 	      
+         mu(3)=(1.0d0+0.861136311594053)/2.0d0        
+         mu(4)=(1.0d0-0.861136311594053)/2.0d0 	      
+         amu(1)=0.652145154862546 	       
+         amu(2)=amu(1) 	      
+         amu(3)=0.347854845137454 	       
+         amu(4)=amu(3)        
+         beta=1.0d0           
+c-------data for 8 points integration           
+      elseif(iimu.eq.8) then             
+         write (*,*)' 8 points for the gauss-legendre angle quadrature.'
+         mu(1)=(1.0d0+0.183434642495650)/2.0d0        
+         mu(2)=(1.0d0-0.183434642495650)/2.0d0        
+         mu(3)=(1.0d0+0.525532409916329)/2.0d0        
+         mu(4)=(1.0d0-0.525532409916329)/2.0d0        
+         mu(5)=(1.0d0+0.796666477413627)/2.0d0        
+         mu(6)=(1.0d0-0.796666477413627)/2.0d0        
+         mu(7)=(1.0d0+0.960289856497536)/2.0d0        
+         mu(8)=(1.0d0-0.960289856497536)/2.0d0        
+         amu(1)=0.362683783378362         
+         amu(2)=amu(1)        
+         amu(3)=0.313706645877887         
+         amu(4)=amu(3)        
+         amu(5)=0.222381034453374         
+         amu(6)=amu(5)        
+         amu(7)=0.101228536290376         
+         amu(8)=amu(7)        
+         beta=1.0d0           
+      end if     
+c!!!!!!!!!!!!!!!!!!!!!!!            
+            
+ccc         
+ccc  determine abundances included in the absorber amount   
+ccc         
+            
+c first, set up the grid ready for interpolation.           
+      do i=1,nzy              
+         zyd(i) = dble(zy(i))             
+      enddo      
+      do i=1,nl              
+         zld(i) = dble(zl(i))             
+      enddo      
+            
+            
+c 2nd: correccion a la n10(i) (cantidad de absorbente en el lower state)
+c por similitud a la que se hace en cza.for     
+            
+      do i=1,nzy              
+         if (isot.eq.5) then  
+	    con(i) = dble( coy(i) * imrco )            
+         else     
+	    con(i) =  dble( co2y(i) * imr(isot) )      
+c vibr. temp of the bending mode :  
+            if(isot.eq.1) call interdp(tvtbs,zyd,nzy,v626t1,zld,nl,1)  
+            if(isot.eq.2) call interdp(tvtbs,zyd,nzy,v628t1,zld,nl,1)  
+            if(isot.eq.3) call interdp(tvtbs,zyd,nzy,v636t1,zld,nl,1)  
+            if(isot.eq.4) call interdp(tvtbs,zyd,nzy,v627t1,zld,nl,1)  
+	    correc = 2.d0 * dexp( dble(-ee*elow(isot,2))/tvtbs(i) )            
+	    con(i) = con(i) * ( 1.d0 - correc )        
+         endif    
+c-----------------------------------------------------------------------
+c mlp & cristina. 17 july 1996      
+c change the calculation of mr. it is used for calculating partial press
+c alpha = alpha(self,co2)*pp +alpha(n2)*(pt-pp) 
+c for an isotope, if mr is obtained by co2*imr(iso)/nt we are considerin
+c collisions with other co2 isotopes (including the major one, 626)     
+c as if they were with n2. assuming mr as co2/nt, we consider collisions
+c of type 628-626 as of 626-626 instead of as 626-n2.       
+c	  mrx(i)=con(i)/ntx(i) ! old malv 
+            
+!	  mrx(i)= dble(co2x(i)/ntx(i))	! mlp & crs    
+            
+c jan 98:   
+c esta modif de mlp implica anular el correc (deberia revisar esto)     
+         mr(i) = dble(co2y(i)/nty(i)) ! malv, jan 98  
+            
+c-----------------------------------------------------------------------
+            
+      end do     
+            
+! como  beta y 1.d5 son comunes a todas las weighted absorber amounts,  
+! los simplificamos:    
+!	coninf = beta * 1.d5 * dble( con(n) / log( con(n-1) / con(n) ) )      
+      coninf = dble( con(nzy) / log( con(nzy-1) / con(nzy) ) )      
+            
+!	write (*,*)  ' coninf =', coninf       
+            
+ccc         
+ccc  temp dependence of the band strength and   
+ccc  nlte correction factor for the absorber amount         
+ccc         
+      call mztf_correccion ( coninf, con, ib, isot, itableout ) 
+            
+ccc         
+ccc reads histogrammed spectral data (strength for lte and vmr=1)       
+ccc         
+	!hfile1 = dirspec//'hi'//dn   ! ya no distinguimos entre d/n     
+!!	hfile1 = dirspec//'hid'       ! (see why in his.for)
+!        hfile='hid'
+!!	if (ib.eq.13 .or. ib.eq.14 ) hfile1 = dirspec//'his'
+!        if (ib.eq.13 .or. ib.eq.14 ) hfile1 = 'his'
+!            
+!	if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5     
+!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
+!	   if (isot.eq.1) hisfile = hfile1//'26-'//ibcode1//'.dat' 
+!	   if (isot.eq.2) hisfile = hfile1//'28-'//ibcode1//'.dat' 
+!	   if (isot.eq.3) hisfile = hfile1//'36-'//ibcode1//'.dat' 
+!	   if (isot.eq.4) hisfile = hfile1//'27-'//ibcode1//'.dat' 
+!	   if (isot.eq.5) hisfile = hfile1//'62-'//ibcode1//'.dat' 
+!	else       
+!	   if (isot.eq.1) hisfile = hfile1//'26-'//ibcode2//'.dat' 
+!	   if (isot.eq.2) hisfile = hfile1//'28-'//ibcode2//'.dat' 
+!	   if (isot.eq.3) hisfile = hfile1//'36-'//ibcode2//'.dat' 
+!	   if (isot.eq.4) hisfile = hfile1//'27-'//ibcode2//'.dat' 
+!	   if (isot.eq.5) hisfile = hfile1//'62-'//ibcode2//'.dat' 
+!	endif      
+!	write (*,*) 'hisfile: ', hisfile       
+            
+! the argument to rhist is to make this compatible with mztf_comp.f,    
+! which is a useful modification of mztf.f (to change strengths of bands
+!	call rhist (1.0)       
+      if(ib.eq.1) then
+         if(isot.eq.1) then     !Case 1
+            mm=mm_c1
+            nbox=nbox_c1
+            tmin=tmin_c1
+            tmax=tmax_c1
+            do i=1,nbox_max
+               no(i)=no_c1(i)
+               dist(i)=dist_c1(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c1(j,i)
+                  xls1(j,i)=xls1_c1(j,i)
+                  xln1(j,i)=xln1_c1(j,i)
+                  xld1(j,i)=xld1_c1(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c1(j)
+            enddo
+         else if(isot.eq.2) then !Case 2
+            mm=mm_c2
+            nbox=nbox_c2
+            tmin=tmin_c2
+            tmax=tmax_c2
+            do i=1,nbox_max
+               no(i)=no_c2(i)
+               dist(i)=dist_c2(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c2(j,i)
+                  xls1(j,i)=xls1_c2(j,i)
+                  xln1(j,i)=xln1_c2(j,i)
+                  xld1(j,i)=xld1_c2(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c2(j)
+            enddo
+         else if(isot.eq.3) then !Case 3
+            mm=mm_c3
+            nbox=nbox_c3
+            tmin=tmin_c3
+            tmax=tmax_c3
+            do i=1,nbox_max
+               no(i)=no_c3(i)
+               dist(i)=dist_c3(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c3(j,i)
+                  xls1(j,i)=xls1_c3(j,i)
+                  xln1(j,i)=xln1_c3(j,i)
+                  xld1(j,i)=xld1_c3(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c3(j)
+            enddo
+         else if(isot.eq.4) then !Case 4
+            mm=mm_c4
+            nbox=nbox_c4
+            tmin=tmin_c4
+            tmax=tmax_c4
+            do i=1,nbox_max
+               no(i)=no_c4(i)
+               dist(i)=dist_c4(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c4(j,i)
+                  xls1(j,i)=xls1_c4(j,i)
+                  xln1(j,i)=xln1_c4(j,i)
+                  xld1(j,i)=xld1_c4(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c4(j)
+            enddo
+         else
+            write(*,*)'isot must be 2,3 or 4 for ib=1!!'
+            write(*,*)'stop at mztf_overlap/317'
+            stop
+         endif
+      else if (ib.eq.2) then
+         if(isot.eq.1) then	!Case 5
+            mm=mm_c5
+            nbox=nbox_c5
+            tmin=tmin_c5
+            tmax=tmax_c5
+            do i=1,nbox_max
+               no(i)=no_c5(i)
+               dist(i)=dist_c5(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c5(j,i)
+                  xls1(j,i)=xls1_c5(j,i)
+                  xln1(j,i)=xln1_c5(j,i)
+                  xld1(j,i)=xld1_c5(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c5(j)
+            enddo
+         else
+            write(*,*)'isot must be 1 for ib=2!!'
+            write(*,*)'stop at mztf_overlap/341'
+            stop
+         endif
+      else if (ib.eq.3) then
+         if(isot.eq.1) then	!Case 6
+            mm=mm_c6
+            nbox=nbox_c6
+            tmin=tmin_c6
+            tmax=tmax_c6
+            do i=1,nbox_max
+               no(i)=no_c6(i)
+               dist(i)=dist_c6(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c6(j,i)
+                  xls1(j,i)=xls1_c6(j,i)
+                  xln1(j,i)=xln1_c6(j,i)
+                  xld1(j,i)=xld1_c6(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c6(j)
+            enddo
+         else
+            write(*,*)'isot must be 1 for ib=3!!'
+            write(*,*)'stop at mztf_overlap/365'
+            stop
+         endif
+      else if (ib.eq.4) then
+         if(isot.eq.1) then	!Case 7
+            mm=mm_c7
+            nbox=nbox_c7
+            tmin=tmin_c7
+            tmax=tmax_c7
+            do i=1,nbox_max
+               no(i)=no_c7(i)
+               dist(i)=dist_c7(i)
+               do j=1,nhist
+                  sk1(j,i)=sk1_c7(j,i)
+                  xls1(j,i)=xls1_c7(j,i)
+                  xln1(j,i)=xln1_c7(j,i)
+                  xld1(j,i)=xld1_c7(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist(j)=thist_c7(j)
+            enddo
+         else
+            write(*,*)'isot must be 1 for ib=4!!'
+            write(*,*)'stop at mztf_overlap/389'
+            stop
+         endif
+      else 
+         write(*,*)'ib must be 1,2,3 or 4!!'
+         write(*,*)'stop at mztf_overlap/394'
+      endif
+      
+      if (isot.ne.5) deltanux = deltanu(isot,ib)     
+      if (isot.eq.5) deltanux = deltanuco            
+            
+c******     
+c****** calculation of tauinf(nl)   
+c******     
+      call initial           
+            
+      ff=1.0e10              
+            
+      do i=nl,1,-1           
+            
+         if(i.eq.nl)then      
+            
+            call intz (zl(i),c2,p2,mr2,t2, con)           
+            do kr=1,nbox          
+               ta(kr)=t2            
+            end do              
+!     write (*,*)  ' i, t2 =', i, t2         
+            call interstrength (st2,t2,ka,ta) 
+            aa = p2 * coninf * mr2 * (st2 * ff)           
+            bb = p2 * coninf * st2            
+            cc = coninf * st2     
+            dd = t2 * coninf * st2            
+            do kr=1,nbox          
+               ccbox(kr) = coninf * ka(kr)          
+               ddbox(kr) = t2 * ccbox(kr)      
+!		  c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5   
+               c2box(kr) = c2 * ka(kr) * dble(deltaz)      
+            end do    
+!		c2 = c2 * st2 * beta * dble(deltaz) * 1.d5   
+            c2 = c2 * st2 * dble(deltaz)      
+            
+         else     
+            call intz (zl(i),c1,p1,mr1,t1, con)           
+            do kr=1,nbox          
+               ta(kr)=t1            
+            end do              
+!	write (*,*)  ' i, t1 =', i, t1         
+            call interstrength (st1,t1,ka,ta) 
+            do kr=1,nbox          
+!     c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5   
+               c1box(kr) = c1 * ka(kr) * dble(deltaz)      
+            end do    
+!		c1 = c1 * st1 * beta * dble(deltaz) * 1.d5   
+            c1 = c1 * st1 * dble(deltaz)      
+            aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0       
+            bb = bb + ( p1*c1 + p2*c2 ) / 2.d0            
+            cc = cc + ( c1 + c2 ) / 2.d0      
+            dd = dd + ( t1*c1 + t2*c2 ) / 2.d0            
+            do kr=1,nbox          
+               ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) )/2.d0       
+               ddbox(kr) = ddbox(kr) + (t1*c1box(kr)+t2*c2box(kr))/2.d0
+            end do    
+            
+            mr2 = mr1             
+            c2=c1     
+            do kr=1,nbox	         
+               c2box(kr) = c1box(kr)           
+            end do    
+            t2=t1     
+            p2=p1     
+         end if   
+         
+         pt = bb / cc         
+         pp = aa / (cc*ff)    
+         
+!	  ta=dd/cc            
+!	  tdop = ta           
+         ts = dd/cc           
+         do kr=1,nbox  
+   	    ta(kr) = ddbox(kr) / ccbox(kr)          
+         end do   
+!	write (*,*)  ' i, ts =', i, ts         
+         call interstrength(st,ts,ka,ta)  
+!	  call intershape(alsa,alna,alda,tdop)        
+         call intershape(alsa,alna,alda,ta)           
+            
+*	  ua = cc/st          
+            
+c  	next loop calculates the eqw for an especified path ua,pp,pt,ta     
+            
+         eqwmu = 0.0d0        
+         do im = 1,iimu       
+	    eqw=0.0d0          
+            do  kr=1,nbox           
+               ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im)  
+               if(ua(kr).lt.0.)write(*,*)'mztf_overlap/483',ua(kr),
+     $              ccbox(kr),ka(kr),beta,mu(im),kr,im,i,nl
+               
+               call findw(ig,iirw, idummy,c1,p1,Desp,wsL)           
+               if ( i_supersat .eq. 0 ) then     
+	          eqw=eqw+no(kr)*w         
+               else      
+                  eqw = w + (no(kr)-1) * ( asat_box*dist(kr) )           
+               endif     
+	    end do             
+	    eqwmu = eqwmu + eqw * mu(im)*amu(im)       
+         end do   
+            
+         tauinf(i) = exp( - eqwmu / dble(deltanux) ) 
+            
+      end do                    ! i continue   
+            
+!	if ( isot.eq.1 .and. ib.eq.2 ) then           
+!		write (*,*)  ' tauinf(nl) = ', tauinf(nl)         
+!		write (*,*)  ' tauinf(1) = ', tauinf(1)           
+!	endif     
+            
+c******     
+c****** calculation of tau(in,ir) for n<=r      
+c******     
+            
+      do 1 in=1,nl-1         
+            
+         call initial          
+         call intz (zl(in), c1,p1,mr1,t1, con)          
+         do kr=1,nbox           
+            ta(kr) = t1          
+         end do     
+         call interstrength (st1,t1,ka,ta)  
+         do kr=1,nbox           
+!	  c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5    
+            c1box(kr) = c1 * ka(kr) * dble(deltaz)       
+         end do     
+!     c1 = c1 * st1 * beta * dble(deltaz) * 1.d5    
+         c1 = c1 * st1 * dble(deltaz)       
+            
+         do 2 ir=in,nl-1        
+            
+            if (ir.eq.in) then     
+               tau(in,ir) = 1.d0    
+               goto 2   
+            end if     
+            
+            call intz (zl(ir), c2,p2,mr2,t2, con)          
+            do kr=1,nbox           
+               ta(kr) = t2          
+            end do     
+            call interstrength (st2,t2,ka,ta)  
+            do kr=1,nbox           
+!	  c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5    
+               c2box(kr) = c2 * ka(kr) * dble(deltaz)       
+            end do     
+!	c2 = c2 * st2 * beta * dble(deltaz) * 1.e5    
+            c2 = c2 * st2 * dble(deltaz)       
+            
+c	aa = aa + ( p1*mr1*c1 + p2*mr2*c2 ) / 2.d0    
+            aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0        
+            bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 
+            cc = cc + ( c1 + c2 ) / 2.d0       
+            dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 
+            do kr=1,nbox           
+               ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) ) /2.d0  
+               ddbox(kr) = ddbox(kr) + 
+     $              ( t1*c1box(kr) + t2*c2box(kr) ) /2.d0        
+            end do     
+            
+            mr1=mr2    
+            t1=t2      
+            c1=c2      
+            p1=p2      
+            do kr=1,nbox	          
+               c1box(kr) = c2box(kr)            
+            end do     
+            
+            pt = bb / cc           
+            pp = aa / (cc * ff)    
+            
+*	ta=dd/cc              
+*	tdop = ta             
+            ts = dd/cc             
+            do kr=1,nbox    
+               ta(kr) = ddbox(kr) / ccbox(kr)          
+            end do     
+            call interstrength(st,ts,ka,ta)    
+            call intershape(alsa,alna,alda,ta) 
+*     ua = cc/st            
+            
+c  	next loop calculates the eqw for an especified path ua,pp,pt,ta     
+            
+            eqwmu = 0.0d0          
+            do im = 1,iimu         
+               eqw=0.0d0            
+               do kr=1,nbox  
+                  ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im)       
+                  if(ua(kr).lt.0.)write(*,*)'mztf_overlap/581',ua(kr),
+     $                 ccbox(kr),ka(kr),beta,mu(im),kr,im,i,nl
+
+                  call findw(ig,iirw, idummy,c1,p1,Desp,wsL)           
+                  if ( i_supersat .eq. 0 ) then     
+                     eqw=eqw+no(kr)*w         
+                  else      
+                     eqw = w + (no(kr)-1) * ( asat_box*dist(kr) )           
+                  endif     
+               end do   
+               eqwmu = eqwmu + eqw * mu(im)*amu(im)         
+            end do     
+            
+            tau(in,ir) = exp( - eqwmu / dble(deltanux) )  
+            
+ 2       continue             
+            
+ 1    continue             
+            
+!	if ( isot.eq.1 .and. ib.eq.2 ) then           
+!		write (*,*)  ' tau(1,*) , *=1,20 '    
+!		write (*,*)  ( sngl(tau(1,k)), k=1,20 )           
+!	endif     
+            
+            
+c**********             
+c**********  calculation of tau(in,ir) for n>r  
+c**********             
+            
+      in=nl      
+            
+      call initial           
+      call intz (zl(in), c1,p1,mr1,t1, con)          
+      do kr=1,nbox           
+         ta(kr) = t1          
+      end do     
+      call interstrength (st1,t1,ka,ta)  
+      do kr=1,nbox           
+!     c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5    
+         c1box(kr) = c1 * ka(kr) * dble(deltaz)       
+      end do     
+!     c1 = c1 * st1 * beta * dble(deltaz) * 1.d5    
+      c1 = c1 * st1 * dble(deltaz)       
+            
+      do 4 ir=in-1,1,-1      
+            
+         call intz (zl(ir), c2,p2,mr2,t2, con)          
+         do kr=1,nbox           
+            ta(kr) = t2          
+         end do     
+         call interstrength (st2,t2,ka,ta)  
+         do kr=1,nbox           
+!     c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5    
+            c2box(kr) = c2 * ka(kr) * dble(deltaz)       
+         end do     
+!	c2 = c2 * st2 * beta * dble(deltaz) * 1.d5    
+         c2 = c2 * st2 * dble(deltaz)       
+            
+         aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0        
+         bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 
+         cc = cc + ( c1 + c2 ) / 2.d0       
+         dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 
+         do kr=1,nbox           
+            ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) ) /2.d0  
+            ddbox(kr) = ddbox(kr) + ( t1*c1box(kr) + t2*c2box(kr) )/2.d0        
+         end do     
+            
+         mr1=mr2    
+         c1=c2      
+         t1=t2      
+         p1=p2      
+         do kr=1,nbox           
+            c1box(kr) = c2box(kr)            
+         end do     
+            
+         pt = bb / cc           
+         pp = aa / (cc * ff)    
+         ts = dd / cc           
+         do kr=1,nbox           
+            ta(kr) = ddbox(kr) / ccbox(kr)   
+         end do     
+         call interstrength (st,ts,ka,ta)   
+         call intershape (alsa,alna,alda,ta)            
+            
+*	ua = cc/st            
+            
+c  	next loop calculates the eqw for an especified path ua,pp,pt,ta     
+            
+         eqwmu = 0.0d0          
+         do im = 1,iimu         
+            eqw=0.0d0            
+            do kr=1,nbox  
+               ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im)
+               if(ua(kr).lt.0.)write(*,*)'mztf_overlap/674',ua(kr),
+     $              ccbox(kr),ka(kr),beta,mu(im),kr,im,i,nl
+               
+               call findw(ig,iirw, idummy,c1,p1,Desp,wsL)           
+               if ( i_supersat .eq. 0 ) then     
+	          eqw=eqw+no(kr)*w         
+               else      
+                  eqw = w + (no(kr)-1) * ( asat_box*dist(kr) )           
+               endif     
+            end do   
+            eqwmu = eqwmu + eqw * mu(im)*amu(im)         
+         end do     
+            
+         tau(in,ir) = exp( - eqwmu / dble(deltanux) )  
+            
+ 4    continue             
+            
+c           
+c due to the simmetry of the transmittances     
+c           
+      do in=nl-1,2,-1       
+         do ir=in-1,1,-1      
+            tau(in,ir) = tau(ir,in)           
+         end do   
+      end do     
+            
+            
+ccc         
+ccc  writing out transmittances     
+ccc         
+      if (itauout.eq.1) then             
+            
+!	        if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5         
+!     @    	 .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then     
+!  	         open( 1, file=          
+!     @    	   dircurtis//'taul'//isotcode//dn//ibcode1//'.dat',     
+!     @    	   access='sequential', form='unformatted' ) 
+!	        else           
+!  	         open( 1, file=          
+!     @    	   dircurtis//'taul'//isotcode//dn//ibcode2//'.dat',     
+!     @    	   access='sequential', form='unformatted' ) 
+!	        endif          
+            
+!		write(1) dummy        
+!		write(1)' format: (tauinf(n),(tau(n,r),r=1,nl),n=1,nl)'   
+!		do in=1,nl            
+!		    write (1) tauinf(in), ( tau(in,ir), ir=1,nl )         
+!		end do    
+!		close(unit=1)         
+            
+      elseif (itauout.eq.2) then         
+  	         
+!	   if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5  
+!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then	     
+!	     open( 1, file=    
+!     @        dircurtis//'taul'//isotcode//dn//ibcode1//'.dat')     
+!	   else    
+!	     open( 1, file=    
+!     @        dircurtis//'taul'//isotcode//dn//ibcode2//'.dat')     
+!	   endif   
+            
+!		!write(1,*) dummy     
+!		!write(1,*) 'tij for curtis matrix calculations '         
+!		!write(1,*)' cira mars model atmosphere '     
+!		write(1,*)' beta= ',beta,'deltanu= ',deltanux 
+!		write(1,*)' number of elements (in,ir)= ',nl,nl           
+!		write(1,*)' format: (tauinf(in),(tau(in,ir),ir=1,nl),in=1,nl)'
+	           
+!		do in=1,nl            
+!		    write (1,*) tauinf(in)        
+!		    do ir=1,nl        
+!			write(1,*) tau(in,ir)            
+!		    end do            
+!		end do    
+!		close(unit=1)         
+            
+!	   if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5  
+!     @    	.or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
+!	      write (*,'(1x, 31htransmitances written out in: ,a22)')          
+!     @    	'taul'//isotcode//dn//ibcode1    
+!	   else    
+!	      write (*,'(1x, 31htransmitances written out in: ,a22)')          
+!     @    	'taul'//isotcode//dn//ibcode2    
+!	   endif   
+            
+      end if     
+            
+c cleaning of transmittances        
+!	call elimin_tau(tau,tauinf,nl,nan,itableout,nw,dummy,     
+!     @    					isotcode,dn,ibcode2)        
+            
+c construction of the curtis matrix 
+            
+      call mzcf ( tauinf,tau, cf,cfup,cfdw, vc,taugr,            
+     @     ib,isot,icfout,itableout )            
+            
+            
+c end       
+      return     
+      end    
+
+
+
+
+c***********************************************************************
+c      mzcf
+c***********************************************************************
+                                                
+      subroutine mzcf( tauinf,tau, c,cup,cdw,vc,taugr,           
+     @     ib,isot,icfout,itableout )            
+                                                
+c     a.k.murphy method to avoid extrapolation in the curtis matrix         
+c     feb-89 	    m. angel 	granada                 
+c     25-sept-96  cristina 	dejar las matrices en doble precision           
+c     jan 98		malv	version para mz1d                
+c     jul 2011 malv+fgg       adapted to LMD-MGCM
+c***********************************************************************
+                                                
+      implicit none                                  
+
+      include 'comcstfi.h'
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+                                                
+c arguments                                     
+      real*8		c(nl,nl), cup(nl,nl), cdw(nl,nl) ! o   
+      real*8 		vc(nl), taugr(nl) ! o       
+      real*8 		tau(nl,nl) ! i                     
+      real*8		tauinf(nl) ! i                      
+      integer		ib      ! i                            
+      integer 	isot		! i                          
+      integer		icfout, itableout ! i               
+                                                
+c external                                      
+      external 	bandid                               
+      character*2 	bandid                            
+                                                
+c local variables                               
+      integer 	i, in, ir, iw                         
+      real*8		cfup(nl,nl), cfdw(nl,nl)               
+      real*8		a(nl,nl), cf(nl,nl)                    
+      character	isotcode*2, bcode*2                  
+                                                
+c formats                                       
+ 101  format(i1)                                 
+ 202  format(i2)                                 
+ 180  format(a80)                                
+ 181  format(a80)                                
+c***********************************************************************
+                                                
+      if (isot.eq.1)  isotcode = '26'               
+      if (isot.eq.2)  isotcode = '28'               
+      if (isot.eq.3)  isotcode = '36'               
+      if (isot.eq.4)  isotcode = '27'               
+      if (isot.eq.5)  isotcode = 'co'               
+      bcode = bandid( ib )                           
+                                                
+!	write (*,*)  ' '                                               
+                                                
+      do in=1,nl                                     
+                                                
+         do ir=1,nl                             
+                                                
+            cf(in,ir) = 0.0d0                     
+            cfup(in,ir) = 0.0d0                   
+            cfdw(in,ir) = 0.0d0                   
+            c(in,ir) = 0.0d0                      
+            cup(in,ir) = 0.0d0                    
+            cdw(in,ir) = 0.0d0                    
+            a(in,ir) = 0.0d0                      
+                                                
+         end do                                 
+                                                
+         vc(in) = 0.0d0                         
+         taugr(in) = 0.0d0                      
+                                                
+      end do                                  
+                                                
+                                                
+c	the next lines are a reduced and equivalent way of calculating        
+c	the c(in,ir) elements for n=2,nl1 and r=1,nl  
+                                                
+                                                
+c	do in=2,nl1                                   
+c	do ir=1,nl                                    
+c	if(ir.eq.1)then                               
+c	c(in,ir)=tau(in-1,1)-tau(in+1,1)              
+c	elseif(ir.eq.nl)then                          
+c	c(in,ir)=tau(in+1,nl1)-tauinf(in+1)-tau(in-1,nl1)+tauinf(in-1)        
+c	else                                          
+c	c(in,ir)=tau(in+1,ir-1)-tau(in+1,ir)-tau(in-1,ir-1)+tau(in-1,ir)      
+c	end if                                        
+c	c(in,ir)=c(in,ir)*pi*deltanu(ib)/(2.*deltaz*1.0e5)	       
+c	end do                                        
+c	end do	                                       
+c	go to 1000                                    
+                                                
+c calculation of the matrix cfup(nl,nl)         
+                                                
+      cfup(1,1) = 1.d0 - tau(1,1)             
+                                                
+      do in=2,nl                              
+         do ir=1,in                              
+                                                
+            if (ir.eq.1) then                       
+               cfup(in,ir) = tau(in,ir) - tau(in,1)        
+            elseif (ir.eq.in) then                  
+               cfup(in,ir) = 1.d0 - tau(in,ir-1)           
+            else                                    
+               cfup(in,ir) = tau(in,ir) - tau(in,ir-1)     
+            end if                                  
+            
+         end do                                  
+      end do                                  
+                                                
+! contribution to upwards fluxes from bb at bottom :        
+      do in=1,nl                              
+         taugr(in) =  tau(in,1)                
+      enddo                                   
+                                                
+c calculation of the matrix cfdw(nl,nl)         
+                                                
+      cfdw(nl,nl) = 1.d0 - tauinf(nl)         
+                                                
+      do in=1,nl-1                            
+         do ir=in,nl                             
+                                                
+            if (ir.eq.in) then                      
+               cfdw(in,ir) = 1.d0 - tau(in,ir)             
+            elseif (ir.eq.nl) then                  
+               cfdw(in,ir) = tau(in,ir-1) - tauinf(in)     
+            else                                    
+               cfdw(in,ir) = tau(in,ir-1) - tau(in,ir)     
+            end if                                  
+                                                
+         end do                                  
+      end do                                  
+                                                
+                                                
+c calculation of the matrix cf(nl,nl)           
+                                                
+      do in=1,nl                                     
+         do ir=1,nl                                     
+                                                
+            if (ir.eq.1) then                              
+	    ! version con l_bb(tg)  =  l_bb(t(1))=j(1) (see also vc below)     
+	    !	cf(in,ir) = tau(in,ir)                   
+	    ! version con l_bb(tg) =/= l_bb(t(1))=j(1) (see also vc below)     
+               cf(in,ir) = tau(in,ir) - tau(in,1)            
+            elseif (ir.eq.nl) then                         
+               cf(in,ir) = tauinf(in) - tau(in,ir-1)         
+            else                                           
+               cf(in,ir) = tau(in,ir) - tau(in,ir-1)         
+            end if                                         
+                                                
+         end do                                         
+      end do                                         
+                                                
+                                                
+c  definition of the a(nl,nl) matrix            
+                                                
+      do in=2,nl-1                                   
+         do ir=1,nl                                      
+            if (ir.eq.in+1) a(in,ir) = -1.d0              
+            if (ir.eq.in-1) a(in,ir) = +1.d0              
+            a(in,ir) = a(in,ir) / ( 2.d0*deltaz*1.d5 )         
+         end do                                       
+      end do                                         
+! this is not needed anymore in the akm scheme  
+!	a(1,1) = +3.d0                                
+!	a(1,2) = -4.d0                                
+!	a(1,3) = +1.d0                                
+!	a(nl,nl)   = -3.d0                            
+!	a(nl,nl1) = +4.d0                             
+!	a(nl,nl2) = -1.d0                             
+                                                
+c calculation of the final curtis matrix ("reduced" by murphy's method) 
+                                                
+      if (isot.ne.5) then                            
+         do in=1,nl                                   
+            do ir=1,nl                                  
+               cf(in,ir) = cf(in,ir) * pi*deltanu(isot,ib)            
+               cfup(in,ir) = cfup(in,ir) * pi*deltanu(isot,ib)        
+               cfdw(in,ir) = cfdw(in,ir) * pi*deltanu(isot,ib)        
+            end do                                      
+            taugr(in) = taugr(in) * pi*deltanu(isot,ib) 
+         end do                                       
+      else                                           
+         do in=1,nl                                   
+            do ir=1,nl                                  
+               cf(in,ir) = cf(in,ir) * pi*deltanuco       
+            enddo                                       
+            taugr(in) = taugr(in) * pi*deltanuco        
+         enddo                                        
+      endif                                          
+                                                
+      do in=2,nl-1                                   
+                                                
+         do ir=1,nl                                   
+                                                
+	    do i=1,nl                                  
+	      ! only c contains the matrix a. matrixes cup,cdw dont because
+	      ! these two will be used for flux calculations, not  
+	      ! only for flux divergencies             
+                                                
+               c(in,ir) = c(in,ir) + a(in,i) * cf(i,ir) 
+		! from this matrix we will extract (see below) the        
+		! nl2 x nl2 "core" for the "reduced" final curtis matrix. 
+                                                
+	    end do                                     
+	    cup(in,ir) = cfup(in,ir)                   
+	    cdw(in,ir) = cfdw(in,ir)                   
+                                                
+         end do			                                    
+	  ! version con l_bb(tg)  =  l_bb(t(1))=j(1)  (see cf above)           
+	  !vc(in) = c(in,1)                            
+	  ! version con l_bb(tg) =/= l_bb(t(1))=j(1)  (see cf above)           
+         vc(in) =  pi*deltanu(isot,ib)/( 2.d0*deltaz*1.d5 ) *     
+     @        ( tau(in-1,1) - tau(in+1,1) )         
+                                                
+      end do			                                      
+		                                              
+ 5    continue                                     
+                                                
+!	write (*,*)  'mztf/1/ c(2,*) =', (c(2,i), i=1,nl)              
+                                                
+!	call elimin_dibuja(c,nl,itableout)            
+                                                
+c ventana del smoothing de c es nw=3 y de vc es 5 (puesto en lisa):     
+c subroutine elimin_mz4(c,vc,ilayer,nl,nan,iw, nw)          
+                                                
+      iw = nan                                       
+      if (isot.eq.4)  iw = 5                         
+      call elimin_mz1d (c,vc,0,iw,itableout,nw)      
+                                                
+! upper boundary condition                      
+!   j'(nl) = j'(nl1) ==> j(nl) = 2j(nl1) - j(nl2) ==>       
+      do in=2,nl-1                                   
+         c(in,nl-2) = c(in,nl-2) - c(in,nl)           
+         c(in,nl-1) = c(in,nl-1) + 2.d0*c(in,nl)      
+         cup(in,nl-2) = cup(in,nl-2) - cup(in,nl)     
+         cup(in,nl-1) = cup(in,nl-1) + 2.d0*cup(in,nl)            
+         cdw(in,nl-2) = cdw(in,nl-2) - cdw(in,nl)     
+         cdw(in,nl-1) = cdw(in,nl-1) + 2.d0*cdw(in,nl)            
+      end do			                                      
+!   j(nl) = j(nl1) ==>                          
+!	do in=2,nl1                                   
+!	  c(in,nl1) = c(in,nl1) + c(in,nl)            
+!	end do			                                     
+                                                
+! 1000	continue                                 
+        
+      if (icfout.eq.1) then                          
+                                                
+! 	 if (ib.eq.1 .or. ib.eq.12 .or. ib.eq.16 .or. ib.eq.18) then  
+!		codmatrx = codmatrx_fb                        
+!	 else                                           
+!		codmatrx = codmatrx_hot                       
+!	 end if                                         
+                                                
+!	 if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5    
+!     @        .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
+                                                
+! 	   open ( 1, access='sequential', form='unformatted', file=           
+!     @    dircurtis//'cfl'//isotcode//dn//ibcode1//codmatrx//'.dat')         
+! 	   open ( 2, access='sequential', form='unformatted', file=           
+!     @    dircurtis//'cflup'//isotcode//dn//ibcode1//codmatrx//'.dat')       
+! 	   open ( 3, access='sequential', form='unformatted', file=           
+!     @    dircurtis//'cfldw'//isotcode//dn//ibcode1//codmatrx//'.dat')       
+                                                
+!	 else                                          
+                                                
+! 	   open ( 1, access='sequential', form='unformatted', file=           
+!     @    dircurtis//'cfl'//isotcode//dn//ibcode2//codmatrx//'.dat')         
+! 	   open ( 2, access='sequential', form='unformatted', file=           
+!     @    dircurtis//'cflup'//isotcode//dn//ibcode2//codmatrx//'.dat')       
+! 	   open ( 3, access='sequential', form='unformatted', file=           
+!     @    dircurtis//'cfldw'//isotcode//dn//ibcode2//codmatrx//'.dat')       
+                                                
+!	 endif                                         
+                                                
+!	    write(1) dummy                             
+!	    write(1)' format: (vc(n),(ch(n,r),r=2,nl-1),n=2,nl-1)' 
+!	    do in=2,nl-1                               
+!	     write(1) vc(in), (c(in,ir)  , ir=2,nl-1 )		           
+	! es mas importante la precision que ocupar mucho espacio asi que      
+	! escribiremos las matrices en doble precision y por tanto en          
+	! [lib]readc_mz4.for no hay que reconvertirlas a doble precision.      
+		! ch is stored in single prec. to save storage space.     
+!	    end do                                     
+                                                
+!	    write(2) dummy                             
+!	    write(2)' format: (cfup(n,r),r=1,nl), n=1,nl)'         
+!	    do in=1,nl                                 
+!	     write(2) ( cup(in,ir)  , ir=1,nl )		      
+!	    end do                                     
+                                                
+!	    write(3) dummy                             
+!	    write(3)' format: (cfdw(n,r),r=1,nl), n=1,nl)'         
+!	    do in=1,nl                                 
+!	     write(3) (cdw(in,ir)  , ir=1,nl )		       
+!	    end do                                     
+                                                
+!	   if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5  
+!     @        .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9)  then      
+!	     write (*,'(1x,30hcurtis matrix written out in: ,a50)' )           
+!     @     dircurtis//'cfl'//isotcode//dn//ibcode1//codmatrx//'.dat'         
+!	   else                                        
+!	     write (*,'(1x,30hcurtis matrix written out in: ,a50)' )           
+!     @     dircurtis//'cfl'//isotcode//dn//ibcode2//codmatrx//'.dat'         
+!	   endif                                       
+                                                
+      else                                           
+           
+	 ! write (*,*)  ' no curtis matrix output file ', char(10)     
+                                                
+      end if                                         
+                                                
+                                                
+c end                                           
+      return                                         
+      end
+
+
+
+
+
+c***********************************************************************
+c     cm15um_hb_simple
+c***********************************************************************
+                                                            
+      subroutine cm15um_hb_simple (ig,icurt)            
+                                                            
+c     computing the curtix matrixes for the 15 um hot bands   
+c     (las de las bandas fudnamentales las calcula cm15um_fb) 
+                                                            
+c     jan 98 		malv		version de mod3/cm_15um.f para mz1d 
+c     jul 2011 malv+fgg               adapted to LMD-MGCM
+c***********************************************************************
+                                                            
+      implicit none                                  
+                                                            
+!!!!!!!!!!!!!!!!!!!!!!!                         
+! common variables & constants                  
+                                                            
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+                                                            
+!!!!!!!!!!!!!!!!!!!!!!!                         
+! arguments                                     
+                   
+      integer ig                ! ADDED FOR TRACEBACK
+      integer icurt             ! icurt=0,1,2                  
+					! new calculations? (see caa.f heads)
+                                                            
+!!!!!!!!!!!!!!!!!!!!!!!                         
+! local variables                               
+                                                            
+      real*4 cdummy(nl,nl), csngl(nl,nl)             
+                                                            
+      real*8 cax1(nl,nl), cax2(nl,nl), cax3(nl,nl)   
+      real*8 v1(nl), v2(nl), v3(nl), cm_factor, vc_factor        
+                                                            
+      integer itauout,icfout,itableout, interpol,ismooth, isngldble          
+      integer i,j,ik,ist,isot,ib,itt                 
+                                                            
+	!character 	bandcode*2
+      character 	isotcode*2
+      character 	codmatrx_hot*5                      
+                                                            
+!!!!!!!!!!!!!!!!!!!!!!!                         
+! external functions                            
+                                                            
+      external bandid                                
+      character*2 bandid                             
+                                                            
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!               
+! subroutines called:                           
+! 	mz4sub, dmzout, readc_mz4, readcupdw, mztf   
+                                                            
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!               
+! formatos                                      
+ 132  format(i2)                                 
+                                                            
+************************************************************************
+************************************************************************
+                                                            
+      call zerom (c121,nl)                           
+      
+      call zerov (vc121,nl)                          
+      
+      call zerom (cup121,nl)                         
+      call zerom (cdw121,nl)                         
+      
+      call zerov (taugr121,nl)                       
+                                                            
+                                                            
+      itauout = 0		! =1 --> with output of tau       
+      icfout = 0		! =1 --> with output of cf         
+      itableout = 0		! =1 --> with output of table of taus       
+      isngldble = 1		! =1 --> dble precission        
+                                                            
+      codmatrx_hot='     '
+      if (icurt.eq.2) then                           
+         icfout=1                                      
+      elseif (icurt.eq.0) then                       
+         write (*,'(a,a$)')                            
+     @        ' hot bands. code for old matrixes (5 chars): '     
+         read (*,'(a)')  codmatrx_hot                  
+      endif                                          
+                                                            
+      fileroot = 'cfl'                               
+                                                            
+! ====================== curtis matrixes for fh bands ==================
+                                                            
+                                                            
+! una piedra en el camino ...                   
+!	write (*,*)  ' cm15um_hb/1 '                                   
+                                                            
+ccc                                             
+      if ( input_cza.ge.1 ) then                     
+ccc                                             
+                                                            
+         if (icurt.eq.2) then                           
+            write (*,'(a,a$)')                           
+     @           '  new calculation of curt. mat. for fh bands.',         
+     @           '    code for new matrixes : '               
+            read (*,'(a)') codmatrx_hot                  
+         elseif (icurt.eq.0) then                       
+            write (*,'(a,a$)')                           
+     @           '  reading in curt. mat. for fh bands.',     
+     @           '    code for old matrixes : '               
+            read (*,'(a)') codmatrx_hot                  
+         else                                           
+!     write (*,'(a)')                             
+!     @        '  new calculation of curt. mat. for fh bands.'         
+         end if                                         
+                                                            
+!       fh bands for the 626 isotope ================================-  
+                                                            
+         ist = 1                                        
+         isot = 26                                      
+! 	encode (2,132,isotcode) isot                  
+         write (isotcode,132) isot  
+                             
+         do 11, ik=1,3                                  
+            
+            ib=ik+1                                      
+                                                            
+            if (icurt.gt.0) then                         
+               call zero3m (cax1,cax2,cax3,nl)            
+! una piedra en el camino ...                   
+	    !write (*,*)  ' cm15um_hb/11 '                                  
+	    !write (*,*)  ' ib, ist, irw, imu =', ib, ist, irw_mztf, imu     
+               call mztf ( ig,cax1,cax2,cax3,v1,v2, ib,ist,irw_mztf,imu,      
+     @              itauout,icfout,itableout)                    
+!	  else                                         
+!	    bandcode = bandid(ib)                      
+!	    filend=isotcode//dn//bandcode//codmatrx_hot            
+!!	    write (*,*)  char(9), fileroot//filend                     
+!	    call zero3m (cax1,cax2,cax3,nl)            
+!	    call readcud_mz1d ( cax1,cax2,cax3, v1, v2,            
+!     @        	fileroot,filend, csngl, nl,nan,0,isngldble) 
+            end if                                       
+                                                            
+c 	  calculating the total c121(n,r) matrix for the first hot band      
+            do i=1,nl                                    
+                                                            
+               if ( ib .eq. 4 ) then                       
+!	    write (*,*)  ' '                                           
+!	    write (*,*)  i, ' ib,ist, altura :', ib,ist, zl(i)         
+               endif                                       
+                                                            
+!	    if ( v1(i) .le. 1.d-99 ) v1(i) = 0.0d0    
+!	    if ( v2(i) .le. 1.d-99 ) v2(i) = 0.0d0    
+                                                            
+                                                            
+               if(ik.eq.1)then                            
+                  cm_factor = (dble(618.03/667.75))**2.d0*      
+     @                 exp( dble(ee*(667.75-618.03)/t(i)) )     
+                  vc_factor = dble(667.75/618.03)               
+               elseif(ik.eq.2)then                        
+                  cm_factor = 1.d0                              
+                  vc_factor = 1.d0                              
+               elseif(ik.eq.3)then                        
+                  cm_factor = ( dble(720.806/667.75) )**2.d0*   
+     @                 exp( dble(ee*(667.75-720.806)/t(i)) )    
+                  vc_factor = dble(667.75/720.806)              
+               end if                                     
+               do j=1,nl                                  
+!	       if (cax1(i,j) .le. 1.d-99 ) cax1(i,j) = 0.0d0      
+!	       if (cax2(i,j) .le. 1.d-99 ) cax2(i,j) = 0.0d0      
+!	       if (cax3(i,j) .le. 1.d-99 ) cax3(i,j) = 0.0d0      
+                  c121(i,j) = c121(i,j) + cax1(i,j) * cm_factor        
+                  cup121(i,j) = cup121(i,j) + cax2(i,j) * cm_factor    
+                  cdw121(i,j) = cdw121(i,j) + cax3(i,j) * cm_factor    
+               end do                                     
+                                                            
+!	    write (*,*)  ' i =', i                                     
+!	    write (*,*)  ' vc_factor =', vc_factor                     
+!	    write (*,*)  ' v1 =', v1(i)                                
+!	    write (*,*)  ' v2 =', v2(i)                                
+!	    write (*,*)  vc121(i), taugr121(i)                         
+!	    write (*,*)  v1(i) * vc_factor                             
+!	    write (*,*)  vc121(i) + v1(i) * vc_factor                  
+                                                            
+               vc121(i) = vc121(i) + v1(i) * vc_factor    
+            
+                                      
+!	    write (*,*)  v2(i) * vc_factor                             
+!	    write (*,*)  taugr121(i) + v2(i) * vc_factor               
+                                                            
+               taugr121(i) = taugr121(i) + v2(i) * vc_factor          
+                                                            
+            end do                                       
+ 11      continue                                     
+                                                            
+ccc                                             
+      end if                                         
+ccc                                             
+                                                            
+                                                            
+      return                                         
+      end 
+
+
+
+
+
Index: /trunk/LMDZ.MARS/libf/phymars/nlte_commons.h
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/nlte_commons.h	(revision 498)
+++ /trunk/LMDZ.MARS/libf/phymars/nlte_commons.h	(revision 498)
@@ -0,0 +1,376 @@
+c****************************************************************************
+c
+c       Merging of different common blocks used in the new NLTE 15um param
+c
+c       jan 2012    fgg+malv
+c****************************************************************************
+c *** Old nlte_atm.h ***
+c Subgrid atmosphere interpolated 
+c
+        common /atm_nl/ zl, t, pl, sh, nt, co2, n2, co, o3p, o2, h2, ar,
+     @    co2vmr, n2vmr, covmr, o3pvmr,hrkday_factor
+
+        real zl(nl), t(nl), pl(nl), nt(nl),  sh(nl),
+     @    co2(nl), n2(nl), co(nl), o3p(nl), o2(nl), h2(nl), ar(nl),
+     @    co2vmr(nl),n2vmr(nl),covmr(nl),o3pvmr(nl),hrkday_factor(nl)
+
+c Subgrid atmosphere obtained from the input atmosphere and limited to the
+c NLTE grid. Only used for computing transmitances. 
+c
+        common /atm_ny/ zy, ty, py, nty, co2y, coy
+        real zy(nzy), ty(nzy), py(nzy), nty(nzy), co2y(nzy), coy(nzy)
+
+c
+	common/deltazetas/ deltaz, deltazy, 
+     @        jlowerboundary, jtopboundary
+	real    deltaz, deltazy
+	integer jlowerboundary, jtopboundary
+
+
+c *** Old nlte_results.h ***
+c Next common: parameter that decides which level populations 
+c are already known and therefore are read and used in this program.
+	common/input_avilable_from/ input_cza, input_czb, input_czc, 
+     @                              input_czco
+	integer input_cza, input_czb, input_czc, input_czco
+
+c temperatura vibracional de entrada:
+	common/temp626/ v626t1,v626t2,v626t3,v626t4, 
+     @   		v626t5,v626t6,v626t7,v626t8
+	common/temp628/ v628t1, v628t2, v628t3, v628t4
+	common/temp636/ v636t1, v636t2, v636t3, v636t4 
+	common/temp627/ v627t1, v627t2, v627t3, v627t4 
+	common/tempco/ vcot1, vcot2, vcot3, vcot4, v63t1,v63t2,v63t3
+	real*8 v626t4(nl), v628t4(nl), v636t4(nl), v627t4(nl)
+	real*8 v626t1(nl), v626t2(nl), v626t3(nl) 
+	real*8 v626t5(nl), v626t6(nl), v626t7(nl), v626t8(nl)
+	real*8 v628t1(nl), v628t2(nl), v628t3(nl) 
+	real*8 v636t1(nl), v636t2(nl), v636t3(nl) 
+	real*8 v627t1(nl), v627t2(nl), v627t3(nl) 
+	real*8 vcot1(nl), vcot2(nl), vcot3(nl), vcot4(nl)
+	real*8 v63t1(nl), v63t2(nl), v63t3(nl)
+
+c output de cza.for
+	common /tv15um/	vt11, vt12, vt13,
+     @      		vt21, vt22, vt23,
+     @      		vt31, vt32, vt33,
+     @      		vt41, vt42, vt43
+	real*8  vt11(nl), vt12(nl), vt13(nl),
+     @      	vt21(nl), vt22(nl), vt23(nl),
+     @      	vt31(nl), vt32(nl), vt33(nl),
+     @      	vt41(nl), vt42(nl), vt43(nl)
+
+	common /hr15um/	hr110,hr210,hr310,hr410,
+     @      		hr121,hr221,hr321,hr421,
+     @      		hr132,hr232,hr332,hr432
+	real*8  hr110(nl),hr121(nl),hr132(nl),
+     @      	hr210(nl),hr310(nl),hr410(nl),
+     @      	hr221(nl),hr232(nl),hr321(nl),
+     @      	hr332(nl),hr421(nl),hr432(nl)
+
+        common/sf15um/ el11,el12,el13, el21,el22,el23,
+     @ 		el31,el32,el33, el41,el42,el43
+        real*8 el11(nl), el12(nl), el13(nl)
+        real*8 el21(nl), el22(nl), el23(nl)
+        real*8 el31(nl), el32(nl), el33(nl)
+        real*8 el41(nl), el42(nl), el43(nl)
+
+        common/sl15um/ sl110,sl121,sl132, sl210,sl221,sl232,
+     @          sl310,sl321,sl332, sl410,sl421,sl432 
+        real*8 sl110(nl), sl121(nl), sl132(nl)
+        real*8 sl210(nl), sl221(nl), sl232(nl)
+        real*8 sl310(nl), sl321(nl), sl332(nl)
+        real*8 sl410(nl), sl421(nl), sl432(nl)
+
+
+c *** Old nlte_matrix.h***
+c curtis matrix de cza:
+	common/curtis_matrixes_15um/ c110,c121, c210,
+     @  	c310, c410,
+     @  	vc110,vc121, vc210,
+     @  	vc310, vc410
+	real*8 c110(nl,nl), c121(nl,nl)
+	real*8 c210(nl,nl)
+	real*8 c310(nl,nl)
+	real*8 c410(nl,nl)
+	real*8 vc110(nl), vc121(nl)
+	real*8 vc210(nl), vc310(nl), vc410(nl)
+ 
+	common/curtis_matr_up_15um/ 
+     @          cup110,cup121
+	real*8 cup110(nl,nl), cup121(nl,nl)
+
+	common/curtis_matr_dw_15um/ 
+     @          cdw110,cdw121
+	real*8 cdw110(nl,nl), cdw121(nl,nl)
+
+        common/curtis_matr_taugr_15um/
+     @  	taugr110,taugr121
+        real*8 taugr110(nl), taugr121(nl)
+        
+! for the new flux formulation:
+!
+!
+        common/tauinf_15um/ tauinf121,
+     @  	tauinf210,tauinf310,tauinf410,tauinf110
+        real*8 tauinf121(nl)
+        real*8 tauinf210(nl), tauinf310(nl), tauinf410(nl)
+        real*8 tauinf110(nl)
+
+! for the cool-to-space formulation:
+!
+	common/taustar_15um/ taustar11, taustar21, taustar31, 
+     @         taustar41, taustar12
+	real*8 taustar11(nl), taustar21(nl), taustar31(nl)
+	real*8 taustar41(nl), taustar12(nl)
+
+	common/tauii_15um/ tauii110, tauii210, tauii310, 
+     @         tauii410, tauii121
+	real*8 tauii110(nl), tauii210(nl), tauii310(nl)
+	real*8 tauii410(nl), tauii121(nl)
+
+! for the name of the C.Matrix files
+!
+	common/cm_names/ fileroot
+	character        fileroot*3
+
+
+c *** Old nlte_rates.h ***
+	common/rates_vt/ k7a(4),k7b(4), k7ap(4),k7bp(4), 
+     @      	k3aa(4),k3ab(4),k3ac(4), k3aap(4),k3abp(4),k3acp(4),
+     @      	k3ba(4),k3bb(4),k3bc(4), k3bap(4),k3bbp(4),k3bcp(4),
+     @      	k19aa(4),k19ab(4),k19ac(4), k19aap(4),k19abp(4),k19acp(4),
+     @      	k19ba(4),k19bb(4),k19bc(4), k19bap(4),k19bbp(4),k19bcp(4),
+     @      	k19ca(4),k19cb(4),k19cc(4), k19cap(4),k19cbp(4),k19ccp(4),
+     @      	k20a(4),k20b(4),k20c(4), k20ap(4),k20bp(4),k20cp(4),
+     @      	k27a,k27b,k27c, k27ap,k27bp,k27cp
+
+	real*8 k7a,k7b, k7ap,k7bp 
+	real*8 k3aa,k3ab,k3ac, k3aap,k3abp,k3acp
+	real*8 k3ba,k3bb,k3bc, k3bap,k3bbp,k3bcp
+	real*8 k19aa,k19ab,k19ac, k19aap,k19abp,k19acp
+	real*8 k19ba,k19bb,k19bc, k19bap,k19bbp,k19bcp
+	real*8 k19ca,k19cb,k19cc, k19cap,k19cbp,k19ccp
+	real*8 k20a,k20b,k20c, k20ap,k20bp,k20cp
+	real*8 k27a,k27b,k27c, k27ap,k27bp,k27cp
+
+        common/rates_vv/ k1(4),k1p(4), 
+     @      	k2a,k2b, k2x,k2y,k2z, k2xp,k2yp,k2zp,
+     @      	k6,k6p, k6a(2:4),k6b(2:4), k6ap(2:4),k6bp(2:4),
+     @      	k21a,k21ap, k21a1(2:4),k21a2(2:4), k21a1p(2:4),k21a2p(2:4),
+     @      	k21b(4),k21c(4), k21bp(4),k21cp(4),
+     @      	k31,k32,
+     @      	k33a1,k33a2,k33b1,k33b2,k33c, 
+     @      	k33a1p(2:4),k33a2p(2:4),k33b1p(2:4),k33b2p(2:4),k33cp(2:4),
+     @      	k28a,k28b,k28c, k28ap,k28bp,k28cp,
+     @      	k26a,k26b,k26c,k26d, k26ap(4),k26bp(4),k26cp(4),k26dp(4), 
+     @      	k41p_taylor, k41p_shved, k41p_starr_hannock, 
+     @      	k41_1,k41p_1, k41_2,k41p_2, k42,k42p
+
+	real*8 k1,k1p
+	real*8 k2a,k2b, k2x,k2y,k2z, k2xp,k2yp,k2zp
+	real*8 k6,k6p, k6a,k6b, k6ap,k6bp
+	real*8 k21a,k21ap, k21a1,k21a2, k21a1p,k21a2p
+	real*8 k21b,k21c, k21bp,k21cp
+	real*8 k31,k32
+	real*8 k33a1,k33a2,k33b1,k33b2,k33c
+	real*8 k33a1p,k33a2p,k33b1p,k33b2p,k33cp
+	real*8 k28a,k28b,k28c, k28ap,k28bp,k28cp
+	real*8 k26a,k26b,k26c,k26d, k26ap,k26bp,k26cp,k26dp
+	real*8 k41p_taylor, k41p_shved, k41p_starr_hannock 
+	real*8 k41_1,k41p_1, k41_2,k41p_2, k42,k42p 
+
+
+	common/rates_k26isot/ k26a21,k26c21,k26d21, 
+     @     k26a22,k26c22,k26d22, k26a23,k26c23,k26d23, 
+     @     k26a24,k26c24,k26d24, 
+     @     k26a32,k26c32,k26d32, k26a33,k26c33,k26d33, 
+     @     k26a31,k26c31,k26d31, 
+     @     k26a34,k26c34,k26d34, k26a42,k26c42,k26d42, 
+     @     k26a41,k26c41,k26d41, 
+     @     k26a43,k26c43,k26d43, k26a44,k26c44,k26d44 
+
+	real*8 k26a21,k26c21,k26d21, 
+     @     k26a22,k26c22,k26d22, k26a23,k26c23,k26d23, 
+     @     k26a24,k26c24,k26d24, 
+     @     k26a32,k26c32,k26d32, k26a33,k26c33,k26d33, 
+     @     k26a31,k26c31,k26d31, 
+     @     k26a34,k26c34,k26d34, k26a42,k26c42,k26d42, 
+     @     k26a41,k26c41,k26d41, 
+     @     k26a43,k26c43,k26d43, k26a44,k26c44,k26d44
+
+
+	common/rates_last/ k23k21c, k24k21c, k34k21c, 
+     @      	k23k21cp, k24k21cp, k34k21cp, k43,k43p, k_vthcl
+
+	real*8 k23k21c,k24k21c,k34k21c, k23k21cp,k24k21cp,k34k21cp 
+	real*8 k43,k43p, k_vthcl
+
+	common/rates_V09/ k41_3,k41p_3, k41_4,k41p_4, k41iso_1,k41iso_1p, 
+     @                    k41iso_2,k41iso_2p, k41iso_3,k41iso_3p, 
+     @                    k42b, k42c, k42bp, k42cp, k43iso,k43isop, 
+     @                    k44a,k44b,k44c,k44d, k44ap,k44bp,k44cp,k44dp, 
+     @                    k42iso,k42isop, k42isob,k42isobp
+        real*8  k41_3,k41p_3, k41_4,k41p_4, k41iso_1,k41iso_1p
+	real*8  k41iso_2,k41iso_2p, k41iso_3,k41iso_3p
+        real*8  k42b, k42c, k42bp, k42cp, k43iso,k43isop
+	real*8  k44a,k44b,k44c,k44d, k44ap,k44bp,k44cp,k44dp
+	real*8  k42iso,k42isop, k42isob,k42isobp
+
+
+c *** Old nlte_curtis.h ***
+
+
+	common/block1/s,alsa,alna,alda,ka,kr
+	real*8 ka(nbox_max),alsa(nbox_max),alna(nbox_max),alda(nbox_max)
+     &,s
+	integer kr
+
+	common/block2/hisfile, hfile1
+	character hisfile*75, hfile1*3
+
+	common/block3/sl_ua,ua,pt,pp,ta,w, icls
+	real*8 sl_ua,ua(nbox_max),pt,pp,ta(nbox_max),w
+	integer	icls
+
+	common/block4/no,sk1,xls1,xln1,xld1,thist,dist, nbox
+	real*8	sk1(nhist,nbox_max)	! line intensity
+	real*8  xls1(nhist,nbox_max)	! Lorentz half width (self-col.)
+	real*8	xln1(nhist,nbox_max)	! Lorentz half width
+	real*8 	xld1(nhist,nbox_max)	! Doppler half width
+	real*8	thist(nhist)		! temperatures in the histogram
+	real*8	no(nbox_max)		! number of lines in box
+	real*8  dist(nbox_max)		! mean distance between lines in box
+	integer nbox		! actual number of boxes
+
+	common/block5/eqw, aa, bb, cc, dd, ddbox, ccbox
+	real*8 eqw, aa, bb, cc, dd
+	real*8 ddbox(nbox_max), ccbox(nbox_max)
+
+	common/block7/ mr, p
+	real*8  mr(nzy), p(nzy)
+
+	common/block8/ tmin,tmax, mm
+	real*8 tmin,tmax
+	integer mm
+
+	common/block9/ w_strongLor_prev
+	real*8 w_strongLor_prev(nbox_max)
+
+        common/block10/no_c1,no_c2,no_c3,no_c4,no_c5,no_c6,no_c7
+	real*8	no_c1(nbox_max)
+	real*8	no_c2(nbox_max)
+	real*8	no_c3(nbox_max)
+	real*8	no_c4(nbox_max)
+	real*8	no_c5(nbox_max)
+	real*8	no_c6(nbox_max)
+	real*8	no_c7(nbox_max)
+
+	common/block11/nbox_c1,nbox_c2,nbox_c3,nbox_c4,
+     $     nbox_c5,nbox_c6,nbox_c7
+	integer nbox_c1
+	integer nbox_c2
+	integer nbox_c3
+	integer nbox_c4
+	integer nbox_c5
+	integer nbox_c6
+	integer nbox_c7
+
+	common/block12/thist_c1,thist_c2,thist_c3,thist_c4,thist_c5,
+     $    thist_c6,thist_c7
+	real*8	thist_c1(nhist)
+	real*8	thist_c2(nhist)
+	real*8	thist_c3(nhist)
+	real*8	thist_c4(nhist)
+	real*8	thist_c5(nhist)
+	real*8	thist_c6(nhist)
+	real*8	thist_c7(nhist)
+
+	common/block13/dist_c1,dist_c2,dist_c3,dist_c4,dist_c5,
+     $    dist_c6,dist_c7
+	real*8  dist_c1(nbox_max)
+	real*8  dist_c2(nbox_max)
+	real*8  dist_c3(nbox_max)
+	real*8  dist_c4(nbox_max)
+	real*8  dist_c5(nbox_max)
+	real*8  dist_c6(nbox_max)
+	real*8  dist_c7(nbox_max)
+
+	common/block14/sk1_c1,sk1_c2,sk1_c3,sk1_c4,sk1_c5,sk1_c6,sk1_c7
+	real*8	sk1_c1(nhist,nbox_max)
+	real*8	sk1_c2(nhist,nbox_max)
+	real*8	sk1_c3(nhist,nbox_max)
+	real*8	sk1_c4(nhist,nbox_max)
+	real*8	sk1_c5(nhist,nbox_max)
+	real*8	sk1_c6(nhist,nbox_max)
+	real*8	sk1_c7(nhist,nbox_max)
+
+	common/block15/xls1_c1,xls1_c2,xls1_c3,xls1_c4,xls1_c5,xls1_c6,
+     $     xls1_c7
+	real*8  xls1_c1(nhist,nbox_max)
+	real*8  xls1_c2(nhist,nbox_max)
+	real*8  xls1_c3(nhist,nbox_max)
+	real*8  xls1_c4(nhist,nbox_max)
+	real*8  xls1_c5(nhist,nbox_max)
+	real*8  xls1_c6(nhist,nbox_max)
+	real*8  xls1_c7(nhist,nbox_max)
+
+	common/block16/xln1_c1,xln1_c2,xln1_c3,xln1_c4,xln1_c5,xln1_c6,
+     $     xln1_c7
+	real*8  xln1_c1(nhist,nbox_max)
+	real*8  xln1_c2(nhist,nbox_max)
+	real*8  xln1_c3(nhist,nbox_max)
+	real*8  xln1_c4(nhist,nbox_max)
+	real*8  xln1_c5(nhist,nbox_max)
+	real*8  xln1_c6(nhist,nbox_max)
+	real*8  xln1_c7(nhist,nbox_max)
+
+	common/block17/xld1_c1,xld1_c2,xld1_c3,xld1_c4,xld1_c5,xld1_c6,
+     $     xld1_c7
+	real*8  xld1_c1(nhist,nbox_max)
+	real*8  xld1_c2(nhist,nbox_max)
+	real*8  xld1_c3(nhist,nbox_max)
+	real*8  xld1_c4(nhist,nbox_max)
+	real*8  xld1_c5(nhist,nbox_max)
+	real*8  xld1_c6(nhist,nbox_max)
+	real*8  xld1_c7(nhist,nbox_max)
+
+	common/block18/mm_c1,mm_c2,mm_c3,mm_c4,mm_c5,mm_c6,mm_c7
+	integer mm_c1
+	integer mm_c2
+	integer mm_c3
+	integer mm_c4
+	integer mm_c5
+	integer mm_c6
+	integer mm_c7
+
+	common/block19/tmin_c1,tmin_c2,tmin_c3,tmin_c4,tmin_c5,tmin_c6,
+     $     tmin_c7
+	real*8 tmin_c1
+	real*8 tmin_c2
+	real*8 tmin_c3
+	real*8 tmin_c4
+	real*8 tmin_c5
+	real*8 tmin_c6
+	real*8 tmin_c7
+
+	common/block20/tmax_c1,tmax_c2,tmax_c3,tmax_c4,tmax_c5,tmax_c6,
+     $     tmax_c7
+	real*8 tmax_c1
+	real*8 tmax_c2
+	real*8 tmax_c3
+	real*8 tmax_c4
+	real*8 tmax_c5
+	real*8 tmax_c6
+	real*8 tmax_c7
+
+        common /lor_overlap/ asat_box, i_supersat
+	real*8 		asat_box
+	integer 	i_supersat
+
+
+c *** Variables formerly included in nlte_data.h ***
+        common /nltedata/ elow, deltanu
+        real elow(nisot,nb), deltanu(nisot,nb)
+
+c****************************************************************************
Index: unk/LMDZ.MARS/libf/phymars/nlte_curtis.h
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/nlte_curtis.h	(revision 497)
+++ 	(revision )
@@ -1,155 +1,0 @@
-c****************************************************************************
-c
-c       curtis.cmn
-c 
-c       Common blocks for Curtis Matrix calculation
-c       
-c       JAN 98  MALV            First version
-c****************************************************************************
-
-
-	common/block1/s,alsa,alna,alda,ka,kr
-	real*8 ka(nbox_max),alsa(nbox_max),alna(nbox_max),alda(nbox_max),s
-	integer kr
-
-	common/block2/hisfile, hfile1
-	character hisfile*75, hfile1*3
-
-	common/block3/sl_ua,ua,pt,pp,ta,w, icls
-	real*8 sl_ua,ua(nbox_max),pt,pp,ta(nbox_max),w
-	integer	icls
-
-	common/block4/no,sk1,xls1,xln1,xld1,thist,dist, nbox
-	real*8	sk1(nhist,nbox_max)	! line intensity
-	real*8  xls1(nhist,nbox_max)	! Lorentz half width (self-col.)
-	real*8	xln1(nhist,nbox_max)	! Lorentz half width
-	real*8 	xld1(nhist,nbox_max)	! Doppler half width
-	real*8	thist(nhist)		! temperatures in the histogram
-	real*8	no(nbox_max)		! number of lines in box
-	real*8  dist(nbox_max)		! mean distance between lines in box
-	integer nbox		! actual number of boxes
-
-	common/block5/eqw, aa, bb, cc, dd, ddbox, ccbox
-	real*8 eqw, aa, bb, cc, dd
-	real*8 ddbox(nbox_max), ccbox(nbox_max)
-
-	common/block7/ mr, p
-	real*8  mr(nzy), p(nzy)
-
-	common/block8/ tmin,tmax, mm
-	real*8 tmin,tmax
-	integer mm
-
-	common/block9/ w_strongLor_prev
-	real*8 w_strongLor_prev(nbox_max)
-
-        common/block10/no_c1,no_c2,no_c3,no_c4,no_c5,no_c6,no_c7
-	real*8	no_c1(nbox_max)
-	real*8	no_c2(nbox_max)
-	real*8	no_c3(nbox_max)
-	real*8	no_c4(nbox_max)
-	real*8	no_c5(nbox_max)
-	real*8	no_c6(nbox_max)
-	real*8	no_c7(nbox_max)
-
-	common/block11/nbox_c1,nbox_c2,nbox_c3,nbox_c4,
-     $     nbox_c5,nbox_c6,nbox_c7
-	integer nbox_c1
-	integer nbox_c2
-	integer nbox_c3
-	integer nbox_c4
-	integer nbox_c5
-	integer nbox_c6
-	integer nbox_c7
-
-	common/block12/thist_c1,thist_c2,thist_c3,thist_c4,thist_c5,
-     $    thist_c6,thist_c7
-	real*8	thist_c1(nhist)
-	real*8	thist_c2(nhist)
-	real*8	thist_c3(nhist)
-	real*8	thist_c4(nhist)
-	real*8	thist_c5(nhist)
-	real*8	thist_c6(nhist)
-	real*8	thist_c7(nhist)
-
-	common/block13/dist_c1,dist_c2,dist_c3,dist_c4,dist_c5,
-     $    dist_c6,dist_c7
-	real*8  dist_c1(nbox_max)
-	real*8  dist_c2(nbox_max)
-	real*8  dist_c3(nbox_max)
-	real*8  dist_c4(nbox_max)
-	real*8  dist_c5(nbox_max)
-	real*8  dist_c6(nbox_max)
-	real*8  dist_c7(nbox_max)
-
-	common/block14/sk1_c1,sk1_c2,sk1_c3,sk1_c4,sk1_c5,sk1_c6,sk1_c7
-	real*8	sk1_c1(nhist,nbox_max)
-	real*8	sk1_c2(nhist,nbox_max)
-	real*8	sk1_c3(nhist,nbox_max)
-	real*8	sk1_c4(nhist,nbox_max)
-	real*8	sk1_c5(nhist,nbox_max)
-	real*8	sk1_c6(nhist,nbox_max)
-	real*8	sk1_c7(nhist,nbox_max)
-
-	common/block15/xls1_c1,xls1_c2,xls1_c3,xls1_c4,xls1_c5,xls1_c6,
-     $     xls1_c7
-	real*8  xls1_c1(nhist,nbox_max)
-	real*8  xls1_c2(nhist,nbox_max)
-	real*8  xls1_c3(nhist,nbox_max)
-	real*8  xls1_c4(nhist,nbox_max)
-	real*8  xls1_c5(nhist,nbox_max)
-	real*8  xls1_c6(nhist,nbox_max)
-	real*8  xls1_c7(nhist,nbox_max)
-
-	common/block16/xln1_c1,xln1_c2,xln1_c3,xln1_c4,xln1_c5,xln1_c6,
-     $     xln1_c7
-	real*8  xln1_c1(nhist,nbox_max)
-	real*8  xln1_c2(nhist,nbox_max)
-	real*8  xln1_c3(nhist,nbox_max)
-	real*8  xln1_c4(nhist,nbox_max)
-	real*8  xln1_c5(nhist,nbox_max)
-	real*8  xln1_c6(nhist,nbox_max)
-	real*8  xln1_c7(nhist,nbox_max)
-
-	common/block17/xld1_c1,xld1_c2,xld1_c3,xld1_c4,xld1_c5,xld1_c6,
-     $     xld1_c7
-	real*8  xld1_c1(nhist,nbox_max)
-	real*8  xld1_c2(nhist,nbox_max)
-	real*8  xld1_c3(nhist,nbox_max)
-	real*8  xld1_c4(nhist,nbox_max)
-	real*8  xld1_c5(nhist,nbox_max)
-	real*8  xld1_c6(nhist,nbox_max)
-	real*8  xld1_c7(nhist,nbox_max)
-
-	common/block18/mm_c1,mm_c2,mm_c3,mm_c4,mm_c5,mm_c6,mm_c7
-	integer mm_c1
-	integer mm_c2
-	integer mm_c3
-	integer mm_c4
-	integer mm_c5
-	integer mm_c6
-	integer mm_c7
-
-	common/block19/tmin_c1,tmin_c2,tmin_c3,tmin_c4,tmin_c5,tmin_c6,
-     $     tmin_c7
-	real*8 tmin_c1
-	real*8 tmin_c2
-	real*8 tmin_c3
-	real*8 tmin_c4
-	real*8 tmin_c5
-	real*8 tmin_c6
-	real*8 tmin_c7
-
-	common/block20/tmax_c1,tmax_c2,tmax_c3,tmax_c4,tmax_c5,tmax_c6,
-     $     tmax_c7
-	real*8 tmax_c1
-	real*8 tmax_c2
-	real*8 tmax_c3
-	real*8 tmax_c4
-	real*8 tmax_c5
-	real*8 tmax_c6
-	real*8 tmax_c7
-
-        common /lor_overlap/ asat_box, i_supersat
-	real*8 		asat_box
-	integer 	i_supersat
Index: unk/LMDZ.MARS/libf/phymars/nlte_data.h
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/nlte_data.h	(revision 497)
+++ 	(revision )
@@ -1,23 +1,0 @@
-!
-	common/spectral/imr, imrco, 
-     @		nu, nun2, nuco_10,
-     @          nu12_0200,nu12_1000, nu22_0200,nu22_1000, 
-     @		nu32_0200,nu32_1000, nu42_0200,nu42_1000, 
-     @  	elow, deltanu, deltanuco, indexisot
-	real imr(nisot), imrco
-	real nu(nisot,8), elow(nisot,nb), deltanu(nisot,nb)
-	real nun2, nu12_0200,nu12_1000, nu22_0200,nu22_1000, 
-     @  	nu32_0200,nu32_1000, nu42_0200,nu42_1000
-	real nuco_10, deltanuco
-	integer indexisot(nisot)
-!
-!
-        common/datis/  vlight, ee, hplanck, gamma
-        real*8  vlight, ee, hplanck, gamma
-
-
-
-
-
-
-
Index: /trunk/LMDZ.MARS/libf/phymars/nlte_leedat.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/nlte_leedat.F	(revision 498)
+++ /trunk/LMDZ.MARS/libf/phymars/nlte_leedat.F	(revision 498)
@@ -0,0 +1,1147 @@
+c***********************************************************************
+      subroutine NLTE_leedat                              
+                                                
+c     reads planetary and molecular parameters     
+                                                
+c     jan 98 	malv		first version	 
+c     jul 2011 malv+fgg       adapted to LMD-MGCM
+c***********************************************************************
+                                                
+      implicit none                                  
+                                                
+      include 'datafile.h'
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+      
+                                                
+c local variables                               
+      integer 	i,j, k,lun1, lun2                      
+      integer :: ib = 0
+      integer		isot
+      character	isotcode*2
+      character       ibcode1*1
+                              
+c formats                                       
+ 132  format (i2)
+ 101  format(i1)                               
+c***********************************************************************
+                                                
+      lun1 = 1                                       
+      lun2 = 2    
+
+      do k=1,nisot                                   
+!	  encode (2,132,isotcode) indexisot(k)  
+         write (isotcode,132) indexisot(k)        
+         open (lun1,                                  
+     @        file=trim(datafile)//'/NLTEDAT/enelow'//isotcode//'.dat',
+     @        status='old')                               
+         open (lun2,                                  
+     @        file=trim(datafile)//'/NLTEDAT/deltanu'//isotcode//'.dat',            
+     @        status='old')                               
+         read (lun1,*)                              
+         read (lun2,*)                              
+         read (lun1,*) (elow(k,i), i=1,nb)          
+         read (lun2,*) (deltanu(k,i), i=1,nb)       
+         close (lun1)                                 
+         close (lun2)                                 
+      end do                                       
+          
+
+c     Call to rhist
+	
+      hfile1='hid'
+!     if (ib.eq.13 .or. ib.eq.14 ) hfile1 = dirspec//'his' 
+      if (ib.eq.13 .or. ib.eq.14 ) hfile1 = 'his' 
+      
+      ib=1
+      do isot=1,4
+c     Cases 1,2,3,4
+         if (isot.eq.1) hisfile = hfile1//'26-1.dat' 
+         if (isot.eq.2) hisfile = hfile1//'28-1.dat' 
+         if (isot.eq.3) hisfile = hfile1//'36-1.dat' 
+         if (isot.eq.4) hisfile = hfile1//'27-1.dat'
+         call rhist(1.0)
+         if (isot.eq.1) then    !Case 1
+            mm_c1=mm
+            nbox_c1=nbox
+            tmin_c1=tmin
+            tmax_c1=tmax
+            do i=1,nbox_max
+               no_c1(i)=no(i)
+               dist_c1(i)=dist(i)
+               do j=1,nhist
+                  sk1_c1(j,i)=sk1(j,i)
+                  xls1_c1(j,i)=xls1(j,i)
+                  xln1_c1(j,i)=xln1(j,i)
+                  xld1_c1(j,i)=xld1(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist_c1(j)=thist(j)
+            enddo
+         else if(isot.eq.2) then !Case 2
+            mm_c2=mm
+            nbox_c2=nbox
+            tmin_c2=tmin
+            tmax_c2=tmax
+            do i=1,nbox_max
+               no_c2(i)=no(i)
+               dist_c2(i)=dist(i)
+               do j=1,nhist
+                  sk1_c2(j,i)=sk1(j,i)
+                  xls1_c2(j,i)=xls1(j,i)
+                  xln1_c2(j,i)=xln1(j,i)
+                  xld1_c2(j,i)=xld1(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist_c2(j)=thist(j)
+            enddo
+         else if (isot.eq.3) then ! Case 3
+            mm_c3=mm
+            nbox_c3=nbox
+            tmin_c3=tmin
+            tmax_c3=tmax
+            do i=1,nbox_max
+               no_c3(i)=no(i)
+               dist_c3(i)=dist(i)
+               do j=1,nhist
+                  sk1_c3(j,i)=sk1(j,i)
+                  xls1_c3(j,i)=xls1(j,i)
+                  xln1_c3(j,i)=xln1(j,i)
+                  xld1_c3(j,i)=xld1(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist_c3(j)=thist(j)
+            enddo
+         else if (isot.eq.4) then ! Case 4
+            mm_c4=mm
+            nbox_c4=nbox
+            tmin_c4=tmin
+            tmax_c4=tmax
+            do i=1,nbox_max
+               no_c4(i)=no(i)
+               dist_c4(i)=dist(i)
+               do j=1,nhist
+                  sk1_c4(j,i)=sk1(j,i)
+                  xls1_c4(j,i)=xls1(j,i)
+                  xln1_c4(j,i)=xln1(j,i)
+                  xld1_c4(j,i)=xld1(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist_c4(j)=thist(j)
+            enddo
+         endif
+      enddo
+      do ib=2,4
+         isot=1
+         write (ibcode1,101) ib
+         hisfile = hfile1//'26-'//ibcode1//'.dat' 
+         call rhist (1.0)
+         if (ib.eq.2) then      !Case 5
+            mm_c5=mm
+            nbox_c5=nbox
+            tmin_c5=tmin
+            tmax_c5=tmax
+            do i=1,nbox_max
+               no_c5(i)=no(i)
+               dist_c5(i)=dist(i)
+               do j=1,nhist
+                  sk1_c5(j,i)=sk1(j,i)
+                  xls1_c5(j,i)=xls1(j,i)
+                  xln1_c5(j,i)=xln1(j,i)
+                  xld1_c5(j,i)=xld1(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist_c5(j)=thist(j)
+            enddo
+         else if (ib.eq.3) then !Case 6
+            mm_c6=mm
+            nbox_c6=nbox
+            tmin_c6=tmin
+            tmax_c6=tmax
+            do i=1,nbox_max
+               no_c6(i)=no(i)
+               dist_c6(i)=dist(i)
+               do j=1,nhist
+                  sk1_c6(j,i)=sk1(j,i)
+                  xls1_c6(j,i)=xls1(j,i)
+                  xln1_c6(j,i)=xln1(j,i)
+                  xld1_c6(j,i)=xld1(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist_c6(j)=thist(j)
+            enddo
+         else if (ib.eq.4) then !Case 7
+            mm_c7=mm
+            nbox_c7=nbox
+            tmin_c7=tmin
+            tmax_c7=tmax
+            do i=1,nbox_max
+               no_c7(i)=no(i)
+               dist_c7(i)=dist(i)
+               do j=1,nhist
+                  sk1_c7(j,i)=sk1(j,i)
+                  xls1_c7(j,i)=xls1(j,i)
+                  xln1_c7(j,i)=xln1(j,i)
+                  xld1_c7(j,i)=xld1(j,i)
+               enddo
+            enddo
+            do j=1,nhist 
+               thist_c7(j)=thist(j)
+            enddo
+         endif
+      enddo
+
+c end                                           
+      return                                         
+
+      end                                            
+                                                
+
+
+c     *******************************************************************   
+                                                
+      subroutine rhist (factor_comp)                 
+                                                
+c     reads histogram data arrays created by ~/spectral/his.for 
+c     malv   nov-98    add average distance between lines for overlapp
+                                                
+c     *******************************************************************   
+                                                
+                                                
+      implicit none                                  
+                                                
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+      include 'datafile.h'
+                                                
+c arguments                                     
+      real            factor_comp                    
+                                                
+c local variables                               
+      integer 	j, r                                  
+      real*8          sk1_aux, xls1_aux, xln1_aux, xld1_aux,weight,nu0      
+      character       tonto*50
+
+c formats                                       
+!  100 	format(80a1)         ! Esto es si fuese       byte   dummy(80)
+ 100  format(a80)               ! Esto es si fuese       character dummy*80
+ 150  format(a50)               ! Esto es si fuese       character dummy*80
+                                                
+c     ***************                               
+
+      open(unit=3,
+     $     file=trim(datafile)//'/NLTEDAT/'
+     $     //hisfile(1:len_trim(hisfile)),status='old')
+	!read(3,100) dummy                              
+      read(3,150) tonto                              
+      read(3,*) weight                               
+      read(3,*) mm                                   
+      read(3,*) nu0                                  
+      read(3,*) nbox                                 
+	!read(3,'(a)') dumm                           
+      read(3,'(a)') tonto   
+                        
+      if ( nbox .gt. nbox_max ) then 
+         write (*,*) ' nbox too large in input file ', hisfile
+         stop ' Check maximum number nbox_max in mz1d.par '
+      endif
+      do 1 j=1,mm               ! for each temperature           
+         read(3,*) thist(j)   
+         do r=1,nbox            ! for each box        
+            read(3,*) no(r), sk1(j,r), xls1(j,r),xln1(j,r),xld1(j,r),
+     @           dist(r)                                      
+c	    xld1(j,r)=xld1(j,r)*0.83255  !0.83255=sqrt(log(2))    
+         enddo                                        
+ 1    continue                                     
+      tmax=thist(1)                                  
+      tmin=thist(mm)                                 
+                                                
+	!close(unit=3,dispose='save')                   
+      close(unit=3)                   
+                                                
+	                                               
+      do 2 j=1,mm                                   
+         do r=1,nbox                                 
+            sk1(j,r) = sk1(j,r) * factor_comp         
+         enddo                                       
+ 2    continue                                      
+                                                
+                                                
+      return                                         
+      end
+
+
+
+      
+c***********************************************************************
+      subroutine leetvt                              
+                                                
+c     reads input vibr. temps. from external files or sets lte values      
+c     according to the driver table                 
+
+c     jul 2011 malv+fgg   adapted to LMD-MGCM
+c     malv    Jan 07          Add new vertical fine-grid for NLTE
+c     jan 98 	malv		based on solar10sub            
+c***********************************************************************
+                                                
+      implicit none                                  
+                                                
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+                                                
+c local variables                               
+      integer i                                      
+      real*8	zld(nl), zyd(nzy)
+      real*8 xvt11(nzy), xvt21(nzy), xvt31(nzy), xvt41(nzy)
+                                                
+c***********************************************************************
+                                                
+      do i=1,nzy                                   
+         zyd(i) = dble(zy(i))                          
+         xvt11(i)= dble( ty(i) )                     
+         xvt21(i)= dble( ty(i) )                     
+         xvt31(i)= dble( ty(i) )                     
+         xvt41(i)= dble( ty(i) )                     
+      end do		                             
+                                                
+                                                
+c interpolate to the nlte subgrid               
+                                                
+      do i=1,nl                                      
+         zld(i) = dble( zl(i) )                     
+      enddo                                             
+      call interdp ( v626t1,zld,nl, xvt11,zyd,nzy, 1) 
+      call interdp ( v628t1,zld,nl, xvt21,zyd,nzy, 1)      
+      call interdp ( v636t1,zld,nl, xvt31,zyd,nzy, 1)      
+      call interdp ( v627t1,zld,nl, xvt41,zyd,nzy, 1)      
+
+
+c end                                           
+      return                                         
+      end 
+
+
+
+c***********************************************************************
+                                                
+      subroutine getk (tt)                           
+                                                
+c     jan 98	malv 		version for mz1d. copied from solar10/getk.f
+c     jul 2011 malv+fgg       adapted to LMD-MGCM
+c***********************************************************************
+	                                               
+      implicit none                                  
+                                                
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+                                                
+c arguments 	                                   
+      real 		tt	! i. temperature                     
+                                                
+!! local variables:                             
+      real*8 k1x, k7x,k7xa,k7xb
+      real*8 k3x, k3xaa,k3xac,k3xab,k3xbb,k3xba,k3xbc    
+      real*8 k3xco2,k3xn2,k3xco, k6x,k6x1,k6x2
+      real*8 k20x,k20xa,k20xb,k20xc       
+      real*8 k19xca,k19xcb,k19xcc
+      real*8 k19xba,k19xbb,k19xbc
+      real*8 k19xaa,k19xab,k19xac  
+      real*8 k21x,k21xa,k21xb,k21xc                  
+      real*8 anu, factor , k21xa_626               
+      real tt1,tt2, de                             
+      integer 	i                                     
+                                                
+c***********************************************************************
+                                                
+co2i(001) + n2 ---> co2i + n2(1)     k1     (not considered in the model
+c k1(i)  i = 1 --- 626	                         
+!	     2 --- 636                                
+!	     3 --- 628                                
+!	     4 --- 627                                
+                                                
+!     k1x = 5.d-13 * sqrt(300.d0/tt)                
+!     do i=1,nisot                                  
+!     k1(i) = k1x * rf1                            
+!     k1p(i) = k1(i) * exp( -ee/tt *1.d0* (-nun2+nu(i,4)) )    
+!     end do                                        
+                                                
+co2(001) + co2i ---> co2 + co2i(001)	k2   (vv1 in table 4, paper i)     
+c     k2i	i = x --- 628                            
+!     y --- 636                                 
+!     z --- 627                                 
+		                                              
+      k2a = 6.8d-12 * sqrt(tt)  ! delta(e)< 42 cm-1 
+      k2b = 3.6d-11 * sqrt(tt) * exp(-65.6557/26.3) ! > 42 cm-1 see table 3
+      k2a = k2a * rf2desac                           
+      k2b = k2b * rf2desac                           
+                                                
+      k2x = 6.8d-12 * sqrt(tt)                       
+      k2y = 3.6d-11 * sqrt(tt) * exp(-65.6557/26.3)  
+      k2z = 6.8d-12 * sqrt(tt)                       
+      k2x = k2x * rf2iso 	                           
+      k2y = k2y * rf2iso 	                           
+      k2z = k2z * rf2iso 	                           
+      k2xp = k2x * exp( dble( -ee/tt * (nu(1,4)-nu(2,4)) ) )     
+      k2yp = k2y * exp( dble( -ee/tt * (nu(1,4)-nu(3,4)) ) )     
+      k2zp = k2z * exp( dble( -ee/tt * (nu(1,4)-nu(4,4)) ) )     
+                                                
+! these are vt1 in table 3, paper i             
+co2i(001) + m ---> co2i(0v0) + m	k3             
+co2i(001) + o3p ---> co2i(0v0) + o3p 	k7        
+c  k3vm(i)  m = a --- co2       v = a --- 3     i = 1,2,3,4 
+!	        b --- n2,o2	    b --- 2		             
+!	        c --- co 	    		                      
+c  k7v(i)  v = a --- 3  	i = 1,2,3,4            
+!	       b --- 2		                              
+                                                
+      k7x = 2.0d-13*sqrt(tt/300.d0)                  
+      k7x = k7x * rf7                                
+                                                
+      if (iopt3.eq.0) then                           
+                                                
+         k3x = 2.2d-15 + 1.14d-10 * exp( dble(-76.75/tt**(1.d0/3.d0)) )      
+         k3xaa = 3.0d-15 + 1.72d-10 * exp( dble(-76.75/tt**(1.d0/3.d0)))  
+         k3xac = 2.2d-15 + 9.66d-11 * exp( dble(-76.75/tt**(1.d0/3.d0)))  
+         k3x = k3x * rf3                              
+         k3xaa = k3xaa * rf3                          
+         k3xac = k3xac * rf3                          
+                                                
+         tt1=220.0              !500.0  !220.0                    
+         tt2=250.0              !250.0                            
+         if(tt.le.tt1)then                            
+	    k3xab = k3x                                
+	    k3xbb = 0.d0                               
+	    k7xa=k7x                                   
+	    k7xb=0.d0                                  
+         else if(tt.gt.tt2)then                       
+	    k3xab = 0.d0                               
+	    k3xbb = k3x                                
+	    k7xa=0.d0                                  
+	    k7xb=k7x                                   
+         else                                         
+	    k3xab = k3x/30.d0*(tt2-tt)                 
+	    k3xbb = k3x/30.d0*(tt-tt1)                 
+	    k7xa=k7x/30.d0*(tt2-tt)                    
+	    k7xb=k7x/30.d0*(tt-tt1)                    
+         end if                                       
+         k3xba = k3xbb                                
+         k3xbc = k3xbb                                
+                                                
+      elseif (iopt3.gt.0) then 	! bauer et. al., 1987            
+                                                
+         if (tt.ge.190. .and. tt.le.250.) then        
+	    factor = 0.9d0 + dble( (0.1-0.9)/(250.-190.) * (tt-190.) )         
+         elseif (tt.lt.190.) then                     
+	    factor = 0.9d0                             
+         elseif (tt.gt.250.) then                     
+	    factor = 0.1d0                             
+         end if                                       
+         
+         k3xn2 = 2.2d-15 + 1.14d-10 * exp(dble( -76.75/tt**(1.d0/3.d0)))     
+         k3xn2 = k3xn2 * rf3                          
+         k3xab = k3xn2 * factor                       
+         k3xbb = k3xn2 * (1.-factor)                  
+         
+         k7xa = k7x * factor                          
+         k7xb = k7x * (1.-factor)                     
+                                                
+         if (iopt3.eq.1) then 	                       
+                                                
+	    if (tt.le.148.8) then                      
+               k3xco2 = 13.8 - 0.1807 * (tt-140.)       
+	    elseif (tt.ge.148.8 .and. tt.le.159.6) then            
+               k3xco2 = 12.21 - 0.1787 * (tt-148.8)     
+	    elseif (tt.ge.159.6 .and. tt.le.171.0) then            
+               k3xco2 = 10.28 - 0.04035 * (tt-159.6)    
+	    elseif (tt.ge.171.0 .and. tt.le.186.4) then            
+               k3xco2 = 9.82 - 0.027273 * (tt-171.0)    
+	    elseif (tt.ge.186.4 .and. tt.le.244.1) then            
+               k3xco2 = 9.4 + 0.002253 * (tt-186.4)     
+	    elseif (tt.ge.244.1 .and. tt.le.300) then  
+               k3xco2 = 9.53 + 0.02129 * (tt-244.1)     
+	    elseif (tt.ge.300 .and. tt.le.336.1) then  
+               k3xco2 = 10.72 + 0.052632 * (tt-300)     
+	    elseif (tt.ge.336.1 .and. tt.le.397.0) then            
+               k3xco2 = 12.62 + 0.0844 * (tt-336.1)     
+	    elseif (tt.ge.397.0 .and. tt.le.523.4) then            
+               k3xco2 = 17.76 + 0.2615 * (tt-397.)      
+	    end if                                     
+	    k3xco2 = k3xco2 * 1.d-15 * rf3             
+	    k3xaa = 0.82d0 * k3xco2                    
+	    k3xba = 0.18d0 * k3xco2                    
+                                                
+	    if (tt.le.163.) then                       
+               k3xco = 10.58 - 0.093 * (tt-140)         
+	    elseif (tt.ge.163. .and. tt.le.180.) then  
+               k3xco = 8.44 - 0.05353 * (tt-163.)       
+	    elseif (tt.ge.180. .and. tt.le.196.) then  
+               k3xco = 7.53 - 0.034375 * (tt-180.)      
+	    elseif (tt.ge.196. .and. tt.le.248.) then  
+               k3xco = 6.98 - 0.0108 * (tt-196.)        
+	    elseif (tt.ge.248. .and. tt.le.301.) then  
+               k3xco = 6.42 + 0.01415 * (tt-248.)       
+	    elseif (tt.ge.301. .and. tt.le.353.) then  
+               k3xco = 7.17 + 0.02865 * (tt-301.)       
+	    end if                                     
+	    k3xac = k3xco * 1.d-15 * rf3               
+	    k3xbc = 0.d0                               
+                                                
+         elseif (iopt3.eq.2) then ! revision for the papers (feb 93)
+                                                
+	    k3xco2 = 7.3d-14 * exp( -850.3/tt + 86523/tt**2.d0 )   
+	    k3xco2 = k3xco2 * rf3                      
+ 	    k3xaa = 0.82d0 * k3xco2                   
+	    k3xba = 0.18d0 * k3xco2                    
+            
+	    k3xco = 1.7d-14 * exp( -448.3/tt + 53636/tt**2.d0 )    
+	    k3xac = k3xco * rf3                        
+	    k3xbc = 0.d0                               
+                                                
+         end if                                       
+                                                
+      end if                                         
+                                                
+      do i=1,nisot                                   
+         k3aa(i) = k3xaa                              
+         k3ba(i) = k3xba                              
+         k3ab(i) = k3xab                              
+         k3bb(i) = k3xbb                              
+         k3ac(i) = k3xac                              
+         k3bc(i) = k3xbc                              
+         anu = nu(i,4)-nu(i,3)                        
+!     anu = nu(i,4)-nu(i,3)+70                    
+         k3aap(i) = k3aa(i) * exp( -ee/tt * anu )/6.d0            
+         k3abp(i) = k3ab(i) * exp( -ee/tt * anu )/6.d0            
+         k3acp(i) = k3ac(i) * exp( -ee/tt * anu )/6.d0            
+         anu = nu(i,4)-nu(i,2)                        
+!     anu = nu(i,4)-nu(i,2)+40                    
+         k3bap(i) = k3ba(i) * exp( -ee/tt * anu )/4.d0            
+         k3bbp(i) = k3bb(i) * exp( -ee/tt * anu )/4.d0            
+         k3bcp(i) = k3bc(i) * exp( -ee/tt * anu )/4.d0            
+         
+         k7a(i) = k7xa                              
+         k7b(i) = k7xb                                
+         k7ap(i) = k7a(i) * exp(dble( -ee/tt*(nu(i,4)-nu(i,3)) ))/6.d0        
+         k7bp(i) = k7b(i) * exp(dble( -ee/tt*(nu(i,4)-nu(i,2)) ))/4.d0        
+      end do                                         
+                                                
+                                                
+! the next ones correspond to vv2 in table 4, paper i       
+co2i(001) + co2 ---> co2i(020) + co2(010)	k6    
+! k6(i)  i = 1,2,3,4                            
+! we need a new index for the inverse rates due to both fractions :     
+c  k6a(i) i=2,3,4      co2i(001) + co2 ---> co2i(020) + co2(010)        
+c  k6b(i)    "          co2i(001) + co2 ---> co2i(010) + co2(020)       
+                                                
+      if (iopt6.eq.1) then                           
+         
+         if(tt.le.175.d0)then                         
+	    k6x=8.6d-15                                
+         elseif(tt.gt.175.0.and.tt.le.200.d0)then     
+	    k6x=8.6d-15+9.d-16*(175.d0-tt)/25.d0       
+         elseif(tt.gt.200.0.and.tt.le.225.d0)then     
+	    k6x=7.7d-15+5.d-16*(200.d0-tt)/25.d0       
+         elseif(tt.gt.225.0.and.tt.le.250.d0)then     
+	    k6x=7.20d-15+6.d-16*(tt-225.d0)/25.d0      
+         elseif(tt.gt.250.0.and.tt.le.275.d0)then     
+	    k6x=7.80d-15+1.d-15*(tt-250.d0)/25.d0      
+         elseif(tt.gt.275.0.and.tt.le.300.d0)then     
+	    k6x=8.80d-15+1.3d-15*(tt-275.d0)/25.d0     
+         elseif(tt.gt.300.0.and.tt.le.325.d0)then     
+	    k6x=10.1d-15+1.54d-15*(tt-300.d0)/25.d0    
+         elseif(tt.gt.325.0)then                      
+            k6x=11.6d-15                        
+         end if                                       
+                                                
+      elseif (iopt6.eq.2) then                       
+                                                
+         k6x = 3.6d-13 * exp( -1660/tt + 176948/tt**2.d0 ) 
+         if (tt.lt.175) k6x = 8.8d-15                 
+         
+      end if                                         
+                                                
+      k6x1 = k6x * rf6 * frac6                       
+      k6x2 = k6x * rf6 * (1.-frac6)                  
+      
+      k6 = k6x * rf6                                 
+      k6p = k6 / 8.d0 * exp(dble( -ee/tt * (nu(1,4)-nu(1,2)-nu(1,1)) ))      
+      do i=2,nisot                                   
+         k6a(i) = k6x1                                
+         k6b(i) = k6x2                                
+         anu = nu(i,4)-nu(i,2)-nu(1,1)                
+         k6ap(i) = k6a(i) / 8.d0 * exp(dble( -ee*anu/tt ))        
+         anu = nu(i,4)-nu(i,1)-nu(1,2)                
+         k6bp(i) = k6b(i) / 8.d0 * exp(dble( -ee*anu/tt ))        
+      end do                                         
+                                                
+                                                
+co2i(0v0) + co2i ---> co2i(0v-10) + co2i(010)   
+c  k5 		esta reaccion es desdenable frente a co2 como colisionante. 
+!	  k5=3.0d-15+6.0d-17*(tt-210.d0)              
+!	  k5=k5*rf5                                   
+!	  k5p=k5/2.d0*exp(-ee*125.77/tt)              
+                                                
+                                                
+co2i(0v0) + m ---> co2i(0v-10) + m	k19     (vt2,k5,k6 in table 3, paper 
+co2i(0v0) + o3p ---> co2i(0v-10) + o3p	k20     (vt2,k7 in table 3, paper
+c  k19vm(i)  m = a --- co2	v = a --- 3   i=1,2,3,4          
+!	       b --- n2		    b --- 2		                
+!	       c --- co		    c --- 1		                
+c  k20v(i)  v = a --- 3		i = 1,2,3,4            
+!	        b --- 2		                             
+!	        c --- 1		                             
+!                                               
+!     k20x=1.9d-8*exp(-76.75/(tt**(1.d0/3.d0))) ! taylor,74 reajusted     
+!     k20x=2.32d-9*exp(-76.75/(tt**(1./3.)))+1.0d-14*sqrt(tt) ! k&j, 83   
+!     k20x = 1.43d-12*(tt/300.d0)	! shved et al, 90           
+                                                
+      if (iopt20.eq.1) then     ! first version of pap1         
+         k20x=2.32d-9*exp(-76.75/(tt**(1./3.)))+3.5d-13*sqrt(tt) ! s&w, 91    
+         k20xb = k20x / 2.d0 * rf20                   
+         k20xc = k20xb                                
+         k20xa = 3.d0/2.d0 * k20xb                    
+      elseif(iopt20.eq.2) then  ! revision for the papers in feb 93          
+         k20x=3.d-12            ! minimum value of lopez-puertas et al., 92  
+         k20xc = k20x * rf20                          
+         k20xb = 2.d0 * k20xc                         
+         k20xa = 3.d0/2.d0 * k20xb                    
+      elseif(iopt20.eq.3) then  ! values from boug & roble '91   
+         k20x=1.d-12/sqrt(300.) * sqrt(tt)             
+         k20xc = k20x * rf20                          
+         k20xb = 2.d0 * k20xc                         
+         k20xa = 3.d0/2.d0 * k20xb                    
+      elseif(iopt20.eq.4) then  ! values from boug & dick '88  case b        
+         k20x=7.d-13                                   
+         k20xc = k20x * rf20                          
+         k20xb = 2.d0 * k20xc                         
+         k20xa = 3.d0/2.d0 * k20xb                    
+      elseif(iopt20.eq.5) then  ! values from s.bougher (oct-98) 
+         k20x = 1.732d-13 * sqrt(tt) ! 1/sqrt(300) * sqrt(t)    
+         k20xc = k20x * rf20                          
+         k20xb = 2.d0 * k20xc                         
+         k20xa = 3.d0/2.d0 * k20xb                    
+      end if                                         
+      
+      if (iopt19.eq.0) then                          
+         
+         k19xca = 4.64d-10 * exp(dble(  - 74.75 / tt**(1.d0/3.d0) ))          
+         k19xcb = 6.69d-10 * exp(dble(  - 84.07 / tt**(1.d0/3.d0) ))          
+         k19xcc = k19xcb                              
+         
+         if ( tt.le.250 ) then                        
+            k19xba = 181.25d0                             
+         elseif ( tt.ge.310 ) then                    
+            k19xba = 200.d0 + 0.9d0 * ( tt - 310.d0 )     
+         else                                         
+            k19xba = 181.25d0 + 0.3125d0 * ( tt - 250.d0 )            
+         end if                                       
+         k19xba = k19xba * 1.03558d-19 * tt ! cm-1 s-1            
+         k19xbb = 1.24d-14 * ( tt / 273.3d0 )**2.d0 ! taine & lepoutre 1979
+         k19xbc = k19xbb                              
+         
+         k19xaa = 3.d0/2.d0 * k19xba                  
+         k19xab = 3.d0/2.d0 * k19xbb                  
+         k19xac = 3.d0/2.d0 * k19xbc                  
+         
+         k19xaa = k19xaa * rf19                       
+         k19xab = k19xab * rf19                       
+         k19xac = k19xac * rf19                       
+         k19xba = k19xba * rf19                       
+         k19xbb = k19xbb * rf19                       
+         k19xbc = k19xbc * rf19                       
+         k19xca = k19xca * rf19                       
+         k19xcb = k19xcb * rf19                       
+         k19xcc = k19xcc * rf19                       
+         
+      elseif (iopt19.ge.1) then 		                   
+         
+         if (iopt19.eq.1) then 	! lunt et. al., 1985 (thesis values)
+            
+	    if (tt.le.175.) then                       
+               k19xca = 4.d0 - 0.02d0 * (tt-140.d0)     
+               k19xcb = 0.494d0 + 0.0076 * (tt-140.d0)	 
+	    elseif (tt.ge.175. .and. tt.le.200.) then  
+               k19xca = 3.3d0 - 0.02d0 * (tt-175.)      
+               k19xcb = 0.76d0 + 0.0076d0 * (tt-175.d0)	            
+	    elseif (tt.ge.200. .and. tt.le.225.) then  
+               k19xca = 2.8d0 + 0.004d0 * (tt-200.d0)   
+               k19xcb = 0.95d0 + 0.014d0 * (tt-200.d0)	 
+	    elseif (tt.ge.225. .and. tt.le.250.) then  
+               k19xca = 2.9d0 + 0.024d0 * (tt-225.d0)   
+               k19xcb = 1.3d0 + 0.016d0 * (tt-225.d0)	  
+	    elseif (tt.ge.250. .and. tt.le.275.) then  
+               k19xca = 3.5d0 + 0.04d0 * (tt-250.d0)    
+               k19xcb = 1.7d0 + 0.032d0 * (tt-250.d0)	  
+	    elseif (tt.ge.275. .and. tt.le.295.) then  
+               k19xca = 4.5d0 + 0.055d0 * (tt-275.d0)   
+               k19xcb = 2.5d0 + 0.045d0 * (tt-275.d0)	  
+	    elseif (tt.ge.295. .and. tt.le.320.) then  
+               k19xca = 5.6d0 + 0.54d0 * (tt-295.d0)    
+               k19xcb = 3.4d0 + 0.045d0 * (tt-295.d0)	  
+	    end if                                     
+	    k19xca = k19xca * 1.d-15 * rf19            
+	    k19xcb = k19xcb * 1.d-15 * rf19            
+	    k19xcc = k19xcb                            
+            
+         elseif (iopt19.eq.2) then ! revision for the papers, feb 1993
+                                                
+!     k19xca = 7.3d-14 * exp( -850.3d0/tt + 86523.d0/tt**2.d0 )         
+	    k19xca = 4.2d-12 * exp( -2988.d0/tt + 303930.d0/tt**2.d0 )         
+	    if (tt.le.175.) k19xca = 3.3d-15           
+	    k19xcb = 2.1d-12 * exp( -2659.d0/tt + 223052.d0/tt**2.d0 ) 	       
+	    if (tt.le.175.) k19xcb = 7.6d-16           
+	    k19xca = k19xca * rf19                     
+	    k19xcb = k19xcb * rf19                     
+	    k19xcc = k19xcb                            
+                                                
+         elseif (iopt19.eq.3) then ! values from dick'72 for k19xc
+					! k19xcb is not modified     
+	    if (tt.le.158.) then                       
+               k19xca = 0.724d-15                            
+	    elseif (tt.le.190.) then                   
+               k19xca = 0.724d-15 +                          
+     @              (1.1d-15-0.724d-15) * (tt-158.) / (190.-158.)  
+	    elseif (tt.le.250.) then                   
+               k19xca = 1.1d-15 +                            
+     @              (3.45d-15-1.1d-15) * (tt-190.) / (250.-190.) 
+ 	    elseif (tt.gt.250.) then                  
+               k19xca = 3.45d-15                      
+	    end if                                     
+	    k19xcb = 2.1d-12 * exp( -2659.d0/tt + 223052.d0/tt**2.d0 ) 	       
+	    if (tt.le.175.) k19xcb = 7.6d-16           
+	    k19xca = k19xca * rf19                     
+	    k19xcb = k19xcb * rf19                     
+	    k19xcc = k19xcb                            
+            
+         elseif (iopt19.eq.5) then 	                  
+                                                
+	    k19xca = 5.2d-15    ! s.bougher, nov-98        
+	    k19xcb = 7.6d-16    ! nuestro, de feb-93       
+	    k19xcc = k19xcb                            
+            
+	    k19xca = k19xca * rf19                     
+	    k19xcb = k19xcb * rf19                     
+                                                
+         end if                                       
+                                                
+         factor = 2.5d0                               
+         k19xba = factor * k19xca                     
+         k19xbb = factor * k19xcb                     
+         k19xbc = factor * k19xcc                     
+         factor = 3.d0/2.d0                           
+         k19xaa = factor * k19xba                     
+         k19xab = factor * k19xbb                     
+         k19xac = factor * k19xbc                     
+                                                
+      end if                                         
+                                                
+      do i = 1, nisot                                
+         
+         k19aa(i) = k19xaa                            
+         k19ba(i) = k19xba                            
+         k19ca(i) = k19xca                            
+         k19ab(i) = k19xab                            
+         k19bb(i) = k19xbb                            
+         k19cb(i) = k19xcb                            
+         k19ac(i) = k19xac                            
+         k19bc(i) = k19xbc                            
+         k19cc(i) = k19xcc                            
+         anu = nu(i,3)-nu(i,2)                        
+         k19aap(i) = k19aa(i) * 6.d0/4.d0 * exp(dble( -ee*anu/tt))            
+         k19abp(i) = k19ab(i) * 6.d0/4.d0 * exp(dble( -ee*anu/tt))            
+         k19acp(i) = k19ac(i) * 6.d0/4.d0 * exp(dble( -ee*anu/tt))            
+         anu = nu(i,2)-nu(i,1)                        
+         k19bap(i) = k19ba(i) * 2.d0 * exp(dble( -ee*anu/tt))     
+         k19bbp(i) = k19bb(i) * 2.d0 * exp(dble( -ee*anu/tt))     
+         k19bcp(i) = k19bc(i) * 2.d0 * exp(dble( -ee*anu/tt))     
+         anu = nu(i,1)                                
+         k19cap(i) = k19ca(i) * 2.d0 * exp(dble( -ee*anu/tt))     
+         k19cbp(i) = k19cb(i) * 2.d0 * exp(dble( -ee*anu/tt))     
+         k19ccp(i) = k19cc(i) * 2.d0 * exp(dble( -ee*anu/tt))     
+         
+         k20a(i) = k20xa                              
+         k20b(i) = k20xb                              
+         k20c(i) = k20xc                              
+         k20ap(i) = k20a(i)*6.d0/4.d0 * 
+     @        exp(dble( -ee/tt * (nu(i,3)-nu(i,2)) )) 
+         k20bp(i) = k20b(i)*4.d0/2.d0 *
+     @        exp(dble( -ee/tt * (nu(i,2)-nu(i,1)) )) 
+         k20cp(i) = k20c(i)*2.d0/1.d0 *
+     @        exp(dble( -ee/tt * nu(i,1) ))           
+      end do                                         
+                                                
+!     write(1,*) tt,k19cap(1),k19ac(1)              
+                                                
+! the next ones correspond to vv3 in table 4 (paper i)      
+co2i(0v0) + co2 ---> co2i(0v-10) + co2(010)	k21	also see k33 
+c  k21v(i)  v = a --- 3		i = 1,2,3,4            
+!	        b --- 2		                             
+!	        c --- 1		                             
+! we need a new index for the 030i rates due to both fractions :        
+c  k21a1       co2i(030) + co2 ---> co2i(020) + co2(010)    
+c  k21a2       co2i(030) + co2 ---> co2i(010) + co2(020)    
+co2i(010) + co2j(000) ---> co2i(000) + co2j(010)   kijk21c  see pag.22-s
+!  k23k21c   i=628,j=636                        
+!  k24k21c   i=628,j=627                        
+!  k34k21c   i=636,j=627                        
+                                                
+      if (iopt21.eq.0) then                          
+         k21x = 1.2d-11      	                        
+         k21xb = k21x                                 
+         k21xa = 3.d0/2.d0 * k21x                     
+         k21xc = k21x           ! esta ultima no se usa con 626   
+      elseif (iopt21.eq.1) then 	                    
+         k21x = 2.49d-11        ! orr & smith, 1987         
+         k21xb = k21x      	                          
+         k21xa = 3.d0/2.d0 * k21xb ! oscilador armonico          
+         k21xc = k21xb / 2.d0   ! novedad mia          
+      elseif (iopt21.eq.2) then 	                    
+         k21x = 100.d0*k19xca   ! dickinson'76 (icarus)            
+         k21xb = k21x      	                          
+         k21xa = 3.d0/2.d0 * k21xb ! oscilador armonico          
+         k21xc = k21xb / 2.d0   ! novedad mia          
+      end if                                         
+      k21xa_626 = k21xa * rf21a !* 0.01d0  !* 10.d0	          
+      k21xa = k21xa * rf21a     !* 0.01d0         
+      k21xb = k21xb * rf21b                          
+      k21xc = k21xc * rf21c                          
+      
+      k21a = k21xa_626                               
+      k21ap = k21a * 6.d0/8.d0 *                     
+     @     exp( dble( -ee/tt * (nu(1,3)-nu(1,2)-nu(1,1)) ) )        
+      do i = 2, nisot                                
+         k21a1(i) = k21xa * frac21                    
+         k21a2(i) = k21xa * (1.d0-frac21)             
+         k21a1p(i) = k21a1(i) * 6.d0/8.d0 *           
+     @        exp(dble(  -ee/tt* (nu(i,3)-nu(i,2)-nu(1,1)) ))          
+         k21a2p(i) = k21a2(i) * 6.d0/8.d0 *           
+     @        exp(dble(  -ee/tt* (nu(i,3)-nu(i,1)-nu(1,2)) ))          
+      end do                                         
+      
+      
+      do i = 1, nisot                                
+	 k21b(i) = k21xb                               
+	 k21c(i) = k21xc                               
+	 k21bp(i) = k21b(i) * 
+     @        exp(dble( -ee/tt* (nu(i,2)-nu(i,1)-nu(1,1)) ))   
+	 k21cp(i) = k21c(i) * 
+     @        exp(dble( -ee/tt * (nu(i,1)-nu(1,1)) ))          
+      end do                                         
+      
+      k23k21c = k21xc                                
+      k24k21c = k21xc                                
+      k34k21c = k21xc                                
+      k23k21cp = k23k21c*2.d0/2.d0 * 
+     @     exp(dble( -ee/tt* (nu(2,1)-nu(3,1)) ))  
+      k24k21cp = k24k21c*2.d0/2.d0 * 
+     @     exp(dble( -ee/tt* (nu(2,1)-nu(4,1)) ))  
+      k34k21cp = k34k21c*2.d0/2.d0 * 
+     @     exp(dble( -ee/tt* (nu(3,1)-nu(4,1)) ))  
+      
+!     these are also vv3 in table 4, paper i         
+c     k31 & k32	                                   
+      
+      k31 = k21x * rf31         ! we're suposing thar the rate for the deactivation  
+                                ! v-v from high combinational levels is the same
+      k32 = k21x * rf32         ! that the one for :  (020) --> (010) + (010)        
+      
+c     o2(***) + co2i ---> co2(***) + co2i(***)	k33   
+c     k33a1 :   co2(001) + co2i ---> co2(020) + co2i(010)    (vv2, table 4, 
+!     a2 :   co2(001) + co2i ---> co2(010) + co2i(020)      "            
+!     b1 :   co2(030) + co2i ---> co2(020) + co2i(010)    (vv3, table 4, 
+!     b2 :   co2(030) + co2i ---> co2(010) + co2i(020)      "            
+!     c :   co2(020) + co2i ---> co2(010) + co2i(010)       "            
+!     we have to add an index to the inverse rates, depending on the isotope
+      
+      k33c = k21x * rf33bc                           
+      k33b1 = 3.d0/3.d0 * k33c * frac33              
+      k33b2 = 3.d0/3.d0 * k33c * (1.d0-frac33)       
+      k33a1 = k6x * rf33a * frac33                   
+      k33a2 = k6x * rf33a * (1.d0-frac33)            
+      
+      do i=2,nisot                                   
+	 k33a1p(i)=k33a1*                              
+     @        1.d0/8.d0*exp(dble( -ee/tt* (nu(1,4)-nu(1,2)-nu(i,1)) )) 
+	 k33a2p(i)=k33a2*                              
+     @        1.d0/8.d0*exp(dble( -ee/tt* (nu(1,4)-nu(1,1)-nu(i,2)) )) 
+	 k33b1p(i)=k33b1*                              
+     @        6.d0/8.d0*exp(dble( -ee/tt* (nu(1,3)-nu(1,2)-nu(i,1)) )) 
+	 k33b2p(i)=k33b2*                              
+     @        6.d0/8.d0*exp(dble( -ee/tt* (nu(1,4)-nu(1,1)-nu(i,2)) )) 
+	 k33cp(i) =k33c * exp(dble( -ee/tt * (nu(1,2)-nu(1,1)-nu(i,1)) ))      
+      end do                                         
+                                                
+! here they are the vt3 in table 3, paper i     
+co2(2.7um) + m ---> co2(2.7um) + m	k27          
+c k27a :    n8 + m ---> n6 + m                  
+!    b :    n7 + m ---> n6 + m                  
+!    c :    n8 + m ---> n7 + m                  
+                                                
+      if (iopt27.eq.0) then	                         
+         k27a = 3.d-11          !between fermi levels          
+         k27b = 3.d-13          !between side levels         
+         k27c = 2.d0 * k27b     !between side levels      
+      elseif (iopt27.ge.1) then ! orr & smith, 1987            
+         k27a = 1.55d-12                              
+         k27c = 4.97d-12                              
+         k27b = k27c                                  
+      end if                                         
+      k27a = k27a * rf27f                            
+      k27b = k27b * rf27s                            
+      k27c = k27c * rf27s                            
+      
+      k27ap = k27a * exp(dble( -ee/tt * (nu(1,8)-nu(1,6)) ))     
+      k27bp = k27b * exp(dble( -ee/tt * (nu(1,7)-nu(1,6)) ))     
+      k27cp = k27c * exp(dble( -ee/tt * (nu(1,8)-nu(1,7)) ))     
+                                                
+                                                
+!     the next two are not used in the model:       
+                                                
+c     k28 :    n* + n2 ---> n*low + n2(1)           
+!     k28v   v = a --- n8                           
+!		   b --- n7                                  
+!	           c --- n6                           
+!     k28a = 5.d-13 * sqrt(300.d0/tt) * rf28 	! = k1            
+!     k28b = k28a                                   
+!     k28c = k28a                                   
+!     k28ap = k28a * exp( -ee/tt * (nu(1,8)-1388.1847-nun2) )   
+!     k28bp = k28b * exp( -ee/tt * (nu(1,7)-1335.1317-nun2) )   
+!     k28cp = k28c * exp( -ee/tt * (nu(1,6)-1285.4087-nun2) )   
+                                                
+c     k29 :    n* + co ---> n*low + co(1)           
+!     k29v   v = a --- n8                           
+!     b --- n7                                  
+!	           c --- n6                           
+	                                               
+c     k29a = ?????????? * rf29                      
+c     k29b = k29a                                   
+c     k29c = k29a                                   
+      
+c     k29ap = k29a * exp( -ee/tt * (nu(1,8)-1388.1847-nuco) )   
+c     k29bp = k29b * exp( -ee/tt * (nu(1,7)-1335.1317-nuco) )   
+c     k29cp = k29c * exp( -ee/tt * (nu(1,6)-1285.4087-nuco) )   
+                                                
+                                                
+! these are also vv1 processes in table 4, paper i          
+c k26 :                                         
+! 1. deactivation of the 626 isotope:           
+!	reaction: n* + co2i ---> n*low + co2i(001)  ; i=1-4       
+!	nomenclature: k26v   ;  v=a,b,c,d  for n8,n7,n6,n5  respectively      
+!	inverse rates: k26vp(i) ; i=1-4               
+! 2. deactivation of the minor isotopes:        
+!	reaction: n*_i + co2j ---> n*_i_low + (001)_j  ; i=2-4 ; j=1-4        
+!	nomenclature:  k26vij ;  v=a,c,d  for n8,n6,n5 respectively           
+!	inverse rates: k26vijp                        
+! 3. notes:                                     
+!   a * it is clear that :  k26vij=/=k26vjip,   
+!   b * at the moment we do not include inverse rates for the case 2., o
+!	   the deactivation of the main isotope (pg. 32b, sn1).   
+!   c * not 0221 level for minor isotopes is considered.    
+!   d * only a value is known for these rates, so all of the deactivatio
+! 	   the same, but not the inverse rates.      
+!   e * although all the direct deactivation constants have the same val
+!          it is useful to distinguish between them with the present nam
+                                                
+      k26a = 6.8d-12 * sqrt(tt) * rf26 ! = k2       
+      k26b = k26a                                    
+      k26c = k26a                                    
+      if (iopt26.eq.0 .or. iopt26.eq.2) then         
+         k26d = k26a                                  
+      elseif( iopt26.eq.1) then                      
+         k26d = 1.15d-10 * rf26                       
+      end if                                         
+      
+      do i=1,4                                       
+         k26ap(i) = k26a * 
+     @        exp(dble( -ee/tt * (nu(1,8)-nu12_1000-nu(i,4)) ))  
+         k26bp(i) = k26b * 
+     @        exp(dble( -ee/tt * (nu(1,7)- nu(1,2) -nu(i,4)) ))  
+         k26cp(i) = k26c * 
+     @        exp(dble( -ee/tt * (nu(1,6)-nu12_0200-nu(i,4)) ))  
+         k26dp(i) = k26d * 
+     @        exp(dble( -ee/tt * (nu(1,5)- nu(1,1) -nu(i,4)) ))  
+      end do                                         
+                                                
+      k26a21 = k26a                                  
+      k26c21 = k26c                                  
+      k26d21 = k26d                                  
+      k26a22 = k26a                                  
+      k26c22 = k26c                                  
+      k26d22 = k26d                                  
+      k26a23 = k26a                                  
+      k26c23 = k26c                                  
+      k26d23 = k26d                                  
+      k26a24 = k26a                                  
+      k26c24 = k26c                                  
+      k26d24 = k26d                                  
+      
+      k26a31 = k26a                                  
+      k26c31 = k26c                                  
+      k26d31 = k26d                                  
+      k26a32 = k26a                                  
+      k26c32 = k26c                                  
+      k26d32 = k26d                                  
+      k26a33 = k26a                                  
+      k26c33 = k26c                                  
+      k26d33 = k26d                                  
+      k26a34 = k26a                                  
+      k26c34 = k26c                                  
+      k26d34 = k26d                                  
+      
+      k26a41 = k26a                                  
+      k26c41 = k26c                                  
+      k26d41 = k26d                                  
+      k26a42 = k26a                                  
+      k26c42 = k26c                                  
+      k26d42 = k26d                                  
+      k26a43 = k26a                                  
+      k26c43 = k26c                                  
+      k26d43 = k26d                                  
+      k26a44 = k26a                                  
+      k26c44 = k26c                                  
+      k26d44 = k26d                                  
+      
+!!	some examples of inverse rates, although not used at the moment      
+!	k26a32p = k26a32 * exp( -ee* (nu(3,8)-nu32_1000-nu(2,4)) / tt )*1./1. 
+!	k26c32p = k26c32 * exp( -ee* (nu(3,6)-nu32_0200-nu(2,4)) / tt )*1./1. 
+!	k26d32p = k26d32 * exp( -ee* (nu(3,5)- nu(3,1) -nu(2,4)) / tt )*2./2. 
+!                                               
+!	k26a43 = k26a34 * exp( -ee* (nu(3,8)-nu32_1000-nu(4,4)) / tt )*1./1.  
+!	k26c43 = k26c34 * exp( -ee* (nu(3,6)-nu32_0200-nu(4,4)) / tt )*1./1.  
+!	k26d43 = k26d34 * exp( -ee* (nu(3,5)- nu(3,1) -nu(4,4)) / tt )*2./2.  
+!                                               
+!	k26a24p = k26a24 * exp( -ee* (nu(2,8)-nu22_1000-nu(4,4)) / tt )*1./1. 
+!	k26c24p = k26c24 * exp( -ee* (nu(2,6)-nu22_0200-nu(4,4)) / tt )*1./1. 
+!	k26d24p = k26d24 * exp( -ee* (nu(2,5)- nu(2,1) -nu(4,4)) / tt )*2./2. 
+	                                               
+	                                               
+! this is taken as vv4 in table 4, paper i (in the inverse direction)   
+c k41 :    co(v) + co2 ---> co(v-1) + co2(001) + de         
+!	k41_v      v=1,2,3,4                
+!
+! de = -205.9 cm-1   when v=1                   
+! de = -232.9 cm-1   when v=2                   
+! de = -258.6 cm-1   when v=3                   
+! de = -285.0 cm-1   when v=4                   
+                                                
+      k41p_taylor = 1.56d-11 * exp( -30.12/tt**0.333333 ) ! [ s-1 cm+3 ]     
+      k41p_shved = 7.5d7/sqrt(tt) ! [ s-1 atm-1 ]
+      k41p_shved = k41p_shved * 1.38d-16/1013250. * tt ! [ s-1 cm+3 ]       
+      k41p_starr_hannock = 6.27d3 ! [ s-1 torr-1 ]
+      
+      if (iopt41.eq.1) then                          
+         k41p_1 = k41p_starr_hannock *                
+     @        760.*1.38d-16/1013250. * tt ! [ s-1 cm+3 ] 
+      elseif (iopt41.eq.2) then                      
+         k41p_1 = 1.6d-12 * exp( -1169/tt + 77601/tt**2.d0 )      
+      end if                                         
+      k41p_1 = k41p_1 * rf41                          
+      k41_1 = k41p_1 * exp(dble( -ee * 205.9/tt ))   
+      k41_2 = k41_1                                  
+      k41p_2 = k41_2 * exp(dble( -ee * (-232.9)/tt ))            
+      k41_3 = k41_1                                  
+      k41p_3 = k41_3 * exp(dble( -ee * (-258.6)/tt ))            
+      k41_4 = k41_1                                  
+      k41p_4 = k41_4 * exp(dble( -ee * (-285.0)/tt ))            
+
+        !k41p_1 = k41p_1 * 1.d-6
+        !k41p_2 = k41p_2 * 1.d-6
+
+c k41iso :    63(v) + co2 ---> 63(v-1) + co2(001) + de         
+!	k41iso_v      v=1,2,3                
+! de = -253 cm-1   when v=1                   
+! de = -278 cm-1   when v=2                   
+! de = -303 cm-1   when v=3                   
+
+      k41iso_1 = k41_1
+      k41iso_1p = k41iso_1 * exp(dble( -ee * (-253.)/tt ))            
+      k41iso_2 = k41iso_1
+      k41iso_2p = k41iso_2 * exp(dble( -ee * (-278.)/tt ))            
+      k41iso_3 = k41iso_1
+      k41iso_3p = k41iso_3 * exp(dble( -ee * (-303.)/tt ))            
+        
+
+
+c k42 :    co(v) + co ---> co(v-1) + co(1) + de=-26.481  si v=2  K42
+!                                               -52.8940 si v=3  k42b
+!                                               -79.2402 si v=4  k42c
+!	tomado de stepanova & shved (ellos de powell, 1975), ver pg .. l5     
+	! solo para v=2 :                              
+                                                
+      k42 = 2.89d-10 * (1./sqrt(tt) + 67.4/tt**1.5) * 
+     @     exp(dble(24.78/tt))    
+      k42 = k42 * rf42                               
+      k42b = k42 
+      k42c = k42 
+      k42p = k42 * exp(dble( -ee * (-26.481)/tt ))   
+      k42bp = k42b * exp(dble( -ee * (-52.894)/tt ))   
+      k42cp = k42c * exp(dble( -ee * (-79.24)/tt ))   
+
+c k42iso :    63(v) + 63 ---> 63(v-1) + 63(1) + de=-25.31  si v=2  K42iso
+!                                                  -50.57  si v=3  k42isob
+!	tomado de stepanova & shved (ellos de powell, 1975), ver pg .. l5     
+	! solo para v=2 :                              
+                                                
+      k42iso = k42 
+      k42isop = k42iso * exp(dble( -ee * (-25.31)/tt ))   
+      k42isob = k42
+      k42isobp = k42isob * exp(dble( -ee * (-50.57)/tt ))   
+
+                                                
+c k43 :   co(v) + o3p ---> co(v-1) + o3p + de=2143   
+! 	tomado de lewittes et. al, 1978 para v=1              
+                                                
+      if (iopt43.eq.1) then 	                        
+         tt1 = tt - 300.                              
+         k43 = 2.85d-14 * exp( dble( 9.5e-3*tt1 + 1.11e-4*tt1**2. ) )         
+      elseif (iopt43.eq.2) then                      
+         k43 = 1.4d-5 * exp( -10957.d0 / tt + 1.486d6 / tt**2.d0 )            
+         if ( tt.lt.265.0 ) k43 = 2.3d-14             
+      end if                                         
+      k43 = k43 * rf43                               
+      k43p = k43 * exp( -ee * dble(2143.3 / tt) )    
+      
+c k43iso :   co63(v) + o3p ---> co63(v-1) + o3p + de=2096   
+! 	Por similitud con el anterior 
+                                                
+      k43iso = k43 
+      k43isop = k43iso * exp( -ee * dble(2096. / tt) )    
+                                 
+               
+c k44 :    co62(v) + co63 ---> co62(v-1) + co63(1) + de
+!	basado en Lopez-Valverde et al para el caso v=1, solo usamos este
+!	k44x   x = a --- v=1   de= 147.33 
+!	           b --- v=2   de=  20.7241
+!	           c --- v=3   de=  -5.7               
+!	           d --- v=4   de= -32.0361              
+                                                
+      k44a = 2.0d-12 * rf44     ! Solo vamos a usar este, no los b,c,d
+      k44b = k44a
+      k44c = k44a
+      k44d = k44a
+      
+      de = 147.33
+      k44ap = k44a * exp(dble( -ee * de/tt ))   
+      de = 20.7241
+      k44bp = k44b * exp(dble( -ee * de/tt ))   
+      de =  -5.7
+      k44cp = k44c * exp(dble( -ee * de/tt ))   
+      de = -32.0361
+      k44dp = k44d * exp(dble( -ee * de/tt ))   
+ 
+
+co2(hcl) + co2 --> co2 + co2 + de(hcl)          
+! este rate tambien lo usamos para los high combination levels (para tra
+! al lte. cualquier valor vale, supongo. es k_vthcl         
+                                                
+      k_vthcl = 3.3d-15         ! similar al valor pequenho del vt2      
+      k_vthcl = k_vthcl * rf_hcl                     
+                                                
+      return                                         
+      end                
Index: unk/LMDZ.MARS/libf/phymars/nlte_matrix.h
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/nlte_matrix.h	(revision 497)
+++ 	(revision )
@@ -1,65 +1,0 @@
-c****************************************************************************
-c	matrices.cmn
-c
-c	common that connects all cz* with fot*, with matrix for groups
-c
-c     @      0-3-97		cristina	
-c	JAN 98		MALV		Version para mz1d
-c****************************************************************************
-
-c curtis matrix de cza:
-	common/curtis_matrixes_15um/ c110,c121, c210,
-     @  	c310, c410,
-     @  	vc110,vc121, vc210,
-     @  	vc310, vc410
-	real*8 c110(nl,nl), c121(nl,nl)
-	real*8 c210(nl,nl)
-	real*8 c310(nl,nl)
-	real*8 c410(nl,nl)
-	real*8 vc110(nl), vc121(nl)
-	real*8 vc210(nl), vc310(nl), vc410(nl)
- 
-	common/curtis_matr_up_15um/ 
-     @          cup110,cup121
-	real*8 cup110(nl,nl), cup121(nl,nl)
-
-	common/curtis_matr_dw_15um/ 
-     @          cdw110,cdw121
-	real*8 cdw110(nl,nl), cdw121(nl,nl)
-
-        common/curtis_matr_taugr_15um/
-     @  	taugr110,taugr121
-        real*8 taugr110(nl), taugr121(nl)
-        
-! for the new flux formulation:
-!
-!
-        common/tauinf_15um/ tauinf121,
-     @  	tauinf210,tauinf310,tauinf410,tauinf110
-        real*8 tauinf121(nl)
-        real*8 tauinf210(nl), tauinf310(nl), tauinf410(nl)
-        real*8 tauinf110(nl)
-
-! for the cool-to-space formulation:
-!
-	common/taustar_15um/ taustar11, taustar21, taustar31, 
-     @         taustar41, taustar12
-	real*8 taustar11(nl), taustar21(nl), taustar31(nl)
-	real*8 taustar41(nl), taustar12(nl)
-
-	common/tauii_15um/ tauii110, tauii210, tauii310, 
-     @         tauii410, tauii121
-	real*8 tauii110(nl), tauii210(nl), tauii310(nl)
-	real*8 tauii410(nl), tauii121(nl)
-
-! for the name of the C.Matrix files
-!
-	common/cm_names/ fileroot
-	character        fileroot*3
-
-c****************************************************************************
-
-
-
-
-
Index: /trunk/LMDZ.MARS/libf/phymars/nlte_paramdef.h
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/nlte_paramdef.h	(revision 498)
+++ /trunk/LMDZ.MARS/libf/phymars/nlte_paramdef.h	(revision 498)
@@ -0,0 +1,166 @@
+c****************************************************************************
+c
+c       Merging of different parameters definitions for new NLTE 15um param
+c
+c       jan 2012    fgg+malv
+c****************************************************************************
+c *** Old nltedefs.h ***
+! NLTE grid parameters:
+
+	integer nl		! actual # alt in NLTE module 
+	parameter ( nl=20 )
+
+	integer nl2		! = nl-2, needed for matrix inversion (mmh2)
+	parameter ( nl2=nl-2 )	
+
+	integer nzy
+	parameter ( nzy = (nl-1)*4 + 1 )  ! Fine grid for mztud.f
+
+
+!  Other NLTE parameters:
+	integer 	nisot		! number of isotopes considered
+	integer 	nb 		! number of bands included
+	parameter ( nisot=4, nb=41 )
+
+	integer 	nhist			! # of temps in histogr.
+	parameter 	( nhist = 36 )          ! (get it from histograms!)
+
+	integer         nbox_max
+	parameter       ( nbox_max = 70 )       ! max.# boxes in histogram
+
+
+c *** Old tcr15um.h ***
+      integer   irw_mztf,imu,ioverlap,nw,itt_cza,icls_mztf,nan
+c
+      parameter (irw_mztf     = 2)
+      parameter (imu          = 1)
+      parameter (ioverlap     = 0)
+      parameter (nw           = 3)
+      parameter (itt_cza      = 13)
+      parameter (icls_mztf    = 5)
+      parameter (nan          = 0)
+c
+c 
+      integer iopt3, iopt19,iopt20, iopt21,iopt27,iopt26
+c
+      parameter (iopt3        = 1)
+      parameter (iopt19       = 2)
+      parameter (iopt20       = 2)
+      parameter (iopt21       = 1)
+      parameter (iopt27       = 1)
+      parameter (iopt26       = 2)
+c
+c
+      integer	iopt41,iopt43, iopt6
+c
+      parameter (iopt6        = 2)
+      parameter (iopt41       = 2)
+      parameter (iopt43       = 2)
+c
+c
+      real   tsurf_excess,Pbottom_atm,Ptop_atm
+c
+      parameter (tsurf_excess = 0.)
+      parameter (Pbottom_atm  = 2.e-5)
+      parameter (Ptop_atm     = 5.e-12)
+c
+c
+      real*8 rf1,rf2desac,rf2iso,rf3,rf6
+c
+      parameter (rf1          = 1.d0)
+      parameter (rf2desac     = 1.d0)
+      parameter (rf2iso       = 1.d0)
+      parameter (rf3          = 1.d0)
+      parameter (rf6          = 1.d0)  
+c
+c
+      real*8 rf7,rf19,rf20,rf21a,rf21b,rf21c 
+c
+      parameter (rf7          = 1.d0)
+      parameter (rf19         = 1.d0)
+      parameter (rf20         = 1.d0)
+      parameter (rf21a        = 1.d0)
+      parameter (rf21b        = 1.d0)
+      parameter (rf21c        = 1.d0)
+c
+c
+      real*8 rf26,rf27f,rf27s,rf28,rf31,rf32,rf33a,rf33bc
+c
+      parameter (rf26         = 1.d0)
+      parameter (rf27f        = 1.d0)
+      parameter (rf27s        = 1.d0)
+      parameter (rf28         = 1.d0)
+      parameter (rf31         = 1.d0)
+      parameter (rf32         = 1.d0)
+      parameter (rf33a        = 1.d0)
+      parameter (rf33bc       = 1.d0)
+c
+c
+      real*8 rf41,rf42,rf43,rf_hcl,rf44
+c
+      parameter (rf41         = 1.d0)
+      parameter (rf42         = 1.d0)
+      parameter (rf43         = 1.d0)
+      parameter (rf_hcl       = 1.d0)
+      parameter (rf44         = 1.d0)
+c
+c                  
+      real*8 frac6,frac21,frac33
+c
+      parameter (frac6        = 1.d0)
+      parameter (frac21       = 1.d0)
+      parameter (frac33       = 1.d0)
+
+
+c *** Old nlte_data.h and bloque.F ***
+      real*8  vlight, ee, hplanck, gamma
+      parameter (vlight       = 2.9979245e10)
+      parameter (ee           = 1.43876866)
+      parameter (hplanck      = 6.6260755e-27)
+      parameter (gamma        = 1.191043934e-5)
+
+      real imr(nisot), imrco
+      parameter (imrco        = 0.9865)      
+      data imr / 0.987, 0.00408, 0.0112, 0.000742 /  
+
+      integer indexisot(nisot)
+      data indexisot/26,28,36,27/
+
+      real deltanuco
+      parameter (deltanuco    = 306.)
+
+      real nuco_10
+      parameter (nuco_10      = 2143.2716)
+
+      real nun2,nu12_0200,nu12_1000,nu22_0200,nu22_1000
+      parameter (nun2         = 2331.0)
+      parameter (nu12_0200    = 1285.4087)
+      parameter (nu12_1000    = 1388.1847)
+      parameter (nu22_0200    = 1259.4257)
+      parameter (nu22_1000    = 1365.8439)
+
+      real nu32_0200,nu32_1000, nu42_0200,nu42_1000
+      parameter (nu32_0200    = 1265.8282)
+      parameter (nu32_1000    = 1370.0626)
+      parameter (nu42_0200    = 1272.2866)
+      parameter (nu42_1000    = 1376.0275)
+
+      real nu(nisot,8)
+      data nu(1,1),nu(1,2),nu(1,3),nu(1,4)    
+     @    /667.3801, 1335.1317, 2003.2463, 2349.1433/       
+      data nu(1,5),nu(1,6),nu(1,7),nu(1,8)    
+     @   /3004.0112, 3612.8417, 3659.2728, 3714.7828/       
+      data nu(2,1),nu(2,2),nu(2,3),nu(2,4)    
+     @   /662.3734, 1325.1410, 1988.3280, 2332.1128/        
+      data nu(2,5),nu(2,6),nu(2,7),nu(2,8)    
+     @   /2982.1115, 3571.1404, 3632.5240, 3675.1332/       
+      data nu(3,1),nu(3,2),nu(3,3),nu(3,4)    
+     @   /648.4784, 1297.2640, 1946.3507, 2283.4876/        
+      data nu(3,5),nu(3,6),nu(3,7),nu(3,8)    
+     @   /2920.2387, 3527.7380, 3557.3145, 3632.9112/       
+      data nu(4,1),nu(4,2),nu(4,3),nu(4,4)    
+     @   /664.7289, 1329.8430, 1995.3520, 2340.0136/        
+      data nu(4,5),nu(4,6),nu(4,7),nu(4,8)    
+     @   /2992.3100, 3591.2510, 3644.9900, 3693.3460/
+
+      
Index: unk/LMDZ.MARS/libf/phymars/nlte_rates.h
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/nlte_rates.h	(revision 497)
+++ 	(revision )
@@ -1,80 +1,0 @@
-	common/rates_vt/ k7a(4),k7b(4), k7ap(4),k7bp(4), 
-     @      	k3aa(4),k3ab(4),k3ac(4), k3aap(4),k3abp(4),k3acp(4),
-     @      	k3ba(4),k3bb(4),k3bc(4), k3bap(4),k3bbp(4),k3bcp(4),
-     @      	k19aa(4),k19ab(4),k19ac(4), k19aap(4),k19abp(4),k19acp(4),
-     @      	k19ba(4),k19bb(4),k19bc(4), k19bap(4),k19bbp(4),k19bcp(4),
-     @      	k19ca(4),k19cb(4),k19cc(4), k19cap(4),k19cbp(4),k19ccp(4),
-     @      	k20a(4),k20b(4),k20c(4), k20ap(4),k20bp(4),k20cp(4),
-     @      	k27a,k27b,k27c, k27ap,k27bp,k27cp
-
-	real*8 k7a,k7b, k7ap,k7bp 
-	real*8 k3aa,k3ab,k3ac, k3aap,k3abp,k3acp
-	real*8 k3ba,k3bb,k3bc, k3bap,k3bbp,k3bcp
-	real*8 k19aa,k19ab,k19ac, k19aap,k19abp,k19acp
-	real*8 k19ba,k19bb,k19bc, k19bap,k19bbp,k19bcp
-	real*8 k19ca,k19cb,k19cc, k19cap,k19cbp,k19ccp
-	real*8 k20a,k20b,k20c, k20ap,k20bp,k20cp
-	real*8 k27a,k27b,k27c, k27ap,k27bp,k27cp
-
-        common/rates_vv/ k1(4),k1p(4), 
-     @      	k2a,k2b, k2x,k2y,k2z, k2xp,k2yp,k2zp,
-     @      	k6,k6p, k6a(2:4),k6b(2:4), k6ap(2:4),k6bp(2:4),
-     @      	k21a,k21ap, k21a1(2:4),k21a2(2:4), k21a1p(2:4),k21a2p(2:4),
-     @      	k21b(4),k21c(4), k21bp(4),k21cp(4),
-     @      	k31,k32,
-     @      	k33a1,k33a2,k33b1,k33b2,k33c, 
-     @      	k33a1p(2:4),k33a2p(2:4),k33b1p(2:4),k33b2p(2:4),k33cp(2:4),
-     @      	k28a,k28b,k28c, k28ap,k28bp,k28cp,
-     @      	k26a,k26b,k26c,k26d, k26ap(4),k26bp(4),k26cp(4),k26dp(4), 
-     @      	k41p_taylor, k41p_shved, k41p_starr_hannock, 
-     @      	k41_1,k41p_1, k41_2,k41p_2, k42,k42p
-
-	real*8 k1,k1p
-	real*8 k2a,k2b, k2x,k2y,k2z, k2xp,k2yp,k2zp
-	real*8 k6,k6p, k6a,k6b, k6ap,k6bp
-	real*8 k21a,k21ap, k21a1,k21a2, k21a1p,k21a2p
-	real*8 k21b,k21c, k21bp,k21cp
-	real*8 k31,k32
-	real*8 k33a1,k33a2,k33b1,k33b2,k33c
-	real*8 k33a1p,k33a2p,k33b1p,k33b2p,k33cp
-	real*8 k28a,k28b,k28c, k28ap,k28bp,k28cp
-	real*8 k26a,k26b,k26c,k26d, k26ap,k26bp,k26cp,k26dp
-	real*8 k41p_taylor, k41p_shved, k41p_starr_hannock 
-	real*8 k41_1,k41p_1, k41_2,k41p_2, k42,k42p 
-
-
-	common/rates_k26isot/ k26a21,k26c21,k26d21, 
-     @     k26a22,k26c22,k26d22, k26a23,k26c23,k26d23, 
-     @     k26a24,k26c24,k26d24, 
-     @     k26a32,k26c32,k26d32, k26a33,k26c33,k26d33, 
-     @     k26a31,k26c31,k26d31, 
-     @     k26a34,k26c34,k26d34, k26a42,k26c42,k26d42, 
-     @     k26a41,k26c41,k26d41, 
-     @     k26a43,k26c43,k26d43, k26a44,k26c44,k26d44 
-
-	real*8 k26a21,k26c21,k26d21, 
-     @     k26a22,k26c22,k26d22, k26a23,k26c23,k26d23, 
-     @     k26a24,k26c24,k26d24, 
-     @     k26a32,k26c32,k26d32, k26a33,k26c33,k26d33, 
-     @     k26a31,k26c31,k26d31, 
-     @     k26a34,k26c34,k26d34, k26a42,k26c42,k26d42, 
-     @     k26a41,k26c41,k26d41, 
-     @     k26a43,k26c43,k26d43, k26a44,k26c44,k26d44
-
-
-	common/rates_last/ k23k21c, k24k21c, k34k21c, 
-     @      	k23k21cp, k24k21cp, k34k21cp, k43,k43p, k_vthcl
-
-	real*8 k23k21c,k24k21c,k34k21c, k23k21cp,k24k21cp,k34k21cp 
-	real*8 k43,k43p, k_vthcl
-
-	common/rates_V09/ k41_3,k41p_3, k41_4,k41p_4, k41iso_1,k41iso_1p, 
-     @                    k41iso_2,k41iso_2p, k41iso_3,k41iso_3p, 
-     @                    k42b, k42c, k42bp, k42cp, k43iso,k43isop, 
-     @                    k44a,k44b,k44c,k44d, k44ap,k44bp,k44cp,k44dp, 
-     @                    k42iso,k42isop, k42isob,k42isobp
-        real*8  k41_3,k41p_3, k41_4,k41p_4, k41iso_1,k41iso_1p
-	real*8  k41iso_2,k41iso_2p, k41iso_3,k41iso_3p
-        real*8  k42b, k42c, k42bp, k42cp, k43iso,k43isop
-	real*8  k44a,k44b,k44c,k44d, k44ap,k44bp,k44cp,k44dp
-	real*8  k42iso,k42isop, k42isob,k42isobp
Index: unk/LMDZ.MARS/libf/phymars/nlte_results.h
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/nlte_results.h	(revision 497)
+++ 	(revision )
@@ -1,62 +1,0 @@
-c****************************************************************************
-c
-c	nlte_results.cmn
-c
-c	JAN 98	MALV		Based on mztv1.cmn, mztv4_abc.cmn
-c****************************************************************************
-
-c Next common: parameter that decides which level populations 
-c are already known and therefore are read and used in this program.
-	common/input_avilable_from/ input_cza, input_czb, input_czc, 
-     @                              input_czco
-	integer input_cza, input_czb, input_czc, input_czco
-
-c temperatura vibracional de entrada:
-	common/temp626/ v626t1,v626t2,v626t3,v626t4, 
-     @   		v626t5,v626t6,v626t7,v626t8
-	common/temp628/ v628t1, v628t2, v628t3, v628t4
-	common/temp636/ v636t1, v636t2, v636t3, v636t4 
-	common/temp627/ v627t1, v627t2, v627t3, v627t4 
-	common/tempco/ vcot1, vcot2, vcot3, vcot4, v63t1,v63t2,v63t3
-	real*8 v626t4(nl), v628t4(nl), v636t4(nl), v627t4(nl)
-	real*8 v626t1(nl), v626t2(nl), v626t3(nl) 
-	real*8 v626t5(nl), v626t6(nl), v626t7(nl), v626t8(nl)
-	real*8 v628t1(nl), v628t2(nl), v628t3(nl) 
-	real*8 v636t1(nl), v636t2(nl), v636t3(nl) 
-	real*8 v627t1(nl), v627t2(nl), v627t3(nl) 
-	real*8 vcot1(nl), vcot2(nl), vcot3(nl), vcot4(nl)
-	real*8 v63t1(nl), v63t2(nl), v63t3(nl)
-
-c output de cza.for
-	common /tv15um/	vt11, vt12, vt13,
-     @      		vt21, vt22, vt23,
-     @      		vt31, vt32, vt33,
-     @      		vt41, vt42, vt43
-	real*8  vt11(nl), vt12(nl), vt13(nl),
-     @      	vt21(nl), vt22(nl), vt23(nl),
-     @      	vt31(nl), vt32(nl), vt33(nl),
-     @      	vt41(nl), vt42(nl), vt43(nl)
-
-	common /hr15um/	hr110,hr210,hr310,hr410,
-     @      		hr121,hr221,hr321,hr421,
-     @      		hr132,hr232,hr332,hr432
-	real*8  hr110(nl),hr121(nl),hr132(nl),
-     @      	hr210(nl),hr310(nl),hr410(nl),
-     @      	hr221(nl),hr232(nl),hr321(nl),
-     @      	hr332(nl),hr421(nl),hr432(nl)
-
-        common/sf15um/ el11,el12,el13, el21,el22,el23,
-     @ 		el31,el32,el33, el41,el42,el43
-        real*8 el11(nl), el12(nl), el13(nl)
-        real*8 el21(nl), el22(nl), el23(nl)
-        real*8 el31(nl), el32(nl), el33(nl)
-        real*8 el41(nl), el42(nl), el43(nl)
-
-        common/sl15um/ sl110,sl121,sl132, sl210,sl221,sl232,
-     @          sl310,sl321,sl332, sl410,sl421,sl432 
-        real*8 sl110(nl), sl121(nl), sl132(nl)
-        real*8 sl210(nl), sl221(nl), sl232(nl)
-        real*8 sl310(nl), sl321(nl), sl332(nl)
-        real*8 sl410(nl), sl421(nl), sl432(nl)
-
-                       
Index: /trunk/LMDZ.MARS/libf/phymars/nlte_tcool.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/nlte_tcool.F	(revision 498)
+++ /trunk/LMDZ.MARS/libf/phymars/nlte_tcool.F	(revision 498)
@@ -0,0 +1,1257 @@
+c***********************************************************************
+                                                            
+      subroutine NLTEdlvr09_TCOOL (ngridgcm,n_gcm,  
+     @     p_gcm, t_gcm, z_gcm, 
+     @     co2vmr_gcm, n2vmr_gcm, covmr_gcm, o3pvmr_gcm,  
+     @     q15umco2_gcm )
+
+c       jul 2011 malv+fgg                             
+c***********************************************************************
+                                                            
+      implicit none                                  
+         
+      include "dimensions.h"
+      include "dimphys.h"
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+      include "chimiedata.h"
+      include "conc.h"
+
+c Arguments 
+      integer n_gcm,ngridgcm
+      real p_gcm(ngridgcm,n_gcm), t_gcm(ngridgcm,n_gcm)
+      real co2vmr_gcm(ngridgcm,n_gcm), n2vmr_gcm(ngridgcm,n_gcm)
+      real covmr_gcm(ngridgcm,n_gcm), o3pvmr_gcm(ngridgcm,n_gcm)
+      real q15umco2_gcm(ngridgcm,n_gcm)
+      real z_gcm(ngridgcm,n_gcm)
+                                                             
+c local variables and constants                 
+      integer 	iz, i, j, k, l, ig,istyle
+      
+      real*8		q15umco2_nl(nl)                        
+      real*8		zld(nl), zgcmd(n_gcm)                      
+      real*8          auxdgcm(n_gcm)                        
+
+
+      real p_ig(n_gcm),z_ig(n_gcm)
+      real t_ig(n_gcm)
+      real co2_ig(n_gcm),n2_ig(n_gcm),co_ig(n_gcm),o3p_ig(n_gcm)
+      real mmean_ig(n_gcm),cpnew_ig(n_gcm)
+        
+
+c**********************************************************************
+
+      do ig=1,ngridgcm
+         do l=1,n_gcm
+            p_ig(l)=p_gcm(ig,l)
+            t_ig(l)=t_gcm(ig,l)
+            co2_ig(l)=co2vmr_gcm(ig,l)
+            n2_ig(l)=n2vmr_gcm(ig,l)
+            o3p_ig(l)=o3pvmr_gcm(ig,l)
+            co_ig(l)=covmr_gcm(ig,l)
+            z_ig(l)=z_gcm(ig,l)/1000.
+            mmean_ig(l)=mmean(ig,l)
+            cpnew_ig(l)=cpnew(ig,l)
+         enddo 
+
+         call NLTEdlvr09_ZGRID (n_gcm,  
+     @        p_ig, t_ig, z_ig, 
+     @        co2_ig,n2_ig,co_ig, 
+     $        o3p_ig , mmean_ig, cpnew_ig)
+
+c     And sets zero to all Curtis Matrixes and Escape Transmissions
+         call leetvt
+         call zero3m (c110,cup110,cdw110, nl)
+         call zero2v (taugr110,vc110, nl)
+         if (itt_cza.eq.24) then 
+            call mzescape ( ig,taustar11,tauinf110,tauii110, 
+     @           1, 1,irw_mztf,imu ) 
+            istyle=2
+            call mzescape_normaliz ( taustar11, istyle )   
+         else
+            call mztud (ig, c110,cup110,cdw110, vc110,taugr110,            
+     @           1, 1, irw_mztf, imu, 0,0,0 ) 
+         endif
+         call mztvc (ig,vc210, 1, 2, irw_mztf, imu, 0,0,0 ) 
+         call mztvc (ig,vc310, 1, 3, irw_mztf, imu, 0,0,0 ) 
+         call mztvc (ig,vc410, 1, 4, irw_mztf, imu, 0,0,0 ) 
+
+         call mzescape_fb (ig)        
+         input_cza = 0  
+         call NLTEdlvr09_CZALU(ig) 
+         
+         if (itt_cza.ne.24) then 
+            call mzescape_fh (ig)        
+            input_cza = 1  
+            call NLTEdlvr09_CZALU(ig)
+         endif
+         
+c total cooling rate                                                
+c smoothing and 
+c interpolation back to original Pgrid 
+c 
+         do i = 1, nl                                   
+            q15umco2_nl(i) = hr110(i) + hr210(i) + hr310(i) + hr410(i) 
+     @           + hr121(i)
+         enddo             
+          
+         do i=1,nl                                      
+            zld(i) = - dble ( alog(pl(i)) )                      
+         enddo                                          
+         do i=1,n_gcm                                      
+            zgcmd(i) = - dble( alog(p_gcm(ig,i)) )  
+         enddo                    
+         call zerov( auxdgcm, n_gcm )
+         call interdp_limits                            
+     @        (auxdgcm,zgcmd,n_gcm,jlowerboundary,jtopboundary,
+     @        q15umco2_nl,zld,nl,1,nl,1)        
+         call suaviza ( auxdgcm, n_gcm, 1, zgcmd )     
+         
+         do i=1,n_gcm                                      
+            q15umco2_gcm(ig,i) = sngl( auxdgcm(i) )                       
+         enddo 
+          
+      enddo
+       
+       
+c end subroutine                                   
+      return
+      end 
+
+
+
+c***********************************************************************
+
+      subroutine NLTEdlvr09_ZGRID (n_gcm,  
+     @     p_gcm, t_gcm, z_gcm, 
+     @     co2vmr_gcm, n2vmr_gcm, covmr_gcm, o3pvmr_gcm ,mmean_gcm,
+     @     cpnew_gcm)
+
+c     jul 2011 malv+fgg    First version
+c***********************************************************************
+                                                
+      implicit none                                  
+        
+      include "dimensions.h"
+      include "dimphys.h"
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+      include 'chimiedata.h'
+      include 'conc.h'
+      
+c     Arguments 
+      integer n_gcm
+      real p_gcm(n_gcm), t_gcm(n_gcm)
+      real co2vmr_gcm(n_gcm), n2vmr_gcm(n_gcm)
+      real covmr_gcm(n_gcm), o3pvmr_gcm(n_gcm)
+      real z_gcm(n_gcm)
+      real mmean_gcm(n_gcm)
+      real cpnew_gcm(n_gcm)
+
+c     local variables                               
+      integer i, j  , iz                               
+!     real  distancia, meanm, gz, Hkm
+      real  zmin, zmax, deltazz, deltazzy
+      real  nt_gcm(n_gcm)
+      real  mmean_nlte(n_gcm),cpnew_nlte(n_gcm)
+              
+c functions                                     
+      external 	hrkday_convert                       
+      real 		hrkday_convert                          
+                                                
+c***********************************************************************
+
+
+! Define working grid for MZ1D model (NL, ZL, ZMIN) 
+! y otro mas fino para M.Curtis (NZ, ZX, ZXMIN = ZMIN
+
+! Para ello hace falta una z de ref del GCM, que voy a suponer la inferior
+
+! Primero, construimos escala z_gcm 
+
+!	z_gcm (1) = zmin_gcm             ! [km]
+
+        !write (*,*) ' iz, p, g, H, z =', 1, p_gcm(1), z_gcm(1)
+!	do iz = 2, n_gcm
+!	do iz=1,n_gcm
+!	   z_gcm(iz)=zlay(iz)/1.e3
+
+!	  meanm = ( co2vmr_gcm(iz)*44. + o3pvmr_gcm(iz)*16. 
+!     @               + n2vmr_gcm(iz)*28. + covmr_gcm(iz)*28. ) 
+!	  meanm = meanm / n_avog
+!	  distancia = ( radio + z_gcm(iz-1) )*1.e5 
+!	  gz = gg * masa / ( distancia * distancia ) 
+!          Hkm = 0.5*( t_gcm(iz)+t_gcm(iz-1) ) / ( meanm * gz )
+!          Hkm = kboltzman * Hkm *1e-5                           ! [km] 
+!          z_gcm(iz) = z_gcm(iz-1) - Hkm * log( p_gcm(iz)/p_gcm(iz-1) )
+
+          !write (*,*) iz, p_gcm(iz), gz, Hkm, z_gcm(iz)
+
+!        enddo
+! Segundo, definimos los límites del modelo, entre las 2 presiones clave
+
+	! Bottom boundary for NLTE model : Pbottom=2e-2mb=1.974e-5 atm
+      jlowerboundary = 1 
+      do while ( p_gcm(jlowerboundary) .gt. Pbottom_atm )
+         jlowerboundary = jlowerboundary + 1
+      enddo
+      zmin = z_gcm(jlowerboundary)
+!	write (*,*) ' jlowerboundary, Pmin, zmin =', 
+!     @            jlowerboundary, p_gcm(jlowerboundary), zmin
+
+	! Top boundary for NLTE model : Ptop=2e-7mb = 1.974e-5 atm
+      jtopboundary = jlowerboundary  
+      do while ( p_gcm(jtopboundary) .gt. Ptop_atm ) 
+         jtopboundary = jtopboundary + 1
+      enddo
+      zmax = z_gcm(jtopboundary)
+!	write (*,*) ' jtopboundary, Pmax, zmax =', 
+!     @      jtopboundary, p_gcm(jtopboundary),zmax
+
+      deltaz = (zmax-zmin) / (nl-1) 
+      do i=1,nl                                      
+         zl(i) = zmin + (i-1) * deltaz
+      enddo                                          
+!	write (*,*) ' ZL grid:  dz,zmin,zmax ', deltaz, zl(1),zl(nl)
+! Creamos el perfil interpolando
+      call intersp (    pl,zl,nl,      p_gcm,z_gcm,n_gcm, 2) ! [atm]
+      call intersp (     t,zl,nl,      t_gcm,z_gcm,n_gcm, 1)       
+      do i = 1, n_gcm
+         nt_gcm(i) = 7.339e+21 * p_gcm(i) / t_gcm(i) ! [cm-3]	   
+      enddo
+      call intersp (    nt,zl,nl,     nt_gcm,z_gcm,n_gcm, 2)       
+      call intersp (co2vmr,zl,nl, co2vmr_gcm,z_gcm,n_gcm, 1)       
+      call intersp ( n2vmr,zl,nl,  n2vmr_gcm,z_gcm,n_gcm, 1)       
+      call intersp ( covmr,zl,nl,  covmr_gcm,z_gcm,n_gcm, 1)       
+      call intersp (o3pvmr,zl,nl, o3pvmr_gcm,z_gcm,n_gcm, 1)  
+      call intersp (mmean_nlte,zl,nl,mmean_gcm,z_gcm,n_gcm,1)
+      call intersp (cpnew_nlte,zl,nl,cpnew_gcm,z_gcm,n_gcm,1)
+	
+
+      do i = 1, nl
+
+         co2(i) = nt(i) * co2vmr(i)
+         n2(i) = nt(i) * n2vmr(i)
+         co(i) = nt(i) * covmr(i)
+         o3p(i) = nt(i) * o3pvmr(i)
+
+!          	hrkday_factor(i) =  hrkday_convert( t(i),        
+!     @        	  co2vmr(i), o3pvmr(i), n2vmr(i), covmr(i) )
+         hrkday_factor(i) = hrkday_convert(mmean_nlte(i),cpnew_nlte(i))
+
+      enddo
+                                                
+                                              
+
+c  Fine grid for transmittance calculations
+
+      deltazy = (zmax-zmin) / (nzy-1) 
+      do i=1,nzy                                      
+         zy(i) = zmin + (i-1) * deltazy	             
+      enddo                                          
+!	write (*,*) ' ZY grid:  nzy,dzy,zmin,zmax ', 
+!     @         nzy, deltazy, zy(1),zy(nzy)
+
+      call intersp (    py,zy,nzy,      p_gcm,z_gcm,n_gcm, 2) ! [atm]
+      call intersp (    ty,zy,nzy,      t_gcm,z_gcm,n_gcm, 1)       
+      call intersp (   nty,zy,nzy,     nt_gcm,z_gcm,n_gcm, 2)       
+      
+      call intersp (  co2y,zy,nzy,   co2vmr_gcm,z_gcm,n_gcm, 1) 
+      do i=1,nzy 
+         co2y(i) = co2y(i) * nty(i)
+      enddo
+
+
+  
+
+c end                                           
+      return                                         
+      end  
+
+
+      
+      
+c***********************************************************************
+                                                            
+      subroutine NLTEdlvr09_CZALU(ig) 
+
+c     jul 2011 malv+fgg
+c***********************************************************************
+                                                            
+      implicit none                                  
+                                                            
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! common variables and constants  
+                                                            
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+      
+c arguments                           
+
+      integer  ig               !ADDED FOR TRACEBACK
+                                                            
+c local variables                               
+                                                            
+! matrixes and vectors                          
+                                                            
+      real*8 e110(nl), e210(nl), e310(nl), e410(nl)  
+      real*8 e121(nl), e112(nl)                      
+      
+      real*8 f1(nl,nl)
+                                                           
+      real*8 cax1(nl,nl), cax2(nl,nl), cax3(nl,nl)   
+      real*8 v1(nl), v2(nl), v3(nl)
+
+      real*8 alf11(nl,nl), alf12(nl,nl)              
+      real*8 alf21(nl,nl), alf31(nl,nl), alf41(nl,nl)            
+      real*8 a11(nl), a1112(nl,nl)                   
+      real*8 		a1121(nl,nl), a1131(nl,nl), a1141(nl,nl)          
+      real*8 a21(nl), a2131(nl,nl), a2141(nl,nl)     
+      real*8 		a2111(nl,nl), a2112(nl,nl)            
+      real*8 a31(nl), a3121(nl,nl), a3141(nl,nl)     
+      real*8 		a3111(nl,nl), a3112(nl,nl)            
+      real*8 a41(nl), a4121(nl,nl), a4131(nl,nl)     
+      real*8 		a4111(nl,nl), a4112(nl,nl)            
+      real*8 a12(nl), a1211(nl,nl)                   
+      real*8 		a1221(nl,nl), a1231(nl,nl), a1241(nl,nl)          
+                                                            
+      real*8 aalf11(nl,nl),aalf21(nl,nl),aalf31(nl,nl),aalf41(nl,nl)         
+      real*8 aa11(nl), aa1121(nl,nl), aa1131(nl,nl), aa1141(nl,nl)           
+      real*8 aa21(nl), aa2111(nl,nl), aa2131(nl,nl), aa2141(nl,nl)           
+      real*8 aa31(nl), aa3111(nl,nl), aa3121(nl,nl), aa3141(nl,nl)           
+      real*8 aa41(nl), aa4111(nl,nl), aa4121(nl,nl), aa4131(nl,nl)           
+      real*8 aa12(nl)                              
+      real*8 aa1211(nl,nl), aa1221(nl,nl), aa1231(nl,nl), aa1241(nl,nl)      
+      real*8 aa1112(nl,nl), aa2112(nl,nl), aa3112(nl,nl), aa4112(nl,nl)      
+                                                            
+      real*8 aaalf11(nl,nl),aaalf21(nl,nl),aaalf31(nl,nl),
+     &     aaalf41(nl,nl)     
+      real*8 aaa11(nl),aaa1121(nl,nl),aaa1131(nl,nl),aaa1141(nl,nl)          
+      real*8 aaa21(nl),aaa2111(nl,nl),aaa2131(nl,nl),aaa2141(nl,nl)          
+      real*8 aaa31(nl),aaa3111(nl,nl),aaa3121(nl,nl),aaa3141(nl,nl)          
+      real*8 aaa41(nl),aaa4111(nl,nl),aaa4121(nl,nl),aaa4131(nl,nl)          
+                                                            
+      real*8 aaaalf11(nl,nl),aaaalf41(nl,nl)         
+      real*8 aaaa11(nl),aaaa1141(nl,nl)              
+      real*8 aaaa41(nl),aaaa4111(nl,nl)              
+                                                            
+                                                            
+                                                            
+! populations                                   
+      real*8 n10(nl), n11(nl)
+      real*8 n20(nl), n21(nl)
+      real*8 n30(nl), n31(nl)
+      real*8 n40(nl), n41(nl)
+      
+                                                            
+! productions and loses                         
+      real*8 d19a1,d19b1,d19c1
+      real*8 d19ap1,d19bp1,d19cp1  
+      real*8 d19a2,d19b2,d19c2 
+      real*8 d19ap2,d19bp2,d19cp2  
+      real*8 d19a3,d19b3,d19c3 
+      real*8 d19ap3,d19bp3,d19cp3  
+      real*8 d19a4,d19b4,d19c4 
+      real*8 d19ap4,d19bp4,d19cp4  
+                                                            
+      real*8 l11, l12, l21, l31, l41                 
+      real*8 p11, p12, p21, p31, p41                 
+      real*8 p1112, p1211, p1221, p1231, p1241       
+      real*8 p1121, p1131, p1141                     
+      real*8 p2111, p2112, p2131, p2141              
+      real*8 p3111, p3112, p3121, p3141              
+      real*8 p4111, p4112, p4121, p4131              
+                                                            
+                                                            
+      real*8 ps11, ps21, ps31, ps41, ps12            
+      
+      real*8 pl11, pl12, pl21, pl31, pl41            
+                                                            
+c local constants and indexes                   
+                                                            
+      integer 	ii		! decides if output of tv,hr   
+      integer 	icurt		! decides if read/comp c.matrix 
+
+      real*8 co2t                                    
+      real*8 ftest                                   
+                                                            
+      real*8 a11_einst(nl), a12_einst(nl)            
+      real*8 a21_einst(nl), a31_einst(nl), a41_einst(nl)         
+      real tsurf                                     
+
+      real*8 nu11, nu12, nu121, nu21, nu31, nu41
+                                                            
+      integer i, j, ik, isot , icurtishb                        
+      integer i_by15sh, i_col020, i_col010636                   
+                                                            
+                                                            
+c external functions and subroutines            
+                                                            
+      external planckdp                              
+      real*8 	planckdp                               
+                                                            
+! subroutines called:                           
+! 	mz4sub, dmzout, readc_mz4, mztf              
+                                                            
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!  start program 
+                                                            
+
+      ii = 4
+      icurt = 1
+
+      call zero4v( aa11, aa21, aa31, aa41, nl)
+      call zero4m( aa1121, aa1131, aa1141, aalf11, nl)
+      call zero4m( aa2111, aa2131, aa2141, aalf21, nl)
+      call zero4m( aa3111, aa3121, aa3141, aalf31, nl)
+      call zero4m( aa4111, aa4121, aa4131, aalf41, nl)
+      call zero4m( aa1112, aa2112, aa3112, aa4112, nl)
+      call zero4m( aa1211, aa1221, aa1231, aa1241, nl)
+      call zero3v( aaa41, aaa31, aaa11, nl )
+      call zero3m( aaa4111, aaa4131, aaalf41, nl)
+      call zero3m( aaa3111, aaa3141, aaalf31, nl)
+      call zero3m( aaa1131, aaa1141, aaalf11, nl)
+      call zero2v( aaaa11, aaaa41, nl )
+      call zero2m( aaaa1141, aaaalf11, nl)
+      call zero2m( aaaa4111, aaaalf41, nl)
+      
+	!write (*,*)  ' --- c z a  simple ---    input_cza : ', input_cza   
+                                    
+
+      call zero3v (vt11,vt12,vt13,nl)                
+      call zero3v (vt21,vt22,vt23,nl)                
+      call zero3v (vt31,vt32,vt33,nl)                
+      call zero3v (vt41,vt42,vt43,nl)                
+                                                            
+      call zero3v (hr110,hr121,hr132,nl)             
+      call zero3v (hr210,hr221,hr232,nl)             
+      call zero3v (hr310,hr321,hr332,nl)             
+      call zero3v (hr410,hr421,hr432,nl)             
+      call zero3v (sl110,sl121,sl132,nl)             
+      call zero3v (sl210,sl221,sl232,nl)             
+      call zero3v (sl310,sl321,sl332,nl)             
+      call zero3v (sl410,sl421,sl432,nl)             
+      
+      call zero4v (el11,el21,el31,el41,nl)           
+      call zero4v (e110,e210,e310,e410,nl)           
+      call zero3v (el12,e121,e112,nl)                
+      
+      call zero3m (cax1,cax2,cax3,nl)                
+      call zerom (f1,nl)                             
+      call zero3v (v1,v2,v3,nl)                      
+      
+      call zero4m (alf11,alf21,alf31,alf41,nl)       
+      call zerom (alf12,nl)                          
+      call zero2v (a11,a12,nl)                       
+      call zero3v (a21,a31,a41,nl)                   
+      
+      call zero3m (a1121,a1131,a1141,nl)             
+      call zerom (a1112,nl)                          
+      
+      call zero3m (a1221,a1231,a1241,nl)             
+      call zerom (a1211,nl)                          
+      
+      call zero2m (a2111,a2112,nl)                   
+      call zero2m (a2131,a2141,nl)                   
+      call zero2m (a3111,a3112,nl)                   
+      call zero2m (a3121,a3141,nl)                   
+      call zero2m (a4111,a4112,nl)                   
+      call zero2m (a4121,a4131,nl)                   
+      
+                                                            
+      call zero4v (n11,n21,n31,n41,nl)               
+                                                            
+      nu11 = nu(1,1)                                 
+      nu12 = nu(1,2)                                 
+      nu121 = nu12-nu11                              
+      
+      nu21 = nu(2,1)                                 
+                                                            
+      nu31 = nu(3,1)                                 
+                                                            
+      nu41 = nu(4,1)                                 
+                                                            
+      ftest = 1.d0                                   
+      i_by15sh = 1 
+      i_col020 = 1                                   
+                                                            
+      i_col010636 = 1                                
+                                                            
+                                                            
+ 101  format(a1)                                  
+ 180  format(a80)                                 
+                                                            
+                                                            
+c establishing molecular populations needed as input        
+      do i=1,nl                                      
+         n10(i) = dble( co2(i) * imr(1) )             
+         n20(i) = dble( co2(i) * imr(2) )             
+         n30(i) = dble( co2(i) * imr(3) )             
+         n40(i) = dble( co2(i) * imr(4) )             
+         if ( input_cza.ge.1 ) then                   
+	    n11(i) = n10(i) *2.d0 *exp( dble(-ee*nu(1,1))/v626t1(i) )          
+	    n21(i) = n20(i) *2.d0 *exp( dble(-ee*nu(2,1))/v628t1(i) )          
+	    n31(i) = n30(i) *2.d0* exp( dble(-ee*nu(3,1))/v636t1(i) )          
+	    n41(i) = n40(i) *2.d0* exp( dble(-ee*nu(4,1))/v627t1(i) )          
+         end if                                       
+      enddo                                   
+	                                               
+cc                                              
+cc   curtis matrix calculation                  
+cc                           
+      if ( input_cza.ge.1 ) then 
+
+         if (itt_cza.eq.15 ) then 
+            
+	    call cm15um_hb_simple ( ig,icurt ) 
+            
+         elseif (itt_cza.eq.13) then 
+            
+            call mztvc_626fh(ig)
+
+         endif
+
+      endif
+
+
+
+      do 4,i=nl,1,-1            !----------------------------------------------
+
+         co2t = dble ( co2(i) *(imr(1)+imr(3)+imr(2)+imr(4)) )      
+         
+         call getk ( t(i) )                             
+                                                                      
+         ps11 = 0.d0                                    
+         ps21 = 0.d0                                    
+         ps31 = 0.d0                                    
+         ps41 = 0.d0                                    
+         ps12 = 0.d0  
+                                  
+         ! V-T productions and losses V-T
+                                                            
+         isot = 1
+         d19b1 = dble(k19ba(isot)*co2t+k19bb(isot)*n2(i))         
+     @        + dble(k19bc(isot)*co(i))                    
+         d19c1 = dble(k19ca(isot)*co2t+k19cb(isot)*n2(i))         
+     @        + dble(k19cc(isot)*co(i))                    
+         d19bp1 = dble( k19bap(isot)*co2t + k19bbp(isot)*n2(i) )  
+     @        + dble( k19bcp(isot)*co(i) )                 
+         d19cp1 = dble( k19cap(isot)*co2t + k19cbp(isot)*n2(i) )  
+     @        + dble( k19ccp(isot)*co(i) )                 
+         isot = 2
+         d19c2 =dble(k19ca(isot)*co2t+k19cb(isot)*n2(i))          
+     @        + dble(k19cc(isot)*co(i))                    
+         d19cp2 =dble( k19cap(isot)*co2t + k19cbp(isot)*n2(i) )   
+     @        + dble( k19ccp(isot)*co(i) )                 
+         isot = 3
+         d19c3 =dble(k19ca(isot)*co2t+k19cb(isot)*n2(i))          
+     @        + dble(k19cc(isot)*co(i))                    
+         d19cp3 =dble( k19cap(isot)*co2t + k19cbp(isot)*n2(i) )   
+     @        + dble( k19ccp(isot)*co(i) )                
+         isot = 4
+         d19c4 =dble(k19ca(isot)*co2t+k19cb(isot)*n2(i))          
+     @        + dble(k19cc(isot)*co(i))                    
+         d19cp4 =dble( k19cap(isot)*co2t + k19cbp(isot)*n2(i) )   
+     @        + dble(k19ccp(isot)*co(i) )                  
+                                ! 
+         l11 = d19c1 + k20c(1)*dble(o3p(i))             
+         p11 = ( d19cp1 + k20cp(1)*dble(o3p(i)) ) * n10(i)          
+         l21 = d19c2 + k20c(2)*dble(o3p(i))             
+         p21 = ( d19cp2 + k20cp(2)*dble(o3p(i)) ) *n20(i)           
+         l31 = d19c3 + k20c(3)*dble(o3p(i))             
+         p31 = ( d19cp3 + k20cp(3)*dble(o3p(i)) ) *n30(i)           
+         l41 = d19c4 + k20c(4)*dble(o3p(i))             
+         p41 = ( d19cp4 + k20cp(4)*dble(o3p(i)) ) *n40(i)           
+           
+          ! Addition of V-V
+        
+         l11 = l11 + k21cp(2)*n20(i) + k21cp(3)*n30(i) + k21cp(4)*n40(i)      
+         p1121 = k21c(2) * n10(i)                     
+         p1131 = k21c(3) * n10(i)                     
+         p1141 = k21c(4) * n10(i)                     
+          !
+         l21 = l21 + k21c(2)*n10(i) + k23k21c*n30(i) + k24k21c*n40(i)         
+         p2111 = k21cp(2) * n20(i)                    
+         p2131 = k23k21cp * n20(i)                    
+         p2141 = k24k21cp * n20(i)                    
+          !                                                  
+         l31 = l31 + k21c(3)*n10(i) + k23k21cp*n20(i) + k34k21c*n40(i)        
+         p3111 = k21cp(3)* n30(i)                     
+         p3121 = k23k21c * n30(i)                     
+         p3141 = k34k21cp* n30(i)                     
+          !                                                  
+         l41 = l41 + k21c(4)*n10(i) + k24k21cp*n20(i) + k34k21cp*n30(i)       
+         p4111 = k21cp(4)* n40(i)                     
+         p4121 = k24k21c * n40(i)                     
+         p4131 = k34k21c * n40(i)                     
+                                                            
+                                                            
+         if ( input_cza.ge.1 ) then         
+                                                            
+	    l12 = d19b1                                   
+     @           + k20b(1)*dble(o3p(i))                       
+     @           + k21b(1)*n10(i)                             
+     @           + k33c*( n20(i) + n30(i) + n40(i) )          
+	    p12 = k21bp(1)*n11(i) * n11(i)                
+	    p1211 = d19bp1 + k20bp(1)*dble(o3p(i))        
+	    p1221 = k33cp(2)*n11(i)                       
+	    p1231 = k33cp(3)*n11(i)                       
+	    p1241 = k33cp(4)*n11(i)                       
+                                                            
+	    l11 = l11 + d19bp1                            
+     @           + k20bp(1)*dble(o3p(i))                  
+     @           + 2.d0 * k21bp(1) * n11(i)               
+     @           +   k33cp(2)*n21(i) + k33cp(3)*n31(i) + k33cp(4)*n41(i)
+	    p1112 = d19b1                               
+     @           + k20b(1)*dble(o3p(i))                   
+     @           + 2.d0*k21b(1)*n10(i)                    
+     @           + k33c*( n20(i) + n30(i) + n40(i) )      
+                                                            
+	    l21 = l21 + k33cp(2)*n11(i)                   
+	    p2112 = k33c*n20(i)                           
+            
+	    l31 = l31 + k33cp(3)*n11(i)                   
+	    p3112 = k33c*n30(i)                           
+                                                            
+	    l41 = l41 + k33cp(4)*n11(i)                   
+	    p4112 = k33c*n40(i)                           
+                                                            
+         end if                                         
+                                                            
+
+          ! Changes in local losses for ITT=13,15 cases 
+
+         a21_einst(i) = 1.3452d00 * 1.8 / 4.0 * taustar21(i)   
+         a31_einst(i) = 1.1878d00 * 1.8 / 4.0 * taustar31(i)   
+         a41_einst(i) = 1.2455d00 * 1.8 / 4.0 * taustar41(i)   
+
+         l21 = l21 + a21_einst(i)              
+         l31 = l31 + a31_einst(i)              
+         l41 = l41 + a41_einst(i)              
+         
+         if (input_cza.ge.1 .and. itt_cza.eq.13) then 
+            a12_einst(i) = 4.35d00 / 3.0d0 * 1.8 / 4.0 * taustar12(i) 
+            l12=l12+a12_einst(i)  
+         endif
+
+         if (itt_cza.eq.24) then 
+            a11_einst(i) = a11_einst(i)  * 1.8 / 4.0 * taustar11(i)
+            l11 = l11 + a11_einst(i)
+         endif
+            
+
+          !  vectors and matrices for the formulation                  
+
+         a11(i) = dble(gamma*nu11**3.) * 1.d0/2.d0 * (p11+ps11) / 
+     @               (n10(i)*l11)  
+         a1121(i,i) = dble((nu11/nu21))**3.d0 * n20(i)/n10(i) *p1121/l11
+         a1131(i,i) = dble((nu11/nu31))**3.d0 * n30(i)/n10(i) *p1131/l11
+         a1141(i,i) = dble((nu11/nu41))**3.d0 * n40(i)/n10(i) *p1141/l11
+         e110(i) = 2.d0* dble(vlight*nu11**2.) * 1.d0/2.d0 / 
+     @        ( n10(i) * l11 )   
+                                                            
+         a21(i) = dble( gamma*nu21**3.) * 1.d0/2.d0 * 
+     @        (p21+ps21)/(n20(i)*l21)   
+         a2111(i,i) = dble((nu21/nu11))**3.d0 * n10(i)/n20(i) *p2111/l21
+         a2131(i,i) = dble((nu21/nu31))**3.d0 * n30(i)/n20(i) *p2131/l21   
+         a2141(i,i) = dble((nu21/nu41))**3.d0 * n40(i)/n20(i) *p2141/l21   
+         e210(i) = 2.d0*dble(vlight*nu21**2.) * 1.d0/2.d0 / 
+     @        ( n20(i) * l21 )    
+                                                            
+         a31(i) = dble(gamma*nu31**3.) * 1.d0/2.d0 * (p31+ps31) / 
+     @        (n30(i)*l31)  
+         a3111(i,i) = dble((nu31/nu11))**3.d0 * n10(i)/n30(i) *p3111/l31   
+         a3121(i,i) = dble((nu31/nu21))**3.d0 * n20(i)/n30(i) *p3121/l31   
+         a3141(i,i) = dble((nu31/nu41))**3.d0 * n40(i)/n30(i) *p3141/l31   
+         e310(i) = 2.d0*dble(vlight*nu31**2.) * 1.d0/2.d0 / 
+     @        ( n30(i) * l31 )    
+         
+         a41(i) = dble(gamma*nu41**3.) * 1.d0/2.d0 * (p41+ps41) / 
+     @        (n40(i)*l41)  
+         a4111(i,i) = dble((nu41/nu11))**3.d0 * n10(i)/n40(i) *p4111/l41   
+         a4121(i,i) = dble((nu41/nu21))**3.d0 * n20(i)/n40(i) *p4121/l41   
+         a4131(i,i) = dble((nu41/nu31))**3.d0 * n30(i)/n40(i) *p4131/l41 
+         e410(i) = 2.d0*dble(vlight*nu41**2.) * 1.d0/2.d0 / 
+     @        ( n40(i) * l41 )   
+                                                            
+         if (input_cza.ge.1) then                       
+            
+	    a1112(i,i) = dble((nu11/nu121))**3.d0 * n11(i)/n10(i) * 
+     @           p1112/l11    
+	    a2112(i,i) = dble((nu21/nu121))**3.d0 * n11(i)/n20(i) * 
+     @           p2112/l21    
+	    a3112(i,i) = dble((nu31/nu121))**3.d0 * n11(i)/n30(i) * 
+     @           p3112/l31    
+	    a4112(i,i) = dble((nu41/nu121))**3.d0 * n11(i)/n40(i) * 
+     @           p4112/l41    
+	    e112(i) = -2.d0*dble(vlight*nu11**3.)/nu121 /2.d0 /
+     @           ( n10(i)*l11 )    
+	    a12(i) = dble( gamma*nu121**3.) *2.d0/4.d0* (p12+ps12)/
+     @           (n11(i)*l12)  
+	    a1211(i,i) = dble((nu121/nu11))**3.d0 * n10(i)/n11(i) * 
+     @           p1211/l12    
+	    a1221(i,i) = dble((nu121/nu21))**3.d0 * n20(i)/n11(i) * 
+     @           p1221/l12    
+	    a1231(i,i) = dble((nu121/nu31))**3.d0 * n30(i)/n11(i) * 
+     @           p1231/l12    
+	    a1241(i,i) = dble((nu121/nu41))**3.d0 * n40(i)/n11(i) * 
+     @           p1241/l12    
+	    e121(i) = 2.d0*dble(vlight*nu121**2.) *2.d0/4.d0 / 
+     @           ( n11(i) * l12 )  
+                                                            
+         end if                                         
+                                                            
+                                                            
+ 4    continue    !-------------------------------------------------------    
+                                                            
+                                                            
+        ! Change C.M. 
+                                                            
+      do i=1,nl                                    
+         do j=1,nl                                  
+            c210(i,j) = 0.0d0                             
+            c310(i,j) = 0.0d0                             
+            c410(i,j) = 0.0d0                             
+         end do                                     
+      end do 
+      if ( itt_cza.eq.13 ) then 
+         do i=1,nl                                    
+	    do j=1,nl                                  
+               c121(i,j) = 0.0d0          
+	    end do                                     
+         end do 
+      endif
+        !Añadido para hacer diagonal C121
+!        if ( itt_cza.eq.15 ) then 
+!	  do i=1,nl                                    
+!	    do j=1,nl
+!               if(abs(i-j).eq.1.or.abs(i-j).eq.2) c121(i,j) = 0.0d0          
+!	    end do                                     
+!	  end do 
+!        endif
+      if ( itt_cza.eq.24 ) then 
+         do i=1,nl                                    
+            do j=1,nl                                  
+               c110(i,j) = 0.0d0          
+            end do                                     
+         end do 
+      endif
+                                                           
+        ! Lower Boundary 
+      tsurf = t(1) + tsurf_excess                    
+      do i=1,nl                                      
+         sl110(i) = sl110(i) + vc110(i) * planckdp( tsurf, nu11 ) 
+         sl210(i) = sl210(i) + vc210(i) * planckdp( tsurf, nu21 ) 
+         sl310(i) = sl310(i) + vc310(i) * planckdp( tsurf, nu31 ) 
+         sl410(i) = sl410(i) + vc410(i) * planckdp( tsurf, nu41 ) 
+      end do                                         
+      if (input_cza.ge.1) then                       
+         do i=1,nl                                      
+	    sl121(i) = sl121(i) + vc121(i) * planckdp( tsurf, nu121 ) 
+         end do     
+      endif
+               
+                                             
+        !!!!!!!!!!!! Solucion del sistema
+                                                            
+        !! Paso 0 :  Calculo de los alphas   alf11, alf21, alf31, alf41, alf12
+
+      call unit  ( cax2, nl ) 
+			                 
+      call diago ( cax1, e110, nl )
+      call mulmm ( cax3, cax1,c110, nl ) 			   
+!        cax3=matmul(cax1,c110)
+      call resmm ( alf11, cax2,cax3, nl ) 			     
+
+      call diago ( cax1, e210, nl ) 	
+      call mulmm ( cax3, cax1,c210, nl ) 			      
+!        cax3=matmul(cax1,c210)
+      call resmm ( alf21, cax2,cax3, nl ) 			     
+
+      call diago ( cax1, e310, nl ) 	
+      call mulmm ( cax3, cax1,c310, nl ) 			      
+!        cax3=matmul(cax1,c310)
+      call resmm ( alf31, cax2,cax3, nl ) 			     
+	!
+      call diago ( cax1, e410, nl ) 	
+      call mulmm ( cax3, cax1,c410, nl ) 			   
+!        cax3=matmul(cax1,c410)
+      call resmm ( alf41, cax2,cax3, nl ) 			  
+           !
+!        if(ig.eq.2223.and.input_cza.eq.1) then
+!           open(168,file='output_curtis_c121diagminus2.dat')
+!           do i=1,nl
+!              do j=1,nl
+!                 write(168,*)i,j,c110(i,j),c121(i,j)
+!              enddo
+!           enddo
+!           close(168)
+!           open(178,file='output_taustar.dat')
+!           do i=1,nl
+!              write(178,*)i,taustar21(i),taustar31(i),taustar41(i)
+!           enddo
+!           close(178)
+!        endif
+      if (input_cza.ge.1) then                   
+         call diago ( cax1, e121, nl ) 	
+         call mulmm ( cax3, cax1,c121, nl ) 			   
+!        cax3=matmul(cax1,c121)
+         call resmm ( alf12, cax2,cax3, nl )
+      endif
+ 
+        !! Paso 1 :  Calculo de vectores y matrices con 1 barra (aa***)
+           
+      if (input_cza.eq.0) then  !  Skip paso 1, pues el12 no se calcula
+
+          ! el11
+         call sypvvv( aa11, a11,e110,sl110, nl )
+         call samem( aa1121, a1121, nl )
+         call samem( aa1131, a1131, nl )
+         call samem( aa1141, a1141, nl )
+         call samem( aalf11, alf11, nl )
+         
+          ! el21
+         call sypvvv( aa21, a21,e210,sl210, nl )
+         call samem( aa2111, a2111, nl )
+         call samem( aa2131, a2131, nl )
+         call samem( aa2141, a2141, nl )
+         call samem( aalf21, alf21, nl )
+
+          ! el31
+         call sypvvv( aa31, a31,e310,sl310, nl )
+         call samem( aa3111, a3111, nl )
+         call samem( aa3121, a3121, nl )
+         call samem( aa3141, a3141, nl )
+         call samem( aalf31, alf31, nl )
+
+          ! el41
+         call sypvvv( aa41, a41,e410,sl410, nl )
+         call samem( aa4111, a4111, nl )
+         call samem( aa4121, a4121, nl )
+         call samem( aa4131, a4131, nl )
+         call samem( aalf41, alf41, nl )
+
+
+      else                      !      (input_cza.ge.1) ,   FH !
+
+
+         call sypvvv( v1, a12,e121,sl121, nl ) ! a12 + e121 * sl121
+
+          ! aa11
+         call sypvvv( v2, a11,e110,sl110, nl )
+         call trucommvv( aa11 , alf12,a1112,v2, v1, nl )
+           
+          ! aalf11
+         call invdiag( cax1, a1112, nl )
+         call mulmm( cax2, alf12, cax1, nl ) ! alf12 * (1/a1112)
+!          cax2=matmul(alf12,cax1)
+         call mulmm( cax3, cax2, alf11, nl )
+!          cax3=matmul(cax2,alf11)
+          
+         call resmm( aalf11, cax3, a1211, nl )
+          ! aa1121
+         call trucodiag(aa1121, alf12,a1112,a1121, a1221, nl)
+          ! aa1131
+         call trucodiag(aa1131, alf12,a1112,a1131, a1231, nl)
+          ! aa1141
+         call trucodiag(aa1141, alf12,a1112,a1141, a1241, nl)
+
+           
+          ! aa21
+         call sypvvv( v2, a21,e210,sl210, nl )
+         call trucommvv( aa21 , alf12,a2112,v2, v1, nl )
+
+          ! aalf21
+         call invdiag( cax1, a2112, nl )
+         call mulmm( cax2, alf12, cax1, nl ) ! alf12 * (1/a2112)
+!          cax2=matmul(alf12,cax1)
+         call mulmm( cax3, cax2, alf21, nl )
+!          cax3=matmul(cax2,alf21)
+         call resmm( aalf21, cax3, a1221, nl )
+          ! aa2111
+         call trucodiag(aa2111, alf12,a2112,a2111, a1211, nl)
+          ! aa2131
+         call trucodiag(aa2131, alf12,a2112,a2131, a1231, nl)
+          ! aa2141
+         call trucodiag(aa2141, alf12,a2112,a2141, a1241, nl)
+
+          
+          ! aa31
+         call sypvvv( v2, a31,e310,sl310, nl )
+         call trucommvv( aa31 , alf12,a3112,v2, v1, nl )
+          ! aalf31
+         call invdiag( cax1, a3112, nl )
+         call mulmm( cax2, alf12, cax1, nl ) ! alf12 * (1/a3112)
+!          cax2=matmul(alf12,cax1)
+         call mulmm( cax3, cax2, alf31, nl )
+!          cax3=matmul(cax2,alf31)
+         call resmm( aalf31, cax3, a1231, nl )
+          ! aa3111
+         call trucodiag(aa3111, alf12,a3112,a3111, a1211, nl)
+          ! aa3121
+         call trucodiag(aa3121, alf12,a3112,a3121, a1221, nl)
+          ! aa3141
+         call trucodiag(aa3141, alf12,a3112,a3141, a1241, nl)
+ 
+
+          ! aa41
+         call sypvvv( v2, a41,e410,sl410, nl )
+         call trucommvv( aa41 , alf12,a4112,v2, v1, nl )
+          ! aalf41
+         call invdiag( cax1, a4112, nl )
+         call mulmm( cax2, alf12, cax1, nl ) ! alf12 * (1/a4112)
+!          cax2=matmul(alf12,cax1)
+         call mulmm( cax3, cax2, alf41, nl )
+!          cax3=matmul(cax2,alf41)
+         call resmm( aalf41, cax3, a1241, nl )
+          ! aa4111
+         call trucodiag(aa4111, alf12,a4112,a4111, a1211, nl)
+          ! aa4121
+         call trucodiag(aa4121, alf12,a4112,a4121, a1221, nl)
+          ! aa4131
+         call trucodiag(aa4131, alf12,a4112,a4131, a1231, nl)
+
+      endif                     ! Final  caso input_cza.ge.1
+
+
+         !! Paso 2 :  Calculo de vectores y matrices con 2 barras (aaa***)
+
+         ! aaalf41
+      call invdiag( cax1, aa4121, nl )
+      call mulmm( cax2, aalf21, cax1, nl ) ! alf21 * (1/a4121)
+!         cax2=matmul(aalf21,cax1)
+      call mulmm( cax3, cax2, aalf41, nl )
+!         cax3=matmul(cax2,aalf41)
+      call resmm( aaalf41, cax3, aa2141, nl )
+         ! aaa41
+      call trucommvv(aaa41, aalf21,aa4121,aa41, aa21, nl)
+         ! aaa4111
+      call trucodiag(aaa4111, aalf21,aa4121,aa4111, aa2111, nl)
+         ! aaa4131
+      call trucodiag(aaa4131, aalf21,aa4121,aa4131, aa2131, nl)
+
+         ! aaalf31
+      call invdiag( cax1, aa3121, nl )
+      call mulmm( cax2, aalf21, cax1, nl ) ! alf21 * (1/a3121)
+!         cax2=matmul(aalf21,cax1)
+      call mulmm( cax3, cax2, aalf31, nl )
+!         cax3=matmul(cax2,aalf31)
+      call resmm( aaalf31, cax3, aa2131, nl )
+         ! aaa31
+      call trucommvv(aaa31, aalf21,aa3121,aa31, aa21, nl)
+         ! aaa3111
+      call trucodiag(aaa3111, aalf21,aa3121,aa3111, aa2111, nl)
+         ! aaa3141
+      call trucodiag(aaa3141, aalf21,aa3121,aa3141, aa2141, nl)
+
+         ! aaalf11
+      call invdiag( cax1, aa1121, nl )
+      call mulmm( cax2, aalf21, cax1, nl ) ! alf21 * (1/a1121)
+!         cax2=matmul(aalf21,cax1)
+      call mulmm( cax3, cax2, aalf11, nl )
+!         cax3=matmul(cax2,aalf11)
+      call resmm( aaalf11, cax3, aa2111, nl )
+         ! aaa11
+      call trucommvv(aaa11, aalf21,aa1121,aa11, aa21, nl)
+         ! aaa1131
+      call trucodiag(aaa1131, aalf21,aa1121,aa1131, aa2131, nl)
+         ! aaa1141
+      call trucodiag(aaa1141, aalf21,aa1121,aa1141, aa2141, nl)
+
+
+         !! Paso 3 :  Calculo de vectores y matrices con 3 barras (aaaa***)
+
+         ! aaaalf41
+      call invdiag( cax1, aaa4131, nl )
+      call mulmm( cax2, aaalf31, cax1, nl ) ! aaalf31 * (1/aaa4131)
+!         cax2=matmul(aaalf31,cax1)
+      call mulmm( cax3, cax2, aaalf41, nl )
+!         cax3=matmul(cax2,aaalf41)
+      call resmm( aaaalf41, cax3, aaa3141, nl )
+         
+         ! aaaa41
+      call trucommvv(aaaa41, aaalf31,aaa4131,aaa41, aaa31, nl)
+         ! aaaa4111
+      call trucodiag(aaaa4111, aaalf31,aaa4131,aaa4111,aaa3111, nl)
+
+         ! aaaalf11
+      call invdiag( cax1, aaa1131, nl )
+      call mulmm( cax2, aaalf31, cax1, nl ) ! aaalf31 * (1/aaa4131)
+!         cax2=matmul(aaalf31,cax1)
+      call mulmm( cax3, cax2, aaalf11, nl )
+!     cax3=matmul(cax2,aaalf11)
+      call resmm( aaaalf11, cax3, aaa3111, nl )
+         ! aaaa11
+      call trucommvv(aaaa11, aaalf31,aaa1131,aaa11, aaa31, nl)
+         ! aaaa1141
+      call trucodiag(aaaa1141, aaalf31,aaa1131,aaa1141,aaa3141, nl)
+
+
+         !! Paso 4 :  Calculo de vectores y matrices finales y calculo de J1
+
+      call trucommvv(v1, aaaalf41,aaaa1141,aaaa11, aaaa41, nl)
+         ! 
+      call invdiag( cax1, aaaa1141, nl )
+      call mulmm( cax2, aaaalf41, cax1, nl ) ! aaaalf41 * (1/aaaa1141)
+!         cax2=matmul(aaaalf41,cax1)
+      call mulmm( cax3, cax2, aaaalf11, nl )
+!         cax3=matmul(cax2,aaaalf11)
+      call resmm( cax1, cax3, aaaa4111, nl )
+         ! 
+      call LUdec ( el11, cax1, v1, nl, nl2 )
+
+         ! Solucion para el41 
+      call sypvmv( v1, aaaa41, aaaa4111,el11, nl )
+      call LUdec ( el41, aaaalf41, v1, nl, nl2 )
+
+         ! Solucion para el31 
+      call sypvmv( v2, aaa31, aaa3111,el11, nl )
+      call sypvmv( v1,    v2, aaa3141,el41, nl )
+      call LUdec ( el31, aaalf31, v1, nl, nl2 )
+
+         ! Solucion para el21 
+      call sypvmv( v3, aa21, aa2111,el11, nl )
+      call sypvmv( v2,   v3, aa2131,el31, nl )
+      call sypvmv( v1,   v2, aa2141,el41, nl )
+      call LUdec ( el21, aalf21, v1, nl, nl2 )
+
+         !!!
+      el11(1) = planckdp( t(1), nu11 )          
+      el21(1) = planckdp( t(1), nu21 )          
+      el31(1) = planckdp( t(1), nu31 )          
+      el41(1) = planckdp( t(1), nu41 )          
+      el11(nl) = 2.d0 * el11(nl-1) - el11(nl2)    
+      el21(nl) = 2.d0 * el21(nl-1) - el21(nl2)    
+      el31(nl) = 2.d0 * el31(nl-1) - el31(nl2)    
+      el41(nl) = 2.d0 * el41(nl-1) - el41(nl2)    
+                                                           
+      call mulmv ( v1, c110,el11, nl )               
+      call sumvv ( hr110, v1,sl110, nl )             
+
+         ! Solucion para el12
+      if (input_cza.ge.1) then    
+
+         call sypvmv( v1, a12, a1211,el11, nl )
+         call sypvmv( v3,  v1, a1221,el21, nl )
+         call sypvmv( v2,  v3, a1231,el31, nl )
+         call sypvmv( v1,  v2, a1241,el41, nl )
+         call LUdec ( el12, alf12, v1, nl, nl2 )
+
+         el12(1) = planckdp( t(1), nu121 )           
+         el12(nl) = 2.d0 * el12(nl-1) - el12(nl2)    
+
+         if (itt_cza.eq.15) then 
+            call mulmv ( v1, c121,el12, nl )           
+            call sumvv ( hr121, v1,sl121, nl )           
+         endif
+         
+      end if                                        
+                                                            
+                                                            
+                                                            
+      if (input_cza.lt.1) then 
+
+         do i=1,nl                                                           
+	    pl11 = el11(i)/dble( gamma * nu11**3.0d0  * 1./2. / n10(i) )   
+	    pl21 = el21(i)/dble( gamma * nu21**3.0d0  * 1./2. / n20(i) )   
+	    pl31 = el31(i)/dble( gamma * nu31**3.0d0  * 1./2. / n30(i) )    
+	    pl41 = el41(i)/dble( gamma * nu41**3.0d0  * 1./2. / n40(i) )    
+	    vt11(i) = dble(-ee*nu11) / log( abs(pl11) / (2.0d0*n10(i)) )    
+	    vt21(i) = dble(-ee*nu21) / log( abs(pl21) / (2.0d0*n20(i)) )    
+	    vt31(i) = dble(-ee*nu31) / log( abs(pl31) / (2.0d0*n30(i)) )    
+	    vt41(i) = dble(-ee*nu41) / log( abs(pl41) / (2.0d0*n40(i)) ) 
+	    hr210(i) = sl210(i) - hplanck*vlight*nu21 * a21_einst(i)*pl21
+	    hr310(i) = sl310(i) - hplanck*vlight*nu31 * a31_einst(i)*pl31
+	    hr410(i) = sl410(i) - hplanck*vlight*nu41 * a41_einst(i)*pl41
+!            hr410(i) = 0.
+         enddo 
+
+         call dinterconnection ( v626t1, vt11 )         
+         call dinterconnection ( v628t1, vt21 )         
+         call dinterconnection ( v636t1, vt31 )         
+         call dinterconnection ( v627t1, vt41 )         
+
+      else
+                                                
+         do i=1,nl                                                           
+	    pl21 = el21(i)/dble( gamma * nu21**3.0d0  * 1./2. / n20(i) )   
+	    pl31 = el31(i)/dble( gamma * nu31**3.0d0  * 1./2. / n30(i) )   
+	    pl41 = el41(i)/dble( gamma * nu41**3.0d0  * 1./2. / n40(i) ) 
+	    hr210(i) = sl210(i) - hplanck*vlight*nu21 * a21_einst(i)*pl21
+	    hr310(i) = sl310(i) - hplanck*vlight*nu31 * a31_einst(i)*pl31
+	    hr410(i) = sl410(i) - hplanck*vlight*nu41 * a41_einst(i)*pl41
+!            hr410(i) = 0.
+ 	    if (itt_cza.eq.13) then                    
+               pl12 = el12(i)/dble(gamma*nu121**3.0d0*2./4./n11(i))  
+               hr121(i) = - hplanck*vlight * nu121 * a12_einst(i) * pl12        
+               hr121(i) = hr121(i) + sl121(i) 
+            endif                         
+         enddo
+
+      endif
+
+        ! K/Dday
+      do i=1,nl                                      
+         hr110(i)=hr110(i)*( hrkday_factor(i) / nt(i) )
+         hr210(i)=hr210(i)*( hrkday_factor(i) / nt(i) )           
+         hr310(i)=hr310(i)*( hrkday_factor(i) / nt(i) )           
+         hr410(i)=hr410(i)*( hrkday_factor(i) / nt(i) )           
+         hr121(i)=hr121(i)*( hrkday_factor(i) / nt(i) )           
+      end do                                         
+                                                            
+                                                            
+
+c  output                                       
+                                                            
+	!codigo = codeout                                                     
+        !call dmzout_tv ( 1 )             
+        !call dmzout_hr ( 1 )             
+
+c final subrutina                                                            
+      return                                         
+      end    
+
+c***********************************************************************
+c	hrkday_convert.f                              
+c                                               
+c	fortran function that returns the factor for conversion from          
+c	hr' [erg s-1 cm-3] to hr [ k day-1 ]           
+c
+c       mar 2010        fgg      adapted to GCM
+c       jan 99          malv     add o2 as major component. 
+c       ago 98          malv     also returns cp_avg,pm_avg 
+c	jul 98 		malv	 first version.	                
+c***********************************************************************
+                                                
+	function hrkday_convert                        
+     @     ( mmean_nlte,cpmean_nlte )         
+                                                
+        implicit none                           
+                          
+        include 'comcstfi.h'
+        include 'param.h'
+                                                
+c argumentos                                    
+	real	mmean_nlte,cpmean_nlte
+	real 	hrkday_convert                           
+                                                
+ccccccccccccccccccccccccccccccccccccc           
+        
+	hrkday_convert = daysec * n_avog / 
+     &                  ( cpmean_nlte * 1.e4 * mmean_nlte ) 
+                                                
+c end                                           
+        return                                  
+        end                                     
+
+c***********************************************************************
+	subroutine sypvvv(a,b,c,d,n)
+c	a(i)=b(i)+c(i)*d(i)
+c       jul 2011 malv+fgg
+c***********************************************************************
+	real*8 a(n),b(n),c(n),d(n)
+	integer n,i
+	do 1,i=2,n-1
+	  a(i)= b(i) + c(i) * d(i)
+ 1	continue
+	a(1) = 0.0d0
+	a(n) = 0.0d0
+	return
+	end
+
+c***********************************************************************
+	subroutine sypvmv(v,u,c,w,n)
+c       inputs: matriz diagonal c , vectores u,w
+c       output: vector v 
+c       Operacion a realizar:  v = u + c * w 
+
+c       jul 2011 malv+fgg
+c***********************************************************************
+	real*8 v(n),u(n),c(n,n),w(n)
+	integer n,i
+	do 1,i=2,n-1
+	  v(i)= u(i) + c(i,i) * w(i)
+ 1	continue
+	v(1) = 0.0d0
+	v(n) = 0.0d0
+	return
+	end
+
+c***********************************************************************
+	subroutine trucommvv(v,b,c,u,w,n)
+c       inputs: matrices b,c , vectores u,w
+c       output: vector v 
+c       Operacion a realizar:  v = b * c^(-1) * u + w
+c       La matriz c va a ser invertida 
+c       c es diagonal, b no
+c       Aprovechamos esa condicion para invertir c, y acelerar el calculo
+c       jul 2011 malv+fgg  
+c***********************************************************************
+	real*8 v(n),b(n,n),c(n,n),u(n),w(n), sum
+	integer n,i,j,k
+	do 1,i=2,n-1
+	  sum=0.0d0
+	  do 2,j=2,n-1
+	    sum=sum+ (b(i,j)) * (u(j)/c(j,j))
+ 2	  continue
+	  v(i) = sum + w(i)
+ 1	continue
+	v(1) = 0.d0
+	v(n) = 0.d0
+	return
+	end
+
+c***********************************************************************
+	subroutine trucodiag(a,b,c,d,e,n)
+c       inputs: matrices b,c,d,e
+c       output: matriz diagonal a
+c       Operacion a realizar:  a = b * c^(-1) * d + e
+c       La matriz c va a ser invertida
+c       Todas las matrices de entrada son diagonales excepto b
+c       Aprovechamos esa condicion para invertir c, acelerar el calculo, y 
+c       ademas, para forzar que a sea diagonal
+c       jul 2011 malv+fgg
+c***********************************************************************
+	real*8 a(n,n),b(n,n),c(n,n),d(n,n),e(n,n), sum
+	integer n,i,j,k
+	do 1,i=2,n-1
+	  sum=0.0d0
+	  do 2,j=2,n-1
+	    sum=sum+ (b(i,j)) * (d(j,j)/c(j,j))
+ 2	  continue
+	  a(i,i) = sum + e(i,i)
+ 1	continue
+	do k=1,n
+	  a(n,k) = 0.0d0
+	  a(1,k) = 0.0d0
+	  a(k,1) = 0.0d0
+	  a(k,n) = 0.0d0
+	end do
+	return
+	end
+
+c***********************************************************************
+	subroutine invdiag(a,b,n)
+c	inverse of a diagonal matrix 
+c       jul 2011 malv
+c***********************************************************************
+	implicit none
+
+	integer n,i,j,k
+	real*8 a(n,n),b(n,n)
+
+	do 1,i=2,n-1
+	  do 2,j=2,n-1
+	    if (i.eq.j) then
+              a(i,j) = 1.d0/b(i,i)
+	    else
+	      a(i,j)=0.0d0
+	    end if
+ 2	  continue
+ 1	continue
+	do k=1,n
+	  a(n,k) = 0.0d0
+	  a(1,k) = 0.0d0
+	  a(k,1) = 0.0d0
+	  a(k,n) = 0.0d0
+	end do
+	return
+	end
Index: unk/LMDZ.MARS/libf/phymars/nltedefs.h
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/nltedefs.h	(revision 497)
+++ 	(revision )
@@ -1,52 +1,0 @@
-! NLTE parameters:
-
-	integer nl		! actual # alt in NLTE module 
-	parameter ( nl=20 )
-	!real deltaz 
-	!parameter ( deltaz=5.0 )   ! Good option for Mars
-                                  ! Asegurarse que el conjunto de valores 
-				  ! (zmin,nl,deltaz) no se salen de los 
-				  ! límites del grid (zxmin,nz,deltazx)
-	integer nl2		! = nl-2, needed for matrix inversion (mmh2)
-	parameter ( nl2=nl-2 )	
-
-	integer nzy
-	parameter ( nzy = (nl-1)*4 + 1 )  ! Fine grid for mztud.f
-	!real deltazy
-	!parameter ( deltazy = deltaz*4.0 )
-
-!  Other NLTE parameters:
-	integer 	nisot		! number of isotopes considered
-	integer 	nb 		! number of bands included
-	integer 	nbmax_jt	! number of bands for solar heating
-	parameter ( nisot=4, nb=41, nbmax_jt=47 )
-
-	integer 	nhist			! # of temps in histogr.
-	parameter 	( nhist = 36 )          ! (get it from histograms!)
-
-	integer 	nmax_freq		! maximum number of points 
-	parameter 	( nmax_freq = 40000 )   ! for overlap-freq integration
-						! If dv (tcr_15um.drv) is very
-                                                ! small this must be increased.
-
-	integer         nbox_max
-	parameter       ( nbox_max = 70 )       ! max.# boxes in histogram
-
-!  Parameter for the composite vectors and matrixes of the compact-LU method
-        integer         nl5
-	parameter       ( nl5 = nl * 5 )
-
-! NLTE parameters that were needed by solar10 and are still in use 
-	integer 	ngroup                  ! normally we use 0 & 10 only
-	parameter 	( ngroup=10 )
-	integer  	nisos                   ! #isotps para los vectores jt
-	parameter 	( nisos = 9 )
-	integer  	nfile,nfile1    	! reminiscencia de cuando se 
-	parameter 	( nfile=5, nfile1=4 )   ! leian las diff.hr desde
-						! ficheros externos
-! NLTE Parameters for JT calculations
-	integer 	nsublayers		! subdivision para el fine grid
-	parameter 	( nsublayers = 50 )     ! called jj in the fot_alljt it
-                                                ! is usually 10 for vert. paths
-                                                ! or if you wish, for smallSZA,
-						! and 50 for oblique (SZA>90)
Index: unk/LMDZ.MARS/libf/phymars/suaviza.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/suaviza.F	(revision 497)
+++ 	(revision )
@@ -1,83 +1,0 @@
-c*****************************************************************************
-c
-	subroutine suaviza ( x, n, ismooth, y )
-c
-c	x - input and return values 
-c       y - auxiliary vector
-c       ismooth = 0  --> no smoothing is performed
-c       ismooth = 1  --> weak smoothing (5 points, centred weighted)
-c       ismooth = 2  --> normal smoothing (3 points, evenly weighted)
-c       ismooth = 3  --> strong smoothing (5 points, evenly weighted)
-
-
-c	malv  august 1991
-c*****************************************************************************
-
-	implicit none
-
-	integer	n, imax, imin, i, ismooth
-	real*8	x(n), y(n)
-c*****************************************************************************
-
-	imin=1
-	imax=n
-
-	if (ismooth.eq.0) then
-
-	  return 
-
-	elseif (ismooth.eq.1) then       ! 5 points, with central weighting 
-
-	  do i=imin,imax 
-	    if(i.eq.imin)then
-	      y(i)=x(imin)
-	    elseif(i.eq.imax)then
-	      y(i)=x(imax-1)+(x(imax-1)-x(imax-3))/2.d0
-	    elseif(i.gt.(imin+1) .and. i.lt.(imax-1) )then
-	      y(i) = ( x(i+2)/4.d0 + x(i+1)/2.d0 + 2.d0*x(i)/3.d0 + 
-	1	x(i-1)/2.d0 + x(i-2)/4.d0 )* 6.d0/13.d0
-	    else
-	      y(i)=(x(i+1)/2.d0+x(i)+x(i-1)/2.d0)/2.d0
-	    end if
-	  end do	
-
-	elseif (ismooth.eq.2) then       ! 3 points, evenly spaced
-
-	  do i=imin,imax 
-	    if(i.eq.imin)then
-	      y(i)=x(imin)
-	    elseif(i.eq.imax)then
-	      y(i)=x(imax-1)+(x(imax-1)-x(imax-3))/2.d0
-	    else
-	      y(i) = ( x(i+1)+x(i)+x(i-1) )/3.d0
-	    end if
-	  end do	
-	  
-	elseif (ismooth.eq.3) then	     ! 5 points, evenly spaced
-
-	  do i=imin,imax 
-	    if(i.eq.imin)then
-	      y(i) = x(imin)
-	    elseif(i.eq.(imin+1) .or. i.eq.(imax-1))then
-	      y(i) = ( x(i+1)+x(i)+x(i-1) )/3.d0 
-	    elseif(i.eq.imax)then
-	      y(i) = ( x(imax-1) + x(imax-1) + x(imax-2) ) / 3.d0
-	    else
-	      y(i) = ( x(i+2)+x(i+1)+x(i)+x(i-1)+x(i-2) )/5.d0
-	    end if
-	  end do	
-
-	else
-
-	  write (*,*) ' Error in suaviza.f   Wrong ismooth value.'
-	  stop
-
-	endif
-
-c rehago el cambio, para devolver x(i)
-	do i=imin,imax 
-	    x(i)=y(i)
-	end do
-
-	return
-	end
Index: unk/LMDZ.MARS/libf/phymars/sypvmv.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/sypvmv.F	(revision 497)
+++ 	(revision )
@@ -1,17 +1,0 @@
-c	***********************************************************************
-	subroutine sypvmv(v,u,c,w,n)
-c       inputs: matriz diagonal c , vectores u,w
-c       output: vector v 
-c       Operacion a realizar:  v = u + c * w 
-
-c       jul 2011 malv+fgg
-c	***********************************************************************
-	real*8 v(n),u(n),c(n,n),w(n)
-	integer n,i
-	do 1,i=2,n-1
-	  v(i)= u(i) + c(i,i) * w(i)
- 1	continue
-	v(1) = 0.0d0
-	v(n) = 0.0d0
-	return
-	end
Index: unk/LMDZ.MARS/libf/phymars/sypvvv.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/sypvvv.F	(revision 497)
+++ 	(revision )
@@ -1,14 +1,0 @@
-c	***********************************************************************
-	subroutine sypvvv(a,b,c,d,n)
-c	a(i)=b(i)+c(i)*d(i)
-c       jul 2011 malv+fgg
-c	***********************************************************************
-	real*8 a(n),b(n),c(n),d(n)
-	integer n,i
-	do 1,i=2,n-1
-	  a(i)= b(i) + c(i) * d(i)
- 1	continue
-	a(1) = 0.0d0
-	a(n) = 0.0d0
-	return
-	end
Index: unk/LMDZ.MARS/libf/phymars/tcr_15um.h
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/tcr_15um.h	(revision 497)
+++ 	(revision )
@@ -1,92 +1,0 @@
-c****************************************************************************
-c
-c       tcr_15um.cmn
-c 
-c       Common blocks of coefficients and constants for NLTE CR 
-c       (for the NLTE driver table)
-c     
-c       JAN 98  MALV            Based on SOLAR10s mztv1.cmn
-c       MAR 2010 FGG            Adaptation to GCM
-c****************************************************************************
-c
-      integer   irw_mztf,imu,ioverlap,nw,itt_cza,icls_mztf,nan
-c
-      parameter (irw_mztf     = 2)
-      parameter (imu          = 1)
-      parameter (ioverlap     = 0)
-      parameter (nw           = 3)
-      parameter (itt_cza      = 13)
-      parameter (icls_mztf    = 5)
-      parameter (nan          = 0)
-c
-c 
-      integer iopt3, iopt19,iopt20, iopt21,iopt27,iopt26
-c
-      parameter (iopt3        = 1)
-      parameter (iopt19       = 2)
-      parameter (iopt20       = 2)
-      parameter (iopt21       = 1)
-      parameter (iopt27       = 1)
-      parameter (iopt26       = 2)
-c
-c
-      integer	iopt41,iopt43, iopt6
-c
-      parameter (iopt6        = 2)
-      parameter (iopt41       = 2)
-      parameter (iopt43       = 2)
-c
-c
-      real   tsurf_excess,Pbottom_atm,Ptop_atm
-c
-      parameter (tsurf_excess = 0.)
-      parameter (Pbottom_atm  = 2.e-5)
-      parameter (Ptop_atm     = 5.e-12)
-c
-c
-      real*8 rf1,rf2desac,rf2iso,rf3,rf6
-c
-      parameter (rf1          = 1.d0)
-      parameter (rf2desac     = 1.d0)
-      parameter (rf2iso       = 1.d0)
-      parameter (rf3          = 1.d0)
-      parameter (rf6          = 1.d0)  
-c
-c
-      real*8 rf7,rf19,rf20,rf21a,rf21b,rf21c 
-c
-      parameter (rf7          = 1.d0)
-      parameter (rf19         = 1.d0)
-      parameter (rf20         = 1.d0)
-      parameter (rf21a        = 1.d0)
-      parameter (rf21b        = 1.d0)
-      parameter (rf21c        = 1.d0)
-c
-c
-      real*8 rf26,rf27f,rf27s,rf28,rf31,rf32,rf33a,rf33bc
-c
-      parameter (rf26         = 1.d0)
-      parameter (rf27f        = 1.d0)
-      parameter (rf27s        = 1.d0)
-      parameter (rf28         = 1.d0)
-      parameter (rf31         = 1.d0)
-      parameter (rf32         = 1.d0)
-      parameter (rf33a        = 1.d0)
-      parameter (rf33bc       = 1.d0)
-c
-c
-      real*8 rf41,rf42,rf43,rf_hcl,rf44
-c
-      parameter (rf41         = 1.d0)
-      parameter (rf42         = 1.d0)
-      parameter (rf43         = 1.d0)
-      parameter (rf_hcl       = 1.d0)
-      parameter (rf44         = 1.d0)
-c
-c                  
-      real*8 frac6,frac21,frac33
-c
-      parameter (frac6        = 1.d0)
-      parameter (frac21       = 1.d0)
-      parameter (frac33       = 1.d0)                   
-
Index: unk/LMDZ.MARS/libf/phymars/tcrco2_subrut.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/tcrco2_subrut.F	(revision 497)
+++ 	(revision )
@@ -1,157 +1,0 @@
-c***********************************************************************
-c	tcrco2_subrut.f                              
-c                                               
-c	jan 98 	malv    version for mz1d. copied from solar10/mz4sub.f         
-c       jul 2011 malv+fgg   adapted to LMD-MGCM
-c***********************************************************************
-                                                
-************************************************************************
-                                                
-	subroutine dinterconnection ( v, vt )          
-                                                
-*  input: vib. temp. from che*.for programs, vt(nl)         
-*  output: test vibrational temp. for other che*.for, v(nl) 
-! iconex_smooth=1  ==>  with smoothing          
-! iconex_smooth=0  ==>  without smoothing       
-! iconex_tk=40  ==>  with forced lte up to 40 km            
-! iconex_tk=20  ==>  with forced lte up to 20 km            
-************************************************************************
-                                                
-        implicit none                           
-	include 'nltedefs.h'          
-                                                
-c argumentos                                    
-	real*8 vt(nl), v(nl)                           
-                                                
-c local variables                               
-	integer 	i                                     
-                                                
-c   *************                               
-                                                
-	do i=1,nl                                      
-	  v(i) = vt(i)                                 
-	end do                                         
-                                                
-! lo siguiente se utilizaba en solar10, pero es mejor introducirlo en   
-! la driver. por ahora no lo uso todavia.       
-!	call fluctua(v,iconex_fluctua)                
-!	call smooth_nl(v,iconex_smooth,nl)               
-!	call forzar_tk(v,iconex_tk)                   
-                                                
-	return                                         
-	end                  
-                                                
-c***********************************************************************
-	subroutine smooth_nl(y,nlx,nl) 
-                                                
-c	returns smoothed y                            
-c***********************************************************************
-                                                
-        implicit none                           
-                                                
-c arguments                          
-        integer         nl      ! Dimension of vectors
-	integer 	nlx	! i. =0 ==> no smoothing          
-                                !    =m ==> smoothing from point m up to nl
-	real*8		y(nl)	! o. is returned after smoothed  
-                                                
-c local variables and constants                 
-	integer 	i  , nlmax   
-        parameter ( nlmax=250 )         ! Llevarse esto al mz1d.par !
-	real*8 		x(nlmax)                                 
-                                                
-c   ***************                             
-                                                
-	if (nlx.eq.0) return                          
-                                                
-	do i=nlx,nl                                    
-	  x(i)=y(i)                                    
-	  y(i)=0.                                      
-	end do                                         
-                                                
-	do i=nlx,nl                                    
-	  if(i.eq.nlx)then                             
-		 y(i)=x(i)                                    
-	  elseif(i.eq.nl)then                          
-		 y(i)=2.*y(i-1)-y(i-2)                        
-	  else                                         
-		 y(i)=(x(i+1)/2.+x(i)+x(i-1)/2.)/2.           
-	  end if                                       
-	end do	                                        
-                                                
-	return                                         
-	end                                            
-                                                
-c***********************************************************************
-	function planckdp(tp,xnu)                      
-c	returns the black body function at wavenumber xnu and temperature t.  
-c***********************************************************************
-                                                
-	implicit none                                  
-
-        include 'nltedefs.h'
-	include 'nlte_data.h'      
-!        common/datis/ pi, vlight, ee, hplanck, gamma, ab,
-!     @       n_avog, GG, R0, cte_sb, kboltzman,  raddeg
-!        real*8  pi, vlight, ee, hplanck, gamma, ab,
-!     @       n_avog, GG, R0, cte_sb, kboltzman,  raddeg
-
-	real*8 planckdp                                
-	real*8 xnu                                     
-	real tp                                        
-                                                
-	planckdp = gamma*xnu**3.0 / exp( ee*xnu/dble(tp) )             
-	!erg cm-2.sr-1/cm-1.                           
-                                                
-	return                                         
-	end                                            
-c***********************************************************************
-	function planckdpdp(tp,xnu)                      
-c	returns the black body function at wavenumber xnu and temperature t.  
-c***********************************************************************
-                                                
-	implicit none                                  
-
-        include 'nltedefs.h'
-	include 'nlte_data.h'      
-!        common/datis/ pi, vlight, ee, hplanck, gamma, ab,
-!     @       n_avog, GG, R0, cte_sb, kboltzman,  raddeg
-!        real*8  pi, vlight, ee, hplanck, gamma, ab,
-!     @       n_avog, GG, R0, cte_sb, kboltzman,  raddeg
-
-	real*8 planckdpdp                               
-	real*8 xnu                                     
-	real*8 tp                                        
-                                                
-	planckdpdp = gamma*xnu**3.0 / exp( ee*xnu/dble(tp) )             
-	!erg cm-2.sr-1/cm-1.                           
-                                                
-	return                                         
-	end                                            
-c       ****************************************************************
-	function bandid (ib)                           
-c       returns the 2 character code of the band            
-c       ****************************************************************
-        implicit none                           
-                                                
-        integer ib                              
-        character*2 bandid                      
-                                                
-132     format(i2)                              
-!        encode (2,132,bandid) ib                
-        write ( bandid, 132) ib                
-                                                
-        if ( ib .eq. 1 ) bandid = '01'          
-        if ( ib .eq. 2 ) bandid = '02'          
-        if ( ib .eq. 3 ) bandid = '03'          
-        if ( ib .eq. 4 ) bandid = '04'          
-        if ( ib .eq. 5 ) bandid = '05'          
-        if ( ib .eq. 6 ) bandid = '06'          
-        if ( ib .eq. 7 ) bandid = '07'          
-        if ( ib .eq. 8 ) bandid = '08'          
-        if ( ib .eq. 9 ) bandid = '09'          
-        if ( ib .eq. 0 ) bandid = '00'          
-                                                
-c end                                           
-        return                                  
-        end                                     
Index: unk/LMDZ.MARS/libf/phymars/trucodiag.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/trucodiag.F	(revision 497)
+++ 	(revision )
@@ -1,28 +1,0 @@
-c	***********************************************************************
-	subroutine trucodiag(a,b,c,d,e,n)
-c       inputs: matrices b,c,d,e
-c       output: matriz diagonal a
-c       Operacion a realizar:  a = b * c^(-1) * d + e
-c       La matriz c va a ser invertida
-c       Todas las matrices de entrada son diagonales excepto b
-c       Aprovechamos esa condicion para invertir c, acelerar el calculo, y 
-c       ademas, para forzar que a sea diagonal
-c       jul 2011 malv+fgg
-c	***********************************************************************
-	real*8 a(n,n),b(n,n),c(n,n),d(n,n),e(n,n), sum
-	integer n,i,j,k
-	do 1,i=2,n-1
-	  sum=0.0d0
-	  do 2,j=2,n-1
-	    sum=sum+ (b(i,j)) * (d(j,j)/c(j,j))
- 2	  continue
-	  a(i,i) = sum + e(i,i)
- 1	continue
-	do k=1,n
-	  a(n,k) = 0.0d0
-	  a(1,k) = 0.0d0
-	  a(k,1) = 0.0d0
-	  a(k,n) = 0.0d0
-	end do
-	return
-	end
Index: unk/LMDZ.MARS/libf/phymars/trucommv.F
===================================================================
--- /trunk/LMDZ.MARS/libf/phymars/trucommv.F	(revision 497)
+++ 	(revision )
@@ -1,23 +1,0 @@
-c	***********************************************************************
-	subroutine trucommvv(v,b,c,u,w,n)
-c       inputs: matrices b,c , vectores u,w
-c       output: vector v 
-c       Operacion a realizar:  v = b * c^(-1) * u + w
-c       La matriz c va a ser invertida 
-c       c es diagonal, b no
-c       Aprovechamos esa condicion para invertir c, y acelerar el calculo
-c       jul 2011 malv+fgg  
-c	***********************************************************************
-	real*8 v(n),b(n,n),c(n,n),u(n),w(n), sum
-	integer n,i,j,k
-	do 1,i=2,n-1
-	  sum=0.0d0
-	  do 2,j=2,n-1
-	    sum=sum+ (b(i,j)) * (u(j)/c(j,j))
- 2	  continue
-	  v(i) = sum + w(i)
- 1	continue
-	v(1) = 0.d0
-	v(n) = 0.d0
-	return
-	end
