Changeset 757 for trunk/LMDZ.MARS/libf

Timestamp:

Aug 7, 2012, 3:14:07 PM (12 years ago)

Author:

emillour

Message:

Mars GCM:

• Improvement of the NLTE 15um scheme (for running with nltemodel = 2); now MUCH faster than previously (by a factor 5 or so):
• Improvements included to the parameterization:
  • Cool-to-space calculation included above P(atm)=1e-10, with a soft merging to the full result (without the CTS approximation) below that level
  • exhaustive cleaning of the code, including FTNCHK and reordering of loops, subroutines and internal calls
  • simplification of the precomputed tables of CO2 bands' atmospheric transmittances
  • the two internal grids (the one used in the CTS region and the one below) have been , in order to reduce the CPU time consumption
  • reading of the spectroscopic histograms is made only once, at the beginning of the GCM, to avoid repetitive readings of ASCII files
  • F90 matrix operations (matmul,...) included.
• Changes in routines:
  • removed nlte_leedat.F
  • updated nlte_calc.F, nlte_tcool.F, nlte_aux.F
  • updated nlte_commons.h, nlte_paramdef.h
  • added nlte_setup.F
• Important: The input files (in the NLTEDAT directory) read as input by these routines have changed. the NLTEDAT directory should now on contain only the following files:

deltanu26.dat enelow27.dat hid26-3.dat parametp_Tstar_IAA1204.dat
deltanu27.dat enelow28.dat hid26-4.dat parametp_VC_IAA1204.dat
deltanu28.dat enelow36.dat hid27-1.dat
deltanu36.dat hid26-1.dat hid28-1.dat
enelow26.dat hid26-2.dat hid36-1.dat

FGG+MALV

Location:

trunk/LMDZ.MARS/libf/phymars

Files:

• nlte_aux.F (modified) (16 diffs)
• nlte_calc.F (modified) (1 diff)
• nlte_commons.h (modified) (2 diffs)
• nlte_leedat.F (deleted)
• nlte_paramdef.h (modified) (2 diffs)
• nlte_setup.F (added)
• nlte_tcool.F (modified) (13 diffs)
• physiq.F (modified) (2 diffs)

trunk/LMDZ.MARS/libf/phymars/nlte_aux.F

@@ +1 @@
+c**********************************************************************
+
+c     Includes the following old 1-D model files/subroutines
+
+c     -MZTCRSUB_dlvr11.f
+c     *dinterconnection
+c     *planckd
+c     *leetvt
+c     -MZTFSUB_dlvr11_02.f
+c     *initial
+c     *intershphunt
+c     *interstrhunt
+c     *intzhunt
+c     *intzhunt_cts
+c     *rhist
+c     *we_clean
+c     *mztf_correccion
+c     *mzescape_normaliz
+c     *mzescape_normaliz_02
+c     -interdpESCTVCISO_dlvr11.f
+c     -hunt_cts.f
+c     -huntdp.f
+c     -hunt.f
+c     -interdp_limits.f
+c     -interhunt2veces.f
+c     -interhunt5veces.f
+c     -interhuntdp3veces.f
+c     -interhuntdp4veces.f
+c     -interhuntdp.f
+c     -interhunt.f
+c     -interhuntlimits2veces.f
+c     -interhuntlimits5veces.f
+c     -interhuntlimits.f
+c     -lubksb_dp.f
+c     -ludcmp_dp.f
+c     -LUdec.f
+c     -mat_oper.f
+c     *unit
+c     *diago
+c     *invdiag
+c     *samem
+c     *mulmv
+c     *trucodiag
+c     *trucommvv
+c     *sypvmv
+c     *mulmm
+c     *resmm
+c     *sumvv
+c     *sypvvv
+c     *zerom
+c     *zero4m
+c     *zero3m
+c     *zero2m
+c     *zerov
+c     *zero4v
+c     *zero3v
+c     *zero2v
+c     -suaviza.f
+
+c**********************************************************************
+
+
+c     *** Old MZTCRSUB_dlvr11.f ***
+
+!************************************************************************
+
+!      subroutine dinterconnection ( v, vt )
+
+
+************************************************************************
+
+!      implicit none
+!      include 'nlte_paramdef.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
+
+!      return
+!      end
+
 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                                  
+      function planckdp(tp,xnu)
 c***********************************************************************
-                                                
-c     ****************************************************************
-      subroutine initial                             
-                                                
-c     ma & crs  !evita troubles 16-july-96           
-c     ****************************************************************
-                                                
-      implicit none                                  
-                                                
+
+      implicit none
+
+      include 'nlte_paramdef.h'
+
+      real*8 planckdp
+      real*8 xnu
+      real tp
+
+      planckdp = gamma*xnu**3.0d0 / exp( ee*xnu/dble(tp) )
+                                !erg cm-2.sr-1/cm-1.
+
+c     end
+      return
+      end
+
+c***********************************************************************
+      subroutine leetvt
+
+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                                  
-      
+
+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
+
+      do i=1,nl
+         zld(i) = dble( zl(i) )
+      enddo
+      call interhuntdp4veces ( v626t1,v628t1,v636t1,v627t1, zld,nl,
+     $     xvt11, xvt21, xvt31, xvt41, zyd,nzy, 1 )
+
+
+c     end
+      return
+      end
+
+
+c     *** MZTFSUB_dlvr11_02.f ***
+
+
+c     ****************************************************************
+      subroutine initial
+
+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     local variables
+      integer   i
+
+c     ***************
+
+      eqw = 0.0d00
+      aa = 0.0d00
+      cc = 0.0d00
+      dd = 0.0d00
+
+      do i=1,nbox
+         ccbox(i) = 0.0d0
+         ddbox(i) = 0.0d0
+      end do
+
+      return
+      end
+
 c     **********************************************************************
-      subroutine interstrength (stx, ts, sx, xtemp)  
-c     interpolates the line strength at a temperature xtemp from            
-c     input histogram data.                         
+
+      subroutine intershphunt (i, alsx,adx,xtemp)
+
 c     **********************************************************************
-                                                
-      implicit none                                  
-                                                
+
+      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     arguments
+      real*8 alsx(nbox_max),adx(nbox_max) ! Output
+      real*8 xtemp(nbox_max)    ! Input
+      integer    i              ! I , O
+
+c     local variables
+      integer   k
+      real*8          factor
+      real*8    temperatura     ! para evitar valores ligeramnt out of limits
+
+c     ***********
+
+      do 1, k=1,nbox_max
+         temperatura = xtemp(k)
+         if (abs(xtemp(k)-thist(1)).le.0.01d0) then
+            temperatura=thist(1)
+         elseif (abs(xtemp(k)-thist(nhist)).le.0.01d0) then
+            temperatura=thist(nhist)
+         endif
+         call huntdp ( thist,nhist, temperatura, i )
+         if ( i.eq.0 .or. i.eq.nhist ) then
+            write (*,*) ' HUNT/ Limits input grid:',
+     @           thist(1),thist(nhist)
+            write (*,*) ' HUNT/ location in new grid:', xtemp(k)
+            stop ' INTERSHP/ Interpolation error. T out of Histogram.'
+         endif
+         factor = 1.d0 /  (thist(i+1)-thist(i))
+         alsx(k) = (( xls1(i,k)*(thist(i+1)-xtemp(k)) +
+     @        xls1(i+1,k)*(xtemp(k)-thist(i)) )) * factor
+         adx(k)  = (( xld1(i,k)*(thist(i+1)-xtemp(k)) +
+     @        xld1(i+1,k)*(xtemp(k)-thist(i)) )) * factor
+ 1    continue
+
+      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                          
+
+      subroutine interstrhunt (i, stx, ts, sx, xtemp )
+
 c     **********************************************************************
-                                                
-      implicit none                                  
+
+      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     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
+      integer   i
+
+c     local variables
+      integer   k
+      real*8          factor
+      real*8    temperatura
+
+c     ***********
+
+      do 1, k=1,nbox
+         temperatura = xtemp(k)
+         if (abs(xtemp(k)-thist(1)).le.0.01d0) then
+            temperatura=thist(1)
+         elseif (abs(xtemp(k)-thist(nhist)).le.0.01d0) then
+            temperatura=thist(nhist)
+         endif
+         call huntdp ( thist,nhist, temperatura, i )
+         if ( i.eq.0 .or. i.eq.nhist ) then
+            write(*,*)'HUNT/ Limits input grid:',thist(1),thist(nhist)
+            write(*,*)'HUNT/ location in new grid:',xtemp(k)
+            stop'INTERSTR/1/ Interpolation error. T out of Histogram.'
+         endif
+         factor = 1.d0 /  (thist(i+1)-thist(i))
+         sx(k) = ( sk1(i,k)   * (thist(i+1)-xtemp(k))
+     @        + sk1(i+1,k) * (xtemp(k)-thist(i))  ) * factor
+ 1    continue
+
+
+      temperatura = ts
+      if (abs(ts-thist(1)).le.0.01d0) then
+         temperatura=thist(1)
+      elseif (abs(ts-thist(nhist)).le.0.01d0) then
+         temperatura=thist(nhist)
+      endif
+      call huntdp ( thist,nhist, temperatura, i )
+      if ( i.eq.0 .or. i.eq.nhist ) then
+         write (*,*) ' HUNT/ Limits input grid:',
+     @        thist(1),thist(nhist)
+         write (*,*) ' HUNT/ location in new grid:', ts
+         stop ' INTERSTR/2/ Interpolat error. T out of Histogram.'
+      endif
+      factor = 1.d0 /  (thist(i+1)-thist(i))
+      stx = 0.d0
+      do k=1,nbox
+         stx = stx + no(k) * ( sk1(i,k)*(thist(i+1)-ts) +
+     @        sk1(i+1,k)*(ts-thist(i)) ) * factor
+      end do
+
+
+      return
+      end
+
 c     **********************************************************************
-      real*8 function iaa_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       
+
+      subroutine intzhunt (k, h, aco2,ap,amr,at, con)
+
+c     k lleva la posicion de la ultima llamada a intz , necesario para
+c     que esto represente una aceleracion real.
 c     **********************************************************************
-                                                
-      implicit none                                  
-      
+
+      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 
-         iaa_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
-
-         iaa_we = sqrt( parentesis )
-!          write (*,*)  ' from iaa_we: xdop,alda,wd', sngl(x),alda(kr),sngl(wd)
-!          write (*,*)  ' from iaa_we: we', iaa_we                             
-
-      else                                           
-
-         iaa_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) iaa_we = wd                         
-      
-      if ( idummy.gt.9 )
-     @     write (*,*) ' wl,wd,w =', wl,wd,iaa_we
-      
-      wsL = wl 
-
-      return                                         
-      end                                            
-                                                
-      
+
+c     arguments
+      real              h       ! i
+      real*8            con(nzy) ! i
+      real*8            aco2, ap, at, amr ! o
+      integer           k       ! i
+
+c     local variables
+      real          factor
+
+c     ************
+
+      call hunt ( zy,nzy, h, k )
+      factor =  (h-zy(k)) /  (zy(k+1)-zy(k))
+      ap = dble( exp( log(py(k)) + log(py(k+1)/py(k)) * factor ) )
+      aco2 = dlog(con(k)) + dlog( con(k+1)/con(k) ) * dble(factor)
+      aco2 = exp( aco2 )
+      at = dble( ty(k) + (ty(k+1)-ty(k)) * factor )
+      amr = dble( mr(k) + (mr(k+1)-mr(k)) * factor )
+
+
+      return
+      end
+
 c     **********************************************************************
-      real*8 function simrul(a,b,fsim,c,acc)         
-c     adaptively integrates fsim from a to b, within the criterion acc.     
+
+      subroutine intzhunt_cts (k, h, nzy_cts_real, 
+     @     aco2,ap,amr,at, con)
+
+c     k lleva la posicion de la ultima llamada a intz , necesario para
+c     que esto represente una aceleracion real.
 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                                  
+
+      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            iaa_we                                    
-      real*8            iaa_f, iaa_fi, simrul                          
-                                                
-      external iaa_f,iaa_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 = iaa_we(ig,ua(kr),pt,pp, idummy, c1,p1, Desp, wsL )  
-            return                                        
-         end if                                      
-         ept=iaa_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 = iaa_we(ig,sl_ua,pt,pp, idummy,c1,p1, Desp, wsL)
-            return                                        
-         end if                                      
-         ept=iaa_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/iaa_f(0.d0)        !width of doppler shifted atmospheric line.    
-      w = 2.0*( simrul(0.0d0,xa,iaa_f,c,eps)
-     .        + simrul(0.1d0,1.0/xa,iaa_fi,c,eps) )
-!no shift.                                      
-                                                
-      return                                     
-      end                                            
-                                                
-                                                
+
+c     arguments
+      real              h       ! i
+      real*8            con(nzy_cts) ! i
+      real*8            aco2, ap, at, amr ! o
+      integer           k       ! i
+      integer         nzy_cts_real ! i
+
+c     local variables
+      real          factor
+
+c     ************
+
+      call hunt_cts ( zy_cts,nzy_cts, nzy_cts_real, h, k )
+      factor =  (h-zy_cts(k)) /  (zy_cts(k+1)-zy_cts(k))
+      ap = dble( exp( log(py_cts(k)) +
+     @     log(py_cts(k+1)/py_cts(k)) * factor ) )
+      aco2 = dlog(con(k)) + dlog( con(k+1)/con(k) ) * dble(factor)
+      aco2 = exp( aco2 )
+      at = dble( ty_cts(k) + (ty_cts(k+1)-ty_cts(k)) * factor )
+      amr = dble( mr_cts(k) + (mr_cts(k+1)-mr_cts(k)) * factor )
+
+
+      return
+      end
+
+
 c     **********************************************************************
-      double precision function iaa_fi(y)                
-c     returns the value of f(1/y)                   
+
+      real*8 function we_clean  ( y,pl, xalsa, xalda )
+
 c     **********************************************************************
-                                                
-      implicit none                                  
-      real*8 iaa_f, y                                    
-                                                
-      iaa_fi=iaa_f(1.0/y)/y**2                               
-      return                                         
-      end                                            
-                                                
-                                                
-c     **********************************************************************
-      double precision function iaa_f(nuaux)                
-c     calculates 1-exp(-k(nu)u) for all series paths or combinations thereof
-c     **********************************************************************
-                                                
-      implicit none                                  
+
+      implicit none
+
+      include 'nlte_paramdef.h'
+
+c     arguments
+      real*8            y       ! I. path's absorber amount * strength
+      real*8          pl        ! I. path's partial pressure of CO2
+      real*8          xalsa     ! I.  Self lorentz linewidth for 1 isot & 1 box
+      real*8          xalda     ! I.  Doppler linewidth        "           "
+
+c     local variables
+      integer   i
+      real*8            x,wl,wd,wvoigt
+      real*8            cn(0:7),dn(0:7)
+      real*8          factor, denom
+      real*8          pi, pi2, sqrtpi
+
+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     ***********
+
+      pi = 3.141592
+      pi2= 6.28318531
+      sqrtpi = 1.77245385
+
+      x=y / ( pi2 * xalsa*pl )
+
+
+c     Lorentz
+      wl=y/sqrt(1.0d0+pi*x/2.0d0)
+
+c     Doppler
+      x = y / (xalda*sqrtpi)
+      if (x .lt. 5.0d0) then
+         wd = cn(0)
+         factor = 1.d0
+         do i=1,7
+            factor = factor * x
+            wd = wd + cn(i) * factor
+         end do
+         wd = xalda * x * sqrtpi * wd
+      else
+         wd = dn(0)
+         factor = 1.d0 / log(x)
+         denom = 1.d0
+         do i=1,7
+            denom = denom * factor
+            wd = wd + dn(i) * denom
+         end do
+         wd = xalda * sqrt(log(x)) * wd
+      end if
+
+c     Voigt
+      wvoigt = wl*wl + wd*wd - (wd*wl/y)*(wd*wl/y)
+
+      if ( wvoigt .lt. 0.0d0 ) then
+         write (*,*) ' Subroutine WE/ Error in Voift EQS calculation '
+         write (*,*) '  WL, WD, X, Y = ', wl, wd, x, y
+         stop '  ERROR : Imaginary EQW. Revise spectral data. '
+      endif
+
+      we_clean = sqrt( wvoigt )
+
+
+      return
+      end
+
+
+c     ***********************************************************************
+
+      subroutine mztf_correccion (coninf, con, ib )
+
+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))     
+
+c     arguments
+      integer           ib
+      real*8            con(nzy), coninf
+
+!     local variables
+      integer   i, isot
+      real*8    tvt0(nzy), tvtbs(nzy), zld(nl),zyd(nzy)
+      real*8  xqv, xes, xlower, xfactor
+
+c     *********
+
+      isot = 1
+      nu11 = dble( nu(1,1) )
+
+      do i=1,nzy
+         zyd(i) = dble(zy(i))
+      enddo
+      do i=1,nl
+         zld(i) = dble( zl(i) )
+      end do
+
+!     tvtbs
+      call interhuntdp (tvtbs,zyd,nzy, v626t1,zld,nl, 1 )
+
+!     tvt0
+      if (ib.eq.2 .or. ib.eq.3 .or. ib.eq.4) then
+         call interhuntdp (tvt0,zyd,nzy, v626t1,zld,nl, 1 )
       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                                         
-                                                
-      iaa_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     ************************************************************************
+         do i=1,nzy
+            tvt0(i) = dble( ty(i) )
+         end do
+      end if
+
+c     factor
+      do i=1,nzy
+
+         xlower = exp( ee*dble(elow(isot,ib)) *
+     @        ( 1.d0/dble(ty(i))-1.d0/tvt0(i) ) )
+         xes = 1.0d0
+         xqv = ( 1.d0-exp( -ee*nu11/tvtbs(i) ) ) /
+     @        (1.d0-exp( -ee*nu11/dble(ty(i)) ))
+         xfactor = xlower * xqv**2.d0 * xes
+
+         con(i) = con(i) * xfactor
+         if (i.eq.nzy) coninf = coninf * xfactor
+
+      end do
+
+
+      return
+      end
+
+
+c     ***********************************************************************
+
+      subroutine mzescape_normaliz ( taustar, istyle )
+
+c     ***********************************************************************
+
+      implicit none
+      include 'nlte_paramdef.h'
+
+c     arguments
+      real*8            taustar(nl) ! o
+      integer         istyle    ! i
+
+c     local variables and constants
+      integer   i, imaximum
+      real*8          maximum
+
+c     ***************
+
+      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
+
+      do i=1,nl
+         taustar(i) = taustar(i) / maximum
+      enddo
+
+
+c     end
+      return
+      end
+
+c     ***********************************************************************
+
+      subroutine mzescape_normaliz_02 ( taustar, nn, istyle )
+
+c     ***********************************************************************
+
+      implicit none
+
+c     arguments
+      real*8            taustar(nn) ! i,o
+      integer         istyle    ! i
+      integer         nn        ! i
+
+c     local variables and constants
+      integer   i, imaximum
+      real*8          maximum
+
+c     ***************
+
+      taustar(nn) = taustar(nn-1)
+
+      if ( istyle .eq. 1 ) then
+         imaximum = nn
+         maximum = taustar(nn)
+         do i=1,nn-1
+            if (taustar(i).gt.maximum) taustar(i) = taustar(nn)
+         enddo
+      elseif ( istyle .eq. 2 ) then
+         imaximum = nn
+         maximum = taustar(nn)
+         do i=nn-1,1,-1
+            if (taustar(i).gt.maximum) then
+               maximum = taustar(i)
+               imaximum = i
+            endif
+         enddo
+         do i=imaximum,nn
+            if (taustar(i).lt.maximum) taustar(i) = maximum
+         enddo
+      endif
+
+      do i=1,nn
+         taustar(i) = taustar(i) / maximum
+      enddo
+
+
+c     end
+      return
+      end
+
+
+c     *** interdp_ESCTVCISO_dlvr11.f ***
+
+c***********************************************************************
+
+      subroutine interdp_ESCTVCISO
+
+c***********************************************************************
 
       implicit none
@@ -833 +622 @@
       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))
