source: trunk/LMDZ.VENUS/libf/phyvenus/nlte_setup.F @ 3567

c***********************************************************************

      subroutine nlte_setup

c     malv    Oct 09          Adapt mz1d_onlyTCR_MUCHASveces.f to "V09"
c     malv    Sep 07          Add LU deccomp & repetition option to test CPU
c     malv    Jan 07          Add new vertical fine-grid for NLTE
c     apr 06  malv            Read date,effuv from Driver. T fixed at zbott.
c     2003    fgg             Double precission in UV, Photoq, Conduct & Diff
c     oct 02  malv            V02: New scheme to allow for continuity eq.
c     dec 01  malv            See changes/progress of the code in mz1d.actual
c     nov 01  malv            adapt for parameterizations of tcr y shr
c     nov 98  malv            add chemical & photochem. processes
c     jul 98  malv            transic hiperb con zs fuera de la region
c     equil hidrostatico. smoothing en cr y sh
c     jan 98    malv            first version
c***********************************************************************

      implicit none

#include "nlte_paramdef.h"
#include "nlte_commons.h"


c***************

c     local variables

      integer   i, k, lun1, lun2
      real*8          xx
      character isotcode*2
      character (len=100) :: datafile="HIGHATM"

c     formats
 132  format (i2)

c**********************************************************************

c     *** Groups old 1-d model subroutines SETTINGS and LeeESCTVCISO_dlvr11
c     *** Both were called in old NLTEdlvr11_SETUP ***