+c     local variables
+      integer    i
+      real*8     lnpnb(nl)
+
+
+c***********************************************************************
+
+c     Use pressure in the NLTE grid but in log and in nb
+      do i=1,nl
+         lnpnb(i) = log( dble( pl(i) * 1013.25 * 1.e6) )
+      enddo
+
+c     Interpolations
+
+      call interhuntdp3veces
+     @     ( taustar21,taustar31,taustar41,    lnpnb, nl,
+     @     tstar21tab,tstar31tab,tstar41tab, lnpnbtab, nztabul,
+     @     1 )
+
+      call interhuntdp3veces ( vc210,vc310,vc410, lnpnb, nl,
+     @     vc210tab,vc310tab,vc410tab, lnpnbtab, nztabul, 2 )
+
+c     end
+      return
+      end
+
+
+c     *** hunt_cts.f ***
+
+cccc  
+      SUBROUTINE hunt_cts(xx,n,n_cts,x,jlo)  
+c     
+c     La dif con hunt es el uso de un indice superior (n_cts) mas bajito que (n)
+c     
+c     Arguments
+      INTEGER jlo               ! O
+      INTEGER n                 ! I
+      INTEGER n_cts             ! I
+      REAL  xx(n)               ! I
+      REAL  x                   ! I
+
+c     Local variables
+      INTEGER inc,jhi,jm  
+      LOGICAL ascnd  
+c     
+cccc  
+c     
+      ascnd=xx(n_cts).ge.xx(1)  
+      if(jlo.le.0.or.jlo.gt.n_cts)then  
+         jlo=0  
+         jhi=n_cts+1  
+         goto 3  
+      endif  
+      inc=1  
+      if(x.ge.xx(jlo).eqv.ascnd)then  
+ 1       jhi=jlo+inc  
+!     write (*,*) jlo
+         if(jhi.gt.n_cts)then  
+            jhi=n_cts+1  
+!     write (*,*) jhi-1
+         else if(x.ge.xx(jhi).eqv.ascnd)then  
+            jlo=jhi  
+            inc=inc+inc  
+!     write (*,*) jlo
+            goto 1  
+         endif  
+      else  
+         jhi=jlo  
+ 2       jlo=jhi-inc  
+!     write (*,*) jlo
+         if(jlo.lt.1)then  
+            jlo=0  
+         else if(x.lt.xx(jlo).eqv.ascnd)then  
+            jhi=jlo  
+            inc=inc+inc  
+            goto 2  
+         endif  
+      endif  
+ 3    if(jhi-jlo.eq.1)then  
+         if(x.eq.xx(n_cts))jlo=n_cts-1  
+         if(x.eq.xx(1))jlo=1  
+!     write (*,*) jlo
+         return  
+      endif  
+      jm=(jhi+jlo)/2  
+      if(x.ge.xx(jm).eqv.ascnd)then  
+         jlo=jm  
+      else  
+         jhi=jm  
+      endif  
+!     write (*,*) jhi-1
+      goto 3  
+c     
+      END  
+
       
- 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
+c     *** huntdp.f ***
+
+cccc  
+      SUBROUTINE huntdp(xx,n,x,jlo)  
+c     
+c     Arguments
+      INTEGER jlo               ! O
+      INTEGER n                 ! I
+      REAL*8  xx(n)             ! I
+      REAL*8  x                 ! I
+
+c     Local variables
+      INTEGER inc,jhi,jm  
+      LOGICAL ascnd  
+c     
+cccc  
+c     
+      ascnd=xx(n).ge.xx(1)  
+      if(jlo.le.0.or.jlo.gt.n)then  
+         jlo=0  
+         jhi=n+1  
+         goto 3  
+      endif  
+      inc=1  
+      if(x.ge.xx(jlo).eqv.ascnd)then  
+ 1       jhi=jlo+inc  
+         if(jhi.gt.n)then  
+            jhi=n+1  
+         else if(x.ge.xx(jhi).eqv.ascnd)then  
+            jlo=jhi  
+            inc=inc+inc  
+            goto 1  
+         endif  
+      else  
+         jhi=jlo  
+ 2       jlo=jhi-inc  
+         if(jlo.lt.1)then  
+            jlo=0  
+         else if(x.lt.xx(jlo).eqv.ascnd)then  
+            jhi=jlo  
+            inc=inc+inc  
+            goto 2  
+         endif  
+      endif  
+ 3    if(jhi-jlo.eq.1)then  
+         if(x.eq.xx(n))jlo=n-1  
+         if(x.eq.xx(1))jlo=1  
+         return  
+      endif  
+      jm=(jhi+jlo)/2  
+      if(x.ge.xx(jm).eqv.ascnd)then  
+         jlo=jm  
+      else  
+         jhi=jm  
+      endif  
+      goto 3  
+c     
+      END  
+
       
-      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 !!!!!!!!!!!!!!
+c     *** hunt.f ***
+
+cccc  
+      SUBROUTINE hunt(xx,n,x,jlo)  
+c     
+c     Arguments
+      INTEGER jlo               ! O
+      INTEGER n                 ! I
+      REAL  xx(n)               ! I
+      REAL  x                   ! I
+
+c     Local variables
+      INTEGER inc,jhi,jm  
+      LOGICAL ascnd  
+c     
+cccc  
+c     
+      ascnd=xx(n).ge.xx(1)  
+      if(jlo.le.0.or.jlo.gt.n)then  
+         jlo=0  
+         jhi=n+1  
+         goto 3  
+      endif  
+      inc=1  
+      if(x.ge.xx(jlo).eqv.ascnd)then  
+ 1       jhi=jlo+inc  
+!     write (*,*) jlo
+         if(jhi.gt.n)then  
+            jhi=n+1  
+!     write (*,*) jhi-1
+         else if(x.ge.xx(jhi).eqv.ascnd)then  
+            jlo=jhi  
+            inc=inc+inc  
+!     write (*,*) jlo
+            goto 1  
+         endif  
+      else  
+         jhi=jlo  
+ 2       jlo=jhi-inc  
+!     write (*,*) jlo
+         if(jlo.lt.1)then  
+            jlo=0  
+         else if(x.lt.xx(jlo).eqv.ascnd)then  
+            jhi=jlo  
+            inc=inc+inc  
+            goto 2  
+         endif  
+      endif  
+ 3    if(jhi-jlo.eq.1)then  
+         if(x.eq.xx(n))jlo=n-1  
+         if(x.eq.xx(1))jlo=1  
+!     write (*,*) jlo
+         return  
+      endif  
+      jm=(jhi+jlo)/2  
+      if(x.ge.xx(jm).eqv.ascnd)then  
+         jlo=jm  
+      else  
+         jhi=jm  
+      endif  
+!     write (*,*) jhi-1
+      goto 3  
+c     
+      END  
+
       
-      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)
+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 usarann 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     ***********************************************************************
+
+      implicit none
+
+!     Arguments 
+      integer   n,m             ! I. Dimensions
+      integer   i1, i2, j1, j2, opt ! I
+      real*8            zz(m)   ! I
+      real*8            yy(m)   ! O
+      real*8            z(n),y(n) ! I
+
+!     Local variables
+      integer   i,j
+      real*8            zmin,zzmin,zmax,zzmax
+
+c     *******************************
+
+!     write (*,*) ' 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)
+      zmin=minval(z(j1:j2))
+      zzmin=minval(zz(i1:i2))
+      zmax=maxval(z(j1:j2))
+      zzmax=maxval(zz(i1:i2))
 
       if(zzmin.lt.zmin)then
@@ -1462 +895 @@
          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
+!     elseif(zzmax.gt.zmax)then
+!     type *,'from interp: new variable out of limits'
+!     type *,zzmax, 'must be .le. ',zmax
+!     stop
       end if
 
@@ -1572 +906 @@
             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
+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))
+            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
@@ -1590 +924 @@
          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)
+!     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
@@ -1610 +944 @@
 
 
-
-c*****************************************************************************
-c     Subroutines previously included in tcrco2_subrut.F
+c     *** interhunt2veces.f ***
+
+c     ***********************************************************************
+
+      subroutine interhunt2veces ( y1,y2,  zz,m, 
+     @     x1,x2,  z,n,  opt)
+
+c     interpolation soubroutine basada en Numerical Recipes HUNT.FOR
+c     input values: y(n) at z(n) 
+c     output values: yy(m) at zz(m)
+c     options: 1 -> lineal
+c     2 -> logarithmic
+c     ***********************************************************************
+
+      implicit none
+
+!     Arguments
+      integer   n,m,opt         ! I
+      real      zz(m),z(n)      ! I
+      real    y1(m),y2(m)       ! O
+      real    x1(n),x2(n)       ! I
+
+
+!     Local variables 
+      integer i, j 
+      real    factor 
+      real    zaux
+
+!!!!  
+
+      j = 1                     ! initial first guess (=n/2 is anothr pssblty)
+
+      do 1,i=1,m                ! 
+
+                                ! Busca indice j donde ocurre q zz(i) esta entre [z(j),z(j+1)]
+         zaux = zz(i)
+         if (abs(zaux-z(1)).le.0.01) then 
+            zaux=z(1)
+         elseif (abs(zaux-z(n)).le.0.01) then
+            zaux=z(n)
+         endif
+         call hunt ( z,n, zaux, j )
+         if ( j.eq.0 .or. j.eq.n ) then 
+            write (*,*) ' HUNT/ Limits input grid:', z(1),z(n)
+            write (*,*) ' HUNT/ location in new grid:', zz(i)
+            stop ' interhunt2/ Interpolat error. zz out of limits.'
+         endif
+
+                                ! Perform interpolation
+         factor = (zz(i)-z(j))/(z(j+1)-z(j))
+         if (opt.eq.1) then
+            y1(i) = x1(j) + (x1(j+1)-x1(j)) * factor 
+            y2(i) = x2(j) + (x2(j+1)-x2(j)) * factor
+         else
+            y1(i) = exp( log(x1(j)) + log(x1(j+1)/x1(j)) * factor )
+            y2(i) = exp( log(x2(j)) + log(x2(j+1)/x2(j)) * factor )
+         end if
+
+ 1    continue
+
+      return
+      end
+
+
+c     *** interhunt5veces.f ***
+
+c     ***********************************************************************
+
+      subroutine interhunt5veces ( y1,y2,y3,y4,y5,  zz,m, 
+     @     x1,x2,x3,x4,x5,  z,n,  opt)
+
+c     interpolation soubroutine basada en Numerical Recipes HUNT.FOR
+c     input values: y(n) at z(n) 
+c     output values: yy(m) at zz(m)
+c     options: 1 -> lineal
+c     2 -> logarithmic
+c     ***********************************************************************
+
+      implicit none
+!     Arguments
+      integer   n,m,opt         ! I
+      real      zz(m),z(n)      ! I
+      real    y1(m),y2(m),y3(m),y4(m),y5(m) ! O
+      real    x1(n),x2(n),x3(n),x4(n),x5(n) ! I
+
+
+!     Local variables 
+      integer i, j 
+      real    factor 
+      real    zaux
+
+!!!!  
+
+      j = 1                     ! initial first guess (=n/2 is anothr pssblty)
+
+      do 1,i=1,m                ! 
+
+                                ! Busca indice j donde ocurre q zz(i) esta entre [z(j),z(j+1)]
+         zaux = zz(i)
+         if (abs(zaux-z(1)).le.0.01) then 
+            zaux=z(1)
+         elseif (abs(zaux-z(n)).le.0.01) then
+            zaux=z(n)
+         endif
+         call hunt ( z,n, zaux, j )
+         if ( j.eq.0 .or. j.eq.n ) then 
+            write (*,*) ' HUNT/ Limits input grid:', z(1),z(n)
+            write (*,*) ' HUNT/ location in new grid:', zz(i)
+            stop ' interhunt5/ Interpolat error. zz out of limits.'
+         endif
+
+                                ! Perform interpolation
+         factor = (zz(i)-z(j))/(z(j+1)-z(j))
+         if (opt.eq.1) then
+            y1(i) = x1(j) + (x1(j+1)-x1(j)) * factor 
+            y2(i) = x2(j) + (x2(j+1)-x2(j)) * factor
+            y3(i) = x3(j) + (x3(j+1)-x3(j)) * factor
+            y4(i) = x4(j) + (x4(j+1)-x4(j)) * factor
+            y5(i) = x5(j) + (x5(j+1)-x5(j)) * factor
+         else
+            y1(i) = exp( log(x1(j)) + log(x1(j+1)/x1(j)) * factor )
+            y2(i) = exp( log(x2(j)) + log(x2(j+1)/x2(j)) * factor )
+            y3(i) = exp( log(x3(j)) + log(x3(j+1)/x3(j)) * factor )
+            y4(i) = exp( log(x4(j)) + log(x4(j+1)/x4(j)) * factor )
+            y5(i) = exp( log(x5(j)) + log(x5(j+1)/x5(j)) * factor )
+         end if
+
+ 1    continue
+
+      return
+      end
+
+
+
+c     *** interhuntdp3veces.f ***
+
+c     ***********************************************************************
+
+      subroutine interhuntdp3veces ( y1,y2,y3, zz,m, 
+     @     x1,x2,x3,  z,n,  opt)
+
+c     interpolation soubroutine basada en Numerical Recipes HUNT.FOR
+c     input values: x(n) at z(n) 
+c     output values: y(m) at zz(m)
+c     options: opt = 1 -> lineal
+c     opt=/=1 -> logarithmic
+c     ***********************************************************************
+!     Arguments
+      integer   n,m,opt         ! I
+      real*8    zz(m),z(n)      ! I
+      real*8    y1(m),y2(m),y3(m) ! O
+      real*8    x1(n),x2(n),x3(n) ! I
+
+
+!     Local variables 
+      integer i, j 
+      real*8    factor 
+      real*8    zaux
+
+!!!!  
+
+      j = 1                     ! initial first guess (=n/2 is anothr pssblty)
+
+      do 1,i=1,m                ! 
+
+                                ! Busca indice j donde ocurre q zz(i) esta entre [z(j),z(j+1)]
+         zaux = zz(i)
+         if (abs(zaux-z(1)).le.0.01d0) then 
+            zaux=z(1)
+         elseif (abs(zaux-z(n)).le.0.01d0) then
+            zaux=z(n)
+         endif
+         call huntdp ( z,n, zaux, j )
+         if ( j.eq.0 .or. j.eq.n ) then 
+            write (*,*) ' HUNT/ Limits input grid:', z(1),z(n)
+            write (*,*) ' HUNT/ location in new grid:', zz(i)
+            stop ' INTERHUNTDP3/ Interpolat error. zz out of limits.'
+         endif
+
+                                ! Perform interpolation
+         factor = (zz(i)-z(j))/(z(j+1)-z(j))
+         if (opt.eq.1) then
+            y1(i) = x1(j) + (x1(j+1)-x1(j)) * factor 
+            y2(i) = x2(j) + (x2(j+1)-x2(j)) * factor
+            y3(i) = x3(j) + (x3(j+1)-x3(j)) * factor
+         else
+            y1(i) = dexp( dlog(x1(j)) + dlog(x1(j+1)/x1(j)) * factor )
+            y2(i) = dexp( dlog(x2(j)) + dlog(x2(j+1)/x2(j)) * factor )
+            y3(i) = dexp( dlog(x3(j)) + dlog(x3(j+1)/x3(j)) * factor )
+         end if
+
+ 1    continue
+
+      return
+      end
+
+
+c     *** interhuntdp4veces.f ***
+
+c     ***********************************************************************
+
+      subroutine interhuntdp4veces ( y1,y2,y3,y4, zz,m, 
+     @     x1,x2,x3,x4,  z,n,  opt)
+
+c     interpolation soubroutine basada en Numerical Recipes HUNT.FOR
+c     input values: x1(n),x2(n),x3(n),x4(n) at z(n) 
+c     output values: y1(m),y2(m),y3(m),y4(m) at zz(m)
+c     options: 1 -> lineal
+c     2 -> logarithmic
+c     ***********************************************************************
+
+      implicit none
+
+!     Arguments
+      integer   n,m,opt         ! I
+      real*8    zz(m),z(n)      ! I
+      real*8    y1(m),y2(m),y3(m),y4(m) ! O
+      real*8    x1(n),x2(n),x3(n),x4(n) ! I
+
+
+!     Local variables 
+      integer i, j 
+      real*8    factor 
+      real*8    zaux
+
+!!!!  
+
+      j = 1                     ! initial first guess (=n/2 is anothr pssblty)
+
+      do 1,i=1,m                ! 
+
+                                ! Caza del indice j donde ocurre que zz(i) esta entre [z(j),z(j+1)]
+         zaux = zz(i)
+         if (abs(zaux-z(1)).le.0.01d0) then 
+            zaux=z(1)
+         elseif (abs(zaux-z(n)).le.0.01d0) then
+            zaux=z(n)
+         endif
+         call huntdp ( z,n, zaux, j )
+         if ( j.eq.0 .or. j.eq.n ) then 
+            write (*,*) ' HUNT/ Limits input grid:', z(1),z(n)
+            write (*,*) ' HUNT/ location in new grid:', zz(i)
+            stop ' INTERHUNTDP4/ Interpolat error. zz out of limits.'
+         endif
+
+                                ! Perform interpolation
+         factor = (zz(i)-z(j))/(z(j+1)-z(j))
+         if (opt.eq.1) then
+            y1(i) = x1(j) + (x1(j+1)-x1(j)) * factor 
+            y2(i) = x2(j) + (x2(j+1)-x2(j)) * factor
+            y3(i) = x3(j) + (x3(j+1)-x3(j)) * factor
+            y4(i) = x4(j) + (x4(j+1)-x4(j)) * factor
+         else
+            y1(i) = dexp( dlog(x1(j)) + dlog(x1(j+1)/x1(j)) * factor )
+            y2(i) = dexp( dlog(x2(j)) + dlog(x2(j+1)/x2(j)) * factor )
+            y3(i) = dexp( dlog(x3(j)) + dlog(x3(j+1)/x3(j)) * factor )
+            y4(i) = dexp( dlog(x4(j)) + dlog(x4(j+1)/x4(j)) * factor )
+         end if
+
+ 1    continue
+
+      return
+      end
+
+
+c     *** interhuntdp.f ***
+
+c     ***********************************************************************
+
+      subroutine interhuntdp ( y1, zz,m, 
+     @     x1,  z,n,  opt)
+
+c     interpolation soubroutine basada en Numerical Recipes HUNT.FOR
+c     input values: x1(n) at z(n) 
+c     output values: y1(m) at zz(m)
+c     options: 1 -> lineal
+c     2 -> logarithmic
+c     ***********************************************************************
+
+      implicit none 
+
+!     Arguments
+      integer   n,m,opt         ! I
+      real*8    zz(m),z(n)      ! I
+      real*8    y1(m)           ! O
+      real*8    x1(n)           ! I
+
+
+!     Local variables 
+      integer i, j 
+      real*8    factor 
+      real*8    zaux
+
+!!!!  
+
+      j = 1                     ! initial first guess (=n/2 is anothr pssblty)
+
+      do 1,i=1,m                ! 
+
+                                ! Caza del indice j donde ocurre que zz(i) esta entre [z(j),z(j+1)]
+         zaux = zz(i)
+         if (abs(zaux-z(1)).le.0.01d0) then 
+            zaux=z(1)
+         elseif (abs(zaux-z(n)).le.0.01d0) then
+            zaux=z(n)
+         endif
+         call huntdp ( z,n, zaux, j )
+         if ( j.eq.0 .or. j.eq.n ) then 
+            write (*,*) ' HUNT/ Limits input grid:', z(1),z(n)
+            write (*,*) ' HUNT/ location in new grid:', zz(i)
+            stop ' INTERHUNT/ Interpolat error. zz out of limits.'
+         endif
+
+                                ! Perform interpolation
+         factor = (zz(i)-z(j))/(z(j+1)-z(j))
+         if (opt.eq.1) then
+            y1(i) = x1(j) + (x1(j+1)-x1(j)) * factor 
+         else
+            y1(i) = dexp( dlog(x1(j)) + dlog(x1(j+1)/x1(j)) * factor )
+         end if
+
+ 1    continue
+
+      return
+      end
+
+
+c     *** interhunt.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
+
+      subroutine interhunt ( y1, zz,m, 
+     @     x1,  z,n,  opt)
+
+c     interpolation soubroutine basada en Numerical Recipes HUNT.FOR
+c     input values: x1(n) at z(n) 
+c     output values: y1(m) at zz(m)
+c     options: 1 -> lineal
+c     2 -> logarithmic
 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                  