c     *** Old SETTINGS ***

      lun1 = 1
      lun2 = 2

      do k=1,nisot
         write (isotcode,132) indexisot(k)
         open (lun1,
     $        file=trim(datafile)//'/enelow'
     $        //isotcode//'.dat',status='old')
         open (lun2,
     $        file=trim(datafile)//'/deltanu'
     $        //isotcode//'.dat',status='old')
         read (lun1,*)
         read (lun2,*)
         read (lun1,*) (elow(k,i), i=1,nb)
         read (lun2,*) (deltanu(k,i), i=1,nb)
         close (lun1)
         close (lun2)
      end do

      a1_010_000 = 1.3546d00
      a2_010_000 = 1.3452d00
      a3_010_000 = 1.1878d00
      a4_010_000 = 1.2455d00
      a1_020_010 = 4.35d0
      

c     *** Old LeeESCTVCISO_dlvr11 ***

      open( 11, file=trim(datafile)//
     $     '/parametp_Tstar_IAA1204.dat' )
      read (11, *)
      do i=1,nztabul
         read (11,*) lnpnbtab(i), tstar11tab(i),
     $        tstar21tab(i), tstar31tab(i), tstar41tab(i)
      enddo
      close (11)

      open( 12, file=trim(datafile)//
     $     '/parametp_VC_IAA1204.dat' )
      read (12, *)
      do i=1,nztabul
         read (12,*) xx, vc210tab(i), vc310tab(i), vc410tab(i)
      enddo
      close (12)
      xx=xx



      call LeeHISTOGRMS

c     end subroutine

      return
      end



c***********************************************************************
      subroutine LeeHISTOGRMS
c***********************************************************************

      implicit none

      include   'nlte_paramdef.h'
      include   'nlte_commons.h'


c     local variables and constants
      integer   ihist

      character (len=100) :: datafile="HIGHATM"
c***********************************************************************

                                ! Banda fundamental 
                                !
      hisfile = trim(datafile)//
     $     '/hid26-1.dat'
      ihist = 1
      call rhist_03 (ihist)


                                ! First Hot bands       
                                !     
      hisfile = trim(datafile)//
     $     '/hid26-2.dat'
      ihist = 2
      call rhist_03 (ihist)

      hisfile = trim(datafile)//
     $     '/hid26-3.dat'
      ihist = 3
      call rhist_03 (ihist)

      hisfile = trim(datafile)//
     $     '/hid26-4.dat'
      ihist = 4
      call rhist_03 (ihist)




      return
      end


c     *** Old GETK_dlvr11.f ***

c***********************************************************************

      subroutine GETK_dlvr11 (tt)

c***********************************************************************

      implicit none

      include 'nlte_paramdef.h'
      include 'nlte_commons.h'

c     arguments
      real              tt      ! i. temperature

!     ! local variables:
      real*8 k20x, k20xb, k20xc
      real*8 k19xca,k19xcb,k19xcc
      real*8 k19xba,k19xbb,k19xbc
      real*8 k21x,k21xa,k21xb,k21xc
      real*8 anu, factor , tdt
      integer   i

c***********************************************************************

      tdt = dble(tt)

                                !! k19 & k20

c     k20x = 3.d-12
c  TEST GG: double the values of Kvv as recently found by Sharma et al.2014
c     k20x = 6.d-12   
c  TEST GG: use the minimum value of the experimental bracket's values [1-6]
c      k20x = 1.d-12 
c--------------------
ccc VCD 1.1 tuning
      k20x = 5.d-12
c--------------------
      k20xc = k20x * rf20
      k20xb = 2.d0 * k20xc

      k19xca = 4.2d-12 * exp( -2988.d0/tdt + 303930.d0/tdt**2.d0 )
      if (tt.le.175.) k19xca = 3.3d-15
      k19xcb = 2.1d-12 * exp( -2659.d0/tdt + 223052.d0/tdt**2.d0 )
      if (tt.le.175.) k19xcb = 7.6d-16
      k19xca = k19xca * rf19
      k19xcb = k19xcb * rf19
      k19xcc = k19xcb

      factor = 2.5d0
      k19xba = factor * k19xca
      k19xbb = factor * k19xcb
      k19xbc = factor * k19xcc

      do i = 1, nisot

         k19ba(i) = k19xba
         k19ca(i) = k19xca
         k19bb(i) = k19xbb
         k19cb(i) = k19xcb
         k19bc(i) = k19xbc
         k19cc(i) = k19xcc

         k20b(i) = k20xb
         k20c(i) = k20xc

         anu = dble( nu(i,2)-nu(i,1) )

         k19bap(i) = k19ba(i) * 2.d0 * exp( -ee*anu/tdt )
         k19bbp(i) = k19bb(i) * 2.d0 * exp( -ee*anu/tdt )
         k19bcp(i) = k19bc(i) * 2.d0 * exp( -ee*anu/tdt )

         k20bp(i) = k20b(i)*4.d0/2.d0 * exp( -ee/tdt * anu )

         anu = dble( nu(i,1) )

         k19cap(i) = k19ca(i) * 2.d0 * exp( -ee*anu/tdt )
         k19cbp(i) = k19cb(i) * 2.d0 * exp( -ee*anu/tdt )
         k19ccp(i) = k19cc(i) * 2.d0 * exp( -ee*anu/tdt )

         k20cp(i) = k20c(i)*2.d0/1.d0 * exp( -ee/tdt * anu )

      end do


                                !! k21 &  k23k21c &  k24k21c & k34k21c

      k21x = 2.49d-11
CCC TEST GG
c      k21x =  2.49d-11*0.5
C      k21x =  2.49d-11*2

      k21xb = k21x
      k21xa = 3.d0/2.d0 * k21xb
      k21xc = k21xb / 2.d0

      k21xa = k21xa * rf21a
      k21xb = k21xb * rf21b
      k21xc = k21xc * rf21c

      do i = 1, nisot
         k21b(i) = k21xb
         k21c(i) = k21xc
         k21bp(i) = k21b(i) *
     @        exp( -ee/tdt* dble(nu(i,2)-nu(i,1)-nu(1,1)) )
         k21cp(i) = k21c(i) *
     @        exp( -ee/tdt * dble(nu(i,1)-nu(1,1)) )
      end do

      k23k21c = k21xc
      k24k21c = k21xc
      k34k21c = k21xc
      k23k21cp = k23k21c*2.d0/2.d0 *
     @     exp( -ee/tdt* dble(nu(2,1)-nu(3,1)) )
      k24k21cp = k24k21c*2.d0/2.d0 *
     @     exp( -ee/tdt* dble(nu(2,1)-nu(4,1)) )
      k34k21cp = k34k21c*2.d0/2.d0 *
     @     exp( -ee/tdt* dble(nu(3,1)-nu(4,1)) )


                                !! k33

      k33c = k21x * rf33bc
      do i=2,nisot
         k33cp(i) = k33c *
     @        exp( -ee/tdt * dble(nu(1,2)-nu(1,1)-nu(i,1)) )
      end do


      return
      end