-                                                
+
+      implicit none
+
+!     Arguments
+      integer   n,m,opt         ! I
+      real      zz(m),z(n)      ! I
+      real    y1(m)             ! O
+      real    x1(n)             ! I
+
+
+!     Local variables 
+      integer i, j 
+      real    factor 
+      real    zaux
+
+!!!!  
+
+      j = 1                     ! initial first guess (=n/2 is anothr pssblty)
+
+      do 1,i=1,m                ! 
+
+                                ! Busca indice j donde ocurre q zz(i) esta entre [z(j),z(j+1)]
+         zaux = zz(i)
+         if (abs(zaux-z(1)).le.0.01) then 
+            zaux=z(1)
+         elseif (abs(zaux-z(n)).le.0.01) then
+            zaux=z(n)
+         endif
+         call hunt ( z,n, zaux, j )
+         if ( j.eq.0 .or. j.eq.n ) then 
+            write (*,*) ' HUNT/ Limits input grid:', z(1),z(n)
+            write (*,*) ' HUNT/ location in new grid:', zz(i)
+            stop ' interhunt/ Interpolat error. z out of limits.'
+         endif
+
+                                ! Perform interpolation
+         factor = (zz(i)-z(j))/(z(j+1)-z(j))
+         if (opt.eq.1) then
+            y1(i) = x1(j) + (x1(j+1)-x1(j)) * factor 
+         else
+            y1(i) = exp( log(x1(j)) + log(x1(j+1)/x1(j)) * factor )
+         end if
+
+
+ 1    continue
+
+      return
+      end
+
+
+c     *** interhuntlimits2veces.f ***
+
 c***********************************************************************
-      function planckdp(tp,xnu)                      
-c     returns the black body function at wavenumber xnu and temperature t.  
+
+      subroutine interhuntlimits2veces 
+     @     ( y1,y2, zz,m, limite1,limite2, 
+     @     x1,x2,  z,n, opt)
+
+c     Interpolation soubroutine basada en Numerical Recipes HUNT.FOR
+c     Input values:  x1,x2(n) at z(n) 
+c     Output values: 
+c     y1,y2(m) at zz(m)   pero solo entre los indices de zz
+c     siguientes: [limite1,limite2]
+c     Options: 1 -> linear in z and linear in x
+c     2 -> linear in z and logarithmic in x
+c     3 -> logarithmic in z and linear in x
+c     4 -> logarithmic in z and logaritmic in x
+c     
+c     NOTAS: Esta subrutina extiende y generaliza la usual  
+c     "interhunt5veces" en 2 direcciones: 
+c     - la condicion en los limites es que zz(limite1:limite2)
+c     esté dentro de los limites de z (pero quizas no todo zz)
+c     - se han añadido 3 opciones mas al caso de interpolacion
+c     logaritmica, ahora se hace en log de z, de x o de ambos.
+c     Notese que esta subrutina engloba a la interhunt5veces 
+c     ( esta es reproducible haciendo  limite1=1  y  limite2=m 
+c     y usando una de las 2 primeras opciones  opt=1,2 )
 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                                  
+
+      implicit none
+
+!     Arguments
+      integer   n,m,opt, limite1,limite2 ! I
+      real      zz(m),z(n)      ! I
+      real    y1(m),y2(m)       ! O
+      real    x1(n),x2(n)       ! I
+
+
+!     Local variables 
+      integer i, j 
+      real    factor 
+      real    zaux
+
+!!!!  
+
+      j = 1                     ! initial first guess (=n/2 is anothr pssblty)
+
+      do 1,i=limite1,limite2              
+
+                                ! Busca indice j donde ocurre q zz(i) esta entre [z(j),z(j+1)]
+         zaux = zz(i)
+         if (abs(zaux-z(1)).le.0.01) then 
+            zaux=z(1)
+         elseif (abs(zaux-z(n)).le.0.01) then
+            zaux=z(n)
+         endif
+         call hunt ( z,n, zaux, j )
+         if ( j.eq.0 .or. j.eq.n ) then 
+            write (*,*) ' HUNT/ Limits input grid:', z(1),z(n)
+            write (*,*) ' HUNT/ location in new grid:', zz(i)
+            stop ' interhuntlimits/ Interpolat error. z out of limits.'
+         endif
+
+                                ! Perform interpolation
+         if (opt.eq.1) then
+            factor = (zz(i)-z(j))/(z(j+1)-z(j))
+            y1(i) = x1(j) + (x1(j+1)-x1(j)) * factor 
+            y2(i) = x2(j) + (x2(j+1)-x2(j)) * factor 
+
+         elseif (opt.eq.2) then 
+            factor = (zz(i)-z(j))/(z(j+1)-z(j))
+            y1(i) = exp( log(x1(j)) + log(x1(j+1)/x1(j)) * factor )
+            y2(i) = exp( log(x2(j)) + log(x2(j+1)/x2(j)) * factor )
+         elseif (opt.eq.3) then 
+            factor = (log(zz(i))-log(z(j)))/(log(z(j+1))-log(z(j)))
+            y1(i) = x1(j) + (x1(j+1)-x1(j)) * factor 
+            y2(i) = x2(j) + (x2(j+1)-x2(j)) * factor 
+         elseif (opt.eq.4) then 
+            factor = (log(zz(i))-log(z(j)))/(log(z(j+1))-log(z(j)))
+            y1(i) = exp( log(x1(j)) + log(x1(j+1)/x1(j)) * factor )
+            y2(i) = exp( log(x2(j)) + log(x2(j+1)/x2(j)) * factor )
+         end if
+
+
+ 1    continue
+
+      return
+      end
+
+
+c     *** interhuntlimits5veces.f ***
+
+c***********************************************************************
+
+      subroutine interhuntlimits5veces 
+     @     ( y1,y2,y3,y4,y5, zz,m, limite1,limite2, 
+     @     x1,x2,x3,x4,x5,  z,n, opt)
+
+c     Interpolation soubroutine basada en Numerical Recipes HUNT.FOR
+c     Input values:  x1,x2,..,x5(n) at z(n) 
+c     Output values: 
+c     y1,y2,...,y5(m) at zz(m)   pero solo entre los indices de zz
+c     siguientes: [limite1,limite2]
+c     Options: 1 -> linear in z and linear in x
+c     2 -> linear in z and logarithmic in x
+c     3 -> logarithmic in z and linear in x
+c     4 -> logarithmic in z and logaritmic in x
+c     
+c     NOTAS: Esta subrutina extiende y generaliza la usual  
+c     "interhunt5veces" en 2 direcciones: 
+c     - la condicion en los limites es que zz(limite1:limite2)
+c     esté dentro de los limites de z (pero quizas no todo zz)
+c     - se han añadido 3 opciones mas al caso de interpolacion
+c     logaritmica, ahora se hace en log de z, de x o de ambos.
+c     Notese que esta subrutina engloba a la interhunt5veces 
+c     ( esta es reproducible haciendo  limite1=1  y  limite2=m 
+c     y usando una de las 2 primeras opciones  opt=1,2 )
+c***********************************************************************
+
+      implicit none
+
+!     Arguments
+      integer   n,m,opt, limite1,limite2 ! I
+      real      zz(m),z(n)      ! I
+      real    y1(m),y2(m),y3(m),y4(m),y5(m) ! O
+      real    x1(n),x2(n),x3(n),x4(n),x5(n) ! I
+
+
+!     Local variables 
+      integer i, j 
+      real    factor 
+      real    zaux
+
+!!!!  
+
+      j = 1                     ! initial first guess (=n/2 is anothr pssblty)
+
+      do 1,i=limite1,limite2              
+
+                                ! Busca indice j donde ocurre q zz(i) esta entre [z(j),z(j+1)]
+         zaux = zz(i)
+         if (abs(zaux-z(1)).le.0.01) then 
+            zaux=z(1)
+         elseif (abs(zaux-z(n)).le.0.01) then
+            zaux=z(n)
+         endif
+         call hunt ( z,n, zaux, j )
+         if ( j.eq.0 .or. j.eq.n ) then 
+            write (*,*) ' HUNT/ Limits input grid:', z(1),z(n)
+            write (*,*) ' HUNT/ location in new grid:', zz(i)
+            stop ' interhuntlimits/ Interpolat error. z out of limits.'
+         endif
+
+                                ! Perform interpolation
+         if (opt.eq.1) then
+            factor = (zz(i)-z(j))/(z(j+1)-z(j))
+            y1(i) = x1(j) + (x1(j+1)-x1(j)) * factor 
+            y2(i) = x2(j) + (x2(j+1)-x2(j)) * factor 
+            y3(i) = x3(j) + (x3(j+1)-x3(j)) * factor 
+            y4(i) = x4(j) + (x4(j+1)-x4(j)) * factor 
+            y5(i) = x5(j) + (x5(j+1)-x5(j)) * factor 
+         elseif (opt.eq.2) then 
+            factor = (zz(i)-z(j))/(z(j+1)-z(j))
+            y1(i) = exp( log(x1(j)) + log(x1(j+1)/x1(j)) * factor )
+            y2(i) = exp( log(x2(j)) + log(x2(j+1)/x2(j)) * factor )
+            y3(i) = exp( log(x3(j)) + log(x3(j+1)/x3(j)) * factor )
+            y4(i) = exp( log(x4(j)) + log(x4(j+1)/x4(j)) * factor )
+            y5(i) = exp( log(x5(j)) + log(x5(j+1)/x5(j)) * factor )
+         elseif (opt.eq.3) then 
+            factor = (log(zz(i))-log(z(j)))/(log(z(j+1))-log(z(j)))
+            y1(i) = x1(j) + (x1(j+1)-x1(j)) * factor 
+            y2(i) = x2(j) + (x2(j+1)-x2(j)) * factor 
+            y3(i) = x3(j) + (x3(j+1)-x3(j)) * factor 
+            y4(i) = x4(j) + (x4(j+1)-x4(j)) * factor 
+            y5(i) = x5(j) + (x5(j+1)-x5(j)) * factor 
+         elseif (opt.eq.4) then 
+            factor = (log(zz(i))-log(z(j)))/(log(z(j+1))-log(z(j)))
+            y1(i) = exp( log(x1(j)) + log(x1(j+1)/x1(j)) * factor )
+            y2(i) = exp( log(x2(j)) + log(x2(j+1)/x2(j)) * factor )
+            y3(i) = exp( log(x3(j)) + log(x3(j+1)/x3(j)) * factor )
+            y4(i) = exp( log(x4(j)) + log(x4(j+1)/x4(j)) * factor )
+            y5(i) = exp( log(x5(j)) + log(x5(j+1)/x5(j)) * factor )
+         end if
+
+
+ 1    continue
+
+      return
+      end
+
+
+
+c     *** interhuntlimits.f ***
+
+c***********************************************************************
+
+      subroutine interhuntlimits ( y, zz,m, limite1,limite2, 
+     @     x,  z,n, opt)
+
+c     Interpolation soubroutine basada en Numerical Recipes HUNT.FOR
+c     Input values:  x(n) at z(n) 
+c     Output values: y(m) at zz(m)   pero solo entre los indices de zz
+c     siguientes: [limite1,limite2]
+c     Options: 1 -> linear in z and linear in x
+c     2 -> linear in z and logarithmic in x
+c     3 -> logarithmic in z and linear in x
+c     4 -> logarithmic in z and logaritmic in x
+c     
+c     NOTAS: Esta subrutina extiende y generaliza la usual  "interhunt"
+c     en 2 direcciones: 
+c     - la condicion en los limites es que zz(limite1:limite2)
+c     esté dentro de los limites de z (pero quizas no todo zz)
+c     - se han añadido 3 opciones mas al caso de interpolacion
+c     logaritmica, ahora se hace en log de z, de x o de ambos.
+c     Notese que esta subrutina engloba a la usual interhunt 
+c     ( esta es reproducible haciendo  limite1=1  y  limite2=m 
+c     y usando una de las 2 primeras opciones  opt=1,2 )
+c***********************************************************************
+
+      implicit none
+
+!     Arguments
+      integer   n,m,opt, limite1,limite2 ! I
+      real      zz(m),z(n)      ! I
+      real    y(m)              ! O
+      real    x(n)              ! I
+
+
+!     Local variables 
+      integer i, j 
+      real    factor 
+      real    zaux
+
+!!!!  
+
+      j = 1                     ! initial first guess (=n/2 is anothr pssblty)
+
+      do 1,i=limite1,limite2              
+
+                                ! Busca indice j donde ocurre q zz(i) esta entre [z(j),z(j+1)]
+         zaux = zz(i)
+         if (abs(zaux-z(1)).le.0.01) then 
+            zaux=z(1)
+         elseif (abs(zaux-z(n)).le.0.01) then
+            zaux=z(n)
+         endif
+         call hunt ( z,n, zaux, j )
+         if ( j.eq.0 .or. j.eq.n ) then 
+            write (*,*) ' HUNT/ Limits input grid:', z(1),z(n)
+            write (*,*) ' HUNT/ location in new grid:', zz(i)
+            stop ' interhuntlimits/ Interpolat error. z out of limits.'
+         endif
+
+                                ! Perform interpolation
+         if (opt.eq.1) then
+            factor = (zz(i)-z(j))/(z(j+1)-z(j))
+            y(i) = x(j) + (x(j+1)-x(j)) * factor 
+         elseif (opt.eq.2) then 
+            factor = (zz(i)-z(j))/(z(j+1)-z(j))
+            y(i) = exp( log(x(j)) + log(x(j+1)/x(j)) * factor )
+         elseif (opt.eq.3) then 
+            factor = (log(zz(i))-log(z(j)))/(log(z(j+1))-log(z(j)))
+            y(i) = x(j) + (x(j+1)-x(j)) * factor 
+         elseif (opt.eq.4) then 
+            factor = (log(zz(i))-log(z(j)))/(log(z(j+1))-log(z(j)))
+            y(i) = exp( log(x(j)) + log(x(j+1)/x(j)) * factor )
+         end if
+
+
+ 1    continue
+
+      return
+      end
+
+
+c     *** lubksb_dp.f ***
+
+      subroutine lubksb_dp(a,n,np,indx,b)     
+
+      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     *** ludcmp_dp.f ***
+
+      subroutine ludcmp_dp(a,n,np,indx,d)
+
+      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 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) 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   
 
 
-
-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     *** LUdec.f ***
+
+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
+
+
+c     *** mat_oper.f ***
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
 c     ***********************************************************************
       subroutine unit(a,n)
 c     store the unit value in the diagonal of a 
 c     ***********************************************************************
+      implicit none
       real*8 a(n,n)
       integer n,i,j,k
@@ -1795 +1843 @@
 
 c     ***********************************************************************
+      subroutine invdiag(a,b,n)
+c     inverse of a diagonal matrix 
+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
+
+
+c     ***********************************************************************
       subroutine samem (a,m,n)
 c     store the matrix m in the matrix a 
 c     ***********************************************************************
+      implicit none
       real*8 a(n,n),m(n,n)
       integer n,i,j,k
@@ -1813 +1890 @@
       return
       end 
+
+
 c     ***********************************************************************
       subroutine mulmv(a,b,c,n)
@@ -1825 +1904 @@
          sum=0.0d0
          do 2,j=2,n-1
-            sum=sum+ (b(i,j)) * (c(j))
+            sum = sum + b(i,j) * c(j)
  2       continue
          a(i)=sum
@@ -1834 +1913 @@
       end
 
-c     ***********************************************************************
-      subroutine mulmm(a,b,c,n)
-c     ***********************************************************************
-      real*8 a(n,n), b(n,n), c(n,n)
+
+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     ***********************************************************************
+      implicit none
+      real*8 a(n,n),b(n,n),c(n,n),d(n,n),e(n,n), sum
       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 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
@@ -1864 +1940 @@
          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
+      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     ***********************************************************************
+      implicit none
+      real*8 v(n),b(n,n),c(n,n),u(n),w(n), sum
+      integer n,i,j
+      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 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     ***********************************************************************
+      implicit none
+      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     ***********************************************************************
@@ -1899 +1997 @@
 
       do 1,i=2,n-1
-         a(i)= (b(i)) + (c(i))
+         a(i)= b(i) + c(i)
  1    continue
       a(1) = 0.0d0
@@ -1906 +2004 @@
       end
 
-c     ***********************************************************************
-      subroutine zerom(a,n)
+
+c     ***********************************************************************
+      subroutine sypvvv(a,b,c,d,n)
+c     a(i)=b(i)+c(i)*d(i)
+c     ***********************************************************************
+      implicit none
+      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 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
+!      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     ***********************************************************************
@@ -1928 +2042 @@
 c     a(i,j) = b(i,j) = c(i,j) = d(i,j) = 0.0 
 c     ***********************************************************************
+      implicit none
       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
+      integer n
+      a(1:n,1:n)=0.d0
+      b(1:n,1:n)=0.d0
+      c(1:n,1:n)=0.d0
+      d(1:n,1:n)=0.d0
+!      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     ***********************************************************************
@@ -1945 +2065 @@
 c     a(i,j) = b(i,j) = c(i,j) = 0.0 
 c     **********************************************************************
+      implicit none
       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
+      integer n
+      a(1:n,1:n)=0.d0
+      b(1:n,1:n)=0.d0
+      c(1:n,1:n)=0.d0
+!      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     ***********************************************************************
@@ -1961 +2086 @@
 c     a(i,j) = b(i,j) = 0.0 
 c     ***********************************************************************
+      implicit none
       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)
+      integer n
+      a(1:n,1:n)=0.d0
+      b(1:n,1:n)=0.d0
+!      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
+!      implicit none
+!      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     ***********************************************************************
+      implicit none
       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
+      integer n
+      a(1:n)=0.d0
+      b(1:n)=0.d0
+      c(1:n)=0.d0
+      d(1:n)=0.d0
+!      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     ***********************************************************************
+      implicit none
       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
+      integer n
+      a(1:n)=0.d0
+      b(1:n)=0.d0
+      c(1:n)=0.d0
+!      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     ***********************************************************************
+      implicit none
       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
-
-
+      integer n
+      a(1:n)=0.d0
+      b(1:n)=0.d0
+!      do 1,i=1,n
+!         a(i) = 0.0d0
+!         b(i) = 0.0d0
+! 1    continue
+      return
+      end
+
+c     ***********************************************************************
+
+
+c****************************************************************************
+
+c     *** suaviza.f ***
+
+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     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     ***********************************************************************
+      subroutine mulmmf90(a,b,c,n)
+c     ***********************************************************************
+      implicit none
+      real*8 a(n,n), b(n,n), c(n,n)
+      integer n
+
+      a=matmul(b,c)
+      a(1,:)=0.d0
+      a(:,1)=0.d0
+      a(n,:)=0.d0
+      a(:,n)=0.d0
+
+      return
+      end
+
+
+c     ***********************************************************************
+      subroutine resmmf90(a,b,c,n)
+c     ***********************************************************************
+      implicit none
+      real*8 a(n,n), b(n,n), c(n,n)
+      integer n
+
+      a=b-c
+      a(1,:)=0.d0
+      a(:,1)=0.d0
+      a(n,:)=0.d0
+      a(:,n)=0.d0
+
+      return
+      end
+
+
+c*******************************************************************
+
+      subroutine gethist_03 (ihist) 
+
+c*******************************************************************
+
+      implicit none
+
+      include   'nlte_paramdef.h'
+      include   'nlte_commons.h'
+
+
+c     arguments 
+      integer         ihist
+
+c     local variables
+      integer   j, r, mm
+      real*8          xx
+
+c     ***************
+
+      nbox = nbox_stored(ihist)
+      do j=1,mm_stored(ihist)
+         thist(j) = thist_stored(ihist,j) 
+         do r=1,nbox_stored(ihist)
+            no(r) = no_stored(ihist,r) 
+            sk1(j,r) = sk1_stored(ihist,j,r) 
+            xls1(j,r) = xls1_stored(ihist,j,r)
+            xld1(j,r) = xld1_stored(ihist,j,r)
+         enddo
+      enddo
+
+
+      return
+      end
+
+
+c     *******************************************************************
+
+      subroutine rhist_03 (ihist) 
+
+c     *******************************************************************
+
+      implicit none
+
+      include   'nlte_paramdef.h'
+      include   'nlte_commons.h'
+
+
+c     arguments 
+      integer         ihist
+
+c     local variables
+      integer   j, r, mm
+      real*8          xx
+
+c     ***************
+
+      open(unit=3,file=hisfile,status='old')
+
+      read(3,*)
+      read(3,*)
+      read(3,*) mm_stored(ihist)
+      read(3,*)
+      read(3,*) nbox_stored(ihist)
+      read(3,*)
+
+      if ( nbox_stored(ihist) .gt. nbox_max ) then
+         write (*,*) ' nbox too large in input file ', hisfile
+         stop ' Check maximum number nbox_max in mz1d.par '
+      endif
+
+      do j=1,mm_stored(ihist)
+         read(3,*) thist_stored(ihist,j) 
+         do r=1,nbox_stored(ihist)
+            read(3,*) no_stored(ihist,r), 
+     &           sk1_stored(ihist,j,r), 
+     &           xls1_stored(ihist,j,r),
+     &           xx,
+     &           xld1_stored(ihist,j,r)
+         enddo
+
+      enddo
+
+      close(unit=3)
+
+
+      return
+      end

trunk/LMDZ.MARS/libf/phymars/nlte_calc.F

@@ -1 @@
-c***********************************************************************
-c     mzescape.f                                    
-c***********************************************************************
-c                                               
-c     program  for calculating atmospheric escape functions, from           
-c     a calculation of transmittances and derivatives of these ones   
+c**********************************************************************
+c     
+c     Includes the following 1-d model subroutines:
+c     
+c     -MZESC110_dlvr11_03.f
+c     -MZTUD110_dlvr11_03.f
+c     -MZMC121_dlvr11_03.f
+c     -MZTUD121_dlvr11_03.f
+c     -MZESC121_dlvr11_03.f
+c     -MZESC121sub_dlvr11_03.f
+c     -MZTVC121_dlvr11.f
+c     -MZTVC121sub_dlvr11_03.f
+
+
+
+c     *** Old MZESC110_dlvr11_03.f
+
+c**********************************************************************
+
+c***********************************************************************
+      subroutine MZESC110 (nl_cts_real, nzy_cts_real)
+c***********************************************************************
+
+      implicit none
+
+      include 'datafile.h'
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+
+c     arguments 
+      integer     nl_cts_real, nzy_cts_real ! i
+
+c     old arguments
+      integer         ierr      ! o
+      real*8          varerr    ! o
+
+c     local variables and constants
+      integer   i, in, ir, iaquiHIST , iaquiZ
+      integer         ib, isot
+      real*8            argumento
+      real*8            tauinf(nl_cts)
+      real*8            con(nzy_cts), 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(nbox_max), c2box(nbox_max)
+      real*8            ff      ! to avoid too small numbers
+      real*8            st, beta, ts
+      real*8    tyd(nzy_cts)
+      real*8            correc
+      real*8            deltanudbl, deltazdbl
+      real*8          yy
+
+c     external function
+      external        we_clean
+      real*8          we_clean
+
+c***********************************************************************
+
+c     
+      ib = 1
+      beta = 1.8d5
+      ibcode1 = '1'
+      isot = 1
+      deltanudbl = dble(deltanu(1,1))
+      deltazdbl = dble(deltaz_cts)
+      ff=1.0d10
+
+ccc   
+      do i=1,nzy_cts_real
+         tyd(i) = dble(ty_cts(i))
+         con(i) =  dble( co2y_cts(i) * imr(isot) )
+         correc = 2.d0 * dexp( -ee*dble(elow(isot,2))/tyd(i) )
+         con(i) = con(i) * ( 1.d0 - correc )
+         mr_cts(i) = dble(co2y_cts(i)/nty_cts(i))
+      end do
+      coninf = dble( con(nzy_cts_real) /
+     @     log( con(nzy_cts_real-1) / con(nzy_cts_real) ) )
+                                ! Correccion pequeña para la FB, nos la saltamos
+                                !call mztf_correccion_cts ( coninf, con, ib )
+
+ccc   
+      call gethist_03 ( 1 )
+
+c     
+c     tauinf
+c     
+      call initial
+
+      iaquiHIST = nhist/2
+      iaquiZ = nzy_cts_real - 2
+
+      do i=nl_cts_real,1,-1
+
+         if(i.eq.nl_cts_real)then
+
+            call intzhunt_cts (iaquiZ, zl_cts(i), nzy_cts_real, 
+     @           c2,p2,mr2,t2, con)
+            do kr=1,nbox
+               ta(kr)=t2
+            end do
+            call interstrhunt (iaquiHIST, st2,t2,ka,ta)
+                                ! Check interpolation errors :
+            if (c2.le.0.0d0) then
+               ierr=15
+               varerr=c2
+               return
+            elseif (p2.le.0.0d0) then
+               ierr=16
+               varerr=p2
+               return
+            elseif (mr2.le.0.0d0) then
+               ierr=17
+               varerr=mr2
+               return
+            elseif (t2.le.0.0d0) then
+               ierr=18
+               varerr=t2
+               return
+            elseif (st2.le.0.0d0) then
+               ierr=19
+               varerr=st2
+               return
+            endif
+                                !
+            aa = p2 * coninf * mr2 * (st2 * ff)
+            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) * deltazdbl
+            end do
+            c2 = c2 * st2 * deltazdbl
+
+         else
+
+            call intzhunt_cts (iaquiZ, zl_cts(i), nzy_cts_real, 
+     @           c1,p1,mr1,t1, con)
+            do kr=1,nbox
+               ta(kr)=t1
+            end do
+            call interstrhunt (iaquiHIST, st1,t1,ka,ta)
+            do kr=1,nbox
+               c1box(kr) = c1 * ka(kr) * deltazdbl
+            end do
+            c1 = c1 * st1 * deltazdbl
+            aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 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
+
+         pp = aa / (cc*ff)
+
+         ts = dd/cc
+         do kr=1,nbox
+            ta(kr) = ddbox(kr) / ccbox(kr)
+         end do
+         call interstrhunt(iaquiHIST, st,ts,ka,ta)
+         call intershphunt(iaquiHIST, alsa,alda,ta)
+
+c     
+         eqw=0.0d0
+         do  kr=1,nbox
+            yy = ccbox(kr) * beta
+            w = we_clean ( yy, pp, alsa(kr),alda(kr) )
+            eqw = eqw + no(kr)*w
+         end do
+
+         argumento = eqw / deltanudbl
+         tauinf(i) = dexp( - argumento )
+
+         if (i.eq.nl_cts_real) then
+            taustar11_cts(i) = 0.0d0
+         else
+            taustar11_cts(i) = deltanudbl * (tauinf(i+1)-tauinf(i))
+     @           / ( beta * ccc )
+         endif
+
+      end do
+
+
+      call mzescape_normaliz_02 ( taustar11_cts, nl_cts_real, 2 )
+
+c     end
+      return
+      end
+
+
+c     *** Old MZTUD110_dlvr11_03.f
+
+c***********************************************************************
+      subroutine MZTUD110( ierr, varerr )
+c***********************************************************************
+
+      implicit none
+
+      include 'datafile.h'
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+
+
+c     arguments
+      integer         ierr      ! o
+      real*8          varerr    ! o
+
+c     local variables and constants
+      integer   i, in, ir, iaquiHIST , iaquiZ
+      integer         ib, isot
+      real*8            tau(nl,nl), argumento
+      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(nbox_max), c2box(nbox_max)
+      real*8            ff      ! to avoid too small numbers
+      real*8            tvtbs(nzy)
+      real*8            st, beta, ts
+      real*8    zld(nl), zyd(nzy), deltazdbl
+      real*8            correc
+      real*8            deltanudbl
+      real*8          maxtau, yy
+
+c     external function
+      external        we_clean
+      real*8          we_clean
+
+c***********************************************************************
+
+c     
+      ib = 1
+      beta = 1.8d5
+      ibcode1 = '1'
+      isot = 1
+      deltanudbl = dble(deltanu(1,1))
+      deltazdbl = dble(deltaz)
+      ff=1.0d10
+
+ccc   
+      do i=1,nzy
+         zyd(i) = dble(zy(i))
+      enddo
+      do i=1,nl
+         zld(i) = dble(zl(i))
+      enddo
+      call interhuntdp ( tvtbs,zyd,nzy, v626t1,zld,nl, 1 )
+      do i=1,nzy
+         con(i) =  dble( co2y(i) * imr(isot) )
+         correc = 2.d0 * dexp( -ee*dble(elow(isot,2))/tvtbs(i) )
+         con(i) = con(i) * ( 1.d0 - correc )
+         mr(i) = dble(co2y(i)/nty(i))
+      end do
+      coninf = dble( con(nzy) / log( con(nzy-1) / con(nzy) ) )
+      call mztf_correccion ( coninf, con, ib )
+
+ccc   
+      call gethist_03 ( 1 )
+
+c     
+c     tauinf
+c     
+      call initial
+
+      iaquiHIST = nhist/2
+      iaquiZ = nzy - 2
+
+      do i=nl,1,-1
+
+         if(i.eq.nl)then
+
+            call intzhunt (iaquiZ, zl(i),c2,p2,mr2,t2, con)
+            do kr=1,nbox
+               ta(kr)=t2
+            end do
+            call interstrhunt (iaquiHIST, st2,t2,ka,ta)
+                                ! Check interpolation errors :
+            if (c2.le.0.0d0) then
+               ierr=15
+               varerr=c2
+               return
+            elseif (p2.le.0.0d0) then
+               ierr=16
+               varerr=p2
+               return
+            elseif (mr2.le.0.0d0) then
+               ierr=17
+               varerr=mr2
+               return
+            elseif (t2.le.0.0d0) then
+               ierr=18
+               varerr=t2
+               return
+            elseif (st2.le.0.0d0) then
+               ierr=19
+               varerr=st2
+               return
+            endif
+                                !
+            aa = p2 * coninf * mr2 * (st2 * ff)
+            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) * deltazdbl
+            end do
+            c2 = c2 * st2 * deltazdbl
+
+         else
+
+            call intzhunt (iaquiZ, zl(i),c1,p1,mr1,t1, con)
+            do kr=1,nbox
+               ta(kr)=t1
+            end do
+            call interstrhunt (iaquiHIST, st1,t1,ka,ta)
+            do kr=1,nbox
+               c1box(kr) = c1 * ka(kr) * deltazdbl
+            end do
+            c1 = c1 * st1 * deltazdbl
+            aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 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
+
+         pp = aa / (cc*ff)
+
+         ts = dd/cc
+         do kr=1,nbox
+            ta(kr) = ddbox(kr) / ccbox(kr)
+         end do
+         call interstrhunt(iaquiHIST, st,ts,ka,ta)
+         call intershphunt(iaquiHIST, alsa,alda,ta)
+
+c     
+         eqw=0.0d0
+         do  kr=1,nbox
+            yy = ccbox(kr) * beta
+            w = we_clean ( yy, pp, alsa(kr),alda(kr) )
+            eqw = eqw + no(kr)*w
+         end do
+
+         argumento = eqw / deltanudbl
+         tauinf(i) = dexp( - argumento )
+
+      end do
+
+
+c     
+c     tau
+c     
+
+      iaquiZ = 2
+      do 1 in=1,nl-1
+
+         call initial
+         call intzhunt (iaquiZ, zl(in), c1,p1,mr1,t1, con)
+         do kr=1,nbox
+            ta(kr) = t1
+         end do
+         call interstrhunt (iaquiHIST, st1,t1,ka,ta)
+         do kr=1,nbox
+            c1box(kr) = c1 * ka(kr) * deltazdbl
+         end do
+         c1 = c1 * st1 * deltazdbl
+
+         do 2 ir=in,nl-1
+
+            if (ir.eq.in) then
+               tau(in,ir) = 1.d0
+               goto 2
+            end if
+
+            call intzhunt (iaquiZ, zl(ir), c2,p2,mr2,t2, con)
+            do kr=1,nbox
+               ta(kr) = t2
+            end do
+            call interstrhunt (iaquiHIST, st2,t2,ka,ta)
+            do kr=1,nbox
+               c2box(kr) = c2 * ka(kr) * deltazdbl
+            end do
+            c2 = c2 * st2 * deltazdbl
+
+            aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 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
+
+            pp = aa / (cc * ff)
+
+            ts = dd/cc
+            do kr=1,nbox
+               ta(kr) = ddbox(kr) / ccbox(kr)
+            end do
+            call interstrhunt(iaquiHIST, st,ts,ka,ta)
+            call intershphunt(iaquiHIST, alsa,alda,ta)
+c     
+            eqw=0.0d0
+            do kr=1,nbox
+               yy = ccbox(kr) * beta
+               w = we_clean ( yy, pp, alsa(kr),alda(kr) )
+               eqw = eqw + no(kr)*w
+            end do
+
+            argumento = eqw / deltanudbl
+            tau(in,ir) = exp( - argumento )
+
+
+ 2       continue
+
+ 1    continue
+
+
+c     
+c     tau(in,ir) for n>r
+c     
+
+      in=nl
+
+      call initial
+
+      iaquiZ = nzy - 2
+      call intzhunt (iaquiZ, zl(in), c1,p1,mr1,t1, con)
+      do kr=1,nbox
+         ta(kr) = t1
+      end do
+      call interstrhunt (iaquiHIST,st1,t1,ka,ta)
+      do kr=1,nbox
+         c1box(kr) = c1 * ka(kr) * deltazdbl
+      end do
+      c1 = c1 * st1 * deltazdbl
+
+      do 4 ir=in-1,1,-1
+
+         call intzhunt (iaquiZ, zl(ir), c2,p2,mr2,t2, con)
+         do kr=1,nbox
+            ta(kr) = t2
+         end do
+         call interstrhunt (iaquiHIST, st2,t2,ka,ta)
+         do kr=1,nbox
+            c2box(kr) = c2 * ka(kr) * deltazdbl
+         end do
+         c2 = c2 * st2 * deltazdbl
+
+         aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 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
+
+         pp = aa / (cc * ff)
+         ts = dd / cc
+         do kr=1,nbox
+            ta(kr) = ddbox(kr) / ccbox(kr)
+         end do
+         call interstrhunt (iaquiHIST, st,ts,ka,ta)
+         call intershphunt (iaquiHIST, alsa,alda,ta)
+
+c     
+
+         eqw=0.0d0
+         do kr=1,nbox
+            yy = ccbox(kr) * beta
+            w = we_clean ( yy, pp, alsa(kr),alda(kr) )
+            eqw = eqw + no(kr)*w
+         end do
+
+         argumento = eqw / deltanudbl
+         tau(in,ir) = exp( - argumento )
+
+
+ 4    continue
+
+c     
+c     
+c     
+      do in=nl-1,2,-1
+         do ir=in-1,1,-1
+            tau(in,ir) = tau(ir,in)
+         end do
+      end do
+
+c     
+c     Tracking potential numerical errors
+c     
+      maxtau = 0.0d0
+      do in=nl-1,2,-1
+         do ir=in-1,1,-1
+            maxtau = max( maxtau, tau(in,ir) )
+         end do
+      end do
+      if (maxtau .gt. 1.0d0) then
+         ierr = 13
+         varerr = maxtau
+         return
+      endif
+
+
+c     
+      call MZCUD110 ( tauinf,tau )
+
+c     end
+      return
+      end
+
+
+c     *** Old file MZCUD_dlvr11.f ***
+
+c***********************************************************************
+
+      subroutine MZCUD110 ( tauinf,tau )
+
+c***********************************************************************
+
+      implicit none
+
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+
+c     arguments
+      real*8            tau(nl,nl) ! i
+      real*8            tauinf(nl) ! i
+
+
+c     local variables
+      integer   i, in, ir
+      real*8            a(nl,nl), cf(nl,nl), pideltanu, deltazdp, pi
+
+c***********************************************************************
+
+      pi = 3.141592
+      pideltanu = pi * dble(deltanu(1,1))
+      deltazdp = 2.0d5 * dble(deltaz)
+
+      do in=1,nl
+         do ir=1,nl
+            cf(in,ir) = 0.0d0
+            c110(in,ir) = 0.0d0
+            a(in,ir) = 0.0d0
+         end do
+         vc110(in) = 0.0d0
+      end do
+
+c     
+      do in=1,nl
+         do ir=1,nl
+
+            if (ir.eq.1) then
+               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     
+      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) / deltazdp
+         end do
+      end do
+
+c     
+      do in=1,nl
+         do ir=1,nl
+            cf(in,ir) = cf(in,ir) * pideltanu
+         end do
+      end do
+
+      do in=2,nl-1
+         do ir=1,nl
+            do i=1,nl
+               c110(in,ir) = c110(in,ir) + a(in,i) * cf(i,ir)
+            end do
+         end do
+      end do
+
+      do in=2,nl-1
+         vc110(in) =  pideltanu/deltazdp *
+     @        ( tau(in-1,1) - tau(in+1,1) )
+      end do
+
+
+c     
+      do in=2,nl-1
+         c110(in,nl-2) = c110(in,nl-2) - c110(in,nl)
+         c110(in,nl-1) = c110(in,nl-1) + 2.d0*c110(in,nl)
+      end do
+
+c     end
+      return
+      end
+
+
+c     *** Old MZMC121_dlvr11_03.f ***
+
+c***********************************************************************
+
+      subroutine MZMC121
+
+c***********************************************************************
+
+      implicit none
+
+                                ! common variables & constants
       
-      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'
+
+                                ! local variables
+
+      real*8 cax1(nl,nl)
+      real*8 v1(nl), cm_factor, vc_factor
+      real nuaux1, nuaux2, nuaux3
+      real*8 faux2,faux3, daux2,daux3
+
+      integer i,j,ik,ib
+
+************************************************************************
+
+      c121(1:nl,1:nl)=0.d0
+!      call zerom (c121,nl)
+      vc121(1:nl)=0.d0
+!      call zerov (vc121,nl)
+
+      nuaux1 = nu(1,2) - nu(1,1) ! 667.75
+      nuaux2 = nu12_0200-nu(1,1) ! 618.03
+      nuaux3 = nu12_1000-nu(1,1) ! 720.81
+      faux2 = dble(nuaux2/nuaux1)
+      faux3 = dble(nuaux3/nuaux1)
+      daux2 = dble(nuaux1-nuaux2)
+      daux3 = dble(nuaux1-nuaux3)
+
+      do 11, ik=1,3
+
+         ib=ik+1
+         cax1(1:nl,1:nl)=0.d0
+!         call zerom (cax1,nl)
+         call MZTUD121 ( cax1,v1, ib )
+
+         do i=1,nl
+
+            if(ik.eq.1)then
+               cm_factor = faux2**2.d0 * exp( daux2*ee/dble(t(i)) )
+               vc_factor = 1.d0/faux2
+            elseif(ik.eq.2)then
+               cm_factor = 1.d0
+               vc_factor = 1.d0
+            elseif(ik.eq.3)then
+               cm_factor = faux3**2.d0 * exp( daux3*ee/dble(t(i)) )
+               vc_factor = 1.d0 / faux3
+            else
+               write (*,*) ' Error in 626 hot band index  ik =', ik
+               stop ' ik can only be = 2,3,4.   Check needed.'
+            end if
+            do j=1,nl
+               c121(i,j) = c121(i,j) + cax1(i,j) * cm_factor
+            end do
+
+            vc121(i) = vc121(i) + v1(i) * vc_factor
+
+         end do
+
+ 11   continue
+
+      return
+      end
+
+
+c     *** Old MZTUD121_dlvr11_03.f ***
+
+c***********************************************************************
+      subroutine MZTUD121 ( cf,vc, ib )
+c***********************************************************************
+
+      implicit none
+
+      include 'datafile.h'
       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)                  
+
+c     arguments
+      real*8    cf(nl,nl)       ! o.
+      real*8            vc(nl)  ! o
+      integer           ib      ! i
+
+
+c     local variables and constants
+      integer   i, in, ir, iaquiHIST, iaquiZ
+      integer   nmu
+      parameter         (nmu = 8)
+      real*8            tau(nl,nl), argumento, deltazdbl
+      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                                
-      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            tvtbs(nzy)
+      real*8            st, beta, ts
+
       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
-
+      real*8            correc
+      real*8    deltanudbl
+      integer         isot
+      real*8          yy
+
+c     external function
+      external        we_clean
+      real*8          we_clean
+
+
+c     formats
+ 101  format(i1)
+c***********************************************************************
+
+c     some values
+      beta = 1.8d5
+      isot = 1
+      write (ibcode1,101) ib
+      deltanudbl = dble( deltanu(isot,ib) )
+      ff=1.0d10
+      deltazdbl = dble(deltaz)
+
+ccc   
+ccc   
+ccc   
+      do i=1,nl
+         zld(i) = dble(zl(i))
+      enddo
       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      
-            
+
+      call interhuntdp ( tvtbs,zyd,nzy, v626t1,zld,nl, 1 )
+
+      do i=1,nzy
+         con(i) =  dble( co2y(i) * imr(isot) )
+         correc = 2.d0 * exp( -ee*dble(elow(isot,2))/tvtbs(i) )
+         con(i) = con(i) * ( 1.d0 - correc )
+         mr(i) = dble( co2y(i) / nty(i) )
+      end do
+
+      coninf = dble( con(nzy) / log( con(nzy-1) / con(nzy) ) )
+      call mztf_correccion ( coninf, con, ib )
+
+ccc   
+      call gethist_03 ( ib )
+
+
+c     
+c     tauinf(nl)
+c     
+      call initial
+
+      iaquiZ = nzy - 2
+      iaquiHIST = nhist / 2
+
+      do i=nl,1,-1
+
+         if(i.eq.nl)then
+
+            call intzhunt ( iaquiZ, zl(i),c2,p2,mr2,t2, con)
+            do kr=1,nbox
+               ta(kr)=t2
+            end do
+            call interstrhunt (iaquiHIST, st2,t2,ka,ta)
+            aa = p2 * coninf * mr2 * (st2 * ff)
+            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) * deltazdbl
+            end do
+            c2 = c2 * st2 * deltazdbl
+
+         else
+            call intzhunt ( iaquiZ, zl(i),c1,p1,mr1,t1, con)
+            do kr=1,nbox
+               ta(kr)=t1
+            end do
+            call interstrhunt (iaquiHIST, st1,t1,ka,ta)
+            do kr=1,nbox
+               c1box(kr) = c1 * ka(kr) * deltazdbl
+            end do
+            c1 = c1 * st1 * deltazdbl
+            aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 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
+
+         pp = aa / (cc*ff)
+
+         ts = dd/cc
+         do kr=1,nbox
+            ta(kr) = ddbox(kr) / ccbox(kr)
+         end do
+         call interstrhunt(iaquiHIST, st,ts,ka,ta)
+         call intershphunt(iaquiHIST, alsa,alda,ta)
+
+c     
+
+         eqw = 0.0d0
+         do  kr=1,nbox
+            yy = ccbox(kr) * beta
+            w = we_clean ( yy, pp, alsa(kr),alda(kr) )
+            eqw = eqw + no(kr)*w
+         end do
+
+         argumento = eqw / deltanudbl
+         tauinf(i) = dexp( - argumento )
+
+
+      end do                    ! i continue
+
+
+c     
+c     tau(in,ir) for n<=r
+c     
+
+      iaquiZ = 2
+      do 1 in=1,nl-1
+
+         call initial
+         call intzhunt ( iaquiZ, zl(in), c1,p1,mr1,t1, con)
+         do kr=1,nbox
+            ta(kr) = t1
+         end do
+         call interstrhunt (iaquiHIST, st1,t1,ka,ta)
+         do kr=1,nbox
+            c1box(kr) = c1 * ka(kr) * deltazdbl
+         end do
+         c1 = c1 * st1 * deltazdbl
+
+         do 2 ir=in,nl-1
+
+            if (ir.eq.in) then
+               tau(in,ir) = 1.d0
+               goto 2
+            end if
+
+            call intzhunt ( iaquiZ, zl(ir), c2,p2,mr2,t2, con)
+            do kr=1,nbox
+               ta(kr) = t2
+            end do
+            call interstrhunt (iaquiHIST, st2,t2,ka,ta)
+            do kr=1,nbox
+               c2box(kr) = c2 * ka(kr) * deltazdbl
+            end do
+            c2 = c2 * st2 * deltazdbl
+
+            aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 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
+
+            pp = aa / (cc * ff)
+
+            ts = dd/cc
+            do kr=1,nbox
+               ta(kr) = ddbox(kr) / ccbox(kr)
+            end do
+            call interstrhunt(iaquiHIST, st,ts,ka,ta)
+            call intershphunt(iaquiHIST, alsa,alda,ta)
+
+c     
+
+            eqw = 0.0d0
+            do kr=1,nbox
+               yy = ccbox(kr) * beta
+               w = we_clean ( yy, pp, alsa(kr),alda(kr) )
+               eqw = eqw + no(kr)*w
+            end do
+
+            argumento = eqw / deltanudbl
+            tau(in,ir) = dexp( - argumento )
+
+ 2       continue
+
+ 1    continue
+
+c     
+c     tau(in,ir) for n>r
+c     
+
+      in=nl
+
+      call initial
+      iaquiZ = nzy - 2
+      call intzhunt ( iaquiZ, zl(in), c1,p1,mr1,t1, con)
+      do kr=1,nbox
+         ta(kr) = t1
+      end do
+      call interstrhunt (iaquiHIST, st1,t1,ka,ta)
+      do kr=1,nbox
+         c1box(kr) = c1 * ka(kr) * deltazdbl
+      end do
+      c1 = c1 * st1 * deltazdbl
+
+      do 4 ir=in-1,1,-1
+
+         call intzhunt ( iaquiZ, zl(ir), c2,p2,mr2,t2, con)
+         do kr=1,nbox
+            ta(kr) = t2
+         end do
+         call interstrhunt (iaquiHIST, st2,t2,ka,ta)
+         do kr=1,nbox
+            c2box(kr) = c2 * ka(kr) * deltazdbl
+         end do
+         c2 = c2 * st2 * deltazdbl
+
+         aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 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
+
+         pp = aa / (cc * ff)
+         ts = dd / cc
+         do kr=1,nbox
+            ta(kr) = ddbox(kr) / ccbox(kr)
+         end do
+         call interstrhunt (iaquiHIST, st,ts,ka,ta)
+         call intershphunt (iaquiHIST, alsa,alda,ta)
+
+c     
+         eqw=0.0d0
+         do kr=1,nbox
+            yy = ccbox(kr) * beta
+            w = we_clean ( yy, pp, alsa(kr),alda(kr) )
+            eqw = eqw + no(kr)*w
+         end do
+
+         argumento = eqw / deltanudbl
+         tau(in,ir) = dexp( - argumento )
+
+ 4    continue
+
+c     
+c     
+c     
+      do in=nl-1,2,-1
+         do ir=in-1,1,-1
+            tau(in,ir) = tau(ir,in)
+         end do
+      end do
+
+c     
+      call MZCUD121 ( tauinf,tau, cf, vc, ib )
+
+
+c     end
+      return
+      end
+
+
+
+c     *** Old MZCUD121_dlvr11.f ***
+
+c***********************************************************************
+
+      subroutine MZCUD121 ( tauinf,tau, c,vc, ib )
+
+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'
+
+
+c     arguments
+      real*8            c(nl,nl) ! o
+      real*8            vc(nl)  ! o
+      real*8            tau(nl,nl) ! i
+      real*8            tauinf(nl) ! i
+      integer           ib      ! i
+
+c     local variables
+      integer   i, in, ir, isot
+      real*8            a(nl,nl), cf(nl,nl), pideltanu, deltazdbl,pi
+
+c***********************************************************************
+
+      pi=3.141592
+      isot = 1
+      pideltanu = pi*dble(deltanu(isot,ib))
+      deltazdbl = dble(deltaz)
+c     
+      do in=1,nl
+
+         do ir=1,nl
+
+            cf(in,ir) = 0.0d0
+            c(in,ir) = 0.0d0
+            a(in,ir) = 0.0d0
+
+         end do
+
+         vc(in) = 0.0d0
+
+      end do
+
+
+c     
+      do in=1,nl
+         do ir=1,nl
+
+            if (ir.eq.1) then
+               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     
+      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.d5*deltazdbl )
+         end do
+      end do
+
+c     
+      do in=1,nl
+         do ir=1,nl
+            cf(in,ir) = cf(in,ir) * pideltanu
+         end do
+      end do
+
+
+      do in=2,nl-1
+         do ir=1,nl
+            do i=1,nl
+               c(in,ir) = c(in,ir) + a(in,i) * cf(i,ir)
+            end do
+         end do
+         vc(in) =  pideltanu /( 2.d5*deltazdbl ) *
+     @        ( tau(in-1,1) - tau(in+1,1) )
+      end do
+
+c     
+      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)
+      end do
+
+
+c     end
+      return
+      end
+
+
+
+c     *** Old MZESC121_dlvr11_03.f ***
+
+c***********************************************************************
+      subroutine MZESC121
+c***********************************************************************
+
+      implicit none
+
       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                                         
+
+
+c     local variables
+      integer   i
+      real*8          factor0200, factor0220, factor1000
+      real*8          aux_0200(nl), aux2_0200(nl)
+      real*8          aux_0220(nl), aux2_0220(nl)
+      real*8          aux_1000(nl), aux2_1000(nl)
+
+c***********************************************************************
+
+!      call zerov (taustar12, nl)
+      taustar12(1:nl)=0.d0
+      call zero2v(aux_0200,aux2_0200, nl)
+      call zero2v(aux_0220,aux2_0220, nl)
+      call zero2v(aux_1000,aux2_1000, nl)
+
+      call MZESC121sub (aux_0200,aux2_0200, 2 )
+      call MZESC121sub (aux_0220,aux2_0220, 3 )
+      call MZESC121sub (aux_1000,aux2_1000, 4 )
+
+      factor0220 = 1.d0
+      factor0200 = dble( (nu(1,2)-nu(1,1)) / (nu12_0200-nu(1,1)) )
+      factor1000 = dble( (nu(1,2)-nu(1,1)) / (nu12_1000-nu(1,1)) )
+      do i=1,nl
+         taustar12(i) = taustar12(i)
+     @        + aux_0200(i) * factor0200
+     @        + aux_0220(i) * factor0220
+     @        + aux_1000(i) * factor1000
+      enddo
+
+      call mzescape_normaliz ( taustar12, 2 )
+
+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                  
-                                                            
+c     *** Old MZESC121sub_dlvr11_03.f ***
+
+c***********************************************************************
+
+      subroutine MZESC121sub (taustar,tauinf, ib )
+
+c***********************************************************************
+
+      implicit none
+
+      include 'datafile.h'
       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)                                 
-                                                            
+
+
+c     arguments
+      real*8            taustar(nl) ! o
+      real*8            tauinf(nl) ! o
+      integer           ib      ! i
+
+
+c     local variables and constants
+      integer   i, iaquiHIST, iaquiZ, isot
+      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
+      real*8    zld(nl), zyd(nzy)
+      real*8            correc
+      real*8            deltanudbl, deltazdbl
+      real*8          yy
+
+c     external function
+      external        we_clean
+      real*8  we_clean
+
+c     formats
+ 101  format(i1)
+
+c***********************************************************************
+
+c     
+      beta = 1.8d5
+      isot = 1
+      write ( ibcode1, 101) ib
+      deltanudbl = dble( deltanu(isot,ib) )
+      ff=1.0d10
+      deltazdbl = dble(deltaz)
+
+c     
+      do i=1,nzy
+         zyd(i) = dble(zy(i))
+      enddo
+      do i=1,nl
+         zld(i) = dble(zl(i))
+      enddo
+
+      call interhuntdp ( tvtbs,zyd,nzy, v626t1,zld,nl, 1 )
+
+      do i=1,nzy
+         con(i) =  dble( co2y(i) * imr(isot) )
+         correc = 2.d0 * dexp( -ee*dble(elow(isot,2))/tvtbs(i) )
+         con(i) = con(i) * ( 1.d0 - correc )
+         mr(i) = dble(co2y(i)/nty(i))
+      end do
+
+      coninf = dble( con(nzy) / log( con(nzy-1) / con(nzy) ) )
+      call mztf_correccion ( coninf, con, ib )
+
+c     
+      call gethist_03 ( ib )
+
+c     
+c     tauinf
+c     
+      call initial
+
+      iaquiHIST = nhist/2
+      iaquiZ = nzy - 2
+
+      do i=nl,1,-1
+
+         if(i.eq.nl)then
+
+            call intzhunt (iaquiZ, zl(i),c2,p2,mr2,t2, con)
+            do kr=1,nbox
+               ta(kr)=t2
+            end do
+            call interstrhunt (iaquiHIST, st2,t2,ka,ta)
+            aa = p2 * coninf * mr2 * (st2 * ff)
+            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) * deltazdbl
+            end do
+            c2 = c2 * st2 * deltazdbl
+
+         else
+            call intzhunt (iaquiZ, zl(i),c1,p1,mr1,t1, con)
+            do kr=1,nbox
+               ta(kr)=t1
+            end do
+            call interstrhunt (iaquiHIST,st1,t1,ka,ta)
+            do kr=1,nbox
+               c1box(kr) = c1 * ka(kr) * deltazdbl
+            end do
+            c1 = c1 * st1 * deltazdbl
+            aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 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
+
+         pp = aa / (cc*ff)
+
+         ts = dd/cc
+         do kr=1,nbox
+            ta(kr) = ddbox(kr) / ccbox(kr)
+         end do
+         call interstrhunt(iaquiHIST,st,ts,ka,ta)
+         call intershphunt(iaquiHIST,alsa,alda,ta)
+
+c     
+         eqw=0.0d0
+         do  kr=1,nbox
+            yy = ccbox(kr) * beta
+            w = we_clean ( yy, pp, alsa(kr),alda(kr) )
+            eqw = eqw + no(kr)*w
+         end do
+         tauinf(i) = dexp( - eqw / deltanudbl )
+         if (tauinf(i).lt.0.d0) tauinf(i) = 0.0d0
+
+         if (i.eq.nl) then
+            taustar(i) = 0.0d0
+         else
+            taustar(i) = deltanudbl * (tauinf(i+1)-tauinf(i))
+     @           / ( beta * ccc  )
+         endif
+
+      end do
+
+
+
+c     end
+      return
+      end
+
+
+c     *** Old MZTVC121_dlvr11.f *** 
+
+c***********************************************************************
+
+      subroutine MZTVC121
+
+c***********************************************************************
+
+      implicit none
+
+!!!!!!!!!!!!!!!!!!!!!!!
+!     common variables & constants
+
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+
+
+!     arguments
+      integer ierr
+      real*8 varerr
+
+
+!     local variables
+
+      real*8 v1(nl), vc_factor
+      integer i,ik,ib
+
 ************************************************************************
-************************************************************************
-                                                            
-      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 
-
-
-
-
-
+
+!      call zerov( vc121, nl )
+      vc121(1:nl)=0.d0
+
+      do 11, ik=1,3
+
+         ib=ik+1
+
+         call MZTVC121sub (v1, ib, ierr,varerr )
+
+         do i=1,nl
+
+            if(ik.eq.1)then
+               vc_factor =
+     @              dble( (nu(1,2)-nu(1,1)) / (nu12_0200-nu(1,1)) )
+            elseif(ik.eq.2)then
+               vc_factor = 1.d0
+            elseif(ik.eq.3)then
+               vc_factor =
+     @              dble( (nu(1,2)-nu(1,1)) / (nu12_1000-nu(1,1)) )
+            end if
+
+            vc121(i) = vc121(i) + v1(i) * vc_factor
+
+         end do
+
+ 11   continue
+
+
+      return
+      end
+
+
+c     *** Old MZTVC121sub_dlvr11_03.f ***
+
+c***********************************************************************
+c     mztf.f
+c***********************************************************************
+
+      subroutine MZTVC121sub  ( vc, ib,  ierr, varerr )
+
+c***********************************************************************
+
+      implicit none
+
+      include 'datafile.h'
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+
+
+c     arguments
+      real*8            vc(nl)  ! o
+      integer           ib      ! i
+      integer ierr              ! o
+      real*8  varerr            ! o
+
+c     local variables and constants
+      integer   i, in, ir, iaquiHIST , iaquiZ, isot
+      integer   nmu
+      parameter         (nmu = 8)
+      real*8            tau(nl,nl), argumento
+      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
+      real*8    zld(nl), zyd(nzy), deltazdbl
+      real*8            correc
+      real*8            deltanudbl, pideltanu,pi
+      real*8          yy
+      real*8          minvc, maxtau
+
+c     external function
+      external        we_clean
+      real*8          we_clean
+
+c     formats
+ 101  format(i1)
+
+c***********************************************************************
+
+c     
+      pi=3.141592
+      isot = 1
+      beta = 1.8d5
+      write (ibcode1,101) ib
+      deltanudbl = dble( deltanu(isot,ib) )
+      pideltanu = pi*deltanudbl
+      ff=1.0d10
+      deltazdbl = dble(deltaz)
+c     
+c     
+c     
+
+      do i=1,nzy
+         zyd(i) = dble(zy(i))
+      enddo
+      do i=1,nl
+         zld(i) = dble(zl(i))
+      enddo
+
+      call interhuntdp ( tvtbs,zyd,nzy, v626t1,zld,nl, 1 )
+
+      do i=1,nzy
+         con(i) =  dble( co2y(i) * imr(isot) )
+         correc = 2.d0 * dexp( -ee*dble(elow(isot,2))/tvtbs(i) )
+         con(i) = con(i) * ( 1.d0 - correc )
+         mr(i) = dble(co2y(i)/nty(i))
+      end do
+
+      coninf = dble( con(nzy) / log( con(nzy-1) / con(nzy) ) )
+      call mztf_correccion ( coninf, con, ib )
+
+ccc   
+      call gethist_03 ( ib )
+
+c     
+c     tau(1,ir)
+c     
+      call initial
+
+      iaquiHIST = nhist/2
+
+      in=1
+
+      tau(in,1) = 1.d0
+
+      call initial
+      iaquiZ = 2
+      call intzhunt ( iaquiZ, zl(in), c1,p1,mr1,t1, con)
+      do kr=1,nbox
+         ta(kr) = t1
+      end do
+      call interstrhunt (iaquiHIST, st1,t1,ka,ta)
+      do kr=1,nbox
+         c1box(kr) = c1 * ka(kr) * deltazdbl
+      end do
+      c1 = c1 * st1 * deltazdbl
+                                ! Check interpolation errors :
+      if (c1.le.0.0d0) then
+         ierr=15
+         varerr=c1
+         return
+      elseif (p1.le.0.0d0) then
+         ierr=16
+         varerr=p1
+         return
+      elseif (mr1.le.0.0d0) then
+         ierr=17
+         varerr=mr1
+         return
+      elseif (t1.le.0.0d0) then
+         ierr=18
+         varerr=t1
+         return
+      elseif (st1.le.0.0d0) then
+         ierr=19
+         varerr=st1
+         return
+      endif
+                                !
+
+      do 2 ir=2,nl
+
+         call intzhunt (iaquiZ, zl(ir), c2,p2,mr2,t2, con)
+         do kr=1,nbox
+            ta(kr) = t2
+         end do
+         call interstrhunt (iaquiHIST, st2,t2,ka,ta)
+         do kr=1,nbox
+            c2box(kr) = c2 * ka(kr) * deltazdbl
+         end do
+         c2 = c2 * st2 * deltazdbl
+
+         aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 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
+
+         pp = aa / (cc * ff)
+
+         ts = dd/cc
+         do kr=1,nbox
+            ta(kr) = ddbox(kr) / ccbox(kr)
+         end do
+         call interstrhunt(iaquiHIST, st,ts,ka,ta)
+         call intershphunt(iaquiHIST, alsa,alda,ta)
+
+         eqw=0.0d0
+         do kr=1,nbox
+            yy = ccbox(kr) * beta
+            w = we_clean ( yy, pp, alsa(kr),alda(kr) )
+            eqw = eqw + no(kr)*w
+         end do
+
+         argumento = eqw / deltanudbl
+         tau(in,ir) = dexp( - argumento )
+
+ 2    continue
+
+
+c     
+c     
+c     
+      do in=nl,2,-1
+         tau(in,1) = tau(1,in)
+      end do
+
+c     
+      vc(1) = 0.0d0
+      vc(nl) = 0.0d0
+      do in=2,nl-1
+         vc(in) =  pideltanu /( 2.d5*deltazdbl ) *
+     @        ( tau(in-1,1) - tau(in+1,1) )
+         if (vc(in) .lt. 0.0d0) vc(in) = vc(in-1)
+      end do
+
+c     
+c     Tracking potential numerical errors
+c     
+      minvc = 1.d6
+      maxtau = tau(nl,1)
+      do in=2,nl-1
+         minvc = min( minvc, vc(in) )
+         maxtau = max( maxtau, tau(in,1) )
+      end do
+      if (maxtau .gt. 1.0d0) then
+         ierr = 13
+         varerr = maxtau
+         return
+      else if (minvc .lt. 0.0d0) then
+         ierr = 14
+         varerr = minvc
+         return
+      endif
+
+c     end
+      return
+      end
+
+
+
+
+
+
+
+
+

trunk/LMDZ.MARS/libf/phymars/nlte_commons.h

@@ -5 +5 @@
 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 *** Old datitos.cmn ***
+c
+        common /spectralv11/ elow, deltanu
+        real elow(nisot,nb), deltanu(nisot,nb)
+
+
+        common/nu_levs_bands_v11/ nu11, nu12, nu121,  
+     @          nu21, nu31, nu41
+        real*8 nu11, nu12, nu121
+        real*8 nu21
+        real*8 nu31
+        real*8 nu41
+
+
+        common /aeinstein1v11/ a1_010_000, a1_020_010
+        common /aeinstein2v11/ a2_010_000        
+        common /aeinstein3v11/ a3_010_000        
+        common /aeinstein4v11/ a4_010_000        
+
+        real*8 a1_010_000, a1_020_010
+        real*8 a2_010_000        
+        real*8 a3_010_000        
+        real*8 a4_010_000
+
+
+c *** Old tabulation.cmn ***
+
+        common/input_tab_v11/ lnpnbtab, 
+     @          tstar11tab, tstar21tab, tstar31tab, tstar41tab,
+     @          vc210tab, vc310tab, vc410tab
+
+        real*8 lnpnbtab(nztabul)
+        real*8 vc210tab(nztabul), vc310tab(nztabul), vc410tab(nztabul)
+        real*8 tstar11tab(nztabul), tstar21tab(nztabul), 
+     @         tstar31tab(nztabul), tstar41tab(nztabul)
+
+
+c *** Old nlte_results.cmn ***
+
+        common/input_avilable_from/ input_cza
+        integer input_cza 
 
 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)
+        common/temp626/ v626t1
+        common/temp628/ v628t1 
+        common/temp636/ v636t1 
+        common/temp627/ v627t1 
+        real*8 v626t1(nl)
+        real*8 v628t1(nl)
+        real*8 v636t1(nl)
+        real*8 v627t1(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***
+        common /tv15um/ vt11, vt12, vt21, vt31, vt41
+        real*8  vt11(nl), vt12(nl), vt21(nl), vt31(nl), vt41(nl)
+
+        common /hr15um/ hr110,hr210,hr310,hr410,hr121
+        real*8  hr110(nl),hr121(nl), 
+     @          hr210(nl),hr310(nl),hr410(nl)
+
+        common/sf15um/ el11,el12, el21, el31, el41
+        real*8 el11(nl), el12(nl)
+        real*8 el21(nl)
+        real*8 el31(nl)
+        real*8 el41(nl)
+
+        common/sl15um/ sl110,sl121, sl210,sl310,sl410
+        real*8 sl110(nl), sl121(nl)
+        real*8 sl210(nl)
+        real*8 sl310(nl)
+        real*8 sl410(nl)
+
+
+c *** Old matrices.cmn ***
+
+
 c curtis matrix de cza:
         common/curtis_matrixes_15um/ c110,c121, c210,
-     @          c310, c410,
-     @          vc110,vc121, vc210,
-     @          vc310, vc410
+     @          c310,c410,
+     @          vc110,vc121,vc210,vc310,vc410
         real*8 c110(nl,nl), c121(nl,nl)
         real*8 c210(nl,nl)
@@ -97 +92 @@
         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
+     @         taustar41, taustar12, taustar11_cts
         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 taustar11_cts(nl_cts)
+
+
+c *** Old atmref.cmn ***
+
+
+c NLTE Subgrid 
+c
+        common /atm_nl/ zl, t, pl, nt, co2, n2, co, o3p, 
+     @    co2vmr, n2vmr, covmr, o3pvmr, 
+     @    hrkday_factor
+
+        real zl(nl), t(nl), pl(nl), nt(nl),  
+     @    co2(nl), n2(nl), co(nl), o3p(nl), 
+     @    co2vmr(nl), n2vmr(nl), covmr(nl), o3pvmr(nl), 
+     @    hrkday_factor(nl)
+
+
+c Subgrid Transmittances 
+c
+        common /atm_ny/ zy, ty, py, nty, co2y
+        real zy(nzy), ty(nzy), py(nzy), nty(nzy), co2y(nzy)
+
+c Grids and indexes
+        common/deltazetas/ deltaz, deltazy, deltaz_cts, deltazy_cts, 
+     @        jlowerboundary, jtopboundary, jtopCTS
+        real    deltaz, deltazy, deltaz_cts, deltazy_cts
+        integer jlowerboundary, jtopboundary, jtopCTS
+
+
+c NLTE-CTS Subgrid 
+c
+        common /atm_nl_cts/ zl_cts, t_cts, pl_cts, nt_cts, 
+     @    co2_cts, n2_cts, co_cts, o3p_cts, 
+     @    co2vmr_cts, n2vmr_cts, covmr_cts, o3pvmr_cts, 
+     @    hrkday_factor_cts,mmean_cts,cpnew_cts
+
+        real zl_cts(nl_cts), t_cts(nl_cts), pl_cts(nl_cts), 
+     @    nt_cts(nl_cts), co2_cts(nl_cts), 
+     @    n2_cts(nl_cts), co_cts(nl_cts),
+     @    o3p_cts(nl_cts), co2vmr_cts(nl_cts), n2vmr_cts(nl_cts), 
+     @    covmr_cts(nl_cts), o3pvmr_cts(nl_cts), 
+     @    hrkday_factor_cts(nl_cts),mmean_cts(nl_cts),
+     @    cpnew_cts(nl_cts)
+
+
+c CTS Subgrid Transmittances 
+c
+        common /atm_ny_cts/ zy_cts, ty_cts, py_cts, nty_cts, co2y_cts
+        real zy_cts(nzy_cts), ty_cts(nzy_cts), py_cts(nzy_cts), 
+     @          nty_cts(nzy_cts), co2y_cts(nzy_cts)
+
+
+c *** Old rates.cmn ***
+
+        common/rates_vt/ 
+     @      k19ba(4),k19bb(4),k19bc(4), k19bap(4),k19bbp(4),k19bcp(4),
+     @      k19ca(4),k19cb(4),k19cc(4), k19cap(4),k19cbp(4),k19ccp(4),
+     @      k20b(4),k20c(4), k20bp(4),k20cp(4)
+
         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),
+        real*8 k20b,k20c, k20bp,k20cp
+
+        common/rates_vv/ 
      @          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
+     @          k33c, k33cp(2:4)
+
         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
-
+        real*8 k33c, k33cp
 
         common/rates_last/ k23k21c, k24k21c, k34k21c, 
-     @          k23k21cp, k24k21cp, k34k21cp, k43,k43p, k_vthcl
+     @          k23k21cp, k24k21cp, k34k21cp
 
         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
+
+
+
+c *** Old curtis.cmn ***
+
+        common /ini_file/ ibcode1
+        character ibcode1*1
+
+        common/block1/ alsa,alda,ka,kr
+        real*8 ka(nbox_max),alsa(nbox_max),alda(nbox_max)
         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
+        common/block2/ hisfile
+        character hisfile*75
+
+        common/block3/ pp,ta,w
+        real*8 pp,ta(nbox_max),w
+
+        common/block4/ no,sk1,xls1,xld1,thist,nbox
+        real*8  sk1(nhist,nbox_max)
+        real*8  xls1(nhist,nbox_max)    
+        real*8  xld1(nhist,nbox_max)    
+        real*8  thist(nhist)            
+        real*8  no(nbox_max)            
+        integer nbox            
+
+        common/block5/eqw, aa,  cc, dd, ddbox, ccbox, mr, mr_cts
+        real*8 eqw, aa, 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)
+        real*8  mr(nzy), mr_cts(nzy_cts)
+
+        common/blockstore/no_stored, sk1_stored, xls1_stored, 
+     &          xld1_stored, thist_stored, nbox_stored, 
+     &          mm_stored
+         real*8 sk1_stored(nb,nhist,nbox_max)
+         real*8 xls1_stored(nb,nhist,nbox_max)  
+         real*8 xld1_stored(nb,nhist,nbox_max)  
+         real*8 thist_stored(nb,nhist)          
+         real*8 no_stored(nb,nbox_max)          
+         integer nbox_stored(nb), mm_stored(nb) 
+
+c*****************************************************
+
+
+c*************************************************************
+
+
+
 
 c****************************************************************************
+
+
+

trunk/LMDZ.MARS/libf/phymars/nlte_paramdef.h

@@ -3 +3 @@
 c       Merging of different parameters definitions for new NLTE 15um param
 c
-c       jan 2012    fgg+malv
+c       jul 2012    fgg+malv
 c****************************************************************************
-c *** Old nltedefs.h ***
-! NLTE grid parameters:
+c *** Old mz1d.par ***
+! Grids parameters :
 
-        integer nl              ! actual # alt in NLTE module 
-        parameter ( nl=20 )
+        integer nztabul          ! # points in tabulation of Tesc & VC (ISO)
+        parameter ( nztabul=79 ) 
 
+! NLTE parameters:
+
+        integer nltot           ! incluye el actual # alt in NLTE module 
+        parameter ( nltot=20 )  ! y el # alturas del Tstar110
+
+        integer nl              ! actual # alt in NLTE module & C.Matrix 
+        parameter ( nl=12 )
         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
+        parameter ( nzy = (nl-1)*4 + 1 )  ! Fine grid for C.Matrix
+
+        integer nl_cts         ! actual # alt para Tstar110
+        parameter ( nl_cts = 2 + nltot-nl )
+        integer nzy_cts         ! fine grid for transmit calculation
+        parameter ( nzy_cts = (nl_cts-1)*4 + 1 ) 
 
 
@@ -27 +39 @@
 
         integer         nbox_max
-        parameter       ( nbox_max = 70 )       ! max.# boxes in histogram
+        parameter       ( nbox_max = 4 )       ! 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 tcr_15um.h ***
+
+        integer itt_cza                        ! Selection of NLTE scheme
+        parameter       ( itt_cza = 13 )
+
+        real    Ptop_atm, Pbottom_atm          ! Upper and lower limits of
+                                               ! NLTE model
+        parameter       ( Ptop_atm = 3.e-10 , Pbottom_atm = 2.e-5 ) 
+        
+
+        real*8  rf19,rf20,rf21a,rf21b,rf21c,rf33bc
+        parameter       ( rf19 = 1.d0, rf20 = 1.d0, rf21a = 1.d0)
+        parameter       ( rf21b = 1.d0, rf21c = 1.d0, rf33bc = 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)
+c *** Old bloque_dlvr11.f ***
 
-      real imr(nisot), imrco
-      parameter (imrco        = 0.9865)      
-      data imr / 0.987, 0.00408, 0.0112, 0.000742 /  
+        real nu(nisot,8)
+c data
+        data nu(1,1),nu(1,2) /667.3801, 1335.1317/
+        data nu(2,1)/662.3734/
+        data nu(3,1)/648.4784/
+        data nu(4,1)/664.7289/
 
-      integer indexisot(nisot)
-      data indexisot/26,28,36,27/
+        real nu12_0200,nu12_1000
+        parameter      (nu12_0200 = 1285.4087)
+        parameter      (nu12_1000 = 1388.1847) 
 
-      real deltanuco
-      parameter (deltanuco    = 306.)
+        integer indexisot(nisot)
+        data indexisot/26,28,36,27/
 
-      real nuco_10
-      parameter (nuco_10      = 2143.2716)
+        ! ctes en el sistema cgs
+        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 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)
+        ! datos de marte
+        real imr(nisot)
+        data imr / 0.987, 0.00408, 0.0112, 0.000742 /
 
-      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/
 
-      
+
+

trunk/LMDZ.MARS/libf/phymars/nlte_tcool.F

@@ +1 @@
+c**********************************************************************
+c     
+c     Contains the following old 1-d model subroutines:
+c     
+c     -NLTEdlvr11_TCOOL_03
+c     -NLTEdlvr11_CZALU_03
+c     -NLTEdlvr11_FB626CTS_03
+c
+c     
+c     
+c     *** Old NLTEdlvr11_TCOOL_02 ***
+c     
 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                                  
-         
+
+      subroutine nlte_tcool(ngridgcm,n_gcm,
+     $     p_gcm, t_gcm, z_gcm,
+     $     co2vmr_gcm, n2vmr_gcm, covmr_gcm, o3pvmr_gcm,
+     $     q15umco2_gcm )
+
+c***********************************************************************
+
+      implicit none
+
       include "dimensions.h"
       include "dimphys.h"
@@ -18 +31 @@
       include "conc.h"
 
-c Arguments 
+
+c     Arguments
       integer n_gcm,ngridgcm
       real p_gcm(ngridgcm,n_gcm), t_gcm(ngridgcm,n_gcm)
+      real z_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 auxgcm(n_gcm)
+      real*8 auxgcmd(n_gcm), aux2gcmd(n_gcm)
+      real zmin_gcm
+      integer ierr
+      real*8 varerr
+
+
+
+c     local variables and constants
+      integer   i,ig,l, indice, nl_cts_real, nzy_cts_real    
+      real*8      q15umco2_nltot(nltot),  zld(nltot)
+      real*8      hr110CTS(nl_cts)
+      real      xx,factor
 
       real p_ig(n_gcm),z_ig(n_gcm)
@@ -38 +57 @@
       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**********************************************************************
+
+
+c***************
+c***************
 
       do ig=1,ngridgcm
+         ierr = 0
+         nl_cts_real = 0
+         nzy_cts_real = 0
          do l=1,n_gcm
             p_ig(l)=p_gcm(ig,l)
@@ -55 +78 @@
          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
+                                ! From GCM's grid to NLTE's grid
+         call NLTEdlvr11_ZGRID_02 (n_gcm,
+     $        p_ig, t_ig, z_ig,
+     $        co2_ig, n2_ig, co_ig, o3p_ig,
+     $        mmean_ig,cpnew_ig,
+     $        nl_cts_real, nzy_cts_real )
+
+
+                                ! Isotopic Tstar & VC at the NLTE grid
+         call interdp_ESCTVCISO
+
+                                ! Tstar para NLTE-CTS
+         call MZESC110 ( nl_cts_real, nzy_cts_real ) 
+
+                                ! 626FB C.M.
          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) 
+         c110(1:nl,1:nl)=0.d0
+!         call zerom (c110, nl)
+         call zero2v (vc110,taustar11, nl)
+         call MZTUD110 ( ierr, varerr )
+         if (ierr .gt. 0) goto 900
+
+         input_cza = 0
+         call NLTEdlvr11_CZALU
+
+         input_cza = 1
+         call NLTEdlvr11_CZALU
+
+                                !  call NLTEdlvr11_FB626CTS
+                                ! Falta un merging del hr110CTS con el HR110
+
+
+!     ! Interpolation of Tstar11(nl) to the GCM grid (será auxgcm)
+!     ! solo entre jlowerboundary y jtopboundary (la extension del NLTE
+!     ! model)
+!     call interhuntlimits( auxgcm, p_gcm,n_gcm,
+!     @                        jlowerboundary,jtopboundary,
+!     @                        taustar11, pl,   nl, 3 )
+!     ! Mejor inter+extra polacion de Tstar11(nl) to the GCM grid
+!     call TSTAR11_extension (n_gcm, p_gcm, auxgcm )
+
+                                ! NLTE-CTS
+         call NLTEdlvr11_FB626CTS ( hr110CTS , nl_cts_real )
+
+
+
+                                ! total TCR
+         do i = 1, nl
+            q15umco2_nltot(i) =hr110(i) + hr210(i) + hr310(i) + hr410(i)
+     @           + hr121(i)
+         enddo
+
          
-         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) )                       
+                                ! Merging con / actualizacion del HR_total 
+                                !   Eliminamos el ultimo pto de hrTotal, y en el penultimo 
+                                !   (que coincide con i=1 en el grid nl_cts)
+                                !   hacemos la media entre hrTotal y hr110CTS :
+         i=nl-1
+         q15umco2_nltot(i) = 0.5*( q15umco2_nltot(i) + hr110CTS(1) )
+         do i=2,nl_cts_real
+            indice = (nl-2) + i
+            q15umco2_nltot(indice) = hr110CTS(i)
          enddo 
-          
-      enddo
-       
-       
-c end subroutine                                   
+         do i=nl_cts_real+1,nl_cts
+            indice = (nl-2) + i
+            q15umco2_nltot(indice) = 0.0d0
+         enddo
+
+                                ! Interpol to original Pgrid
+                                !  
+                                ! Primero, la parte conocida ([1,nl_cts_real])
+         do i=1,nl
+            zld(i) = - dble ( alog(pl(i)) )
+                                !write (*,*) i, zld(i), q15umco2_nltot(i)
+         enddo
+         do i=3,nl_cts_real
+            indice = (nl-2) + i
+            zld(indice) = - dble ( alog(pl_cts(i)) )
+                                !write (*,*) indice, zld(indice), q15umco2_nltot(indice)
+         enddo
+                                ! En caso que nl_cts_real < nl_cts , extrapolo el grid alegremente
+         factor = pl_cts(nl_cts_real)/pl_cts(nl_cts_real-1)
+         xx = pl_cts(nl_cts_real) 
+         do i=nl_cts_real+1,nl_cts 
+            indice = (nl-2) + i
+            xx = xx * factor  
+            zld(indice) = - dble ( alog(xx) )
+         enddo
+
+         do i=1,n_gcm
+            auxgcmd(i) = - dble( alog(p_gcm(ig,i)) )
+         enddo
+!         call zerov( aux2gcmd, n_gcm )
+         aux2gcmd(1:n_gcm)=0.d0
+         call interdp_limits
+     $        (     aux2gcmd, auxgcmd, n_gcm,   jlowerboundary,jtopCTS,
+     $        q15umco2_nltot,     zld, nltot,                1,  nltot,
+     $        1 )
+
+                                ! Smoothing
+         call suaviza ( aux2gcmd, n_gcm, 1, auxgcmd )
+
+         do i=1,n_gcm
+            q15umco2_gcm(ig,i) = sngl( aux2gcmd(i) )
+         enddo
+
+      enddo
+c     end subroutine
       return
-      end 
-
+
+c     Error messages
+ 900  write (*,*) ' ERROR in MZTUD (banda 110).    ierr=',ierr
+      write (*,*) ' VAR available : ', varerr
+      return
+
+ 901  write (*,*) ' ERROR in MZTVC for vc210.    ierr=',ierr
+      write (*,*) ' VAR available : ', varerr
+      return
+
+ 902  write (*,*) ' ERROR in MZTVC for vc310.    ierr=',ierr
+      write (*,*) ' VAR available : ', varerr
+      return
+
+ 903  write (*,*) ' ERROR in MZTVC for vc410.    ierr=',ierr
+      write (*,*) ' VAR available : ', varerr
+      return
+
+ 904  write (*,*) ' ERROR in mzescape_fb    ierr=',ierr
+      write (*,*) ' VAR available : ', varerr
+      return
+      
+ 930  write (*,*) ' ERROR in mztvc3iso. Temp is NaN'
+      write (*,*) ' ierr , VAR =', ierr, varerr
+      if (ierr.eq.30) write (*,*) ' During computation of VC210.'
+      if (ierr.eq.31) write (*,*) ' During computation of VC310.'
+      if (ierr.eq.32) write (*,*) ' During computation of VC410.'
+      return
+
+c     end subroutine
+      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
+      subroutine NLTEdlvr11_ZGRID_02 (n_gcm,
+     $     p_gcm, t_gcm, z_gcm, co2vmr_gcm, n2vmr_gcm, 
+     $     covmr_gcm, o3pvmr_gcm, mmean_gcm,cpnew_gcm,
+     $     nl_cts_real, nzy_cts_real )
+
 c***********************************************************************
-                                                
-      implicit none                                  
-        
-      include "dimensions.h"
-      include "dimphys.h"
+
+      implicit none
+      
       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)
+
+c     Arguments
+      integer n_gcm             ! I
+      real p_gcm(n_gcm), t_gcm(n_gcm) ! I
+      real co2vmr_gcm(n_gcm), n2vmr_gcm(n_gcm) ! I
+      real covmr_gcm(n_gcm), o3pvmr_gcm(n_gcm) ! I
+      real z_gcm(n_gcm)         ! I
+      real mmean_gcm(n_gcm)     ! I
+      real cpnew_gcm(n_gcm)     ! I
+      integer   nl_cts_real, nzy_cts_real ! O
+
+c     local variables
+      integer i, iz 
+      real  distancia, meanm, gz, Hkm
+      real  zmin, zmax
       real  mmean_nlte(n_gcm),cpnew_nlte(n_gcm)
-              
-c functions                                     
-      external  hrkday_convert                       
-      real              hrkday_convert                          
-                                                
+
+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 
+!     Define el working grid para MZ1D (NL, ZL, ZMIN)
+!     y otro mas fino para M.Curtis (NZ, ZX, ZXMIN = ZMIN)
+!     Tambien el working grid para MZESC110 (NL_cts, ZL_cts, ZMIN_cts=??)
+!     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]
+
+!     do iz = 2, n_gcm
+!     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) )
+!     enddo
+
+!     Segundo, definimos los límites de los 2 modelos de NLTE.
+!     NLTE model completo: indices [jlowerboundary,jtopboundary]
+!     NLTE CTS : indices [jbotCTS,jtopCTS] donde jbotCTS = jtopboundary-2
+
+!!!!!!!!!Primero el NLTE completo  !!!!!!!!
+
+                                ! Bottom boundary for NLTE model :
+                                !   Pbot_atm = 2e-2 mb = 1.974e-5 atm , lnp(nb)=9.9   (see mz1d.par)
+      jlowerboundary = 1
       do while ( p_gcm(jlowerboundary) .gt. Pbottom_atm )
          jlowerboundary = jlowerboundary + 1
-      enddo
+         if (jlowerboundary .gt. n_gcm) then
+            write (*,*) 'Error in lower boundary pressure.'
+            write (*,*) ' p_gcm too low or wrong. '
+            write (*,*) ' p_gcm, Pbottom_atm =',
+     $           p_gcm(n_gcm), Pbottom_atm
+            stop ' Check input value "p_gcm" or modify "Pbottom_atm" '
+         endif
+      enddo
+
+                                ! Top boundary for NLTE model :
+                                !   Ptop_atm = 1e-9 atm                          (see mz1d.par)
+      jtopboundary = jlowerboundary
+      do while ( p_gcm(jtopboundary) .gt. Ptop_atm )
+         jtopboundary = jtopboundary + 1
+         if (jtopboundary .gt. n_gcm) then
+            write (*,*) '!!!!!!!! Warning in top boundary pressure. '
+            write (*,*) ' Ptop_atm too high for p_gcm. '
+            write (*,*) ' p_gcm, Ptop_atm =',
+     $           p_gcm(n_gcm), Ptop_atm
+            write (*,*) '!!!!!!!! NLTE upper boundary modified '//
+     $           ' to match p_gcm'
+            jtopboundary=n_gcm
+            goto 5000
+         endif
+      enddo
+ 5000 continue
+
+                                ! Grid steps
+
       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                                      
+      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)
-        
+      enddo
+
+
+                                ! Creamos el perfil del NLTE modelo completo interpolando
+
+      call interhunt (    pl,zl,nl,      p_gcm,z_gcm,n_gcm, 2) ! [atm]
+      call interhunt5veces
+     $     ( t, co2vmr, n2vmr, covmr, o3pvmr,
+     $     zl, nl,
+     $     t_gcm, co2vmr_gcm, n2vmr_gcm, covmr_gcm, o3pvmr_gcm,
+     $     z_gcm, n_gcm,
+     $     1 )
+      call interhunt ( mmean_nlte,zl,nl,mmean_gcm,z_gcm,n_gcm,1)
+      call interhunt ( cpnew_nlte,zl,nl,cpnew_gcm,z_gcm,n_gcm,1)
 
       do i = 1, nl
-
+         nt(i) = 7.339e+21 * pl(i) / t(i) ! --> [cm-3]
          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( 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)       
+     &        ,cpnew_nlte(i))
+      enddo
       
-      call intersp (  co2y,zy,nzy,   co2vmr_gcm,z_gcm,n_gcm, 1) 
-      do i=1,nzy 
+                                !  Comprobar que las temps no se salen del grid del histograma
+
+      do i=1,nl
+         if (t(i) .gt. 400.0) then
+            write (*,*) '!!!! WARNING    Temp higher than Histogram.'
+            write (*,*) ' Histogram will be extrapolated. '
+            write (*,*) ' i, t(i), pl(i) =', i, t(i), pl(i)
+         endif
+         if (t(i) .lt. 50.0) then
+            write (*,*) '!!!! WARNING    Temp lower than Histogram.'
+            write (*,*) ' Histogram will be extrapolated. '
+            write (*,*) ' i, t(i), pl(i) =', i, t(i), pl(i)
+         endif
+      enddo
+
+                                !  Fine grid for transmittance calculations
+
+      zmin = z_gcm(jlowerboundary)
+      zmax = z_gcm(jtopboundary)
+      deltazy = (zmax-zmin) / (nzy-1)
+      do i=1,nzy
+         zy(i) = zmin + (i-1) * deltazy
+      enddo
+      call interhunt (    py,zy,nzy,      p_gcm,z_gcm,n_gcm, 2) ! [atm]
+      call interhunt2veces ( ty,co2y, zy,nzy,
+     $     t_gcm,co2vmr_gcm, z_gcm,n_gcm, 1)
+
+      do i=1,nzy
+         nty(i) = 7.339e+21 * py(i) / ty(i) ! --> [cm-3]
          co2y(i) = co2y(i) * nty(i)
       enddo
 
 
-  
-
-c end                                           
-      return                                         
-      end  
-
-
+!!!!!!!!!Segundo, el NLTE - CTS  !!!!!!!!
+
+                                ! Grid steps
+      deltaz_cts = deltaz
+      zl_cts(1) = zl(nl-1)
+      nl_cts_real = 1
+      do i=2,nl_cts
+         zl_cts(i) = zl_cts(1) + (i-1)*deltaz_cts
+         if (zl_cts(i) .gt. z_gcm(n_gcm)) then
+            write (*,*) '!!!!!!!! Warning in top CTS layers. '
+            write (*,*) ' zl_Cts too high for z_gcm. '
+            write (*,*) ' z_gcm, zl_cts(i), i =',
+     $           z_gcm(n_gcm), zl_cts(i), i
+            write (*,*) '!!!!!!!! NLTE-CTS upper boundary modified '//
+     $           ' to match z_gcm'
+            nl_cts_real=i-1
+            write (*,*) '  Original,Real NL_CTS=', nl_cts,nl_cts_real
+            goto 6000
+         endif
+      enddo
+      nl_cts_real = nl_cts
+ 6000 continue
       
-      
+                                ! Creamos perfil por interpolacion
+
+      call interhuntlimits ( pl_cts,zl_cts,nl_cts, 1,nl_cts_real,
+     $     p_gcm,z_gcm,n_gcm, 2)
+      call interhuntlimits5veces
+     $     ( t_cts, co2vmr_cts, n2vmr_cts, covmr_cts, o3pvmr_cts,
+     $     zl_cts, nl_cts,
+     $     1,nl_cts_real,
+     $     t_gcm, co2vmr_gcm, n2vmr_gcm, covmr_gcm, o3pvmr_gcm,
+     $     z_gcm, n_gcm,
+     $     1 )
+      call interhuntlimits( cpnew_cts,zl_cts,nl_cts,1,nl_cts_real,
+     $     cpnew_gcm,z_gcm,n_gcm, 1)
+      call interhuntlimits( mmean_cts,zl_cts,nl_cts,1,nl_cts_real,
+     $     mmean_gcm,z_gcm,n_gcm, 1)
+
+      do i = 1, nl_cts_real
+         nt_cts(i) = 7.339e+21 * pl_cts(i) / t_cts(i) ! --> [cm-3]
+         co2_cts(i) = nt_cts(i) * co2vmr_cts(i)
+         n2_cts(i) = nt_cts(i) * n2vmr_cts(i)
+         co_cts(i) = nt_cts(i) * covmr_cts(i)
+         o3p_cts(i) = nt_cts(i) * o3pvmr_cts(i)
+         hrkday_factor_cts(i) =  hrkday_convert( mmean_cts(i)
+     &        ,cpnew_cts(i) )
+      enddo
+
+                                !  Comprobar que las temps no se salen del grid del histograma
+      do i=1,nl_cts_real
+         if (t_cts(i) .gt. 400.0) then
+            write (*,*) '!!!! WARNING    Temp higher than Histogram.'
+            write (*,*) ' ZGRID: Histogram will be extrapolated. '
+            write (*,*) ' i, t(i), pl(i) =', i, t_cts(i), pl_cts(i)
+         endif
+         if (t_cts(i) .lt. 50.0) then
+            write (*,*) '!!!! WARNING    Temp lower than Histogram.'
+            write (*,*) ' ZGRID: Histogram will be extrapolated. '
+            write (*,*) ' i, t(i), pl(i) =', i, t_cts(i), pl_cts(i)
+         endif
+      enddo
+
+                                ! Calculo del indice maximo del GCM hasta donde llega el NLTE-CTS
+      jtopCTS = jtopboundary
+      do while ( p_gcm(jtopCTS) .gt. pl_cts(nl_cts_real) )
+         jtopCTS = jtopCTS + 1
+         if (jtopCTS .gt. n_gcm) then
+            write (*,*) '!!!!!!!! Warning in top boundary pressure. '
+            write (*,*) ' Ptop_NLTECTS too high for p_gcm. '
+            write (*,*) ' p_gcm, Ptop_NLTECTS =',
+     $           p_gcm(n_gcm), pl_cts(nl_cts_real)
+            write (*,*) '!!!!!!!! NLTE-CTS upper boundary modified '//
+     $           ' to match p_gcm'
+            jtopCTS=n_gcm
+            goto 7000
+         endif
+      enddo
+ 7000 continue
+
+                                !  Fine grid for transmittance calculations
+
+      deltazy_cts = 0.25*deltaz_cts ! Comprobar el factor 4 en mz1d.par
+      do i=1,nzy_cts
+         zy_cts(i) = zl_cts(1) + (i-1) * deltazy_cts
+      enddo
+      nzy_cts_real = (nl_cts_real - 1)*4 + 1
+      call interhuntlimits ( py_cts,zy_cts,nzy_cts, 1,nzy_cts_real,
+     $     p_gcm, z_gcm, n_gcm,   2) ! [atm]
+      call interhuntlimits2veces
+     $     ( ty_cts,co2y_cts, zy_cts,nzy_cts,  1,nzy_cts_real,
+     $     t_gcm,co2vmr_gcm, z_gcm,n_gcm, 1)
+
+      do i=1,nzy_cts_real
+         nty_cts(i) = 7.339e+21 * py_cts(i) / ty_cts(i) ! --> [cm-3]
+         co2y_cts(i) = co2y_cts(i) * nty_cts(i)
+      enddo
+
+!     write (*,*) '  NL = ', NL
+!     write (*,*) '  Original,Real NL_CTS=', nl_cts,nl_cts_real
+!     write (*,*) '  Original,Real NZY_CTS =', nzy_cts,nzy_cts_real
+
+
+
+c     end
+      return
+      end
+
+
+c     *** Old NLTEdlvr11_CZALU_03 ***
+
+c**********************************************************************
+
+
+      subroutine NLTEdlvr11_CZALU
+
 c***********************************************************************
-                                                            
-      subroutine NLTEdlvr09_CZALU(ig) 
-
-c     jul 2011 malv+fgg
-c***********************************************************************
-                                                            
-      implicit none                                  
-                                                            
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! common variables and constants  
-                                                            
+
+      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)                      
-      
+
+
+c     local variables
+
+!     matrixes and vectors
+
+      real*8 e110(nl), e210(nl), e310(nl), e410(nl)
+      real*8 e121(nl)
       real*8 f1(nl,nl)
-                                                           
-      real*8 cax1(nl,nl), cax2(nl,nl), cax3(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 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 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), aaalf31(nl,nl), aaalf41(nl,nl)
+      real*8 aaa11(nl),aaa1131(nl,nl),aaa1141(nl,nl)
+      real*8 aaa31(nl),aaa3111(nl,nl),aaa3141(nl,nl)
+      real*8 aaa41(nl),aaa4111(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), n12(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
+
+!     productions and loses
+      real*8 d19b1,d19c1
+      real*8 d19bp1,d19cp1
+      real*8 d19c2
+      real*8 d19cp2
+      real*8 d19c3
+      real*8 d19cp3
+      real*8 d19c4
+      real*8 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 pl11, pl12, pl21, pl31, pl41
+
+
+c     local constants and indexes
+
+      real*8 co2t, o3pdbl, codble, n2dble
+      real*8 a12_einst(nl)
+      real*8 a21_einst(nl), a31_einst(nl), a41_einst(nl)
+      real tsurf
+
+      integer i, isot
+
+c     external functions and subroutines
+
+      external planckdp
+      real*8    planckdp
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!start program
+
 
       call zero4v( aa11, aa21, aa31, aa41, nl)
@@ -414 +610 @@
       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)
+
+      call zero2v (vt11,vt12,nl)
+      call zero3v (vt21,vt31,vt41,nl)
+      call zero2v (hr110,hr121,nl)
+      call zero3v (hr210,hr310,hr410,nl)
+      call zero2v (sl110,sl121,nl)
+      call zero3v (sl210,sl310,sl410,nl)
+
+      call zero4v (el11,el21,el31,el41,nl)
+      call zero4v (e110,e210,e310,e410,nl)
+      call zero2v (el12,e121,nl)
+
+      call zero3m (cax1,cax2,cax3,nl)
+      f1(1:nl,1:nl)=0.d0
+!      call zerom (f1,nl)
+
+      call zero3v (v1,v2,v3,nl)
+
+      call zero4m (alf11,alf21,alf31,alf41,nl)
+      alf12(1:nl,1:nl)=0.d0
+!      call zerom (alf12,nl)
+      call zero2v (a11,a12,nl)
+      call zero3v (a21,a31,a41,nl)
+
+      call zero3m (a1121,a1131,a1141,nl)
+      a1112(1:nl,1:nl)=0.d0
+!      call zerom (a1112,nl)
+
+      call zero3m (a1221,a1231,a1241,nl)
+      a1211(1:nl,1:nl)=0.d0
+!      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 zero2v (n11,n12,nl)
+      call zero3v (n21,n31,n41,nl)
+
+      nu11 = dble(nu(1,1))
+      nu12 = dble(nu(1,2))
+      nu121 =  nu12-nu11
+      nu21 =  dble(nu(2,1))
+      nu31 =  dble(nu(3,1))
+      nu41 =  dble(nu(4,1))
+
+c     
+c     
+      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( -ee*nu11/v626t1(i) )
+            n21(i) = n20(i) *2.d0 *exp( -ee*nu21/v628t1(i) )
+            n31(i) = n30(i) *2.d0* exp( -ee*nu31/v636t1(i) )
+            n41(i) = n40(i) *2.d0* exp( -ee*nu41/v627t1(i) )
+         end if
+      enddo
+
+c     
+c     curtis matrix calculation
+c     
+      call zero3m (c210,c310,c410, nl)
+
+      if ( input_cza.ge.1 ) then
+
+         if (itt_cza.eq.15 ) then
+
+            call MZMC121
+
+         elseif (itt_cza.eq.13) then
+
+!            call zerom ( c121, nl )
+            c121(1:nl,1:nl)=0.d0
+            call MZESC121
+            call MZTVC121
 
          endif
@@ -513 +696 @@
       endif
 
+                                ! Lower Boundary
+      tsurf = t(1)
+      do i=1,nl
+         sl110(i) = vc110(i) * planckdp( tsurf, nu11 )
+         sl210(i) = vc210(i) * planckdp( tsurf, nu21 )
+         sl310(i) = vc310(i) * planckdp( tsurf, nu31 )
+         sl410(i) = vc410(i) * planckdp( tsurf, nu41 )
+      end do
+      if (input_cza.ge.1) then
+         do i=1,nl
+            sl121(i) = vc121(i) * planckdp( tsurf, nu121 )
+         end do
+      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
-                                                            
+         co2t = dble( co2(i) *(imr(1)+imr(3)+imr(2)+imr(4)) )
+         o3pdbl = dble( o3p(i) )
+         n2dble = dble( n2(i) )
+         codble = dble ( co(i) )
+
+         call GETK_dlvr11 ( t(i) )
+
+                                ! 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) )                 
+         d19b1 = k19ba(isot)*co2t + k19bb(isot)*n2dble
+     @        + k19bc(isot)*codble
+         d19c1 = k19ca(isot)*co2t + k19cb(isot)*n2dble
+     @        + k19cc(isot)*codble
+         d19bp1 = k19bap(isot)*co2t + k19bbp(isot)*n2dble
+     @        + k19bcp(isot)*codble
+         d19cp1 = k19cap(isot)*co2t + k19cbp(isot)*n2dble
+     @        + k19ccp(isot)*codble
          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) )                 
+         d19c2 = k19ca(isot)*co2t + k19cb(isot)*n2dble
+     @        + k19cc(isot)*codble
+         d19cp2 = k19cap(isot)*co2t + k19cbp(isot)*n2dble
+     @        + k19ccp(isot)*codble
          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) )                
+         d19c3 = k19ca(isot)*co2t + k19cb(isot)*n2dble
+     @        + k19cc(isot)*codble
+         d19cp3 = k19cap(isot)*co2t + k19cbp(isot)*n2dble
+     @        + k19ccp(isot)*codble
          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)               
+         d19c4 = k19ca(isot)*co2t + k19cb(isot)*n2dble
+     @        + k19cc(isot)*codble
+         d19cp4 = k19cap(isot)*co2t + k19cbp(isot)*n2dble
+     @        + k19ccp(isot)*codble
+                                !
+         l11 = d19c1 + k20c(1)*o3pdbl
+         p11 = ( d19cp1 + k20cp(1)*o3pdbl ) * n10(i)
+         l21 = d19c2 + k20c(2)*o3pdbl
+         p21 = ( d19cp2 + k20cp(2)*o3pdbl ) *n20(i)
+         l31 = d19c3 + k20c(3)*o3pdbl
+         p31 = ( d19cp3 + k20cp(3)*o3pdbl ) *n30(i)
+         l41 = d19c4 + k20c(4)*o3pdbl
+         p41 = ( d19cp4 + k20cp(4)*o3pdbl ) *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)*o3pdbl
+     @           + k21b(1)*n10(i)
+     @           + k33c*( n20(i) + n30(i) + n40(i) )
+            p12 = k21bp(1)*n11(i) * n11(i)
+            p1211 = d19bp1 + k20bp(1)*o3pdbl
+            p1221 = k33cp(2)*n11(i)
+            p1231 = k33cp(3)*n11(i)
+            p1241 = k33cp(4)*n11(i)
+
+            l11 = l11 + d19bp1
+     @           + k20bp(1)*o3pdbl
+     @           + 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)  
+            p1112 = d19b1
+     @           + k20b(1)*o3pdbl
+     @           + 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
+
+
+                                ! For ITT=13,15
+
+         a21_einst(i) = a2_010_000 * 1.8d0 / 4.d0 * taustar21(i)
+         a31_einst(i) = a3_010_000 * 1.8d0 / 4.d0 * taustar31(i)
+         a41_einst(i) = a4_010_000 * 1.8d0 / 4.d0 * taustar41(i)
+
+         l21 = l21 + a21_einst(i)
+         l31 = l31 + a31_einst(i)
+         l41 = l41 + a41_einst(i)
+
+                                ! For ITT=13
+         if (input_cza.ge.1 .and. itt_cza.eq.13) then
+            a12_einst(i) = a1_020_010/3.d0 * 1.8d0/4.d0 * 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 
+
+                                !
+
+         a11(i) = gamma*nu11**3.d0 * 1.d0/2.d0 * (p11) /
+     @        (n10(i)*l11)
+         a1121(i,i) = (nu11/nu21)**3.d0 * n20(i)/n10(i) * p1121/l11
+         a1131(i,i) = (nu11/nu31)**3.d0 * n30(i)/n10(i) * p1131/l11
+         a1141(i,i) = (nu11/nu41)**3.d0 * n40(i)/n10(i) * p1141/l11
+         e110(i) = 2.d0* vlight*nu11**2.d0 * 1.d0/2.d0 /
+     @        ( n10(i) * l11 )
+
+         a21(i) = gamma*nu21**3.d0 * 1.d0/2.d0 *
+     @        (p21)/(n20(i)*l21)
+         a2111(i,i) = (nu21/nu11)**3.d0 * n10(i)/n20(i) * p2111/l21
+         a2131(i,i) = (nu21/nu31)**3.d0 * n30(i)/n20(i) * p2131/l21
+         a2141(i,i) = (nu21/nu41)**3.d0 * n40(i)/n20(i) * p2141/l21
+         e210(i) = 2.d0*vlight*nu21**2.d0 * 1.d0/2.d0 /
+     @        ( n20(i) * l21 )
+
+         a31(i) = gamma*nu31**3.d0 * 1.d0/2.d0 * (p31) /
+     @        (n30(i)*l31)
+         a3111(i,i) = (nu31/nu11)**3.d0 * n10(i)/n30(i) * p3111/l31
+         a3121(i,i) = (nu31/nu21)**3.d0 * n20(i)/n30(i) * p3121/l31
+         a3141(i,i) = (nu31/nu41)**3.d0 * n40(i)/n30(i) * p3141/l31
+         e310(i) = 2.d0*vlight*nu31**2.d0 * 1.d0/2.d0 /
+     @        ( n30(i) * l31 )
+
+         a41(i) = gamma*nu41**3.d0 * 1.d0/2.d0 * (p41) /
+     @        (n40(i)*l41)
+         a4111(i,i) = (nu41/nu11)**3.d0 * n10(i)/n40(i) * p4111/l41
+         a4121(i,i) = (nu41/nu21)**3.d0 * n20(i)/n40(i) * p4121/l41
+         a4131(i,i) = (nu41/nu31)**3.d0 * n30(i)/n40(i) * p4131/l41
+         e410(i) = 2.d0*vlight*nu41**2.d0 * 1.d0/2.d0 /
+     @        ( n40(i) * l41 )
+
+         if (input_cza.ge.1) then
+
+            a1112(i,i) = (nu11/nu121)**3.d0 * n11(i)/n10(i) *
+     @           p1112/l11
+            a2112(i,i) = (nu21/nu121)**3.d0 * n11(i)/n20(i) *
+     @           p2112/l21
+            a3112(i,i) = (nu31/nu121)**3.d0 * n11(i)/n30(i) *
+     @           p3112/l31
+            a4112(i,i) = (nu41/nu121)**3.d0 * n11(i)/n40(i) *
+     @           p4112/l41
+            a12(i) = gamma*nu121**3.d0 *2.d0/4.d0* (p12)/
+     @           (n11(i)*l12)
+            a1211(i,i) = (nu121/nu11)**3.d0 * n10(i)/n11(i) *
+     @           p1211/l12
+            a1221(i,i) = (nu121/nu21)**3.d0 * n20(i)/n11(i) *
+     @           p1221/l12
+            a1231(i,i) = (nu121/nu31)**3.d0 * n30(i)/n11(i) *
+     @           p1231/l12
+            a1241(i,i) = (nu121/nu41)**3.d0 * n40(i)/n11(i) *
+     @           p1241/l12
+            e121(i) = 2.d0*vlight*nu121**2.d0 *2.d0/4.d0 /
+     @           ( n11(i) * l12 )
+
+         end if
+
+
+ 4    continue                  !-------------------------------------------------------
+
+
+
+                                !!!!!!!!!!!! Solucion del sistema
+
+                                !! Paso 0 :  Calculo de los alphas   alf11, alf21, alf31, alf41, alf12
+
+      call unit  ( cax2, nl )
+
+      call diago ( cax1, e110, nl )
+      call mulmmf90 ( cax3, cax1,c110, nl )
+      call resmmf90 ( alf11, cax2,cax3, nl )
+
+      call diago ( cax1, e210, nl )
+      call mulmmf90 ( cax3, cax1,c210, nl )
+      call resmmf90 ( alf21, cax2,cax3, nl )
+
+      call diago ( cax1, e310, nl )
+      call mulmmf90 ( cax3, cax1,c310, nl )
+      call resmmf90 ( alf31, cax2,cax3, nl )
+
+      call diago ( cax1, e410, nl )
+      call mulmmf90 ( cax3, cax1,c410, nl )
+      call resmmf90 ( alf41, cax2,cax3, nl )
+
+      if (input_cza.ge.1) then
+         call diago ( cax1, e121, nl )
+         call mulmmf90 ( cax3, cax1,c121, nl )
+         call resmmf90 ( alf12, cax2,cax3, nl )
       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***)
-           
+
+                                !! 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
+                                ! el11
          call sypvvv( aa11, a11,e110,sl110, nl )
          call samem( aa1121, a1121, nl )
@@ -809 +933 @@
          call samem( aa1141, a1141, nl )
          call samem( aalf11, alf11, nl )
-         
-          ! el21
+
+                                ! el21
          call sypvvv( aa21, a21,e210,sl210, nl )
          call samem( aa2111, a2111, nl )
@@ -817 +941 @@
          call samem( aalf21, alf21, nl )
 
-          ! el31
+                                ! el31
          call sypvvv( aa31, a31,e310,sl310, nl )
          call samem( aa3111, a3111, nl )
@@ -824 +948 @@
          call samem( aalf31, alf31, nl )
 
-          ! el41
+                                ! el41
          call sypvvv( aa41, a41,e410,sl410, nl )
          call samem( aa4111, a4111, nl )
@@ -837 +961 @@
          call sypvvv( v1, a12,e121,sl121, nl ) ! a12 + e121 * sl121
 
-          ! aa11
+                                ! aa11
          call sypvvv( v2, a11,e110,sl110, nl )
          call trucommvv( aa11 , alf12,a1112,v2, v1, nl )
-           
-          ! aalf11
+
+                                ! 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 mulmmf90( cax2, alf12, cax1, nl ) ! alf12 * (1/a1112)
+         call mulmmf90( cax3, cax2, alf11, nl )
+         call resmmf90( aalf11, cax3, a1211, nl )
+                                ! aa1121
          call trucodiag(aa1121, alf12,a1112,a1121, a1221, nl)
-          ! aa1131
+                                ! aa1131
          call trucodiag(aa1131, alf12,a1112,a1131, a1231, nl)
-          ! aa1141
+                                ! aa1141
          call trucodiag(aa1141, alf12,a1112,a1141, a1241, nl)
 
-           
-          ! aa21
+
+                                ! aa21
          call sypvvv( v2, a21,e210,sl210, nl )
          call trucommvv( aa21 , alf12,a2112,v2, v1, nl )
 
-          ! aalf21
+                                ! 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 mulmmf90( cax2, alf12, cax1, nl ) ! alf12 * (1/a2112)
+         call mulmmf90( cax3, cax2, alf21, nl )
+         call resmmf90( aalf21, cax3, a1221, nl )
+                                ! aa2111
          call trucodiag(aa2111, alf12,a2112,a2111, a1211, nl)
-          ! aa2131
+                                ! aa2131
          call trucodiag(aa2131, alf12,a2112,a2131, a1231, nl)
-          ! aa2141
+                                ! aa2141
          call trucodiag(aa2141, alf12,a2112,a2141, a1241, nl)
 
-          
-          ! aa31
-         call sypvvv( v2, a31,e310,sl310, nl )
+
+                                ! aa31
+         call sypvvv ( v2, a31,e310,sl310, nl )
          call trucommvv( aa31 , alf12,a3112,v2, v1, nl )
-          ! aalf31
+                                ! 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 mulmmf90( cax2, alf12, cax1, nl ) ! alf12 * (1/a3112)
+         call mulmmf90( cax3, cax2, alf31, nl )
+         call resmmf90( aalf31, cax3, a1231, nl )
+                                ! aa3111
          call trucodiag(aa3111, alf12,a3112,a3111, a1211, nl)
-          ! aa3121
+                                ! aa3121
          call trucodiag(aa3121, alf12,a3112,a3121, a1221, nl)
-          ! aa3141
+                                ! aa3141
          call trucodiag(aa3141, alf12,a3112,a3141, a1241, nl)
- 
-
-          ! aa41
+
+
+                                ! aa41
          call sypvvv( v2, a41,e410,sl410, nl )
          call trucommvv( aa41 , alf12,a4112,v2, v1, nl )
-          ! aalf41
+                                ! 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 mulmmf90( cax2, alf12, cax1, nl ) ! alf12 * (1/a4112)
+         call mulmmf90( cax3, cax2, alf41, nl )
+         call resmmf90( aalf41, cax3, a1241, nl )
+                                ! aa4111
          call trucodiag(aa4111, alf12,a4112,a4111, a1211, nl)
-          ! aa4121
+                                ! aa4121
          call trucodiag(aa4121, alf12,a4112,a4121, a1221, nl)
-          ! aa4131
+                                ! aa4131
          call trucodiag(aa4131, alf12,a4112,a4131, a1231, nl)
 
@@ -914 +1029 @@
 
 
-         !! Paso 2 :  Calculo de vectores y matrices con 2 barras (aaa***)
-
-         ! aaalf41
+                                !! 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 mulmmf90( cax2, aalf21, cax1, nl ) ! alf21 * (1/a4121)
+      call mulmmf90( cax3, cax2, aalf41, nl )
+      call resmmf90( aaalf41, cax3, aa2141, nl )
+                                ! aaa41
       call trucommvv(aaa41, aalf21,aa4121,aa41, aa21, nl)
-         ! aaa4111
+                                ! aaa4111
       call trucodiag(aaa4111, aalf21,aa4121,aa4111, aa2111, nl)
-         ! aaa4131
+                                ! aaa4131
       call trucodiag(aaa4131, aalf21,aa4121,aa4131, aa2131, nl)
 
-         ! aaalf31
+                                ! 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 mulmmf90( cax2, aalf21, cax1, nl ) ! alf21 * (1/a3121)
+      call mulmmf90( cax3, cax2, aalf31, nl )
+      call resmmf90( aaalf31, cax3, aa2131, nl )
+                                ! aaa31
       call trucommvv(aaa31, aalf21,aa3121,aa31, aa21, nl)
-         ! aaa3111
+                                ! aaa3111
       call trucodiag(aaa3111, aalf21,aa3121,aa3111, aa2111, nl)
-         ! aaa3141
+                                ! aaa3141
       call trucodiag(aaa3141, aalf21,aa3121,aa3141, aa2141, nl)
 
-         ! aaalf11
+                                ! 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 mulmmf90( cax2, aalf21, cax1, nl ) ! alf21 * (1/a1121)
+      call mulmmf90( cax3, cax2, aalf11, nl )
+      call resmmf90( aaalf11, cax3, aa2111, nl )
+                                ! aaa11
       call trucommvv(aaa11, aalf21,aa1121,aa11, aa21, nl)
-         ! aaa1131
+                                ! aaa1131
       call trucodiag(aaa1131, aalf21,aa1121,aa1131, aa2131, nl)
-         ! aaa1141
+                                ! aaa1141
       call trucodiag(aaa1141, aalf21,aa1121,aa1141, aa2141, nl)
 
 
-         !! Paso 3 :  Calculo de vectores y matrices con 3 barras (aaaa***)
-
-         ! aaaalf41
+                                !! 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 mulmmf90( cax2, aaalf31, cax1, nl ) ! aaalf31 * (1/aaa4131)
+      call mulmmf90( cax3, cax2, aaalf41, nl )
+      call resmmf90( aaaalf41, cax3, aaa3141, nl )
+                                ! aaaa41
       call trucommvv(aaaa41, aaalf31,aaa4131,aaa41, aaa31, nl)
-         ! aaaa4111
+                                ! aaaa4111
       call trucodiag(aaaa4111, aaalf31,aaa4131,aaa4111,aaa3111, nl)
 
-         ! aaaalf11
+                                ! 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 mulmmf90( cax2, aaalf31, cax1, nl ) ! aaalf31 * (1/aaa4131)
+      call mulmmf90( cax3, cax2, aaalf11, nl )
+      call resmmf90( aaaalf11, cax3, aaa3111, nl )
+                                ! aaaa11
       call trucommvv(aaaa11, aaalf31,aaa1131,aaa11, aaa31, nl)
-         ! aaaa1141
+                                ! aaaa1141
       call trucodiag(aaaa1141, aaalf31,aaa1131,aaa1141,aaa3141, nl)
 
 
-         !! Paso 4 :  Calculo de vectores y matrices finales y calculo de J1
+                                !! 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 mulmmf90( cax2, aaaalf41, cax1, nl ) ! aaaalf41 * (1/aaaa1141)
+      call mulmmf90( cax3, cax2, aaaalf11, nl )
+      call resmmf90( cax1, cax3, aaaa4111, nl )
+                                !
       call LUdec ( el11, cax1, v1, nl, nl2 )
 
-         ! Solucion para el41 
+                                ! Solucion para el41
       call sypvmv( v1, aaaa41, aaaa4111,el11, nl )
       call LUdec ( el41, aaaalf41, v1, nl, nl2 )
 
-         ! Solucion para el31 
+                                ! 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 
+                                ! Solucion para el21
       call sypvmv( v3, aa21, aa2111,el11, nl )
       call sypvmv( v2,   v3, aa2131,el31, nl )
@@ -1015 +1117 @@
       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    
+                                !!!
+      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 )
@@ -1037 +1139 @@
          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 )           
+         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)/( gamma * nu11**3.0d0  * 1.d0/2.d0 /n10(i) )
+            pl21 = el21(i)/( gamma * nu21**3.0d0  * 1.d0/2.d0 /n20(i) )
+            pl31 = el31(i)/( gamma * nu31**3.0d0  * 1.d0/2.d0 /n30(i) )
+            pl41 = el41(i)/( gamma * nu41**3.0d0  * 1.d0/2.d0 /n40(i) )
+            vt11(i) = -ee*nu11 / log( abs(pl11) / (2.0d0*n10(i)) )
+            vt21(i) = -ee*nu21 / log( abs(pl21) / (2.0d0*n20(i)) )
+            vt31(i) = -ee*nu31 / log( abs(pl31) / (2.0d0*n30(i)) )
+            vt41(i) = -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
+         enddo
+
+         v626t1(1:nl)=vt11(1:nl)
+         v628t1(1:nl)=vt21(1:nl)
+         v636t1(1:nl)=vt31(1:nl)
+         v627t1(1:nl)=vt41(1:nl)
+!         call dinterconnection( v626t1, vt11 )
+!         call dinterconnection ( v628t1, vt21 )
+!         call dinterconnection ( v636t1, vt31 )
+!         call dinterconnection ( v627t1, vt41 )
+
+      else
+
+         do i=1,nl
+            pl21 = el21(i)/( gamma * nu21**3.0d0 * 1.d0/2.d0 / n20(i) )
+            pl31 = el31(i)/( gamma * nu31**3.0d0 * 1.d0/2.d0 / n30(i) )
+            pl41 = el41(i)/( gamma * nu41**3.0d0 * 1.d0/2.d0 / 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
+            if (itt_cza.eq.13) then
+               pl12 = el12(i)/( gamma*nu121**3.0d0 * 2.d0/4.d0 /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)*dble( hrkday_factor(i) / nt(i) )
+         hr210(i)=hr210(i)*dble( hrkday_factor(i) / nt(i) )
+         hr310(i)=hr310(i)*dble( hrkday_factor(i) / nt(i) )
+         hr410(i)=hr410(i)*dble( hrkday_factor(i) / nt(i) )
+         hr121(i)=hr121(i)*dble( hrkday_factor(i) / nt(i) )
+      end do
+
+
+c     final
+      return
+c     
+      end
+
+
+c *** Old NLTEdlvr11_FB626CTS_02 ***
+
+c***********************************************************************
+      
+      subroutine NLTEdlvr11_FB626CTS ( hr110CTS, nl_cts_real )
+
+c***********************************************************************
+
+      implicit none
+
+!!!!!!!!!!!!!!!!!! common variables and constants
+
+      include 'nlte_paramdef.h'
+      include 'nlte_commons.h'
+        
+
+c Arguments 
+      real*8 hr110CTS(nl_cts)   ! output
+      integer  nl_cts_real      ! i
+
+c local variables
+
+      real*8 n11CTS(nl_cts), slopeTstar110(nl_cts)
+      real*8 n10(nl_cts), co2t, codbl, n2dbl, o3pdbl
+      real*8 d19c1, d19cp1, l11, p11
+      real*8 a11_einst(nl_cts), hcv, maxslope
+      integer i, isot
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!  start program
+
+      nu11 = dble(nu(1,1))
+      hcv =  hplanck*vlight*nu11
+
+      call zero2v (hr110CTS,n11CTS,nl_cts)
+
+      do i=1,nl_cts_real
+
+         co2t = dble ( co2_cts(i) *(imr(1)+imr(3)+imr(2)+imr(4)) )
+         n10(i) = dble( co2_cts(i) * imr(1) )
+         codbl = dble(co_cts(i))
+         o3pdbl = dble(o3p_cts(i))
+         n2dbl = dble(n2_cts(i))
+
+         call GETK_dlvr11 ( t_cts(i) )
+         isot = 1
+         d19c1 = k19ca(isot)*co2t + k19cb(isot)*n2dbl
+     $        + k19cc(isot)*codbl
+         d19cp1 = k19cap(isot)*co2t + k19cbp(isot)*n2dbl
+     $        + k19ccp(isot)*codbl
+         l11 = d19c1 + k20c(1)*o3pdbl
+         p11 = ( d19cp1 + k20cp(1)*o3pdbl ) * n10(i)
          
-      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                         
+         a11_einst(i) = a1_010_000 * 1.8d0/4.d0 * taustar11_cts(i)
+         
+         n11CTS(i) = p11 / (l11 + a11_einst(i))
+
+         hr110CTS(i) = - n11CTS(i) * a11_einst(i) * hcv
+         hr110CTS(i) = hr110CTS(i)*
+     $        dble( hrkday_factor_cts(i) / nt_cts(i) ) !K/Day
+
+      enddo
+
+
+c calculo de la altura de transicion, a partir de Tstar
+c y merging con el hr110(i), ya calculado con CZALU
+
+      slopeTstar110(1) = taustar11_cts(2)-taustar11_cts(1)
+      slopeTstar110(nl_cts_real) = taustar11_cts(nl_cts_real) -
+     $     taustar11_cts(nl_cts_real-1)
+      maxslope = max( slopeTstar110(1),slopeTstar110(nl_cts_real)) 
+      if (nl_cts_real .gt. 2) then 
+         do i=2,nl_cts_real-1
+            slopeTstar110(i) = ( taustar11_cts(i+1) -
+     $           taustar11_cts(i-1) ) * 0.5d0
+            if ( slopeTstar110(i) .gt. maxslope ) then
+                                !write (*,*) i, pl_cts(i), maxslope, slopeTstar110(i)
+               maxslope=slopeTstar110(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
+      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     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                        
+      
+      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
+      
+      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        

trunk/LMDZ.MARS/libf/phymars/physiq.F

@@ -454 +454 @@
          endif         
 
-         if(callnlte.and.nltemodel.eq.2) call NLTE_leedat
+         if(callnlte.and.nltemodel.eq.2) call nlte_setup
          if(callnirco2.and.nircorr.eq.1) call NIR_leedat
 
@@ -585 +585 @@
      &                      mmean(1:ngrid,1:nlayer)/mmol(igcm_o)
                  
-                 CALL NLTEdlvr09_TCOOL(ngrid,nlayer,pplay*9.869e-6,
+                 CALL nlte_tcool(ngrid,nlayer,pplay*9.869e-6,
      $                pt,zzlay,co2vmr_gcm, n2vmr_gcm, covmr_gcm, 
      $                ovmr_gcm,  zdtnlte )