!*****************************************************************************************
! generates meteor spectrum observable from ground and calculates luminous efficiency
! allowed flight speed = 10 to 40 km/s
! allowed flight altitude = 0 to 60 km
! allowed nose radius = 0.01 to 100 m 
! specify chemical composition of meteoroid in meteor_spect.inp file lines 1206 - 1219 
! luminous efficiency is given in the last column of amdot.tally file
!
! written by Chul Park, Korea Advanced Institute of Science and Technology (KAIST), March, 2017                                                                  
      program meteor_spect                                                                     
      parameter(mnode=1,matoms=56,mdiatoms=12,mtriatoms=6,msp=60)                         
      parameter(nw=400000)                                                                
      implicit real*8(a-h,o-z)                                                            
      character*4 atom_rads(3,168),diatom_bands(3,100),                         &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                           &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                      &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                               &               
     &  triatomnm1(mtriatoms),spnma(9)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,   &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      character*1 dum(120)                                                                
      dimension temp1(11),tempx(11),spgam(msp),waveli(11),iwavel(11),           &               
     & absbi(11,11),elmsf(8),spmlf(32),an(10)                                                                      
      common/coma/absb(nw)                                                      
      common/comi/nwave                                                                   
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)
      real*8 intw,int_e
      common/spect/calpha,slope_ratio,wavmin,wavmax,range   
      common/eqivu/rho_ivu(11),t_ivu(11),h_ivu(11)                                           
      common/lowdens/ntlow
      common/lowdens1/templ(11),enthl(11)
      save
!                                                                                         
! concx's are species concentrations in m-3                                               
! p means +, e.g. cp = C+                                                                 
! ne means electron                                                                       
! hvy means heavy particles (atoms, diatoms, triatoms, and their ions) 
!
! enths=0.5*vinf*vinf*enfac  
! enthj=temporary enthalpy value
! enth(idm)=enthalpy at node points                 
      dimension concAl(mnode),concAlp(mnode),concAlpp(mnode),             &
     & concAl3p(mnode),concC(mnode), concC2(mnode),                       &
     & concCa(mnode),concCap(mnode),concCl(mnode),concC2H(mnode),         &
     & concC3(mnode),concCH(mnode), concCN(mnode),concCO(mnode),          &
     & concCO2(mnode),concCp(mnode), concCpp(mnode),concC3p(mnode),       &
     & concC4p(mnode),concCr(mnode),concCrp(mnode),concCrpp(mnode),       &
     & concFe(mnode),concFeO(mnode),concFep(mnode),concFepp(mnode),       &
     & concFe3p(mnode),concFe4p(mnode),concFe5p(mnode),concH(mnode),      &
     & concH2(mnode), concHp(mnode),concH2O(mnode),concK(mnode),          &
     & concMg(mnode), concMgO(mnode),concMgp(mnode),concMgpp(mnode),      &
     & concMg3p(mnode),concMg4p(mnode),concN(mnode),concNE(mnode),        &
     & concN2(mnode),concN2p(mnode),concNp(mnode),concNpp(mnode),         &
     & concN3p(mnode),concN4p(mnode),concNa(mnode),concNap(mnode),        &
     & concNO(mnode),concNi(mnode),concNip(mnode),concNipp(mnode),        &
     & concNi3p(mnode),concO(mnode),concO2(mnode),concOH(mnode),          &
     & concOp(mnode),concOpp(mnode),concO3p(mnode),concO4p(mnode),        &
     & concS(mnode),concSi(mnode),concSO(mnode),concSiO(mnode),           &
     & concSip(mnode),concSipp(mnode),concSi3p(mnode),concSi4p(mnode),    &
     & concSp(mnode),concSpp(mnode),concS3p(mnode),concS4p(mnode),        &
     & concSiH(mnode),concTi(mnode),concTip(mnode),concTipp(mnode),       &
     & concTi3p(mnode),concTiO(mnode),                                    &               
     & z(mnode), tran(mnode),trot(mnode),tvib(mnode),tele(mnode),         &               
     & avg_molwt(mnode),tblack(2),ansp(msp)                                               
      dimension rhoi(9),tempi(31)                                                         
      data dum1/60*'****'/
!                                                                                         
      open(1,file='atom.out')                                                             
      open(2,file='diatom.out')                                                           
      open(3,file='triatom.out')                                                          
      open(4,file='eqtab_air_vis.dat')                                                     
      open(5,file='meteor_spect.inp')                                                      
      open(6,file='meteor_spect.out')                                                      
      open(7,file='atom.dat')                                                             
      open(8,file='diatom.dat')                                                           
      open(9,file='triatom.dat ')                                                         
      open(10,file='amdot.tally')
      open(11,file='flowfield.out')
      open(12,file='outer_conv.out')
      open(13,file='inner_conv.out')
      open(14,file='spect_air.plt')
      open(15,file='spect_vap.plt')
      open(16,file='absb_air.out')
      open(17,file='absb_vap.out')
      open(18,file='absb_low.out')
      open(19,file='thermair.inp')
      open(20,file='temp_display')
      open(21,file='short_file')
      open(22,file='trouble_shooting')
                                                                                          
      data atom_rads/         &               
     & 'Al  ','bb  ','Al  ',  & ! 'Al  ','bb  '   1                        &               
     & 'Al  ','bc  ','Al  ',  & ! 'Al  ','bf  '   2                        &               
     & 'Al  ','ff  ','Al  ',  & ! 'Al  ','ff  '   3                        &               
     & 'C   ','bb  ','C   ',  & ! 'C   ','bb  ',  4                        &               
     & 'C   ','bc  ','C   ',  & ! 'C   ','bf  ',  5                        &               
     & 'C   ','ff  ','C   ',  & ! 'C   ','ff  ',  6                        &               
     & 'Ca  ','bb  ','Ca  ',  & ! 'Ca  ','bb  '   7                        &               
     & 'Ca  ','bG  ','Ca  ',  & ! 'Ca  ','bf  '   8                        &               
     & 'Ca  ','ff  ','Ca  ',  & ! 'Ca  ','ff  '   9                        &               
     & 'Cr  ','bb  ','Cr  ',  & ! 'Cr  ','bb  '  10--------------------    &               
     & 'Cr  ','bG  ','Cr  ',  & ! 'Cr  ','bf  '  11                        &               
     & 'Cr  ','ff  ','Cr  ',  & ! 'cr  ','ff  '  12                        &               
     & 'Fe  ','bb  ','Fe  ',  & ! 'Fe  ','bb  '  13                        &               
     & 'Fe  ','bG  ','Fe  ',  & ! 'Fe  ','bf  '  14                        &               
     & 'Fe  ','ff  ','Fe  ',  & ! 'Fe  ','ff  '  15                        &               
     & 'H   ','bb  ','H   ',  & ! 'H   ','bb  ', 16                        &               
     & 'H   ','bG  ','H   ',  & ! 'H   ','bf  ', 17                        &               
     & 'H   ','ff  ','H   ',  & ! 'H   ','ff  ', 18                        &               
     & 'Mg  ','bb  ','Mg  ',  & ! 'Mg  ','bb  ', 19                        &               
     & 'Mg  ','bc  ','Mg  ',  & ! 'Mg  ','bf  ', 20-------------------     &               
     & 'Mg  ','ff  ','Mg  ',  & ! 'Mg  ','ff  '  21                        &               
     & 'Na  ','bb  ','Na  ',  & ! 'Na  ','bb  '  22                        &               
     & 'Na  ','bc  ','Na  ',  & ! 'Na  ','bf  '  23                        &               
     & 'Na  ','ff  ','Na  ',  & ! 'Na  ','ff  '  24                        &               
     & 'N   ','bb  ','N   ',  & ! 'N   ','bb  ', 25                        &               
     & 'N   ','bc  ','N   ',  & ! 'N   ','bf  ', 26                        &               
     & 'N   ','ff  ','N   ',  & ! 'N   ','ff  ', 27                        &               
     & 'Ni  ','bb  ','Ni  ',  & ! 'Ni  ','bb  '  28                        &               
     & 'Ni  ','bG  ','Ni  ',  & ! 'Ni  ','bf  '  29                        &               
     & 'Ni  ','ff  ','Ni  ',  & ! 'Ni  ','ff  '  30------------------      &               
     & 'O   ','bb  ','O   ',  & ! 'O   ','bb  ', 31                        &               
     & 'O   ','bc  ','O   ',  & ! 'O   ','bf  ', 32                        &               
     & 'O   ','ff  ','O   ',  & ! 'O   ','ff  ', 33                        &               
     & 'S   ','bb  ','S   ',  & ! 'S   ','bb  '  34                        &               
     & 'S   ','bG  ','S   ',  & ! 'S   ','bf  '  35                        &               
     & 'S   ','ff  ','S   ',  & ! 'S   ','ff  '  36                        &               
     & 'Si  ','bb  ','Si  ',  & ! 'Si  ','bb  ', 37                        &               
     & 'Si  ','bc  ','Si  ',  & ! 'Si  ','bf  ', 38                        &               
     & 'Si  ','ff  ','Si  ',  & ! 'Si  ','ff  ', 39                        &               
     & 'Ti  ','bb  ','Ti  ',  & ! 'Ti  ','bb  '  40------------------      &               
     & 'Ti  ','bG  ','Ti  ',  & ! 'Ti  ','bf  '  41                        &               
     & 'Ti  ','ff  ','Ti  ',  & ! 'Ti  ','ff  '  42                        &               
     & 'Al+ ','bb  ','Al+ ',  & ! 'Al+ ','bb  '  43                        &               
     & 'Al+ ','bc  ','Al+ ',  & ! 'Al+ ','bf  '  44                        &               
     & 'Al+ ','ff  ','Al+ ',  & ! 'Al+ ','ff  '  45                        &               
     & 'C+  ','bb  ','C+  ',  & ! 'C+  ','bb  '  46                        &               
     & 'C+  ','bc  ','C+  ',  & ! 'C+  ','bf  '  47                        &               
     & 'C+  ','ff  ','C+  ',  & ! 'C+  ','ff  '  48                        &               
     & 'Ca+ ','bb  ','Ca+ ',  & ! 'Ca+ ','bb  '  49                        &               
     & 'Ca+ ','bc  ','Ca+ ',  & ! 'Ca+ ','bf  '  50-----------------       &               
     & 'Ca+ ','ff  ','Ca+ ',  & ! 'Ca+ ','ff  '  51                        &               
     & 'Cr+ ','bb  ','Cr+ ',  & ! 'Cr+ ','bb  '  52                        &               
     & 'Cr+ ','bG  ','Cr+ ',  & ! 'Cr+ ','bf  '  53                        &                   
     & 'Cr+ ','ff  ','Cr+ ',  & ! 'Cr+ ','ff  '  54                        &               
     & 'Fe+ ','bb  ','Fe+ ',  & ! 'Fe+ ','bb  '  55                        &               
     & 'Fe+ ','bG  ','Fe+ ',  & ! 'Fe+ ','bf  '  56                        &               
     & 'Fe+ ','ff  ','Fe+ ',  & ! 'Fe+ ','ff  '  57                        &               
     & 'Mg+ ','bb  ','Mg+ ',  & ! 'Mg+ ','bb  '  58                        &               
     & 'Mg+ ','bc  ','Mg+ ',  & ! 'Mg+ ','bf  '  59                        &               
     & 'Mg+ ','ff  ','Mg+ ',  & ! 'Mg+ ','ff  '  60-------------           &               
     & 'N+  ','bb  ','N+  ',  & ! 'N+  ','bb  '  61                        &               
     & 'N+  ','bc  ','N+  ',  & ! 'N+  ','bf  '  62                        &               
     & 'N+  ','ff  ','N+  ',  & ! 'N+  ','ff  '  63                        &               
     & 'Na+ ','bb  ','Na+ ',  & ! 'Na+ ','bb  '  64                        &               
     & 'Na+ ','bG  ','Na+ ',  & ! 'Na+ ','bf  '  65                        &               
     & 'Na+ ','ff  ','Na+ ',  & ! 'Na+ ','ff  '  66                        &               
     & 'Ni+ ','bb  ','Ni+ ',  & ! 'Ni+ ','bb  '  67                        &               
     & 'Ni+ ','bG  ','Ni+ ',  & ! 'Ni+ ','bf  '  68                        &               
     & 'Ni+ ','ff  ','Ni+ ',  & ! 'Ni+  ,'ff  '  69                        &               
     & 'O+  ','bb  ','O+  ',  & ! 'O+  ','bb  '  70-------------------     &               
     & 'O+  ','bc  ','O+  ',  & ! 'O+  ','bf  '  71                        &               
     & 'O+  ','ff  ','O+  ',  & ! 'O+  ','ff  '  72                        &               
     & 'S+  ','bG  ','S+  ',  & ! 'S+  ','bb  '  73                        &               
     & 'S+  ','ff  ','S+  ',  & ! 'S+  ','bf  '  74                        &               
     & 'S+  ','ff  ','S+  ',  & ! 'S+  ','ff  '  75                        &               
     & 'Si+ ','bb  ','Si+ ',  & ! 'Si+ ','bb  '  76                        &               
     & 'Si+ ','bc  ','Si+ ',  & ! 'Si+ ','bf  '  77                        &               
     & 'Si+ ','ff  ','Si+ ',  & ! 'Si+ ','ff  '  78                        &               
     & 'Ti+ ','bb  ','Ti+ ',  & ! 'Ti+ ','bb  '  79                        &               
     & 'Ti+ ','bG  ','Ti+ ',  & ! 'Ti+ ','bf  '  80------------------      &               
     & 'Ti+ ','ff  ','Ti+ ',  & ! 'Ti+ ','ff  '  81                        &               
     & 'Al++','bb  ','Al++',  & ! 'Al++','bb  '  82                        &               
     & 'Al++','bG  ','Al++',  & ! 'Al++','bf  '  83                        &               
     & 'Al++','ff  ','Al++',  & ! 'Al++','ff  '  84                        &               
     & 'C++ ','bb  ','C++ ',  & ! 'C++ ','bb  '  85                        &               
     & 'C++ ','bc  ','C++ ',  & ! 'C++ ','bf  '  86                        &               
     & 'C++ ','ff  ','C++ ',  & ! 'C++ ','ff  '  87                        &               
     & 'Fe++','bb  ','Fe++',  & ! 'Fe++','bb  '  88                        &               
     & 'Fe++','bG  ','Fe++',  & ! 'Fe++','bf  '  89                        &               
     & 'Fe++','ff  ','Fe++',  & ! 'Fe++','ff  '  90------------------      &               
     & 'Mg++','bb  ','Mg++',  & ! 'Mg++','bb  '  91                        &               
     & 'Mg++','bG  ','Mg++',  & ! 'Mg++','bf  '  92                        &               
     & 'Mg++','ff  ','Mg++',  & ! 'Mg++','ff  '  93                        &               
     & 'N++ ','bb  ','N++ ',  & ! 'N++ ','bb  '  94                        &               
     & 'N++ ','bG  ','N++ ',  & ! 'N++ ','bf  '  95                        &               
     & 'N++ ','ff  ','N++ ',  & ! 'N++ ','ff  '  96                        &               
     & 'Ni++','bb  ','Ni++',  & ! 'Ni++','bb  '  97                        &               
     & 'Ni++','bG  ','Ni++',  & ! 'Ni++','bf  '  98                        &               
     & 'Ni++','ff  ','Ni++',  & ! 'Nr++','ff  '  99                        &               
     & 'O++ ','bb  ','O++ ',  & ! 'O++ ','bb  ' 100---------------         &               
     & 'O++ ','bG  ','O++ ',  & ! 'O++ ','bf  ' 101                        &               
     & 'O++ ','ff  ','O++ ',  & ! 'O++ ','ff  ' 102                        &               
     & 'S++ ','bb  ','S++ ',  & ! 'S++ ','bb  ' 103                        &               
     & 'S++ ','bG  ','S++ ',  & ! 'S++ ','bf  ' 104                        &               
     & 'S++ ','ff  ','S++ ',  & ! 'S++ ','ff  ' 105                        &               
     & 'Si++','bb  ','Si++',  & ! 'Si++','bb  ' 106                        &               
     & 'Si++','bG  ','Si++',  & ! 'Si++','bf  ' 107                        &               
     & 'Si++','ff  ','Si++',  & ! 'Si++','ff  ' 108                        &               
     & 'Ti++','bb  ','Ti++',  & ! 'Ti++','bb  ' 109                        &               
     & 'Ti++','bG  ','Ti++',  & ! 'Ti++','bf  ' 110----------------        &               
     & 'Ti++','ff  ','Ti++',  & ! 'T+++','ff  ' 111                        &               
     & 'Al+3','bb  ','Al+3',  & ! 'Al+3','bb  ' 112                        &               
     & 'Al+3','bG  ','Al+3',  & ! 'Al+3','bf  ' 113                        &               
     & 'Al+3','ff  ','Al+3',  & ! 'Al+3','ff  ' 114                        &               
     & 'C+3 ','bb  ','C+3 ',  & ! 'C+3 ','bb  ' 115                        &               
     & 'C+3 ','bG  ','C+3 ',  & ! 'C+3 ','bf  ' 116                        &               
     & 'C+3 ','ff  ','C+3 ',  & ! 'C+3 ','ff  ' 117                        &               
     & 'Fe+3','bb  ','Fe+3',  & ! 'Fe+3','bb  ' 118                        &               
     & 'Fe+3','bG  ','Fe+3',  & ! 'Fe+3','bf  ' 119                        &               
     & 'Fe+3','ff  ','Fe+3',  & ! 'Fe+3','ff  ' 120------------------      &               
     & 'Mg+3','bb  ','Mg+3',  & ! 'Mg+3','bb  ' 121                        &               
     & 'Mg+3','bG  ','Mg+3',  & ! 'Mg+3','bf  ' 122                        &               
     & 'Mg+3','ff  ','Mg+3',  & ! 'Mg+3','ff  ' 123                        &               
     & 'S+3 ','bb  ','S+3 ',  & ! 'S+3 ','bb  ' 124                        &               
     & 'S+3 ','bG  ','S+3 ',  & ! 'S+3 ','bf  ' 125                        &               
     & 'S+3 ','ff  ','S+3 ',  & ! 'S+3 ','ff  ' 126                        &               
     & 'N+3 ','bb  ','N+3 ',  & ! 'N+3 ','bb  ' 127                        &               
     & 'N+3 ','bG  ','N+3 ',  & ! 'N+3 ','bf  ' 128                        &               
     & 'N+3 ','ff  ','N+3 ',  & ! 'N+3 ','ff  ' 129                        &               
     & 'Ni+3','bb  ','Ni+3',  & ! 'Ni+3','bb  ' 130-----------------       &               
     & 'Ni+3','bG  ','Ni+3',  & ! 'Ni+3','bf  ' 131                        &               
     & 'Ni+3','ff  ','Ni+3',  & ! 'Ni+3','ff  ' 132                        &               
     & 'O+3 ','bb  ','O+3 ',  & ! 'O+3 ','bb  ' 133                        &               
     & 'O+3 ','bG  ','O+3 ',  & ! 'O+3 ','bf  ' 134                        &               
     & 'O+3 ','ff  ','O+3 ',  & ! 'O+3 ','ff  ' 135                        &               
     & 'Si+3','bb  ','Si+3',  & ! 'Si+3','bb  ' 136                        &               
     & 'Si+3','bG  ','Si+3',  & ! 'Si+3','bf  ' 137                        &               
     & 'Si+3','ff  ','Si+3',  & ! 'Si+3','ff  ' 138                        &               
     & 'Ti+3','bb  ','Ti+3',  & ! 'Ti+3','bb  ' 139                        &               
     & 'Ti+3','bG  ','Ti+3',  & ! 'Ti+3','bf  ' 140------------------      &               
     & 'Ti+3','ff  ','Ti+3',  & ! 'T++3','ff  ' 141                        &               
     & 'C+4 ','bb  ','C+4 ',  & ! 'C+4 ','bb  ' 142                        &               
     & 'C+4 ','bG  ','C+4 ',  & ! 'C+4 ','bf  ' 143                        &               
     & 'C+4 ','ff  ','C+4 ',  & ! 'C+4 ','ff  ' 144                        &               
     & 'Fe+4','bb  ','Fe+4',  & ! 'Fe+4','bb  ' 145                        &               
     & 'Fe+4','bG  ','Fe+4',  & ! 'Fe+4','bf  ' 146                        &               
     & 'Fe+4','ff  ','Fe+4',  & ! 'Fe+4','ff  ' 147                        &               
     & 'Mg+4','bb  ','Mg+4',  & ! 'Mg+4','bb  ' 148                        &               
     & 'Mg+4','bG  ','Mg+4',  & ! 'Mg+4','bf  ' 149                        &               
     & 'Mg+4','ff  ','Mg+4',  & ! 'Mg+4','ff  ' 150-----------------       &               
     & 'N+4 ','bb  ','N+4 ',  & ! 'N+4 ','bb  ' 151                        &               
     & 'N+4 ','bG  ','N+4 ',  & ! 'N+4 ','bf  ' 152                        &               
     & 'N+4 ','ff  ','N+4 ',  & ! 'N+4 ','ff  ' 153                        &               
     & 'O+4 ','bb  ','O+4 ',  & ! 'O+4 ','bb  ' 154                        &               
     & 'O+4 ','bG  ','O+4 ',  & ! 'O+4 ','bf  ' 155                        &               
     & 'O+4 ','ff  ','O+4 ',  & ! 'O+4 ','ff  ' 156                        &               
     & 'Si+4','bb  ','Si+4',  & ! 'Si+4','bb  ' 157                        &               
     & 'Si+4','bG  ','Si+4',  & ! 'Si+4','bf  ' 158                        &               
     & 'Si+4','ff  ','Si+4',  & ! 'Si+4','ff  ' 159                        &               
     & 'Fe+5','bb  ','Fe+5',  & ! 'Fe+5','bb  ' 160----------------        &               
     & 'Fe+5','bG  ','Fe+5',  & ! 'Fe+5','bf  ' 161                        &               
     & 'Fe+5','ff  ','Fe+5',  & ! 'Fe+5','ff  ' 162                        &               
     & 'H+  ','ff  ','H+  ',  & ! 'H+  ','ff  ' 163                        &               
     & '    ','bb  ','K   ',  & ! 'K   ','bb  ' 164                        &               
     & '    ','bf  ','K   ',  & ! 'K   ','bf  ' 165                        &               
     & '    ','ff  ','K   ',  & ! 'K   ','ff  ' 166                        &               
     & '    ','    ','    ',  & ! '    ','    ' 167                        &
     & '    ','    ','    '/    ! '    ','bf  ' 168                        &                   

! atom list in atom.dat, matoms = 59
!     data atomnm1/                                                              &  
!   &  'Al  ','Al+ ','Al++','Al+3','C   ','C+  ','C++ ','C+3 ','C+4 ','Ca  ',    & 
!   &  'Ca+ ','Cl  ','Cr  ','Cr+ ','Fe  ','Fe+ ','Fe++','Fe+3','Fe+4','Fe+5',    &
!   &  'Fe+6','H   ','H+  ','K   ','Mg  ','Mg+ ','Mg++','Mg+3','Mg+4','N   ',    &
!   &  'N+  ','N++ ','N+3 ','N+4 ','Na  ','Na+ ','Ni  ','Ni+ ','Ni++','Ni+3',    &
!   &  'O   ','O+  ','O++ ','O+3 ','O+4 ','S   ','S+  ','S++ ','S+3 ','S+4 ',    &   
!   &  'Si  ','Si+ ','Si++','Si+3','Si+4','Ti  ','Ti+ ','Ti++','Ti+3'/

! atom list in source code head = 56
      data atomnm1/                                                              &
     & 'Al  ','C   ','Ca  ','Cr  ','Fe  ','H   ','Mg  ','Na  ','N   ','Ni  ',    &  
     & 'O   ','S   ','Si  ','Ti  ','Al+ ','C+  ','Ca+ ','Cr+ ','Fe+ ','Mg+ ',    &
     & 'N+  ','Na+ ','Ni+ ','O+  ','S+  ','Si+ ','Ti+ ','Al++','C++ ','Fe++',    &
     & 'Mg++','N++ ','Ni++','O++ ','S++ ','Si++','Ti++','Al+3','C+3 ','Fe+3',    &
     & 'Mg+3','S+3 ','N+3 ','Ni+3','O+3 ','Si+3','Ti+3','C+4 ','Fe+4','Mg+4',    &
     & 'N+4 ','O+4 ','Si+4','Fe+5','H+  ','    '/              
!
! species list in eqcal2 = 67
!   &   'Al  ','C   ','C2  ','Cl  ','Cr  ','C2H ','Ca  ','C3  ','CH  ','CN  ',   &                                                     
!   &   'CO  ','CO2 ','Al+ ','Al++','Al+3','C+  ','Ca+ ','Cr+ ','C++ ','C+3 ',   &
!   &   'Cr++','Fe  ','FeO ','Fe+ ','Fe++','Fe+3','Fe+4','Fe+5','H   ','H2  ',   &                                                      
!   &   'N2  ','N2+ ','N+  ','N++ ','N+3 ','N+4 ','Na  ','Na+ ','Ni  ','Ni+ ',   &                                                      
!   &   'Ni++','Ni+3','NO  ','O   ','O2  ','OH  ','O+  ','O++ ','O+3 ','O+4 ',   &
!   &   'S   ','Si  ','SO  ','Si+ ','Si++','Si+3','Si+4','S+  ','S++ ','S+3 ',   &
!   &   'SiH ','SiO ','Ti  ','Ti+ ','Ti++','Ti+3','TiO '/                                                     
!
! number of variables in air = 16
!   &   'N   ','O   ','N2  ','O2  ','NO  ','N+  ','O+  ','N++ ','O++ ','N+3 ',   &
!   &   'O+3 ','N+4 ','O+4 ','NO+ ','N2+ ','O2+ '/    
!
! number of variables in ablation-product = 59
!   &   'S   ','H   ','C   ','O   ','Si  ','Mg  ','Fe  ','Ca  ','Al  ','Na  ',   &
!   &   'Ti  ','Cr  ','Ni  ','O2  ','OH  ','CO  ','SO  ','SiO ','MgO ','FeO ',   &
!   &   'TiO ','SiO2','S+  ','C+  ','H+  ','O+  ','Si+ ','Mg+ ','Fe+ ','Ca+ ',   &
!   &   'Al+ ','Na+ ','Ti+ ','Cr+ ','Ni+ ','Al++','C++ ','S++ ','O++ ','Si++',   &
!   &   'Mg++','Fe++','Ti++','Cr++','Ni++','Al+3','S+3 ','C+3 ','O+3 ','Si+3',   &
!   &   'Mg+3','Fe+3','Ti+3','Cr+3','Ni+3','Si+4','Fe+4','Ti+4','Ni+4'/
!
! overlapping species between air and ablation product = 5
!   'O   ','O2  ','O+  ','O++ ','O+3 '
! net number of variables in program = 16 + 59 - 5 = 70
!                                                                                         
      data diatom_bands/        &               
     & 'C2  ','Swan','C2  ',    &  ! 'C2  ','Swan',  1                            &               
     & 'C2  ','Phil','C2  ',    &  ! 'C2  ','Phil',  2                            &               
     & 'C2  ','BR  ','C2  ',    &  ! 'C2  ','BR  ',  3                            &               
     & 'C2  ','Frey','C2  ',    &  ! 'C2  ','Frey',  4                            &               
     & 'C2  ','FH  ','C2  ',    &  ! 'C2  ','FH  ',  5--                          &               
     & 'C2  ','Mull','C2  ',    &  ! 'C2  ','Mull',  6                            &               
     & 'C2  ','Dd  ','C2  ',    &  ! 'C2  ','Dd  ',  7                            &               
     & 'C2  ','nrct','C2  ',    &  ! 'C2  ','nrct',  8                            &               
     & 'C2  ','cont','C2  ',    &  ! 'C2  ','cont',  9                            &               
     & 'CN  ','Viol','CN  ',    &  ! 'CN  ','Viol', 10--------                    &               
     & 'CN  ','Red ','CN  ',    &  ! 'CN  ','Red ', 11                            &               
     & 'CO  ','4+  ','CO  ',    &  ! 'CO  ','4+  ', 12           CO               &               
     & 'CO  ','BX  ','CO  ',    &  ! 'CO  ','BX  ', 13           CO               &               
     & 'CO  ','CX  ','CO  ',    &  ! 'CO  ','CX  ', 14           CO               &               
     & 'CO  ','EX  ','CO  ',    &  ! 'CO  ','EX  ', 15--         CO               &               
     & 'CO  ','FX  ','CO  ',    &  ! 'CO  ','FX  ', 16           CO               &               
     & 'CO  ','GX  ','CO  ',    &  ! 'CO  ','GX  ', 17           CO               &               
     & 'CO  ','3+  ','CO  ',    &  ! 'CO  ','3+  ', 18           CO               &               
     & 'CO  ','cont','CO  ',    &  ! 'CO  ','cont', 19           CO               &               
     & 'H2  ','BX  ','H2  ',    &  ! 'H2  ','BX  ', 20-----------                 &               
     & 'H2  ','CX  ','H2  ',    &  ! 'H2  ','CX  ', 21                            &               
     & 'H2  ','cont','H2  ',    &  ! 'H2  ','cont', 22                            &               
     & 'N2  ','1+  ','N2  ',    &  ! 'N2  ','1+  ', 23           N2               &               
     & 'N2  ','2+  ','N2  ',    &  ! 'N2  ','2+  ', 24           N2               &               
     & 'N2  ','W   ','N2  ',    &  ! 'N2  ','W   ', 25--         N2               &               
     & 'N2  ','BH1 ','N2  ',    &  ! 'N2  ','BH1 ', 26           N2               &               
     & 'N2  ','BH2 ','N2  ',    &  ! 'N2  ','BH2 ', 27           N2               &               
     & 'N2  ','WJ  ','N2  ',    &  ! 'N2  ','WJ  ', 28           N2               &               
     & 'N2  ','CY  ','N2  ',    &  ! 'N2  ','CY  ', 29           N2               &               
     & 'N2  ','LBH ','N2  ',    &  ! 'N2  ','LBH ', 30-----------N2               &               
     & 'N2  ','cont','N2  ',    &  ! 'N2  ','cont', 31           N2               &               
     & 'N2+ ','1-  ','N2+ ',    &  ! 'N2+ ','1-  ', 32           N2+              &               
     & 'N2+ ','Mein','N2+ ',    &  ! 'N2+ ','Mein', 33           N2+              &               
     & 'N2+ ','2-  ','N2+ ',    &  ! 'N2+ ','2-  ', 34           N2+              &               
     & 'NO  ','Gamm','NO  ',    &  ! 'NO  ','Gamm', 35--         NO               &               
     & 'NO  ','Beta','NO  ',    &  ! 'NO  ','Beta', 36           NO               &               
     & 'NO  ','Delt','NO  ',    &  ! 'NO  ','Delt', 37           NO               &               
     & 'NO  ','Epsi','NO  ',    &  ! 'NO  ','Epsi', 38           NO               &               
     & 'O2  ','SR  ','O2  ',    &  ! 'O2  ','SR  ', 39           O2               &               
     & 'O2  ','cont','O2  ',    &  ! 'O2  ','cont', 40-----------O2               &               
     & 'CH  ','AX  ','CH  ',    &  ! 'CH  ','AX  ', 41                            &               
     & 'CH  ','BX  ','CH  ',    &  ! 'CH  ','BX  ', 42                            &               
     & 'CH  ','CX  ','CH  ',    &  ! 'CH  ','CX  ', 43                            &               
     & 'OH  ','AX  ','OH  ',    &  ! 'OH  ','AX  ', 44           OH               &               
     & '    ','    ','    ',    &  ! '    ','    ', 45--                          &               
     & 'SiO ','AX  ','SiO ',    &  ! 'SiO ','AX  ', 46           SiO              &               
     & 'SiO ','EX  ','SiO ',    &  ! 'SiO ','EX  ', 47           SiO              &               
     & 'SiO ','cont','SiO ',    &  ! 'SiO ','cont', 48           SiO              &               
     & 'MgO ','BX  ','MgO ',    &  ! 'MgO ','BX  ', 49           MgO              &               
     & 'MgO ','BA  ','MgO ',    &  ! 'MgO ','BA  ', 50-----------MgO              &               
     & 'MgO ','AX  ','MgO ',    &  ! 'MgO ','AX  ', 51           MgO              &               
     & 'MgO ','Ba  ','MgO ',    &  ! 'MgO ','Ba  ', 52           MgO              &               
     & 'MgO ','da  ','MgO ',    &  ! 'MgO ','da  ', 53           MgO              &               
     & 'MgO ','Da  ','MgO ',    &  ! 'MgO ','Da  ', 54           MgO              &               
     & 'FeO ','OR1 ','FeO ',    &  ! 'FeO ','OR1 ', 55--         FeO              &               
     & 'FeO ','OR2 ','FeO ',    &  ! 'FeO ','OR2 ', 56           FeO              &               
     & 'FeO ','cont','FeO ',    &  ! 'FeO ','IR3 ', 57           FeO              &               
     & 'SO  ','AX0 ','SO  ',    &  ! 'SO  ','AX0 ', 58           SO               &               
     & 'SO  ','AX1 ','SO  ',    &  ! 'SO  ','AX1 ', 59           SO               &               
     & 'SO  ','AX2 ','SO  ',    &  ! 'SO  ','AX2 ', 60-----------SO               &               
     & 'TiO ','A-X ','TiO ',    &  ! 'TiO ','A-X ', 61           TiO              &               
     & 'TIO ','B-X ','TiO ',    &  ! 'TIO ','B-X ', 62           TiO              &               
     & 'TIO ','E-X ','TiO ',    &  ! 'TIO ','C-X ', 63           TiO              &               
     & 'TIO ','E-X ','TiO ',    &  ! 'TIO ','E-X ', 64           TiO              &               
     & 'TIO ','f-a ','TiO ',    &  ! 'TIO ','f-a ', 65--         TiO              &               
     & 'TIO ','f-c ','TiO ',    &  ! 'TIO ','f-c ', 66           TiO              &               
     & 'TIO ','f-b ','TiO ',    &  ! 'TIO ','f-b ', 67           TiO              &               
     & 'TiO ','b-a ','TiO ',    &  ! 'TiO ','b-a ', 68           TiO              &               
     & 'TiO ','b-d ','TiO ',    &  ! 'TiO ','b-d ', 69           TiO              &               
     & 'TiO ','c-a ','TiO ',    &  ! 'TiO ','c-a ', 70-----------                 &               
     & 'SiH ','AX  ','SiH ',    &  ! 'SiH ','AX  ', 71                            &               
     & 'SiH ','cont','SiH ',    &  ! 'SiH ','cont', 72                            &               
     & 'MgH ','AX  ','MgH ',    &  ! 'MgH ','AX  ', 73                            &               
     & 'MgH ','BX  ','MgH ',    &  ! 'MgH ','BX  ', 74                            &               
     & 'MgH ','CX  ','MgH ',    &  ! 'MgH ','CX  ', 75--                          &               
     & 'MgH ','cont','MgH ',    &  ! 'MgH ','cont', 76                            &               
     & '    ','    ','    ',    &  ! '    ','    ', 77                            &               
     & '    ','    ','    ',    &  ! '    ','    ', 78                            &               
     & '    ','    ','    ',    &  ! '    ','    ', 79                            &               
     & '    ','    ','    ',    &  ! '    ','    ', 80-----------                 &               
     & '    ','    ','    ',    &  ! '    ','    ', 81                            &               
     & '    ','    ','    ',    &  ! '    ','    ', 82                            &               
     & '    ','    ','    ',    &  ! '    ','    ', 83                            &               
     & '    ','    ','    ',    &  ! '    ','    ', 84                            &               
     & '    ','    ','    ',    &  ! '    ','    ', 85----                        &               
     & '    ','    ','    ',    &  ! '    ','    ', 86                            &               
     & '    ','    ','    ',    &  ! '    ','    ', 87                            &               
     & '    ','    ','    ',    &  ! '    ','    ', 88                            &               
     & '    ','    ','    ',    &  ! '    ','    ', 89                            &               
     & '    ','    ','    ',    &  ! '    ','    ', 90-----------                 &               
     & '    ','    ','    ',    &  ! '    ','    ', 91                            &               
     & '    ','    ','    ',    &  ! '    ','    ', 92                            &               
     & '    ','    ','    ',    &  ! '    ','    ', 93                            &               
     & '    ','    ','    ',    &  ! '    ','    ', 94                            &               
     & '    ','    ','    ',    &  ! '    ','    ', 95------                      &               
     & '    ','    ','    ',    &  ! '    ','    ', 96                            &               
     & '    ','    ','    ',    &  ! '    ','    ', 97                            &               
     & '    ','    ','    ',    &  ! '    ','    ', 98                            &               
     & '    ','    ','    ',    &  ! '    ','    ', 99                            &               
     & '    ','    ','    '/       ! '    ','    ',100---------------                            

      data diatomnm1/'N2  ','O2  ','NO  ','N2+ ','SiO ','MgO ','FeO ',            &               
     &  'SO  ','OH  ','CO  ','TiO ','    '/                                                             
!                                                                                         
      data triatom_bands/                                                         &               
     & 'C3  ','Swin','C3  ',    &  ! 'C3  ','Swin',  1                            &               
     & 'C3  ','VUV ','C3  ',    &  ! 'C3  ','VUV ',  2                            &               
     & 'C3  ','phot','C3  ',    &  ! 'C3  ','phot',  3                            &               
     & '    ','UV  ','C2H ',    &  ! 'C2H ','UV  ',  4                            &               
     & 'H2O ','VUV ','H2O ',    &  ! 'H2O ','VUV ',  5                            &               
     & 'H2O ','visi','H2O ',    &  ! 'H2O ','visi',  6                            &               
     & 'H2O ','IR  ','H2O ',    &  ! 'H2O ','IR  ',  7                            &               
     & 'CO2 ','VUV ','CO2 ',    &  ! 'CO2 ','VUV ',  8                            &               
     & 'CO2 ','IR  ','CO2 ',    &  ! 'CO2 ','IR  ',  9                            &               
     & '    ','    ','    '/       ! '    ','    ', 10                                            
      data triatomnm1/6*'    '/                                                           
      data nprt/1/                                                                        
! slope ratio of the wavelength-vs- iw curve
      data slope_ratio/3./
!                                                                                         
! initialize equilibrium tables                                                           
      call pH_air(0,0.d0,0.d0, rhos,temps)      !                                         
      call pT_air(0,0.d0,0.d0, rhos,enth_dum,cp)   !                                         
      call pT_vis_air(0.,0., visc)
!                                                                                         
! read spectroscopic data                                                                 
      natoms=56                            ! number of atoms in list
      call atom_read(natoms)  
      ndiatoms=10                          ! number of diatoms in list                                                                         
      call diatom_read(ndiatoms)                         
      ntriatoms=5                          ! number of triatoms in list                                                                      
      call triatom_read(ntriatoms) 
!                                                                                         
! flight conditions                                                                       
      read(5,210) (dum(i),i=1,120)
  210 format(130a1)
      write(6,210) (dum(i),i=1,120)
      read(5,10) nwave,(dum(i),i=1,120)                                                   
   10 format(i10,120a1)                                                                   
      write(6,10) nwave,(dum(i),i=1,120)                                                  
      read(5,10) nair,(dum(i),i=1,120)                                                   
      write(6,10) nair,(dum(i),i=1,120)                                                  
      read(5,10) nabl,(dum(i),i=1,120)                                                   
      write(6,10) nabl,(dum(i),i=1,120)  
      read(5,30) wavmin,(dum(i),i=1,120)
      write(6,40) wavmin,(dum(i),i=1,120)
      read(5,30) wavmax,(dum(i),i=1,120)
      write(6,40) wavmax,(dum(i),i=1,120)                                                
      read(5,210) (dum(i),i=1,120)
      write(6,210) (dum(i),i=1,120)
      read(5,30) rhoinf,(dum(i),i=1,120)                                                  
   30 format(e10.3,120a1)                                                                 
      write(6,40) rhoinf,(dum(i),i=1,120)                                                 
   40 format(1pe10.3,120a1)                                                                                                                                                         
      read(5,30) vinf,(dum(i),i=1,120)                                                    
      write(6,40) vinf,(dum(i),i=1,120)                                                   
      read(5,30) rnose,(dum(i),i=1,80)
      write(6,40) rnose,(dum(i),i=1,80)
      read(5,10) ndm,(dum(i),i=1,80)
      write(6,10) ndm,(dum(i),i=1,80)
      read(5,10) nout,(dum(i),i=1,80)     
      write(6,10) nout,(dum(i),i=1,80)
      read(5,10) nim,(dum(i),i=1,80)     
      write(6,10) nim,(dum(i),i=1,80)
      read(5,30) facout1,(dum(i),i=1,80)
      write(6,40) facout1,(dum(i),i=1,80)
      read(5,30) facin1,(dum(i),i=1,80)
      write(6,40) facin1,(dum(i),i=1,80)
      read(5,30) facout2,(dum(i),i=1,80)
      write(6,40) facout2,(dum(i),i=1,80)
      read(5,30) facin2,(dum(i),i=1,80)
      write(6,40) facin2,(dum(i),i=1,80)
      read(5,30) famdot,(dum(i),i=1,80)
      write(6,40) famdot,(dum(i),i=1,80)
      read(5,30) enfac,(dum(i),i=1,80)
      write(6,40) enfac,(dum(i),i=1,80)
      read(5,30) elev_ang,(dum(i),i=1,80)
      write(6,40) elev_ang,(dum(i),i=1,80)
      read(5,30) hwhh,(dum(i),i=1,80)
      write(6,40) hwhh,(dum(i),i=1,80)
      read(5,30) sigma,(dum(i),i=1,80)
      write(6,40) sigma,(dum(i),i=1,80)
      read(5,30) spallf,(dum(i),i=1,80)
      write(6,40) spallf,(dum(i),i=1,80)
                                                                                          
      pres=rhoinf*vinf*vinf    
      write(6,120) pres                                                           
  120 format(1pe11.4,' Pa. Shock layer pressure')  
! 
! parameter in wavelength calculation
      calpha=dlog(slope_ratio)/dlog(dfloat(nwave))+1.                                       
!
! assumed shock layer enthalpy
      enths=0.5*vinf*vinf*enfac 
      call pH_air(1,pres,enths, rhos,temps)                                               
!                                                                                         
!----------------------------------------------------------------air begins               
      concAl(1)=0.
      concAlp(1)=0.
      concAlpp(1)=0.
      concAl3p(1)=0.
      concC(1)=0.  
      concCa(1)=0.
      concCap(1)=0.                                                                       
      concC2(1)=0.                                                                        
      concCl(1)=0.                                                                        
      concC2H(1)=0.                                                                       
      concC3(1)=0.                                                                        
      concCH(1)=0.                                                                        
      concCN(1)=0.                                                                        
      concCO(1)=0.                                                                        
      concCO2(1)=0.                                                                       
      concCp(1)=0.                                                                        
      concCpp(1)=0.                                                                       
      concC3p(1)=0.                                                                       
      concC4p(1)=0. 
      concCr(1)=0.
      concCrp(1)=0.
      concCrpp(1)=0.                                                                      
      concFe(1)=0.                                                                        
      concFeO(1)=0.                                                                       
      concFep(1)=0.                                                                       
      concFepp(1)=0.                                                                      
      concFe3p(1)=0.                                                                      
      concFe4p(1)=0.                                                                      
      concFe5p(1)=0.                                                                      
      concH(1)=0.                                                                         
      concH2(1)=0.                                                                        
      concHp(1)=0.                                                                        
      concH2O(1)=0.                                                                       
      concK(1)=0.                                                                         
      concMg(1)=0.                                                                        
      concMgO(1)=0.                                                                       
      concMgp(1)=0.                                                                       
      concMgpp(1)=0.                                                                      
      concMg3p(1)=0.                                                                      
      concMg4p(1)=0   
      concNa(1)=0.
      concNap(1)=0.   
      concNi(1)=0.
      concNip(1)=0.
      concNipp(1)=0.
      concNi3p(1)=0.                                                                 
      concOH(1)=0.                                                                        
      concS(1)=0.                                                                         
      concSi(1)=0.                                                                        
      concSO(1)=0.                                                                        
      concSiO(1)=0.                                                                       
      concSip(1)=0.                                                                       
      concSipp(1)=0.                                                                      
      concSi3p(1)=0.                                                                      
      concSi4p(1)=0.                                                                      
      concSp(1)=0.                                                                        
      concSpp(1)=0.                                                                       
      concS3p(1)=0.                                                                       
      concS4p(1)=0.                                                                       
      concSiH(1)=0.  
      concTi(1)=0.
      concTip(1)=0.
      concTipp(1)=0.
      concTi3p(1)=0. 
      concTiO(1)=0.                                                                    
! 
! read in air chemistry data
      call thrinp(1,5,nprt, nsp,spnm,pres,spallf, tw,delH1) 
      if(spallf.gt.1.0e-6) delH=delH1/spallf
      if(spallf.le.1.0e-6) delH=delH1
      nprint=1000
      pkwav=(6000./temps)*6000.              ! Planck function peak                       
      if((wavmin.lt.1.0).and.(wavmax.lt.1.0)) then
        wavmin=pkwav/2.5                                                                    
        wavmax=25000.                                                                       
      end if
      write(6,80) wavmin,pkwav,wavmax                                                     
  80  format(/' wavmin=',f10.2,' pkwav=',f10.2,' wavmax=',f10.2)                     
      rangex=100.                                                                         
!                                                                                         
! make interpolating temperatures  
      t1max=10000./temps
      t1min=10000./(temps/1.6)
      ntemp=11                                                                            
      do itemp=1,5                                                                       
        tair(itemp)=t1min+(t1max-t1min)*0.25*(itemp-1)
        tempx(itemp)=10000./tair(itemp) 
      end do                                                                              
!                                                                                         
!  cycle over temperature                                                                 
      do itemp=1,5  
        tran(1)=tempx(itemp)                                                              
        trot(1)=tran(1)                                                                   
        tvib(1)=tran(1)                                                                   
        tele(1)=tran(1)                                                                   
        call pT_air(1,pres,tempx(itemp), rho,enthj,cp)                                     
        write(6,20) itemp,pres,tempx(itemp),rho,enthj,cp                                   
   20   format(/                                                          &               
     &    ' itemp      =',i2/                                             &               
     &    ' pres       =',1pe12.5,' Pascal'/                              &               
     &    ' tempx(iemp)=',0pf10.1,' K'/                                   &               
     &    ' rho        =',1pe12.5,' kg/m3'/                               &               
     &    ' enthj      =',e12.5,' J/kg'/                                  &               
     &    ' Cp         =',e12.5)                                                          
        do i=1,nsp                                                                        
          spgam(i)=0.1                                                                    
        end do                                                                            
        tmax=1.25d0*tran(1)                                                               
        tmin=0.8d0*tran(1)       
        call thrcal(tmax,tmin,itemp)  
!
! calculate absb array
        if(nair.eq.0) then
          write(*,*) ' calling eqcal2 for air'
          write(6,*) ' calling eqcal2 for air'
          call eqcal2(rho,tran(1),spnm,spgam,nstep,nprt,nprint, eint,   &               
     &      pres,enthj,zz,avmw,ansp)
          write(*,*) ' out of eqcal2 for air'
          write(6,*) ' out of eqcal2 for air'  
          write(6,180) rho,tran(1),pres,enthj,avmw                                           
 180      format(' rho=',1pe10.3,' temp=',e10.3,' pres=',e10.3,         &               
     &      ' enthj=',e10.3,' avmw=',1pe12.5)      

          call interp(nsp,natoms,ndiatoms,ntriatoms,rho,          &
     &     tran(1),spnm,spgam,pres,enthj,avmw,ansp,               &               
     &     concAl(1),concAlp(1),concAlpp(1),concAl3p(1),          &
     &     concC(1), concC2(1),                                   &
     &     concCa(1),concCap(1),concCl(1),concC2H(1),             &
     &     concC3(1),concCH(1), concCN(1),concCO(1),              &
     &     concCO2(1),concCp(1), concCpp(1),concC3p(1),           &
     &     concC4p(1),concCr(1),concCrp(1),concCrpp(1),           &
     &     concFe(1),concFeO(1),concFep(1),concFepp(1),           &
     &     concFe3p(1),concFe4p(1),concFe5p(1),concH(1),          &
     &     concH2(1), concHp(1),concH2O(1),concK(1),              &
     &     concMg(1), concMgO(1),concMgp(1),concMgpp(1),          &
     &     concMg3p(1),concMg4p(1),concN(1),concNE(1),            &
     &     concN2(1),concN2p(1),concNp(1),concNpp(1),             &
     &     concN3p(1),concN4p(1),concNa(1),concNap(1),            &
     &     concNO(1),concNi(1),concNip(1),concNipp(1),            &
     &     concNi3p(1),concO(1),concO2(1),concOH(1),              &
     &     concOp(1),concOpp(1),concO3p(1),concO4p(1),            &
     &     concS(1),concSi(1),concSO(1),concSiO(1),               &
     &     concSip(1),concSipp(1),concSi3p(1),concSi4p(1),        &
     &     concSp(1),concSpp(1),concS3p(1),concS4p(1),            &
     &     concSiH(1),concTi(1),concTip(1),concTipp(1),           &
     &     concTi3p(1),concTiO(1))                                          
!                                                                                         
          method=1        
!   
          write(*,*) ' calling radipac for air'    
          write(6,*) ' calling radipac for air'    
          call radipac(nprt,natoms,ndiatoms,method,tblack,    &               
     &     rnose,rangex,nwave,tran,trot,tvib,tele,            &               
     &     concAl,concAlp,concAlpp,concAl3p,                  &
     &     concC, concC2,                                     &
     &     concCa,concCap,concCl,concC2H,                     &
     &     concC3,concCH, concCN,concCO,                      &
     &     concCO2,concCp, concCpp,concC3p,                   &
     &     concC4p,concCr,concCrp,concCrpp,                   &
     &     concFe,concFeO,concFep,concFepp,                   &
     &     concFe3p,concFe4p,concFe5p,concH,                  &
     &     concH2, concHp,concH2O,concK,                      &
     &     concMg, concMgO,concMgp,concMgpp,                  &
     &     concMg3p,concMg4p,concN,concNE,                    &
     &     concN2,concN2p,concNp,concNpp,                     &
     &     concN3p,concN4p,concNa,concNap,                    &
     &     concNO,concNi,concNip,concNipp,                    &
     &     concNi3p,concO,concO2,concOH,                      &
     &     concOp,concOpp,concO3p,concO4p,                    &
     &     concS,concSi,concSO,concSiO,                       &
     &     concSip,concSipp,concSi3p,concSi4p,                &
     &     concSp,concSpp,concS3p,concS4p,                    &
     &     concSiH,concTi,concTip,concTipp,                   &
     &     concTi3p,concTiO,                                  &               
     &     avg_molwt)                                              
!                                                                                         
! copy absb into a big array                                                              
          do m=1,nwave                                                                      
            absb_air(itemp,m)=absb(m)                                                          
          end do                                                                            
        end if
      end do                                                                              
!                                                                                         
! write out absorption coefficients  
      if(nair.eq.0) then
        write(16,*) ' air absorption coefficients'                                                     
        write(16,90) (tair(itemp),itemp=1,5)                                              
   90   format('    wavel ',11f10.6)                                                                 
        do m=1,nwave                                                                        
          write(16,60) wavel(m),(absb_air(itemp,m),itemp=1,5)                                 
   60     format(f10.4,1p5e10.3)                                                           
        end do                                                                              
        close(16)
      end if
!
! read absb data from absb_air.out
       if(nair.eq.1) then
         read(16,210) (dum(i),i=1,100)
         read(16,211) (tair(itemp),itemp=1,5)
  211    format(10x,5f10.6)
         do iw=1,nwave
           read(16,61) wavel(iw),(absb_air(itemp,iw),itemp=1,5)
   61      format(f10.3,5e10.3)
         end do
       end if      
!                                                                                         
!--------------------------------------------air ended, freestream begins
! low T, hi_T limits
!
      inode=1; nprt=0
      tlow=1500.; thigh=0.5*temps; nintvl=10; ntlow=11
      t1=10000./thigh; t2=10000./tlow
      tintvl=(t2-t1)/nintvl

! read JANAF coefficients  
      data spnma/'O   ','N   ','O2  ','N2  ','NO  ','O+  ','N+  ','NO+ ','E-  '/                                                               
      call spdinp  
      iprb=1  
      enth=5.0e8
      rho=rhoinf
      pinf=8.3144*rhoinf*298./0.028854
      patm=pinf/1.0133e5
      elmsf(1)=0.233; elmsf(2)=0.767   
      write(6,*) ' '
      write(6,*) ' freestream precursor region'                                                                  
! vary temperature
      do itemp=1,ntlow
        txlow(itemp)=t1+tintvl*(itemp-1)
        tran(1)=10000./txlow(itemp)
        trot(1)=tran(1)
        tvib(1)=tran(1)
        trot(1)=tran(1)
        call kmeqm(patm,tran(1),enth,iprb,elmsf,spmlf,avmw,rho) 
        patm=patm*(rhoinf/rho)                                      
        call kmeqm(patm,tran(1),enth,iprb,elmsf,spmlf,avmw,rho) 
        patm=patm*(rhoinf/rho)                                      
        call kmeqm(patm,trot(1),enthl(itemp),iprb,elmsf,spmlf,avmw,rho) 
        templ(itemp)=trot(1)
        pr=patm*1.0133e5
        antot=pr/(1.3806e-23*tran(1))
        write(6,*) ' '
        write(6,221) trot(1),pr,enth
  221   format(' temperature =',f10.1,' K. pressure=',1pe10.3,' Pa. enthalpy=',    &
  &       e10.3,' J/kg')
        write(6,*) ' isp  spnm    spmlf       sum        n(cm-3)'
        sum=0.
        do isp=1,9
          sum=sum+spmlf(isp)
          an(isp)=antot*spmlf(isp)/1.0e6
          write(6,220) isp,spnma(isp),spmlf(isp),sum,an(isp)
  220     format(i5,2x,a4,1p4e12.5)
        end do
!
        if(nair.eq.0) then                                                       
          call emis_absb1(itemp,natoms,ndiatoms,ntriatoms,                     &
  &       nprt,inode,trot(1),rho,an,avg_molwt)
          do iw=1,nwave
            absb_low(itemp,iw)=absb(iw)
          end do
        end if
      end do

      if(nair.eq.0) then
        write(18,17) 
   17   format(' freestream air absorption coefficients')
        write(18,15) (txlow(it),it=1,ntlow)
   15   format('   wavel  ',11f10.6)
        do iw=1,nwave
          write(18,16) wavel(iw),(absb_low(it,iw),it=1,ntlow)
   16     format(f10.3,1p11e10.3)
        end do
        write(18,62) (dum1(i),i=1,21)
        do it=1,ntlow
          write(18,203) it,templ(it),enthl(it)
  204     format(i10,1p4e10.3)
        end do
        close(18)
      end if      
!
! read absb data from absb_low.out
       if(nair.eq.1) then
         read(18,210) (dum(i),i=1,100)
         read(18,18)  (txlow(it),it=1,ntlow)
   18    format(10x,11f10.6)
         do m=1,nwave
           read(18,19) wavel(m),(absb_low(itemp,m),itemp=1,ntlow)
   19      format(f10.3,11e10.3)
         end do
         read(18,62) (dum1(i),i=1,21)
         do it=1,ntlow
           read(18,203) i,templ(it),enthl(it)
         end do
       end if      
!--------------------------------------------freestream ended, ablation product begins 
      concN(1)=0.                                                                         
      concN2(1)=0.                                                                        
      concNp(1)=0.                                                                        
      concNpp(1)=0.                                                                       
      concN3p(1)=0.                                                                       
      concN4p(1)=0.                                                                       
      concO(1)=0.                                                                         
      concO2(1)=0.                                                                        
      concOp(1)=0.                                                                        
      concOpp(1)=0.                                                                       
      concO3p(1)=0.                                                                       
      concO4p(1)=0.                                                                       
      concNO(1)=0.                                                                        
      concN2p(1)=0.                                                                       
      concNe(1)=0.            
!
! read in ablation product chemical data
      call thrinp(2,5,nprt, nsp,spnm,pres,spallf, tw,delH)  
      
      nprint=1000
! 
      t1max=10000./(temps/2.0)
      t1min=10000./1500.d0                                                                                        
      do itemp=1,11                                                                       
        tcho(itemp)=t1min+(t1max-t1min)*0.1*(itemp-1)
        tempx(itemp)=10000./tcho(itemp)
      end do                                                                              
!                                                                                         
!  cycle over temperature   
      zero=0.                                                              
      do itemp=1,11          
        tran(1)=tempx(itemp)    
        trot(1)=tran(1)                                                                   
        tvib(1)=tran(1)                                                                   
        tele(1)=tran(1)                                                                   
        write(6,20) itemp,pres,tempx(itemp),zero,zero,zero                                   
        tmax=1.25d0*tran(1)                                                               
        tmin=0.8d0*tran(1)                                                                
        call thrcal(tmax,tmin,itemp) 
!
! calculate absb array
        if(nabl.eq.0) then
        write(*,*) ' calling eqcal2 for ablation product'
        write(6,*) ' calling eqcal2 for ablation product'
          call eqcal2(rho,tran(1),spnm,spgam,nstep,nprt,nprint, eint,   &               
     &      pres,enthj,zz,avmw,ansp)
!        call eqcal3(pres,tran(1),spnm,spgam,nstep,nprt,nprint, eint,        &               
!     &    rho,enthj,zz,avmw,ansp)
        write(*,*) ' out of eqcal2 for ablation product'
        write(6,*) ' out of eqcal2 for ablation product'  
        write(6,180) rho,tran(1),pres,enthj,avmw  
    
          write(6,180) rho,tran(1),pres,enthj,avmw                                           
! 180      format(' rho=',1pe10.3,' temp=',e10.3,' pres=',e10.3,         &               
!     &      ' enthj=',e10.3,' avmw=',1pe12.5)      
          rho_ivu(itemp)=rho; t_ivu(itemp)=tran(1); h_ivu(itemp)=enthj                                         

          call interp(nsp,natoms,ndiatoms,ntriatoms,rho,          &
     &     tran(1),spnm,spgam,pres,enthj,avmw,ansp,               &               
     &    concAl(1),concAlp(1),concAlpp(1),concAl3p(1),                     &
     &    concC(1), concC2(1),                                              &
     &    concCa(1),concCap(1),concCl(1),concC2H(1),                        &
     &    concC3(1),concCH(1), concCN(1),concCO(1),                         &
     &    concCO2(1),concCp(1), concCpp(1),concC3p(1),                      &
     &    concC4p(1),concCr(1),concCrp(1),concCrpp(1),                      &
     &    concFe(1),concFeO(1),concFep(1),concFepp(1),                      &
     &    concFe3p(1),concFe4p(1),concFe5p(1),concH(1),                     &
     &    concH2(1), concHp(1),concH2O(1),concK(1),                         &
     &    concMg(1), concMgO(1),concMgp(1),concMgpp(1),                     &
     &    concMg3p(1),concMg4p(1),concN(1),concNE(1),                       &
     &    concN2(1),concN2p(1),concNp(1),concNpp(1),                        &
     &    concN3p(1),concN4p(1),concNa(1),concNap(1),                       &
     &    concNO(1),concNi(1),concNip(1),concNipp(1),                       &
     &    concNi3p(1),concO(1),concO2(1),concOH(1),                         &
     &    concOp(1),concOpp(1),concO3p(1),concO4p(1),                       &
     &    concS(1),concSi(1),concSO(1),concSiO(1),                          &
     &    concSip(1),concSipp(1),concSi3p(1),concSi4p(1),                   &
     &    concSp(1),concSpp(1),concS3p(1),concS4p(1),                       &
     &    concSiH(1),concTi(1),concTip(1),concTipp(1),                      &
     &    concTi3p(1),concTiO(1))      

          call radipac(nprt,natoms,ndiatoms,method,tblack,     &               
     &      rnose,rangex,nwave,tran,trot,tvib,tele,            &               
     &      concAl,concAlp,concAlpp,concAl3p,                  &
     &      concC, concC2,                                     &
     &      concCa,concCap,concCl,concC2H,                     &
     &      concC3,concCH, concCN,concCO,                      &
     &      concCO2,concCp, concCpp,concC3p,                   &
     &      concC4p,concCr,concCrp,concCrpp,                   &
     &      concFe,concFeO,concFep,concFepp,                   &
     &      concFe3p,concFe4p,concFe5p,concH,                  &
     &      concH2, concHp,concH2O,concK,                      &
     &      concMg, concMgO,concMgp,concMgpp,                  &
     &      concMg3p,concMg4p,concN,concNE,                    &
     &      concN2,concN2p,concNp,concNpp,                     &
     &      concN3p,concN4p,concNa,concNap,                    &
     &      concNO,concNi,concNip,concNipp,                    &
     &      concNi3p,concO,concO2,concOH,                      &
     &      concOp,concOpp,concO3p,concO4p,                    &
     &      concS,concSi,concSO,concSiO,                       &
     &      concSip,concSipp,concSi3p,concSi4p,                &
     &      concSp,concSpp,concS3p,concS4p,                    &
     &      concSiH,concTi,concTip,concTipp,                   &
     &      concTi3p,concTiO,                                  &               
     &      avg_molwt)                                              
!                                                                                         
! copy absb into a big array                                                              
          do m=1,nwave                                                                      
            absb_cho(itemp,m)=absb(m)                                                          
          end do                                                                            
! reset the last line                                                                     
          absb_cho(itemp,nwave)=absb_cho(itemp,nwave-1)                                           
        end if
      end do
!                                                                                         
! write out absorption coefficients  
      if(nabl.eq.0) then
        write(17,*) ' ablation product absorption coefficients'                                                     
        write(17,196) (tcho(itemp),itemp=1,11) 
  196   format('   tcho   ',11f10.6)                                               
        do m=1,nwave                                                                        
          write(17,69) wavel(m),(absb_cho(itemp,m),itemp=1,11)                                 
   69     format(f10.3,1p11e10.3)
        end do                                                                              
        write(17,62) (dum1(i),i=1,20)
  62    format(40a4)
        do itemp=1,11
          write(17,206) itemp,t_ivu(itemp),h_ivu(itemp),rho_ivu(itemp)
  206     format(i10,1p6e10.3)
        end do    
        close(17)
      end if
!
! read absb data from absb_vap.out
      if(nabl.eq.1) then
        read(17,210) (dum(i),i=1,100)
        read(17,215) (tcho(itemp),itemp=1,11)
  215   format(10x,11f10.6)
        do m=1,nwave
          read(17,63) wavel(m),(absb_cho(itemp,m),itemp=1,11)
   63     format(f10.3,11e10.3)
        end do
        read(17,218) (dum(i),i=1,40)
  218   format(100a1)        
        do itemp=1,11
          read(17,203) item,t_ivu(itemp),h_ivu(itemp),rho_ivu(itemp)  
  203     format(i10,5e10.3)      
        end do
      end if      
!
! initialize equilibrium tables           
      call pH_ivu(0,0.d0,0.d0, rhos,temps)         !     
      call pT_ivu(0,0.d0,0.d0, rhos,enths,cpivu)   !     
!
      write(6,190)
  190 format(/'   it       temp        enth       rho')
      do itemp=1,11
        write(6,200) itemp,t_ivu(itemp),h_ivu(itemp),rho_ivu(itemp)
  200   format(i5,1p5e12.5)
      end do

  130   format(30a4)                                                                      
  150   format(10a1,10e10.3)                                                              
  160   format(10a1,1p10e10.3)                                                            
  170   continue                                                                          
!
! flow calc
      call comet_lbl(nwave,rhoinf,vinf,pres,enths,tw,delH,rnose,spallf,         &
  &     ndm,nout,nim,facout1,facin1,facout2,facin2,famdot,elev_ang,hwhh,        &
  &     enfac,sigma)
      close(1);  close(2);  close(3);  close(4);  close(5);  close(6); close(7)
      close(8);  close(9);  close(10); close(11); close(12); close(13)
      close(14); close(21); close(22)                                                                         

      stop                                                                                
      end                                                                                 
!***********************************************************************
      subroutine altrho(iuse,altit,rhoinf)
! converts altitude into density or density into altitude
! input parameters:
!   iuse=1: altitude into density, =2: density into altitude
! output parameters:
!   altit=altitude, m
!   rhoinf=density, kg/m3
      implicit real*8(a-h,o-z)
      dimension hx(25),rhox(25),rhoy(26)
      save
      data hx/                                                      &
  &    0.0000,   10000.,  20000.,  30000.,  40000.,  50000.,        &
  &    60000.,   70000.,  80000.,  90000., 100000., 110000.,        &
  &    120000., 130000., 140000., 150000., 160000., 170000.,        &
  &    180000., 190000., 200000., 210000., 220000., 230000.,        &
  &    240000./
      data rhox/                                                    &
  &    1.225,   4.135e-1, 8.891e-2, 1.841e-2, 3.996e-3, 1.027e-3,   &
  &   3.097e-4, 8.283e-5, 1.846e-5, 4.114e-6, 9.169e-7, 2.043e-7,   &
  &   5.000e-8, 1.224e-8, 2.995e-9, 7.329e-10,1.793e-10,4.389e-11,  &
  &   1.074e-11,2.628e-12,6.430e-13,1.157e-13,3.850e-14,9.422e-15,  &
  &   2.305e-15/
      data itime/0/
!
! take log of density
      if(itime.eq.0) then
        do i=1,25
          rhoy(i)=dlog(rhox(i))
        end do
        itime=1
      end if
!
! from altitude get density
      if(iuse.eq.1) then
        mon=0
        call taint(hx,rhox,rhoinf,rhoinf,25,2,ier,mon)
        rhoinf=dexp(rhoinf)
        return
      end if
!
! from density get altitude
      if(iuse.eq.2) then
        rholog=dlog(rhoinf)
        mon=0
        call taint(rhoy,hx,rholog,altit,25,2,ier,mon)
        return
      end if

      return
      end
!***********************************************************************                  
      subroutine assign(gamsp,nprt)                                                  
! this subroutine and accompanying subroutine conv1 shrink and restore
!   species list by ivoking elemental conservation 
! assumes the first nelem species are to be removed and put back in                                 
! input: gamsp(i),i=1,nsp: original species list                                                               
!        nprt=print index                                                                 
! output: gamsp1(i),i=1,nsp-nelem; shrunken species list                                                         
      parameter(msp=60)                                                                   
      implicit real*8(a-h,o-z)                                                            
      common/eqcoma/elemwt(15),                                           &               
     & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp),            &               
     & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp),             &               
     & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp),                     &               
     & akb(5,msp),akd(5,msp),avmw0                                                        
      common/eqcomb/elemnm(12)                                                            
      common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc,  &               
  &    neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp),   &               
  &    im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp)                        
      dimension gamsp(msp),fac(15),gam_a(15)                                                    
      character*4 elemnm,spnm                                                             
      save
!
      do isp=nelem+1,nsp
        gamsp(isp)=1.0e-4          !   1.0e-4
      end do
      sum=0.
      do j=1,nelem
        gamsp(j)=felem(j)/elemwt(j)
        sum=sum+gamsp(j)
      end do

! write
      write(6,*) '  isp  spnm   im     gamsp'
      do isp=1,nsp
        write(6,20) isp,spnm(isp),im(isp),gamsp(isp)
   20   format(i5,2x,a4,2x,i4,1pe11.4)
      end do
!
! audit
      do j=1,nelem
        gam_a(j)=0.
        do i=1,nsp
          gam_a(j)=gam_a(j)+ielem(i,j)*gamsp(i)*spwt(j)
        end do
      end do
      write(6,40)
   40 format(' isp  elemnm     frac')
      do j=1,nelem
        write(6,30) j,elemnm(j),gam_a(j)
   30   format(i5,2x,a4,1pe11.4)
      end do

      return                                                                              
      end                                                                                 
!*********************************************************************************
      subroutine atm_absb(mwave,nwave,flux_prec,int_prec,altit,elev_ang,rhoinf,      &
  &     flux_grd,int_grd)
! accounts for atmospheric absorption
! input parameters:
!   mwave=wavelength index for 1750 A
!   nwave=index for max wavelength
!   flux_prec=spectral flux at end of precursor region, W/m2
!   int_prec(nw)=normal intensity at end of precursor region, W/(cm2-mic-sr)
!   altit=altitude, m
!   elev_ang=elevation angle, degrees
!   rhoinf=freestream density, kg/m3
! output parameters:
!   int_grd(nw)=normal intensity at ground, W/(cm2-mic-sr) 
!   flux_grd=radiative flux at ground, W/m2
      parameter(nw=400000)
      implicit real*8(a-h,o-z)
      real*8 int_prec,int_grd,intw,int_e
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

! flux_prec(nw)=radiative flux at end of precursor; flux_grd(nw)=radiative flux at ground
      dimension int_prec(nw),int_grd(nw)
      dimension wav_tran(155),air_tran(155),altabs(22),absfr(22)
      data pi/3.14159265/
!
! wavelengths specifying atmospheric transmission, A      
      data wav_tran/ 100.,                                                       &
  &      2994.9,  3020.2,  3045.7,  3071.4,  3097.3,  3123.5,  3149.9,  3176.5,  &
  &      3203.3,  3230.3,  3257.6,  3285.1,  3312.8,  3340.8,  3369.0,  3397.4,  &
  &      3426.1,  3455.1,  3484.2,  3513.6,  3543.3,  3573.2,  3603.4,  3633.8,  &
  &      3664.5,  3695.4,  3726.6,  3758.1,  3789.8,  3821.8,  3854.1,  3886.6,  &
  &      3919.5,  3952.5,  3985.9,  4019.6,  4053.5,  4087.7,  4122.2,  4157.0,  &
  &      4192.1,  4227.5,  4263.2,  4299.2,  4335.5,  4372.1,  4409.0,  4446.3,  &
  &      4483.8,  4521.7,  4559.8,  4598.3,  4637.2,  4676.3,  4715.8,  4755.6,  &
  &      4795.8,  4836.3,  4877.1,  4918.3,  4959.8,  5001.7,  5043.9,  5086.5,  &
  &      5129.4,  5172.7,  5216.4,  5260.4,  5304.9,  5349.6,  5394.8,  5440.4,  &
  &      5486.3,  5532.6,  5579.3,  5626.4,  5673.9,  5721.8,  5770.1,  5818.9,  &
  &      5868.0,  5917.5,  5967.5,  6017.9,  6068.7,  6119.9,  6171.6,  6223.7,  &
  &      6276.3,  6329.2,  6382.7,  6436.6,  6490.9,  6545.7,  6601.0,  6656.7,  &
  &      6712.9,  6769.6,                                                        &
  &      6785.,   6927.,   7110.,   7185.,   7298.,   7452.,   7530.,   7648.,   &
  &      7687.,   7688.,   7769.,   7875.,   7891.,   8099.,   8125.,   8159.,   &
  &      8444.,   8622.,   8989.,   9083.,   9274.,   9371.,   9469.,   9976.,   &
  &     10842.,  10843.,  10956.,  11187.,  11304.,  11423.,  11663.,  11724.,   &
  &     12096.,  12480.,  12743.,  12810.,  13107.,  13565.,  14143.,  14440.,   &
  &     14516.,  14744.,  15292.,  15452.,  17060.,  17602.,  18066.,  19433.,   &
  &     19636.,  20686.,  21343.,  22485.,  23199.,  25347.,  28573.,  30101./
!
! atmospheric transmission, vertical, from infinite height to ground
      data air_tran/ 0.0000,                                                      &
  &      0.0000,  0.0302,  0.0665,  0.1088,  0.1641,  0.2177,  0.2684,  0.3159,   &
  &      0.3584,  0.3932,  0.4198,  0.4448,  0.4684,  0.4904,  0.5091,  0.5241,   &
  &      0.5387,  0.5530,  0.5668,  0.5802,  0.5932,  0.6059,  0.6181,  0.6294,   &
  &      0.6399,  0.6502,  0.6602,  0.6701,  0.6797,  0.6891,  0.6983,  0.7074,   &
  &      0.7162,  0.7248,  0.7332,  0.7413,  0.7492,  0.7569,  0.7644,  0.7717,   &
  &      0.7788,  0.7857,  0.7924,  0.7990,  0.8053,  0.8115,  0.8174,  0.8232,   &
  &      0.8288,  0.8336,  0.8383,  0.8429,  0.8474,  0.8518,  0.8561,  0.8603,   &
  &      0.8644,  0.8685,  0.8724,  0.8762,  0.8800,  0.8836,  0.8868,  0.8899,   &
  &      0.8930,  0.8961,  0.8990,  0.9019,  0.9048,  0.9076,  0.9103,  0.9130,   &
  &      0.9157,  0.9182,  0.9207,  0.9232,  0.9256,  0.9280,  0.9302,  0.9325,   &
  &      0.9347,  0.9368,  0.9388,  0.9408,  0.9428,  0.9447,  0.9465,  0.9483,   &
  &      0.9500,  0.9517,  0.9533,  0.9548,  0.9563,  0.9578,  0.9591,  0.9605,   &
  &      0.9617,  0.9629,                                                         &
  &      0.9811,  0.9868,  0.9434,  0.7453,  0.8066,  0.9717,  0.9717,  0.6132,   &
  &      0.6132,  0.9717,  0.9764,  0.9764,  0.9575,  0.9528,  0.9764,  0.9802,   &
  &      0.9764,  0.8585,  0.9811,  0.7453,  0.7453,  0.3208,  0.3208,  0.9764,   &
  &      1.0000,  0.9292,  0.9292,  0.2264,  0.9349,  0.3491,  0.3491,  0.7925,   &
  &      0.8585,  0.9811,  0.9811,  0.9623,  0.9198,  0.0000,  0.0000,  0.0991,   &
  &      0.2264,  0.2264,  0.9292,  0.9764,  0.9764,  0.7925,  0.0000,  0.0000,   &
  &      0.1887,  0.9877,  0.9528,  0.9434,  0.8774,  0.0000,  0.0000,  0.1509/
!
! altitudes specifying density height
      data altabs/                                                                 &
  &           0.,      5000.,     10000.,     15000.,     20000.,     25000.,      &
  &       30000.,     35000.,     40000.,     45000.,     50000.,     55000.,      & 
  &       60000.,     65000.,     70000.,     75000.,     80000.,     85000.,      & 
  &       90000.,     95000.,    100000.,    105000./   
!
! fraction of density height
      data absfr/                                                                  &
  &     0.0000000,  0.4739088,  0.7374038,  0.8790913,  0.9441218,  0.9743732,     &
  &     0.9879313,  0.9941887,  0.9971017,  0.9984768,  0.9991990,  0.9995715,     &
  &     0.9997782,  0.9998896,  0.9999462,  0.9999746,  0.9999880,  0.9999943,     &
  &     0.9999973,  0.9999987,  0.9999994,  0.9999997/ 

      elev_ang1=elev_ang/57.296                 ! elevation angle in radian
      mon1=0; mon2=0
      flux_grd=0.
      do iw=1,nwave
        if(iw.lt.mwave) int_grd(iw)=0.
        if(iw.ge.mwave) then
          int_grd(iw)=int_prec(iw)
          call taint(wav_tran(1),air_tran(1),wavel(iw),fmult,155,1,ier1,mon1)
          fmult=dmax1(fmult,1.0d-4)
          call altrho(2,altit,rhoinf)
          call taint(altabs,absfr,altit,extinc,22,2,ier2,mon2)          
          fac_angl=1./dsin(elev_ang1)
          fmul1=(fmult*extinc)**fac_angl
          int_grd(iw)=int_prec(iw)*fmul1
          delw=wavel(iw)-wavel(iw-1)
          flux_grd=flux_grd+2.0*pi*int_grd(iw)*delw    ! rad flux at ground in quasi 1-D
        end if
      end do
      return
      end
!************************************************************************************     
      subroutine atom_bb(isp,temp, power)                                          
! calculates bound-bound radiation of an atom                                             
! input parameters:                                                                       
!   isp=species number                                                                    
!   atomnm(isp)=species name, A4                                                          
!   temp=temperature, K                                                                   
! output parameters:                                                                      
!   power=emission power, W                                                               
      parameter(matoms=56,nlev_tot_atom=999,                                   &               
     & line_tot=2830,mdiatoms=12,mtriatoms=6,msp=60)                                                     
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 ion_pot,nk,ni,neq_factor_k,neq_factor_i                                      
      character*4 atom_rads(3,168),diatom_bands(3,100),                        &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                          &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                     &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                              &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,  &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      common/comi/nwave                                                                   
      integer g_atom,g_ion,gi_atom,gk_atom,g_neq_lev_atom                                 
      common/coma1/atomwt(matoms),ion_pot(matoms),                        &               
     &  Ecm_atom(nlev_tot_atom,matoms),Ecm_ion(nlev_tot_atom,matoms),     &               
     &  starkg(line_tot,matoms),                                          &               
     &  starkn(line_tot,matoms),Ecm_neq_lev_atom(23,matoms),              &               
     &  ei_atom(line_tot,matoms),ek_atom(line_tot,matoms),                &               
     &  wavel_atom(line_tot,matoms),aki_atom(line_tot,                    &               
     &  matoms),z(matoms),e_inner(matoms),ephot_gaunt(21,matoms),         &               
     &  e_gaunt(51,matoms),gaunt(9,51,matoms),temp_cross_atom(11,matoms)  &               
     &  ,wavel_cross_atom(101,matoms),cross_atom(101,11,matoms),          &               
     &  ephot_ff(11,matoms),temp_ff(31,matoms),gaunt_ff(7,31,matoms),     &               
     &  eimp_ro(26,26,matoms),eimp_rexp(26,26,matoms)                                     
      common/comb1/ g_atom(nlev_tot_atom,matoms),g_neq_lev_atom(23,       &               
     &  matoms),gi_atom(line_tot,matoms),g_ion(nlev_tot_atom,             &               
     &  matoms),gk_atom(line_tot,matoms),ig_gaunt(99,matoms),             &               
     &  ind_lev_atom(nlev_tot_atom,matoms),ind_lev_ion(nlev_tot_atom,     &               
     &  matoms),ind_line(line_tot,matoms),iz_atom(matoms),                &               
     &  neq_lev_atom(matoms),n_gaunt(99,matoms),ng_atom(nlev_tot_atom,    &               
     &  matoms),ng_gaunt(99,matoms),n_temp_cross_atom(matoms),            &               
     &  ngi_atom(line_tot,matoms),ngk_atom(line_tot,matoms),              &               
     &  nlev_atom(matoms),nlev_atomic_ion(matoms),nline(matoms),          &               
     &  n_temp_ff_atom(matoms),ntot_gaunt(matoms),num_exct(matoms),       &               
     &  n_wavel_cross_atom(matoms)                                                        
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/spect/calpha,slope_ratio,wavmin,wavmax,range1                                             
      common/scratch/emisr(nw) 
      save                                                           
      data itime/0/                                                                       
!                                                                                         
      write(6,30) atomnm(isp),dens_atom(isp)                                              
 30   format(' in atom_bb. species = ', a4,1pe10.3,' cm-3') 
!
! power emission 
      power=0.                                                                                          
! neutral partition function                                                              
      partn=0.                                                                            
      do i=1,nlev_atom(isp)                                                               
        partn=partn+g_atom(i,isp)*dexp(-1.43877d0*Ecm_atom(i,isp)/temp)                   
      end do                                                                              
!                                                                                          !                                                                                         
! cycle over lines                                                                        
      power=0.       
      do k = 1,nline(isp)                                                                 
! check if this line is in the desired wavelength range                                   
        if((wavel_atom(k,isp).lt.wavmin).or.                              &               
     &    (wavel_atom(k,isp).gt.wavmax)) go to 20                                         
! number density of upper state                                                           
        if(ngk_atom(k,isp).eq.0) neq_factor_k = 1.0                                       
        kk=ngk_atom(k,isp)                                                                
        if(ngk_atom(k,isp).ne.0) neq_factor_k=atom_rho(kk,isp)/           &               
     &    atom_chi(isp)                                                                   
        if(ngi_atom(k,isp).eq.0) neq_factor_i=1.0                                         
        kk=ngi_atom(k,isp)                                                                
        if(ngi_atom(k,isp).ne.0) neq_factor_i=atom_rho(kk,isp)/           &               
     &    atom_chi(isp)                                                                   
        nk=(dens_atom(isp)*gk_atom(k,isp) * dexp(-1.43877d0               &               
     &    *ek_atom(k,isp)/temp)/partn) * neq_factor_k                                     
!                                                                                         
! number density of lower state                                                           
        ni=(dens_atom(isp)* gi_atom(k,isp)* dexp(-1.43877d0               &               
     &    *ei_atom(k,isp)/temp)/partn) * neq_factor_i                                     
!                                                                                         
! Gaussian width, from richter, in plasma diagnostics, lochte-holtgreven, pp. 1-65.       
        widthg=7.16d-7*wavel_atom(k,isp)*dsqrt(temp/atomwt(isp))                          
                                                                                          
! classical natural width, also from richter, ibid                                        
        width1 = 1.18d-4                                                                  
                                                                                          
! stark width, following griem, plasma spectroscopy                                       
        gam=starkg(k,isp)                                                                 
        expn=starkn(k,isp)                                                                
                                                                                          
! default formula when gam is not given: from arnold et al, progress in astronautics      
! and aeronautics, vol. 69, 1980, pp.52-82.                                               
!        if(starkn(k,isp).lt.1.0d-8) gam =                                 &               
!     &    0.042d0*(wavel_atom(k,isp)**2)/(ion_pot(isp)-ek_atom(k,isp)     &               
!     &    )**2                                                                            
        if(starkn(k,isp).lt.1.0d-20) gam =                                &              
     &    0.042d0*(wavel_atom(k,isp)**2)/(ion_pot(isp)-ek_atom(k,isp)     &               
     &    )**2                                                                            
                                                                                          
        if(starkg(k,isp).lt.1.0d-20) expn=0.33d0                                           
        width2=2.0d0*gam*((1.0d-4*temp)**expn)*dens_elec*1.0d-16                             
!                                                                                         
! pressure broadening by non-resonant collisions, from traving, in plasma diagnostics,    
!   lochte-holtgreven, 1968, pp. 66-134.                                                  
        cw3=5.85d-30*dsqrt(2.0d0/atom_avg_molwt)*dens_atom_hvy            &               
     &  *dsqrt(temp)                                                                      
        width3=cw3*wavel_atom(k,isp)**2                                                   
!                                                                                         
! resonance width also from traving, ibid                                                 
        width4=1.03d-25*(1.0d-20*wavel_atom(k,isp)**5)                    &               
     &    *sqrt(real(gk_atom(k,isp))/real(gi_atom(k,isp)))                &               
     &    *aki_atom(k,isp)*ni                                                             
                                                                                          
! sum up to get lorenz line width, in A                                                   
        widthl = width1 + width2 + width3 + width4                                        
!                                                                                         
! voigt line width at half-height, in A                                                   
        widthv=widthl/2.0d0 + dsqrt(widthl**2/4.0d0 +widthg**2)                           
!                                                                                         
! determine the range multiplication factor range from a semi-empirical formula           
        range=20000.d0*dexp(-ei_atom(k,isp)/16000.d0) + 2000.               ! verified                                                                                     
!                                                                                         
! determine the wavelength node m for line center                                         
        ncentr=nwave*((wavel_atom(k,isp)-wavmin)/(wavmax-wavmin))**(1./calpha)
!        ncentr=(1.0d0/dsqrt(wavmin) - 1.0d0/dsqrt(wavel_atom(k,isp)))/estep + 1                         
                                                                                          
! determine wavelength interval at line center in angstrom                                
        witv=((wavmax-wavmin)/float(nwave)**calpha)*calpha*float(ncentr)**(calpha-1.)
!        witv=wavmin**2*estep/((1.0d0-wavmin*estep*ncentr)                 &               
!     &    *(1.0d0-wavmin*estep*(ncentr-1)))                                               
!        witv=1./(1./dsqrt(wavmin)-estep*(ncentr-1))**2                       &
!   &      -1./(1./dsqrt(wavmin)-estep*ncentr)**2
        witv=dabs(witv)
        wd1=1/widthv
        csprd2=widthl/widthv
        csprd3=(1.065+0.447*csprd2+0.058*csprd2**2)*widthv*1.0e-4
        csprd1=(1.-csprd2)/csprd3
        csprd2=csprd2/csprd3
!                                                                                         
! determine line shape spreading index nspred                                             
        nspred = 1 + range * widthv/witv                                                  
        nstart = ncentr - nspred                                                          
        if(nstart.lt.1) nstart = 1                                                        
        nend = ncentr + nspred                                                            
        if(nend.gt.nwave) nend=nwave    
!                                                                                         
! set line center wavelength to be a node point, in cm                                    
        wavctr=wavel_atom(k,isp)
        ax=(real(gi_atom(k,isp))/real(gk_atom(k,isp)))*(nk/ni)                            
        blam=1.1904d-16*ax/((1.0d-8*wavctr)**5*(1.0d0-ax))                     
!                                                                                         
! line emissiion power in w/(cm3-sr)                                                      
        e=1.580d-16*aki_atom(k,isp)*nk/wavctr                                  
        power=power+e                                                                     
!                                                                                         
! the line shape converts the emitted power e to spectral emission coef, emis,            
!   w/cm3-micron-sr.                                                                                                                                                     
        mtot=0   
        do m = nstart,nend                                                                
          csprd3=dabs((wavctr-wavel(m))*wd1)
          csp2=csprd3**2
          csp3=csp2*dsqrt(dsqrt(csprd3))   
          emisr(m)=e*(csprd1*dexp(-2.772*csp2)+csprd2/(1.+4.*csp2)+0.016*     &
  &         csprd2*(1.0-widthl*wd1)*(dexp(-0.4*csp3)-10.0/(10.0+csp3)))
          if(emisr(m).lt.1.0e-20) then                                                    
  50        format(a4,' m=',i6,' emisr=',1pe10.3)                                         
            emisr(m)=1.0e-20                                                              
          end if                                                                          
          mtot=mtot+1                                                                     
        end do                                                                            
        call trapez(ans,wavel(nstart),emisr(nstart),mtot,ier)                             
        ratio1=ans/10000.                                                                 
        do m=nstart,nend                                                                  
          emisr(m)=emisr(m)/ratio1                                                        
        end do                                                                            
        do m=nstart,nend     
          emission=emisr(m)*e                                                             
          ratio=1.52*widthv/witv                                                          
          if((m.eq.ncentr).and.(ratio.lt.1.0)) emission=emission*ratio                    
          ax = dexp(-1.43877d0*1.0d8/(wavel_atom(k,isp)*temp))                           
          blam=1.1904d-16*ax/((1.0d-8*wavel_atom(k,isp))**5*(1.0d0-ax))                  
          absbx=emission/blam                                                             
          cross=absbx/dens_atom(isp)                                                      
          absby=cross*dens_atom(isp)                                                      
          absb(m)=absb(m)+absby                                                           
          if(absb(m).lt.0.) then                                                          
            write(*,40) atomnm(isp),dens_atom(isp),m,wavel(m),            &               
     &        ei_atom(k,isp),ek_atom(k,isp),e,emisr(m),ratio,absbx,       &               
     &        cross,absby,absb(m)                                                         
  40        format(a4,' dens=',1pe10.3,' m=',i6,' wavel=',0pf10.2,        &               
     &        ' ei=',f10.2/' ek=',f10.2,' e=',1pe10.3,' emisr=',e10.3,    &               
     &        ' ratio=',e10.3/' absbx=',e10.3,' cross=',e10.3,            &               
     &        ' absby=',e10.3,' absb=',e10.3)                                             
            stop                                                                          
          end if                                                                                                                                                       
        end do                                                                            
20      continue                                                                          
      end do                                                                              
      itime=itime+1
      write(6,66) atomnm(isp),dens_atom(isp),power
66    format(1x,a4,2x,' dens_atom=',1pe10.3,' power=',e10.3)
      return                                                                              
      end                                                                                 
!****************************************************************************             
      subroutine atom_bf_cr(isp,temp, power)                                       
! calculates emission and absorption coefficients for bound-free transitions              
!   of atoms using cross sections. Peach, Mem.  R. astr. Soc (1970) 1-123                 
! input parameters:                                                                       
!   isp=species index                                                                                   
!   atomnm(matoms)=name of atom                                                                                
!   temp=temperature                                                                                  
! output parameter:                                                                       
!   power=emission power, W/cm3                                                           
      parameter(matoms=56,mdiatoms=12,mtriatoms=6,nlev_tot_atom=999,      &               
     & line_tot=2830,msp=60)                                                                     
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 ion_pot,nk,ni,neq_factor_k,neq_factor_i                                      
      character*4 atom_rads(3,168),diatom_bands(3,100),                   &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                     &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                         &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,  &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      common/comi/nwave                                                                   
      integer g_atom,g_ion,gi_atom,gk_atom,g_neq_lev_atom                                 
      common/coma1/atomwt(matoms),ion_pot(matoms),                        &               
     &  Ecm_atom(nlev_tot_atom,matoms),Ecm_ion(nlev_tot_atom,matoms),     &               
     &  starkg(line_tot,matoms),                                          &               
     &  starkn(line_tot,matoms),Ecm_neq_lev_atom(23,matoms),              &               
     &  ei_atom(line_tot,matoms),ek_atom(line_tot,matoms),                &               
     &  wavel_atom(line_tot,matoms),aki_atom(line_tot,                    &               
     &  matoms),z(matoms),e_inner(matoms),ephot_gaunt(21,matoms),         &               
     &  e_gaunt(51,matoms),gaunt(9,51,matoms),temp_cross_atom(11,matoms)  &               
     &  ,wavel_cross_atom(101,matoms),cross_atom(101,11,matoms),          &               
     &  ephot_ff(11,matoms),temp_ff(31,matoms),gaunt_ff(7,31,matoms),     &               
     &  eimp_ro(26,26,matoms),eimp_rexp(26,26,matoms)                                     
      common/comb1/ g_atom(nlev_tot_atom,matoms),g_neq_lev_atom(23,       &               
     &  matoms),gi_atom(line_tot,matoms),g_ion(nlev_tot_atom,             &               
     &  matoms),gk_atom(line_tot,matoms),ig_gaunt(99,matoms),             &               
     &  ind_lev_atom(nlev_tot_atom,matoms),ind_lev_ion(nlev_tot_atom,     &               
     &  matoms),ind_line(line_tot,matoms),iz_atom(matoms),                &               
     &  neq_lev_atom(matoms),n_gaunt(99,matoms),ng_atom(nlev_tot_atom,    &               
     &  matoms),ng_gaunt(99,matoms),n_temp_cross_atom(matoms),            &               
     &  ngi_atom(line_tot,matoms),ngk_atom(line_tot,matoms),              &               
     &  nlev_atom(matoms),nlev_atomic_ion(matoms),nline(matoms),          &               
     &  n_temp_ff_atom(matoms),ntot_gaunt(matoms),num_exct(matoms),       &               
     &  n_wavel_cross_atom(matoms)                                                        
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/spect/calpha,slope_ratio,wavmin,wavmax,range1                                             
      common/scratch/yy(nw)                                                               
      dimension tlog(17),y(17),wavelx(501),cross(501)   
      save                                  
      data itime/0/                                                                       
!                                                                                         
      write(6,10) atomnm(isp),dens_atom(isp)                                              
  10  format(' In atom_bf_cr. species = ',a4,1pe10.3,' cm-3')                             
!                                                                                         
! cycle over transition                                                                   
      ntemp=n_temp_cross_atom(isp)                                                        
      nwavel=n_wavel_cross_atom(isp)                                                      
      wavelmin = wavel_cross_atom(1,isp)                                                  
      nwavel_c=n_wavel_cross_atom(isp)                                                    
      wavelmax = wavel_cross_atom(nwavel_c,isp)                                           

!                                                                                         
! determine the wavelength node m for line center                                         
      nstart=nwave*((wavelmin-wavmin)/(wavmax-wavmin))**(1./calpha)
!      nstart = (1./dsqrt(wavmin)-1./dsqrt(wavelmin))/estep + 1
      nend=nwave*((wavelmax-wavmin)/(wavmax-wavmin))**(1./calpha)
!      nend = (1./dsqrt(wavmin)-1./dsqrt(wavelmax))/estep + 1                                   
      if(nstart.lt.1) nstart=1
      if(nend.gt.nwave) nend=nwave                                         
!                                                                                         
! interpolate absorption cross sections for given electron temperature                    
      do it = 1,ntemp                                                                     
        tlog(it) = dlog(temp_cross_atom(it,isp))                                          
      end do                                                                              
      tlogx = dlog(temp)                                                                  
      mon = 0                                                                             
      do iwavel = 1, nwavel_c                                                             
        wavelx(iwavel) = wavel_cross_atom(iwavel,isp)                                     
        do it = 1, ntemp                                                                  
          if(cross_atom(iwavel,it,isp).gt.0.)                             &               
     &      y(it) = dlog(cross_atom(iwavel,it,isp))                                       
        end do                                                                            
        if(temp.lt.temp_cross_atom(ntemp,isp))                            &               
     &    call taint(tlog,y,tlogx,crossx,ntemp,1,ner,mon)                                 
        if(temp.ge.temp_cross_atom(ntemp,isp))                            &               
     &    call taint(tlog,y,tlogx,crossx,ntemp,1,ner,mon)                                 
        cross(iwavel) = crossx                                                            
      end do                                                                              
!                                                                                         
!  yy(m) is used as emission                                                              
      do m=1,nwave                                                                        
        yy(m)=0.0d0                                                                       
      end do                                                                              
!                                                                                         
! interpolate to find cross section crosx                                                 
      mon = 0                                                                             
      do m = nend,nstrt,-1 
        crosx=0.; absorption=0.                                                               
        if(wavel(m).gt.wavelmin) then                                                     
          call taint(wavelx,cross,wavel(m),crosx,nwavel_c,1,ner,mon)                      
          crosx=dexp(crosx)                                                               
          absorption = crosx * dens_atom(isp) 
        end if                                                                            
        ax = dexp(-1.43877d0*1.0d8/(wavel(m)*temp))                                       
        blam = 1.1904d-16 * ax/((1.0d-8*wavel(m))**5*(1.0d0 - ax))                        
        emission = absorption * blam                                                      
        yy(m) = yy(m) + emission                                                          
        absb(m) = absb(m) + absorption                                                    
      enddo                                                                               
!                                                                                         
! emission power                                                                          
      call trapez(power,wavel,yy,nwave,ier)                                               
      power=4.d0*3.1415926d0*1.d-4*power                                                  
      return                                                                              
      end                                                                                 
!****************************************************************************             
      subroutine atom_bf_Gaunt(isp,temp, power)                                    
! calculates emission and absorption coefficients for bound-free transitions              
!   of atoms using Gaunt factors. Based on Griem, Plasma Spectroscopy and                 
!   Peach, Mem.  R. astr. Soc (1970) 1-123                                                
! input parameters:                                                                       
!   isp=species index                                                                                   
!   atomnm(matoms)=name of atom                                                                                
!   temp=temperature                                                                                  
! output parameter:                                                                       
!   power=emission power                                                                  
      parameter(matoms=56,nlev_tot_atom=999,line_tot=2830,mdiatoms=12,         &
    &   mtriatoms=6,msp=60)                                                     
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 ion_pot,nk,ni,neq_factor_k,neq_factor_i                                      
      character*4 atom_rads(3,168),diatom_bands(3,100),                        &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                          &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                     &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                              &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,  &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      common/comi/nwave                                                                   
      integer g_atom,g_ion,gi_atom,gk_atom,g_neq_lev_atom,sw_limit_m                                 
      common/coma1/atomwt(matoms),ion_pot(matoms),                        &               
     &  Ecm_atom(nlev_tot_atom,matoms),Ecm_ion(nlev_tot_atom,matoms),     &               
     &  starkg(line_tot,matoms),                                          &               
     &  starkn(line_tot,matoms),Ecm_neq_lev_atom(23,matoms),              &               
     &  ei_atom(line_tot,matoms),ek_atom(line_tot,matoms),                &               
     &  wavel_atom(line_tot,matoms),aki_atom(line_tot,                    &               
     &  matoms),z(matoms),e_inner(matoms),ephot_gaunt(21,matoms),         &               
     &  e_gaunt(51,matoms),gaunt(9,51,matoms),temp_cross_atom(11,matoms)  &               
     &  ,wavel_cross_atom(101,matoms),cross_atom(101,11,matoms),          &               
     &  ephot_ff(11,matoms),temp_ff(31,matoms),gaunt_ff(7,31,matoms),     &               
     &  eimp_ro(26,26,matoms),eimp_rexp(26,26,matoms)                                     
      common/comb1/ g_atom(nlev_tot_atom,matoms),g_neq_lev_atom(23,       &               
     &  matoms),gi_atom(line_tot,matoms),g_ion(nlev_tot_atom,             &               
     &  matoms),gk_atom(line_tot,matoms),ig_gaunt(99,matoms),             &               
     &  ind_lev_atom(nlev_tot_atom,matoms),ind_lev_ion(nlev_tot_atom,     &               
     &  matoms),ind_line(line_tot,matoms),iz_atom(matoms),                &               
     &  neq_lev_atom(matoms),n_gaunt(99,matoms),ng_atom(nlev_tot_atom,    &               
     &  matoms),ng_gaunt(99,matoms),n_temp_cross_atom(matoms),            &               
     &  ngi_atom(line_tot,matoms),ngk_atom(line_tot,matoms),              &               
     &  nlev_atom(matoms),nlev_atomic_ion(matoms),nline(matoms),          &               
     &  n_temp_ff_atom(matoms),ntot_gaunt(matoms),num_exct(matoms),       &               
     &  n_wavel_cross_atom(matoms)                                                        
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/spect/calpha,slope_ratio,wavmin,wavmax,range1                                             
      common/scratch/yy(nw)
      save                                                               
!                                                                                         
      write(6,10) atomnm(isp),dens_atom(isp)                                              
  10  format(' In atom_bf. species = ',a4,1pe10.3,' cm-3')                                
!                                                                                         
! neutral partition function                                                              
      partn=0.                                                                            
      do i=1,ntot_gaunt(isp)                                                               
        partn=partn+ig_gaunt(i,isp)*dexp(-1.43877d0*e_gaunt(i,isp)/temp)                   
      end do                                                                              
!                                                                                         
! yy(m) is used to calculated emission                                                    
      do m=1,nwave                                                                        
        yy(m)=0.d0                                                                        
      end do                                                                              
!                                                                                         
! cycle over transition                                                                   
      do itran=1,ntot_gaunt(isp)   
!                                                                                         
! number density of lower state                                                           
!        if(ngi_atom(itran,isp).eq.0) neq_factor_i=1.0     
        neq_factor_i=1.0                                
!        if(atoms(isp)%line(k)%ngi.eq.0) neq_factor_i = 1.0                               
        kk=ngi_atom(itran,isp)   
!        if(ngi_atom(itran,isp).ne.0) neq_factor_i=atom_rho(kk,isp)/       &               
!     &    atom_chi(isp)                                                                   
        neq_factor_i=1.0
!        ni=(dens_atom(isp)* gi_atom(itran,isp)* dexp(-1.43877d0           &               
        ni=(dens_atom(isp)* IG_GAUNT(itran,isp)* dexp(-1.43877d0           &               
     &    *e_gaunt(itran,isp)/temp)/partn)   
!     >    *ei_atom(itran,isp)/temp)/partn) * neq_factor_i                                
!                                                                                         
! threshold parameters                                                                    
        threshold_e = ion_pot(isp) - e_gaunt(itran,isp)  
        threshold_ryd = threshold_e/109679.d0                                             
        threshold_wavel = 1.0d8/threshold_e       
        nstart=nwave*((threshold_wavel-wavmin)/(wavmax-wavmin))**(1./calpha)
!        nstart=(1./dsqrt(wavmin) - 1./dsqrt(threshold_wavel))/estep + 1
        if(nstart.gt.nwave) nstart = nwave                                                
! if out of range, skip calculation   
        if(nstart.lt.1) go to 20                                                          
!                                                                                         
! short wavelength limit, taken to be 10 times the electron thermal energy kT             
        photon_to_kt_ratio = 10.          ! max photon energy/kT consider                 
        ekt = temp/1.43877d0                                                              
        sw_limit_e = threshold_e + photon_to_kt_ratio * ekt                               
                                          ! short wavelength limit energy, cm-1           
        sw_limit_w = 1.0d8/sw_limit_e      ! short wavelength limit in Angstrom           
        sw_limit_m = nwave*((sw_limit_w-wavmin)/(wavmax-wavmin))**(1./calpha)
!        sw_limit_m = (1./dsqrt(wavmin) - 1./dsqrt(sw_limit_w))/estep + 1
        if(sw_limit_m.lt.1) sw_limit_m = 1                                                
!                                                                                         
! cycle over wavelength                                                                   
        do k=nstart-1,1,-1 
          photon_e=(1.0d0/wavel(k))/109679.d0 - threshold_ryd                             
          if(wavel(k).gt.sw_limit_w) then                                                 
            call intpl1(ephot_gaunt(1,isp),gaunt(1,itran,isp),            &               
     &      photon_e,gauntx,9)                                                            
            if(gauntx.lt.0.1) gauntx=0.1                                                  
          end if                                                                          
          cross_section = (7.908d-18 * (109679.d0*wavel(k)/1.0d8)**3/     &               
     &      n_gaunt(itran,isp)**5) * gauntx                                               
          absorption = ni*cross_section                                                   
          absb(k) = absb(k) + absorption                                                  
        end do                                                                            
  20    continue                                                                          
      enddo                                                                               

! emission power                                                                          
      call trapez(power,wavel,yy,nwave,ier)    ! power in per st-radian                   
      power=4.d0*3.1415926d0*1.0d-4*power                                                 
      return                                                                              
      end                                                                                 
!***********************************************************************************      
      subroutine atom_ff(isp,temp, power)                                          
! calculates emission and absorption coefficients for bound-free transitions of           
! atoms based on griem, plasma spectroscopy and peach, mem.  r. astr. soc(1970)           
! 1-123                                                                                   
! input parameters:                                                                       
!   isp=species index                                                                                   
!   atomnm(matoms)=name of atom                                                                                
!   temp=temperature, K                                                                                  
! output parameter:                                                                       
!   power=emission power, W/cm3                                                           
!                                                                                         
      parameter(matoms=56,nlev_tot_atom=999,line_tot=2830,mdiatoms=12,          &
    &  mtriatoms=6,msp=60)                                                     
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 ion_pot,nk,ni,neq_factor_k,neq_factor_i                                      
      character*4 atom_rads(3,168),diatom_bands(3,100),                         &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                           &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                      &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                               &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,   &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      common/comi/nwave                                                                   
      integer e_photon,g_atom,gi_atom,gk_atom,g_neq_lev_atom,g_ion                        
      common/coma1/atomwt(matoms),ion_pot(matoms),                        &               
     &  Ecm_atom(nlev_tot_atom,matoms),Ecm_ion(nlev_tot_atom,matoms),     &               
     &  starkg(line_tot,matoms),                                          &               
     &  starkn(line_tot,matoms),Ecm_neq_lev_atom(23,matoms),              &               
     &  ei_atom(line_tot,matoms),ek_atom(line_tot,matoms),                &               
     &  wavel_atom(line_tot,matoms),aki_atom(line_tot,                    &               
     &  matoms),z(matoms),e_inner(matoms),ephot_gaunt(21,matoms),         &               
     &  e_gaunt(51,matoms),gaunt(9,51,matoms),temp_cross_atom(11,matoms)  &               
     &  ,wavel_cross_atom(101,matoms),cross_atom(101,11,matoms),          &               
     &  ephot_ff(11,matoms),temp_ff(31,matoms),gaunt_ff(7,31,matoms),     &               
     &  eimp_ro(26,26,matoms),eimp_rexp(26,26,matoms)                                     
      common/comb1/ g_atom(nlev_tot_atom,matoms),g_neq_lev_atom(23,       &               
     &  matoms),gi_atom(line_tot,matoms),g_ion(nlev_tot_atom,             &               
     &  matoms),gk_atom(line_tot,matoms),ig_gaunt(99,matoms),             &               
     &  ind_lev_atom(nlev_tot_atom,matoms),ind_lev_ion(nlev_tot_atom,     &               
     &  matoms),ind_line(line_tot,matoms),iz_atom(matoms),                &               
     &  neq_lev_atom(matoms),n_gaunt(99,matoms),ng_atom(nlev_tot_atom,    &               
     &  matoms),ng_gaunt(99,matoms),n_temp_cross_atom(matoms),            &               
     &  ngi_atom(line_tot,matoms),ngk_atom(line_tot,matoms),              &               
     &  nlev_atom(matoms),nlev_atomic_ion(matoms),nline(matoms),          &               
     &  n_temp_ff_atom(matoms),ntot_gaunt(matoms),num_exct(matoms),       &               
     &  n_wavel_cross_atom(matoms)                                                        
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/spect/calpha,slope_ratio,wavmin,wavmax,range1                                             
      dimension x(30),y(30),d_peach(30)                                                   
!                                                                                         
      write(6,10) atomnm(isp),dens_atom(isp)                                              
  10  format(' in atom_ff. species = ',a4,1pe10.3,' cm-3')                                
!                                                                                         
! constant                                                                                
      c1 = 1.368d-23 * dens_elec * dens_atom_ion /dsqrt(temp)                             
!                                                                                         
! generate the temperature variable                                                       
      do it=1,n_temp_ff_atom(isp)                                                         
        x(it)=temp_ff(it,isp)                                                             
      end do                                                                              
!                                                                                         
! interpolate d of peach for given electron temperature                                   
      mon = 0                                                                             
      do e_photon = 1,6                                                                   
        do it=1,n_temp_ff_atom(isp)                                                       
          y(it)=gaunt_ff(e_photon,it,isp)                                                 
        end do                                                                            
        call taint(x, y, temp, d_peach(e_photon),                         &               
     &    n_temp_ff_atom(isp),2,ner,mon)                                                  
      enddo                                                                               
      e_ph_max=ephot_ff(6,isp)                                                            
!                                                                                         
! cycle over wavelength                                                                   
      mon = 0                                                                             
      do m = nwave,1,-1                                                                   
        photon_e = (1.0d8/wavel(m))/109679.d0                                             
        if(photon_e.le.e_ph_max) then                                                     
          call taint(ephot_ff(1,isp),d_peach(1),photon_e,d,6,2,ner,mon)                   
          gauntx = 1.0d0 + d                                                              
        end if                                                                            
        absorption = c1 * gauntx * (1.0d-8 * wavel(m))**3                                 
        ax = dexp(-1.43877d0*1.0d8/(wavel(m)*temp))                                       
        blam = 1.1904d-16 * ax/((1.0d-8*wavel(m))**5*(1.0d0 - ax))                        
        emission = blam * absorption                                                      
        emis = emis + emission                                                            
        absb(m) = absb(m) + absorption                                                    
      enddo                                                                               
!                                                                                         
      return                                                                              
      end                                                                                 
!**************************************************************************************** 
      subroutine atom_read(natoms)                              
! read in monatomic input data from atom.dat                                              
! input parameters:                                                                       
!   natoms=number of atoms                                                                
!   atomnm1(matoms)= name of atom                                                                        
!   atom_rads(3,168)=list of atomic radiation mechanisms to be calculated                      
!                                                                                         
      parameter(matoms=56,nlev_tot_atom=999,line_tot=2830,msp=60,mdiatoms=12,  &
    &   mtriatoms=6)                                
      implicit real*8(a-h,o-z)                                                            
      real*8  ion_pot                                                                     
      character*4 atom_rads(3,168),diatom_bands(3,100),                        &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                          &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                     &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                              &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,  &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      character*4  unknown,asterik,minus1                                                 
      integer g_atom,g_ion,gi_atom,gk_atom,g_neq_lev_atom,check                           
      common/coma1/atomwt(matoms),ion_pot(matoms),                        &               
     &  Ecm_atom(nlev_tot_atom,matoms),Ecm_ion(nlev_tot_atom,matoms),     &               
     &  starkg(line_tot,matoms),                                          &               
     &  starkn(line_tot,matoms),Ecm_neq_lev_atom(23,matoms),              &               
     &  ei_atom(line_tot,matoms),ek_atom(line_tot,matoms),                &               
     &  wavel_atom(line_tot,matoms),aki_atom(line_tot,                    &               
     &  matoms),z(matoms),e_inner(matoms),ephot_gaunt(21,matoms),         &               
     &  e_gaunt(51,matoms),gaunt(9,51,matoms),temp_cross_atom(11,matoms)  &               
     &  ,wavel_cross_atom(101,matoms),cross_atom(101,11,matoms),          &               
     &  ephot_ff(11,matoms),temp_ff(31,matoms),gaunt_ff(7,31,matoms),     &               
     &  eimp_ro(26,26,matoms),eimp_rexp(26,26,matoms)                                     
      common/comb1/ g_atom(nlev_tot_atom,matoms),g_neq_lev_atom(23,       &               
     &  matoms),gi_atom(line_tot,matoms),g_ion(nlev_tot_atom,             &               
     &  matoms),gk_atom(line_tot,matoms),ig_gaunt(99,matoms),             &               
     &  ind_lev_atom(nlev_tot_atom,matoms),ind_lev_ion(nlev_tot_atom,     &               
     &  matoms),ind_line(line_tot,matoms),iz_atom(matoms),                &               
     &  neq_lev_atom(matoms),n_gaunt(99,matoms),ng_atom(nlev_tot_atom,    &               
     &  matoms),ng_gaunt(99,matoms),n_temp_cross_atom(matoms),            &               
     &  ngi_atom(line_tot,matoms),ngk_atom(line_tot,matoms),              &               
     &  nlev_atom(matoms),nlev_atomic_ion(matoms),nline(matoms),          &               
     &  n_temp_ff_atom(matoms),ntot_gaunt(matoms),num_exct(matoms),       &               
     &  n_wavel_cross_atom(matoms)                                                        
      character*1  dum(90)                                                                
      data asterik/'****'/,minus1/'-1  '/                                                 
!                                                                                         
      write(1,900)                                                                        
 900  format(' In atom_read')                                                             
!                                                                                         
! start counting chemical species number                                                  
      isp=0                                                                               
! read asterik line                                                                       
!                                                                                         
      read(7,10) (dum(i),i=1,80)                                                          
      write(1,10) (dum(i),i=1,80)                                                         
!                                                                                         
! read chemical species as unknown                                                        
10000 continue                                                                            
      read(7,20) unknown,(dum(i),i=1,75)  
20    format(a4,90a1)                                                                     
      write(1,20) unknown,(dum(i),i=1,75)                                                 
      if(unknown.eq.minus1) then                                                          
        write(1,*) ' Data reading finished' 
        return                                                                            
      endif                                                                               
!                                                                                         
! check if this species is required     
      check = 0                                                                           
      do i=1,matoms                                                                       
        if(unknown.eq.atomnm1(i)) then                                                    
          do j = 1,167,3 
            if(unknown.eq.atom_rads(1,j)) then
              check=1  
            end if                                     
          end do                                                                          
        end if                                                                            
      end do                                                                              
      if(check.eq.1) then                                                                 
        isp=isp+1  
        go to 130                                                                         
      endif                                                                               
!                                                                                         
! This species is not needed and skipped                                                  
      write(1,140)                                                                        
140   format(' This species is skipped'//                                 &               
     &  '************************************************************')                   
150   read(7,160) unknown                                                                 
160   format(a4)           
      if(unknown.ne.asterik) go to 150                                                    
      go to 10000                                                                         
!                                                                                         
 130  continue 
!                                                                                         
! set species name                                                                        
      atomnm(isp)=unknown                                                                 
      do j=1,5                                                                            
        read(7,10) (dum(i),i=1,90)                                                        
        write(1,10) (dum(i),i=1,90)                                                       
10      format(130a1)                                                                     
      enddo                                                                               
!                                                                                         
! prepare to read NIST energy levels of neutral species                                   
      read(7,35) atomwt(isp),(dum(i),i=1,38),                             &               
     & iz_atom(isp),(dum(i),i=39,75)  
  35  format(f12.2,38a1,i10,40a1)                                                         
30    format(f12.2,40a1)                                                                  
      write(1,35) atomwt(isp),(dum(i),i=1,38),                            &               
     & iz_atom(isp),(dum(i),i=39,75)                                                      
      read(7,30) ion_pot(isp),(dum(i),i=1,40)                                             
      write(1,30) ion_pot(isp),(dum(i),i=1,40)                                            
      read(7,40) nlev_atom(isp),(dum(i),i=1,40)                                           
40    format(i10,40a1)                                                                    
      write(1,40) nlev_atom(isp),(dum(i),i=1,40)                                          
!                                                                                         
      do j=1,3                                                                            
        read(7,10) (dum(i),i=1,90)                                                        
        write(1,10) (dum(i),i=1,90)                                                       
      enddo                                                                               
!                                                                                         
! read NIST energy levels of neutral species                                              
      do ilev=1,nlev_atom(isp)                                                            
        ind_lev_atom(ilev,isp)=ilev                                                       
        ind_lev_atom(ilev,isp) = ilev                                                     
        read(7,50) (dum(i),i=1,30),                                       &               
     &    g_atom(ilev,isp),Ecm_atom(ilev,isp),ng_atom(ilev,isp)                           
        write(1,50) (dum(i),i=1,30),                                      &               
     &    g_atom(ilev,isp),Ecm_atom(ilev,isp),ng_atom(ilev,isp)                           
50      format(30a1,i3,f13.3,i3)                                                          
      enddo                                                                               
!                                                                                         
! prepare to read NIST energy levels of ionized species                                   
      do i1=1,2                                                                           
        read(7,10) (dum(i),i=1,72)                                                        
        write(1,10) (dum(i),i=1,72)                                                       
      enddo                                                                               
      read(7,40) nlev_atomic_ion(isp), (dum(i),i=1,40)                                    
      write(1,40) nlev_atomic_ion(isp), (dum(i),i=1,40)                                   
!                                                                                         
      do i1=1,2                                                                           
        read(7,10) (dum(i),i=1,72)                                                        
        write(1,10) (dum(i),i=1,72)                                                       
      enddo                                                                               
!                                                                                         
! read NIST energy levels of ionized species                                              
      do ilev=1,nlev_atomic_ion(isp)                                                      
         ind_lev_ion(ilev,isp)=ilev                                                       
!                                                                                         
        read(7,50) (dum(i),i=1,30),                                       &               
     &    g_ion(ilev,isp),Ecm_ion(ilev,isp)                                               
        write(1,50) (dum(i),i=1,30),                                      &               
     &    g_ion(ilev,isp),Ecm_ion(ilev,isp)                                               
      enddo                                                                               
!                                                                                         
! prepare to read nonequilibrium energy levels                                            
      do i1=1,3                                                                           
        read(7,10) (dum(i),i=1,90)                                                        
        write(1,10) (dum(i),i=1,90)                                                       
      enddo                                                                               
      read(7,40) neq_lev_atom(isp), (dum(i),i=1,40)                                       
      write(1,40) neq_lev_atom(isp),(dum(i),i=1,40)                                       
      do i1=1,3                                                                           
        read(7,10) (dum(i),i=1,90)                                                        
        write(1,10) (dum(i),i=1,90)                                                       
      enddo                                                                               
!                                                                                         
! read nonequilibrium energy levels                                                       
      do ilev=1,neq_lev_atom(isp)                                                         
        read(7,60) (dum(i),i=1,10),                                       &               
     &    Ecm_neq_lev_atom(ilev,isp),g_neq_lev_atom(ilev,isp),            &               
     &    (dum(i),i=11,40)                                                                
        write(1,60) (dum(i),i=1,10),                                      &               
     &    Ecm_neq_lev_atom(ilev,isp),g_neq_lev_atom(ilev,isp),            &               
     &    (dum(i),i=11,40)                                                                
60      format(10a1,f12.2,i7,30a1)                                                        
      enddo                                                                               
!                                                                                         
! prepare to read NIST line table                                                         
      do i1=1,4                                                                           
        read(7,10) (dum(i),i=1,90)                                                        
        write(1,10) (dum(i),i=1,90)                                                       
      enddo                                                                               
      read(7,40) nline(isp),(dum(i),i=1,40)                                               
      write(1,40) nline(isp),(dum(i),i=1,40)                                              
      do i1=1,2                                                                           
        read(7,10) (dum(i),i=1,90)                                                        
        write(1,10) (dum(i),i=1,90)                                                       
      enddo                                                                               
!                                                                                         
! read lines      
      do iline=1,nline(isp) 
        read(7,70)                                                        &               
     &    ind_line(iline,isp),wavel_atom(iline,isp),aki_atom(iline,isp),  &               
     &    ei_atom(iline,isp),ek_atom(iline,isp),(dum(i),i=1,43),          &               
     &    gi_atom(iline,isp),gk_atom(iline,isp)                           &
     &    ,starkg(iline,isp),starkn(iline,isp),ngi_atom(iline,isp),       &
     &    ngk_atom(iline,isp)                       
        write(1,70)                                                       &               
     &    ind_line(iline,isp),wavel_atom(iline,isp),aki_atom(iline,isp),  &               
     &    ei_atom(iline,isp),ek_atom(iline,isp),(dum(i),i=1,43),          &               
     &    gi_atom(iline,isp),gk_atom(iline,isp)                           &
     &    ,starkg(iline,isp),starkn(iline,isp),ngi_atom(iline,isp),       &
     &    ngk_atom(iline,isp)                       
      enddo                                                                               
70    format(i4,f10.3,e9.2,2f11.3,43a1,2i4,e10.3,f6.3,2i4)                                
!                                                                                         
! bound-free continuum                                                                    
! check whether the data are given in Gaunt factors or cross sections   
      read(7,10) (dum(i),i=1,72)  
      write(1,10) (dum(i),i=1,72)                                                         
      read(7,10) (dum(i),i=1,72)                                                          
      write(1,10) (dum(i),i=1,72) 
      if(dum(27).eq.'G') go to 300    ! data given in Gaunt factors                       
      if(dum(27).eq.'c') go to 320    ! data given in cross sections                      
!                                                                                         
! data given in Gaunt factors                                                             
300   continue                                                                            
!      atom_rads(2,isp)='bG  '                                                             
      do i1=1,1                                                                           
        read(7,10) (dum(i),i=1,72)                                                        
        write(1,10) (dum(i),i=1,72)                                                       
      enddo                                                                               
      read(7,40) ntot_gaunt(isp),(dum(i),i=1,40)                                          
      write(1,40) ntot_gaunt(isp), (dum(i),i=1,40)                                        
      read(7,30) z(isp),(dum(i),i=1,40)                                                   
      write(1,30) z(isp),(dum(i),i=1,40)                                                  
      read(7,30) e_inner(isp), (dum(i),i=1,40)                                            
      write(1,30) e_inner(isp), (dum(i),i=1,40)                                           
      read(7,80) (dum(i),i=1,32), (ephot_gaunt(i,isp),i=1,9)                              
      write(1,80) (dum(i),i=1,32), (ephot_gaunt(i,isp),i=1,9)                             
80    format(32a1,9f8.4)                                                                  
      read(7,10) (dum(i),i=1,90)                                                          
      write(1,10) (dum(i),i=1,90)                                                         
!                                                                                         
      do itran=1,ntot_gaunt(isp)                                                          
        read(7,90) (dum(i),i=1,12),                                       &               
     &    ig_gaunt(itran,isp),e_gaunt(itran,isp),n_gaunt(itran,isp),      &               
     &    ng_gaunt(itran,isp),(gaunt(i,itran,isp),i=1,9)                                  
        write(1,90) (dum(i),i=1,12),                                      &               
     &    ig_gaunt(itran,isp),e_gaunt(itran,isp),n_gaunt(itran,isp),      &               
     &    ng_gaunt(itran,isp),(gaunt(i,itran,isp),i=1,9)                                  
      enddo                                                                               
90    format(12a1,i3,f10.2,2i3,9f8.4)                                                     
      go to 310                                                                           
!                                                                                         
! data given in cross sections                                                            
320   continue                                                                            
!      atom_rads(2,isp)='bc  '                                                             
      do i1=1,2                                                                           
        read(7,10) (dum(i),i=1,72)                                                        
        write(1,10) (dum(i),i=1,72)                                                       
      enddo                                                                               
                                                                                          
      read(7,330) n_temp_cross_atom(isp),(dum(i),i=1,60)                                  
330   format(i10,90a1)                                                                    
      write(1,330) n_temp_cross_atom(isp), (dum(i),i=1,60)                                
      read(7,330) n_wavel_cross_atom(isp), (dum(i),i=1,60)                                
      write(1,330) n_wavel_cross_atom(isp), (dum(i),i=1,60)                               
      read(7,10) (dum(i),i=1,79)                                                          
      write(1,10) (dum(i),i=1,79)                                                         
      read(7,340) (dum(i),i=1,11),(temp_cross_atom(it,isp),               &               
     &  it=1,n_temp_cross_atom(isp))                                                      
      write(1,340) (dum(i),i=1,11),(temp_cross_atom(it,isp),              &               
     &  it=1,n_temp_cross_atom(isp))                                                      
340   format(11a1,11f10.1)                                                                
      read(7,10) (dum(i),i=1,90)                                                          
      write(1,10) (dum(i),i=1,90)                                                         
                                                                                          
      do iwav=1,n_wavel_cross_atom(isp)                                                   
        read(7,350) wavel_cross_atom(iwav,isp),                           &               
     &    (cross_atom(iwav,it,isp),it=1,n_temp_cross_atom(isp))                           
350     format(f10.2,11e10.3)                                                             
        write(1,350) wavel_cross_atom(iwav,isp),                          &               
     &    (cross_atom(iwav,it,isp),it=1,n_temp_cross_atom(isp))                           
      end do                                                                              
310   continue                                                                            
!                                                                                         
! prepare to read free-free Gaunt factors                                                 
      do j=1,3                                                                            
        read(7,10) (dum(i),i=1,90)                                                        
        write(1,10) (dum(i),i=1,90)                                                       
      enddo                                                                               
      read(7,40) n_temp_ff_atom(isp), (dum(i),i=1,30)                                     
      write(1,40) n_temp_ff_atom(isp)                                                     
      read(7,10) (dum(i),i=1,90)                                                          
      write(1,10) (dum(i),i=1,90)                                                         
      read(7,100) (dum(i),i=1,8),(ephot_ff(i,isp),i=1,6)                                  
      write(1,100) (dum(i),i=1,8),(ephot_ff(i,isp),i=1,6)                                 
100   format(8a1,6f10.4)                                                                  
      read(7,10) (dum(i),i=1,90)                                                          
      write(1,10) (dum(i),i=1,90)                                                         
!                                                                                         
! read free-free gaunt factors                                                            
      do it=1,n_temp_ff_atom(isp)                                                         
        read(7,110) temp_ff(it,isp),(gaunt_ff(i,it,isp),i=1,6)                            
        write(1,110) temp_ff(it,isp),(gaunt_ff(i,it,isp),i=1,6)                           
      enddo                                                                               
110   format(f8.0,6f10.4)                                                                 
!                                                                                         
! prepare to read electron-impact excitation rate data                                    
      do i1=1,5                                                                           
        read(7,10) (dum(i),i=1,90)                                                        
        write(1,10) (dum(i),i=1,90)                                                       
      enddo                                                                               
      read(7,40) num_exct(isp), (dum(i),i=1,40)                                           
      write(1,40) num_exct(isp), (dum(i),i=1,40)                                          
      do j=1,2                                                                            
        read(7,10) (dum(i),i=1,90)                                                        
        write(1,10) (dum(i),i=1,90)                                                       
      enddo                                                                               
!                                                                                         
! set r0 and rexp to default value of 0                                                   
      do il=1,21                                                                          
        do iu=1,21                                                                        
          eimp_ro(il,iu,isp)=0.                                                           
          eimp_rexp(il,iu,isp)=0.                                                         
        enddo                                                                             
      enddo                                                                               
!                                                                                         
! read electron-impact excitation rate parameters                                         
      do i1=1, num_exct(isp)                                                              
        read(7,120) il1,iu1,ro1,rexp1,il2,iu2,ro2,rexp2,il3,iu3,ro3,      &               
     &    rexp3,il4,iu4,ro4,rexp4                                                         
        write(1,121) il1,iu1,ro1,rexp1,il2,iu2,ro2,rexp2,il3,iu3,ro3,     &               
     &    rexp3,il4,iu4,ro4,rexp4                                                         
120     format(4(2i3,e8.1,f5.2))                                                          
121     format(4(2i3,es8.1,f5.2))                                                         
        eimp_ro(il1,iu1,isp)=ro1                                                          
        eimp_rexp(il1,iu1,isp)=rexp1                                                      
        eimp_ro(il2,iu2,isp)=ro2                                                          
        eimp_rexp(il2,iu2,isp)=rexp2                                                      
        eimp_ro(il3,iu3,isp)=ro1                                                          
        eimp_rexp(il1,iu1,isp)=rexp3                                                      
        eimp_ro(il4,iu4,isp)=ro4                                                          
        eimp_rexp(il4,iu4,isp)=rexp4                                                      
      enddo                                                                               
      read(7,10) (dum(i),i=1,90)                                                          
      write(1,10) (dum(i),i=1,90)                                                         
!                                                                                         
      go to 10000                                                                         
!                                                                                         
      end                                                                                 
!************************************************************************************     
      subroutine audit(gamsp,nprt)                                                 
! enlarges species list by ivoking elemental conservation                                 
! input: gamsp1(i),i=1,nsp-nelem, species concentration, mol/kg                           
!        nprt=print index. 0=no print, 1=print                                            
! output: gamsp(i),i=1,nsp                                                                
      parameter(msp=60)                                                                   
      implicit real*8(a-h,o-z)                                                            
      common/eqcoma/elemwt(15),                                           &               
     & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp),            &               
     & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp),             &               
     & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp),                     &               
     & akb(5,msp),akd(5,msp),avmw0                                                        
      common/eqcomb/elemnm(12)                                                            
      common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc,  &               
     & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp),   &               
     & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp)                        
      dimension gamsp(msp),gamsp1(msp),felx(15)                                                    
      character*4 elemnm,spnm      
!
      do iel=1,nelem
        felx(iel)=0.
        do isp=1,nsp
          felx(iel)=felx(iel)+ielem(isp,iel)*gamsp(isp)*spwt(isp)
        end do
      end do
!  
      write(6,10)
   10 format(/' element (felx) conservation audit'/                         &
 &            '  iel name   elemwt       felx      felem') 
      do iel=1,nelem
        write(6,20) iel,elemnm(iel),elemwt(iel),felx(iel),felem(iel)
   20   format(i5,2x,a4,1p4e11.4)
      end do
      write(6,*) ' '
            
      return
      end                                                       
!***********************************************************************
      subroutine boltzf(wavel,camera)
! makes Boltzmann plot of Mg I lines in wavelengths 4000 to 6500 A
! input parameters:
!   wavel(nw)=wavelength 
!   camera(nw)=intensity obtained in camera, W/(cm2-mic-sr)
      parameter(nw=400000)
      implicit real*8(a-h,o-z)
      real*8 mg2(5,3),mg9(5,1),mg11(5,1),mg14(5,1)
      dimension wavel(nw),camera(nw),x(4),y(4,1),z(4,1),x1(11),y0(11),       &
 &      w(4),resid(4,1),ax(2,2),bx(2,2),sum(1),wavx(4),z0(11),               &
 &      ca1(5,1),ca2(5,1),ca3(5,1),ca4(5,1),ca5(5,1)
 
      data w/1.,1.,1.,1./
!
! Mg lines------------------------------------------------------------
!  multplet No. wavelength   ek      gk       Aki
      data mg2/                                          &
  &      2.0,    5183.60,  41197.0,  3.0,   0.561e8,     &
  &      2.0,    5172.68,  41197.0,  3.0,   0.346e8,     &
  &      2.0,    5167.32,  41197.0,  3.0,   0.116e8/
      data mg9/                                          &
  &      9.0,    5528.40,  53135.0,  5.0,   0.14e8/
      data mg11/                                         &
  &     11.0,    4702.99,  56308.0,  5.0,   0.16e8/
      data mg14/                                         &
  &     14.0,    4351.91,  58023.0,  5.0,   0.21e8/
      data w/1., 1., 1., 1./
!
! multiplet 2----------------------------------------------------------
! find peak
      m=1
   10 m=m+1
      if(wavel(m).lt.5168.) go to 10
! find peak 5183
!   20 m=m+1
!      if(camera(m).gt.camera(m-1)) go to 20
      mpk=m  
! find backward valley point mvl1
      m=1
   11 m=m+1
      if(wavel(m).lt.5161.) go to 11
      mvl1=m
! find forward valley point mvl2
      m=mpk
  121 m=m+1
      if(wavel(m).lt.5178) go to 121
      mvl2=m
! integrate from mvl1 to mvl2
!      mint=mvl2-mvl1+1
!      call simp(area2,wavel(mvl1),camera(mvl1),mint,ier)
!      area2=area2-0.5*(camera(mvl1)+camera(mvl2))*(wavel(mvl2-1)-wavel(mvl1+1))
! background
      m=1
  122 m=m+1
      if(wavel(m).lt.5159.) go to 122
      background=camera(m)
! area
      mint=mvl2-mvl1+1
      call simp(area2,wavel(mvl1),camera(mvl1),mint,ier)
      area2=area2-0.5*(camera(mfl1)+camera(mvl2))*(wavel(mvl2)-wavel(mvl1))
!      area2=area2-background*(wavel(mvl2)-wavel(mvl1))
!      area2=(camera(mpk)-background)*(wavel(mvl2)-wavel(mvl1))
! determine Boltzmann plot point
      x(1)=mg2(3,2)
      wavx(1)=mg2(2,2)
      gtot=mg2(4,2)+mg2(4,3)
      avaki=(mg2(5,2)*mg2(4,2)+mg2(5,3)*mg2(4,3))/gtot
      y(1,1)=area2/(gtot*avaki)
      z(1,1)=dlog(y(1,1))       
!
! multiplet 9------------------------------------------------------------
! find peak
      m=1
   30 m=m+1
      if(wavel(m).lt.5528.) go to 30
      mpk=m
! find backward valley point mvl1
      m=1
   31 m=m+1
      if(wavel(m).lt.5523.) go to 31
      mvl1=m
! find forward valley point mvl2
      m=1
   32 m=m+1
      if(wavel(m).lt.5533.) go to 32
      mvl2=m
! background
      m=1
   33 m=m+1
      if(wavel(m).lt.5518.) go to 33
      background=camera(m)
! integrate from mvl1 to mvl2
      mint=mvl2-mvl1+1
      call simp(area9,wavel(mvl1),camera(mvl1),mint,ier)
      area9=area9-0.5*(camera(mvl1)+camera(mvl2))*(wavel(mvl2-1)-wavel(mvl1+1))
!      area9=(camera(mpk)-background)*(wavel(mvl2)-wavel(mvl1))
! determine Boltzmann plot point
      x(2)=mg9(3,1)
      wavx(2)=mg9(2,1)
      y(2,1)=area9/(mg9(4,1)*mg9(5,1))
      z(2,1)=dlog(y(2,1))
!
! multiplet 11-------------------------------------------------------------
! find peak
      m=1
   50 m=m+1
      if(wavel(m).lt.4702.) go to 50
      mpk=m  
! find backward valley point mvl1
      m=1
   51 m=m+1
      if(wavel(m).lt.4695.) go to 51
      mvl1=m
! find forward valley point mvl2
      m=mpk+3
   52 m=m+1 
!      if(camera(m).lt.camera(m-1)) go to 52
      if(wavel(m).lt.4712.) go to 52
      mvl2=m
! integrate from mvl1 to mvl2
      mint=mvl2-mvl1+1
      call simp(area11,wavel(mvl1),camera(mvl1),mint,ier)
      area11=area11-0.5*(camera(mvl1)+camera(mvl2))*(wavel(mvl2-1)-wavel(mvl1+1))
!      background=camera(mvl1)
!      area11=(camera(mpk)-background)*(wavel(mvl2)-wavel(mvl1))
! determine Boltzmann plot point
      x(3)=mg11(3,1)
      wavx(3)=mg11(2,1)
      y(3,1)=area11/(mg11(4,1)*mg11(5,1))
      z(3,1)=dlog(y(3,1))
!
! multiplet 14---------------------------------------------------------------
! find peak
      m=1
   70 m=m+1
      if(wavel(m).lt.4351.9) go to 70
      mpk=m  
! find backward valley point mvl1
      m=1
   71 m=m+1
      if(wavel(m).lt.4348.) go to 71
      mvl1=m
! find forward valley point nvl2
      m=mpk
   72 m=m+1
      if(wavel(m).lt.4357.) go to 72
!      if(camera(m).lt.camera(m-1)) go to 72
      mvl2=m
! integrate from mvl1 to mvl2
      mint=mvl2-mvl1+1
      call simp(area14,wavel(mvl1),camera(mvl1),mint,ier)
      area14=area14-0.5*(camera(mvl1)+camera(mvl2))*(wavel(mvl2-1)-wavel(mvl1+1))
! find background
!      m=mpk
!   73 m=m+1
!      if(wavel(m).lt.4357.) go to 73
!      background=camera(m)
!      area14=(camera(mpk)-background)*(wavel(mvl2)-wavel(mvl1))
! determine Boltzmann plot point
      x(4)=mg14(3,1)
      wavx(4)=mg14(2,1)
      y(4,1)=area14/(mg14(4,1)*mg14(5,1))
      z(4,1)=dlog(y(4,1))
!
! plot the results
      write(6,110)
  110 format(/' Boltzmann plot of Mg I lines'/                          &
 &      '     E       wavel        y        log(y)')
      do i=1,4
        write(6,100) x(i),wavx(i),y(i,1),z(i,1)
      end do
!
! least-square line fit
      n=4; l=1; mm=2
      call lsqpol(x,z,w,resid,n,sum,l,ax,bx,mm)
!  y = bx(1,1) + bx(2,1)*x
      write(6,90) bx(1,1),bx(2,1)

      xlow=40000.; xhigh=60000.
   90 format(' bx(1,1)=',1pe10.3,' bx(2,1)=',e10.3/                      &
 &      ' best-fit line coordinates'/                                    &
 &      '     E          y        log(y)')
      do i=1,11
        x1(i)=xlow+(xhigh-xlow)*0.1*(i-1)
        y0(i)=bx(1,1)+bx(2,1)*x1(i)
        z0(i)=dexp(y0(i))
!        y1=dexp(y0(i))
        write(6,101) x1(i),y0(i),z0(i)
 100    format(f10.0,f10.1p2e11.3)
 101    format(f10.0,1p2e11.3)
      end do    
!
! Boltzmann temperature
      slope=(y0(11)-y0(1))/(x1(11)-x1(1))
      temp=-1.43877/slope 
      write(6,120) temp
  120 format(' Boltzmann fit temperature =',f10.1)
           
      return  
      end  
!***********************************************************************
      subroutine boltzf1(wavel,int)
! makes Boltzmann plot of Fe I lines in wavelengths 4000 to 6500 A
! input parameters:
!   wavel(nw)=wavelength
!   int(nw)=intensity, any units
      parameter(nw=400000)
      implicit real*8(a-h,o-z)
      dimension wavel(nw),int(nw)
      dimension fedat(5,27),wavelc(27),ek(27),gk(27),aki(27),y(27),        &
  &     logy(27,1),area(27),w(27),x1(25),y0(25),teny0(25),ax(2,2),bx(2,1), &
  &     resid(27,1),sum(1)
      real*8 int,logy
      data w/27*1.0/
!
! Fe lines------------------------------------------------------------
!         No.   wavel      ek      gk      Aki
      data Fedat/                                       & ! Fedat(5,27)
         1.0,  6136.62,  36079.4,  7.0,  1.01e6,        &
         2.0,  6230.72,  36686.2,  9.0,  9.99e5,        &  
         3.0,  6065.48,  37521.2,  5.0,  1.07e6,        &
         4.0,  5049.82,  38175.4,  7.0,  1.65e6,        &
         5.0,  4352.73,  40895.0,  5.0,  3.63e6,        &
         6.0,  4957.60,  42815.9, 13.0,  4.22e7,        &
         7.0,  5139.25,  43633.5,  5.0,  8.86e6,        &
         8.0,  4918.99,  43434.6,  7.0,  1.79e7,        &
         9.0,  5192.34,  43434.6,  7.0,  1.34e7,        &
        10.0,  4903.31,  43633.5,  5.0,  6.58e6,        &
        11.0,  4871.32,  43633.5,  5.0,  2.44e7,        &
        12.0,  5339.93,  45061.3,  7.0,  6.36e6,        &
        13.0,  6246.32,  45061.3,  7.0,  3.24e6,        &
        14.0,  6301.50,  45333.9,  5.0,  6.43e6,        &
        15.0,  6301.50,  45333.9,  5.0,  6.43e6,        &
        16.0,  6336.82,  45509.2,  3.0,  7.71e6,        &
        17.0,  4351.54,  47092.7,  7.0,  9.39e5,        &
        18.0,  4667.45,  50475.3,  9.0,  6.03e6,        &
        19.0,  5476.56,  51350.5,  9.0,  8.70e6,        &
        20.0,  5731.76,  51770.6,  7.0,  1.60e6,        &
        21.0,  5543.94,  52049.8,  5.0,  3.40e6,        &
        22.0,  5383.37,  53353.0,  1.0,  7.81e7,        &
        23.0,  5816.37,  53874.3,  1.0,  4.49e6,        &
        24.0,  6079.01,  53966.7,  5.0,  2.90e6,        &
        25.0,  5806.73,  54379.4,  7.0,  2.70e6,        &
        26.0,  5927.79,  54386.2,  3.0,  5.40e6,        &
        27.0,  5905.67,  54449.3,  3.0,  1.10e7/

! cycle over lines
      do il=1,27
        wavelc(il)=fedat(2,il)
        ek(il)=fedat(3,il)
        gk(il)=fedat(4,il)
        aki(il)=fedat(5,il)
        
! find line center
        m=1
   10   m=m+1
        if(wavel(m).lt.wavelc(il)) go to 10
        mpk=m               ! peak point
! find backward valley point
        m=mpk-5
   20   m=m-1
        if(int(m).gt.int(m-2)) go to 20
        mvl1=m              ! backward valley point
        if(il.eq.5) then
          m=1
   43     m=m+1
          if(wavel(m).lt.4348.) go to 43
          mvl1=m
        end if
        if(il.eq.6) then
          m=1
   21     m=m+1
          if(wavel(m).lt.4933.) go to 21
          mvl1=m
        end if
        if(il.eq.23) then
          m=1
   35     m=m+1
          if(wavel(m).lt.5812.) go to 35
          mvl1=m
        end if
        if(il.eq.25) then
          m=1
   36     m=m+1
          if(wavel(m).lt.5801.) go to 36
          mvl1=m
        end if
! find forward valley point
        m=mpk+5
   30   m=m+1
        if(int(m).lt.int(m-2)) go to 30
        mvl2=m              ! forward valley point
        if(il.eq.1) then
          m=mpk+2
   31     m=m+1
          if(wavel(m).lt.6144.) go to 31
          mvl2=m
        end if
        if(il.eq.6) then
          m=mpk
   32     m=m+1
          if(wavel(m).lt.4976.) go to 32
          mvl2=m
        end if
        if(il.eq.17) then
          m=1
   33     m=m+1
          if(wavel(m).lt.4357.) go to 33
          mvl2=m
        end if
        if(il.eq.18) then
          m=1
   34     m=m+1
          if(wavel(m).lt.4674.) go to 34
          mvl2=m
        end if
! write out the information
        write(6,40) fedat(1,il),wavel(mvl1),int(mvl1),wavel(mpk),int(mpk),  &
  &       wavel(mvl2),int(mvl2)
   40   format(/                                                    &
  &       ' line number                 =',  f10.1/                 &
  &       ' backward valley point: wavel=',  f10.2,' int=',1pe10.3/ &
  &       ' peak point:            wavel=',0pf10.2,' int=',1pe10.3/ &
  &       ' forward valley point:  wavel=',0pf10.2,' int=',1pe10.3)
!
! area under the curve        
        intvl=mvl2-mvl1+1
        call simp(area(il),wavel(mvl1),int(mvl1),intvl,ier)
        write(6,100) wavelc(il),ier
   100  format(' wavelc=',f10.3,' ier=',i2)
! plotting parameter
        htsmall=int(mvl1)
        if(int(mvl2).lt.htsmall) htsmall=int(mvl2)
        defic=0.5*(int(mvl1)+int(mvl2))*(wavel(mvl2)-wavel(mvl1))
        if(il.eq.12) defic=0.
        areax=area(il)-defic
        if((areax.lt.0.).or.(il.eq.1)) then
          defic=htsmall*(wavel(mvl2)-wavel(mvl1))
          if(il.eq.12) defic=0.
          areax=area(il)-defic
        end if
        if(il.eq.6) then
          m=1
  101     m=m+1
          if(wavel(m).lt.4908.) go to 101
          htsmall=int(m)
          defic=htsmall*(wavel(mvl2)-wavel(mvl1))
          areax=area(il)-defic
        end if
        area(il)=areax
        y(il)=area(il)/(gk(il)*aki(il))
        logy(il,1)=dlog(y(il))
      end do
!
! plot the results
      write(6,50)
   50 format(/' Boltzmann plot of Fe I lines'/                          &
 &      ' No.      E         wavel      area         y       log(y)')
      do il=1,27
        write(6,60) il,ek(il),wavelc(il),area(il),y(il),logy(il,1)
   60   format(i5,f11.1,f11.2,1p4e11.3)
      end do
!
! least-square line fit
      n=27; l=1; mm=2
      call lsqpol(ek,logy,w,resid,n,sum,l,ax,bx,mm)
!  y = bx(1,1) + bx(2,1)*x
      write(6,70) bx(1,1),bx(2,1)
      xlow=30000.; xhigh=55000.
   70 format(' bx(1,1)=',1pe10.3,' bx(2,1)=',e10.3/                      &
 &      ' best-fit line coordinates'/                                    &
 &      '     E        exp(y)         y ')    
      do i=1,21
        x1(i)=xlow+(xhigh-xlow)*0.05*(i-1)
        y0(i)=bx(1,1)+bx(2,1)*x1(i)
        teny0(i)=dexp(y0(i))
!        y1=dexp(y0(i))
!        write(6,80) x1(i),y0(i),teny0(i)
        write(6,80) x1(i),teny0(i),y0(i)
   80    format(f10.0,1pe11.3,0pf11.4)
      end do    
!
! Boltzmann temperature
      slope=(y0(11)-y0(1))/(x1(11)-x1(1))
      temp=-1.43877/slope 
      write(6,90) temp
   90 format(' Boltzmann fit temperature =',f10.1)

      return
      end
!**************************************************************************
      subroutine calc(nwave,ndm,tx,rhoinf,vinf,pres,tw,rnose,temps,rhos,            &
  &     enths,delta,delH,spallf,nout,nim,facout1,facin1,facout2,facin2,famdot,      &
  &     enfac,sigma,iout1,im1)
! calculation of radiative transfer through shock layer and ablation-product layer
! input parameters
!   nwave=number of wavelength points
!   ndm=number of spatial node points, must be an even number
!   tx(ndm)=temperature, K
!   rhoinf=freestream density, kg/m3
!   vinf=flight speed-freestream velocity, m/s
!   pres=stagnation point pressure, Pascal
!   tw=wall temperature, K
!   rnose=nose radius, m
!   temps=stagnation point gas temperature, K
!   rhos=stagnation point density, kg/m3
!   enths=stagnation point enthalpy, J/kg
!   delta=shock stand-off distance, m
!   delH=ablation energy, J/kg
!   nout=allowed number of iteration for air shock layer in one sweep
!   nim=allowed number of iteration for ablation-product vapor in one sweep
!   facout1=fraction by which an old solution is modified by the new solution
!     for air shock layer in the first two sweeps
!   facin1=fraction by which an old solution is modified by the new solution
!     for ablation product layer in the first two sweeps
!   facout2=fraction by which an old solution is modified by the new solution
!     for air shock layer in the late two sweeps
!   facin2=fraction by which an old solution is modified by the new solution
!     for ablation production layer in the later two sweeps
!   famdot=fraction by which an old ablation rate is modified by the new ablation
!     rate value
!   enfac=enthalpy entering shock wave divided by 0.5*vinf*vinf
!   sigma=wall emissivity
! output parameters
!   iout1=beginning index for air outer layer calc in the 3rd sweep
!   im1=beginning index for ablation-product layer calc in the 3rd sweep
! output parameters
!   tx(idm)
!   enth(idm)
      parameter (nw=400000)
      implicit real*8(a-h,o-z)
      character*4 dum(41)
      common/qpqm/qp(802),qm(802),int_s(10,nw),ang(11),sin2(11),                    &
  &     int_cam(nw)
      dimension tx(802),qpa(802),int_prec(nw),flx(nw),flx_prec(nw)
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),      &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e,int_old,int_prec,int_s,int_cam,int_abl
      common/comcalc/beta(802),rhoa(802),rhorat(802),rhovrat(802),y(802),           &
   &    enth(802),enth3(802),amdot(0:441)
      dimension dqdy(802),int_old(10,nw),f(802),fp(802),ax(4,4),rhs(4,2),           &
   &    sum(2),axy(3,3),rhsy(3,2),dtdy(802)
      save
!
      ndm1=ndm/2
      ndm2=ndm1+1
      ndm3=ndm1-1
      dusdr=vinf/rnose
      rootpi=sqrt(3.141592)
      flow_in=rhoinf*vinf
      enflo_in=rhoinf*vinf*enths
!
! first approximation of beta and rhovrat in the outer layer
      beta(ndm2)=0.
      rhoa(ndm2)=rhos
      do inode=ndm2,ndm
        beta(inode)=beta(ndm2)+delta*(inode-ndm2)/ndm3
      end do
      tempi=0.8*temps       ! 0.8
      enthi=0.8*enths       ! 0.8
      do inode=ndm2,ndm
        tx(inode)=tempi+(temps-tempi)*(float(inode-ndm2)/float(ndm3))
        rhoa(inode)=rhos
        enth(inode)=enthi+(enths-enthi)*(inode-ndm2)/float(ndm3)
        rhorat(inode)=1.
        b1=dsqrt(2.*rhoinf/rhoa(ndm2))
        b2=b1-(1.-b1)*beta(ndm2)/(beta(ndm)-beta(ndm2))
        b3=0.5*(1.-b1)/(beta(ndm)-beta(ndm2))
        b4=b2*(beta(ndm)-beta(ndm2))+b3*(beta(ndm)**2-beta(ndm2)**2)
        rhovrat(inode)=(b2*(beta(inode)-beta(ndm2))+b3*(beta(inode)**2                &
   &      -beta(ndm2)**2))/b4
      end do
      y(ndm2)=0.
      do inode=ndm2+1,ndm
        rhoav=0.5*(rhoa(inode-1)+rhoa(inode))
        y(inode)=y(inode-1)+(rhos/rhoav)*(beta(inode)-beta(inode-1))
      end do
      enth(ndm)=enths
!
! very first time. assume interface intensity to be black body intensity at wall temperature
      do iw=1,nw
        ax1=dexp(-1.43877d0*1.0d8/(wavel(iw)*tw))
        do iang=1,10
          if(spallf.gt.1.0e-6) then
            intw(iang,iw)=1.1904d-16*ax1/((1.0d-8*wavel(iw))**5*(1.d0-ax1))   ! W/(cm2-mic-sr)
            int_e(iang,iw)=intw(iang,iw)
          end if
          if(spallf.le.1.0e-6) then
            intw(iang,iw)=0.; int_e(iang,iw)=0.
          end if
        end do
      end do
      call slope(ndm1,y(ndm2),tx(ndm2), dtdy(ndm2))
!
! iteration on outer layer profile iout begins---------------------------
      do iout=iout1,iout1+nout-1        
        call flux_outer(nwave,ndm,iout,nout,rhoinf,rnose,vinf,y,beta,tx,dtdy,         &
   &      int_old, dqdy,qps) 
!
! change enthalpy
        ndm4=0.2*ndm1+ndm1
        ndm5=0.4*ndm1+ndm1
        ndm6=0.6*ndm1+ndm1
        ndm7=0.8*ndm1+ndm1
        fenth1=facout1
        do idm=ndm-1,ndm4,-1
          dely=(y(idm+1)-y(idm))
          rhovrat_av=0.5*(rhovrat(idm)+rhovrat(idm+1))
          dqdy_av=dqdy(idm+1)-dqdy(idm)
          enth(idm)=fenth1*(enth(idm+1)-(dqdy_av/(rhoinf*vinf))*(1./rhovrat_av)*dely) &
  &         +(1.-fenth1)*enth(idm)
        end do
        y1=y(ndm)-y(ndm4); y2=y(ndm)-y(ndm5); y3=y(ndm)-y(ndm6); y4=y(ndm)-y(ndm7)
        h1=enth(ndm4)-enth(ndm); h2=enth(ndm5)-enth(ndm); h3=enth(ndm6)-enth(ndm)
          h4=enth(ndm7)-enth(ndm)
        ax(1,1)=y1; ax(1,2)=y1**2; ax(1,3)=y1**3; ax(1,4)=y1**4; rhs(1,1)=h1
        ax(2,1)=y2; ax(2,2)=y2**2; ax(2,3)=y2**3; ax(2,4)=y2**4; rhs(2,1)=h2
        ax(3,1)=y3; ax(3,2)=y3**2; ax(3,3)=y3**3; ax(3,4)=y3**4; rhs(3,1)=h3
        ax(4,1)=y4; ax(4,2)=y4**2; ax(4,3)=y4**3; ax(4,4)=y4**4; rhs(4,1)=h4
        call minv(ax,4,4,rhs,1,determ)
        a1=rhs(1,1); a2=rhs(2,1); a3=rhs(3,1); a4=rhs(4,1)
! construct enthalpy and temperature
        fac=facout1
        do idm=ndm2,ndm
          enthx=enths+a1*(y(ndm)-y(idm))+a2*(y(ndm)-y(idm))**2+a3*(y(ndm)-y(idm))**3  &
  &         +a4*(y(ndm)-y(idm))**4
          enth(idm)=enthx
          enth3(idm)=enth(idm)
!          enth(idm)=(1.-fac)*enth(idm)+fac*enthx
          call pH_air(1,pres,enth(idm), rhoa(idm),tx(idm))
        end do
! mass and energy out flow rates
        flow_air=0.
        enflo_air=0.
        b1=dsqrt(2.*rhoinf/rhoa(ndm2))
        do inode=ndm2+1,ndm
          rhobyrhos=rhoa(inode)/rhoa(ndm)
          ubyus=b1+(1.-b1)*(beta(inode)-beta(ndm2))/(beta(ndm)-beta(ndm2))
          flow_air=flow_air+rhobyrhos*ubyus*(y(inode)-y(inode-1))
          enflo_air=enflo_air+rhobyrhos*ubyus*enth(inode)*(y(inode)-y(inode-1))
        end do
        flow_air=flow_air*2.*rhoa(ndm)*vinf/rnose
        enflo_air=enflo_air*2.*rhoa(ndm)*vinf/rnose
        write(6,10) iout,enth(ndm2),tx(ndm2),flow_in,enflo_in,flow_air,enflo_air
        write(*,10) iout,enth(ndm2),tx(ndm2),flow_in,enflo_in,flow_air,enflo_air
   10   format(/' iout =',i3/                                                         &
 &        ' enth(ndm2)  =',1pe10.3,' tx(ndm2)        =',e10.3/                        &
 &        ' rhoinf*vinf =',1pe10.3,' 0.5*vinf*vinf**3=',e10.3/                        &
 &        ' flow_air    =',e10.3,  ' enflo_air       =',e10.3)
!
! rescale beta
        deltax=beta(ndm)-beta(ndm2)
        ratio=flow_in/flow_air
        deltax=deltax*ratio
        do inode=ndm2,ndm
          beta(inode)=0.5*(beta(ndm2)+deltax*(inode-ndm2)/ndm3)+                      &
 &          0.5*beta(inode)
        end do
        y(ndm2)=0.
        do inode=ndm2+1,ndm
          rhoav=0.5*(rhoa(inode-1)+rhoa(inode))
          y(inode)=y(inode-1)+(rhos/rhoav)*(beta(inode)-beta(inode-1))
        end do
        write(12,80) iout,flow_air
   80   format(i6,1pe10.3)
      end do
!
      write(*,37) qm(ndm2)
  37  format(/' radiative heat flux crossing interface=',1pe10.3)
      if(spallf.lt.1.0e-6) return
!
! inner layer------------------------------------------------------------------------
!
! first approximation of temperature
      txndm2=0.5*(tw+tx(ndm2))
      do inode=i,ndm1
        tx(inode)=tw+(txndm2-tw)*float(inode-1)/float(ndm3)
      end do
!
! iterate over ablation rate
      qm(ndm1)=qm(ndm2)
      amdot(0)=0.5*qm(ndm2)/delH
      amdot(1)=0.5*qm(ndm2)/delH
      do im=im1,im1+nim-1
        write(6,*) ' '
        write(*,*) ' '
        write(6,*) ' im=',im
        write(*,*) ' im=',im
        if(im.eq.1) then
          do inode=1,ndm1
            call pT_ivu(1,pres,tx(inode), rhoa(inode),enth(inode),cp)
          end do
        end if
        enthw=enth(1)
!
        do inode=1,ndm1
          rhorat(inode)=rhoa(ndm1)/rhoa(inode)
        end do
        rhoe=rhoa(ndm1)
        rhorw=rhoa(ndm1)/rhoa(1)
        call ffp5(ndm,rhoinf,vinf,rnose,rhorat,amdot(im-1),rhos,rhoe,                     &
    &     beta,f,fp,betae,fw)
         do inode=1,ndm1
          rhovrat(inode)=(f(inode)/f(1))*amdot(im-1)/(rhoinf*vinf)
        end do
        duedr=(vinf/rnose)*dsqrt(2.*rhoinf/rhoa(ndm1))
        y(1)=0.
        do inode=2,ndm1
          rhoav=0.5*(rhoa(inode-1)+rhoa(inode))
          y(inode)=y(inode-1)+(rhoa(ndm1)/rhoav)*(beta(inode)-beta(inode-1))
        end do

        flow=0.
        aint=0.
        do inode=2,ndm1 
          rhoav=0.5*(rhoa(inode-1)+rhoa(inode))
          rhorat_av=0.5*(rhorat(inode-1)+rhorat(inode))
          enthav=0.5*(enth(inode-1)+enth(inode))
          fpav=0.5*(fp(inode-1)+fp(inode))
          dely=y(inode)-y(inode-1)
          flow=flow+2.*rhoe*duedr*rhorat_av*fpav*dely
          aint=aint+2.*rhoav*duedr*(enthav-enthw)*fpav*dely
        end do
        entot=qm(1)-qp(1)+aint
!
! radiation
        call slope(ndm1,y,tx, dtdy)
        call flux_inner(nwave,ndm,im,nim,y,beta,tx,dtdy,sigma,int_old,         &
   &      dqdy)
        dqdy(ndm1-1)=0.5*dqdy(ndm1-2)
        amdot(im)=(1.-famdot)*amdot(im-1)+famdot*(qm(im)-qp(im))/delh
        nimx=im+1
!
! change enthalpy
!
! determine 1/4, 1/2, 3/4 points
        ndm4=0; ndm5=0; ndm6=0
        do idm=1,ndm1
          if(y(idm).gt.0.25*y(ndm1)) then; ndm4=idm; go to 881; end if
        end do
 881    do idm=1,ndm1
          if(y(idm).gt.0.50*y(ndm1)) then; ndm5=idm; go to 882; end if
        end do
 882    do idm=1,ndm1
          if(y(idm).gt.0.75*y(ndm1)) then; ndm6=idm; go to 883; end if
        end do
 883    continue
        fac=im*facin1/10.
        if(fac.gt.facin1) fac=facin1
        do idm=2,ndm6
          dely=y(idm)-y(idm-1)
          rhovrat_av=0.5*(rhovrat(idm)+rhovrat(idm-1))
          dqdy_av=dqdy(idm)-dqdy(idm-1)
          enth(idm)=fac*(enth(idm-1)+(dqdy_av/(rhoinf*vinf))                   &
 &          *(1./rhovrat_av)*dely) + (1.-fac)*enth(idm)       
          call pH_ivu(1,pres,enth(idm), rhoax,tx(idm))
        end do
!
        y1=y(1); y2=y(ndm4); y3=y(ndm5); y4=y(ndm6)
        t1=tw; t2=tx(ndm4); t3=tx(ndm5); t4=tx(ndm6)
        ax(1,1)=1.; ax(1,2)=y1; ax(1,3)=y1**2; ax(1,4)=y1**3; rhs(1,1)=t1
        ax(2,1)=1.; ax(2,2)=y2; ax(2,3)=y2**2; ax(2,4)=y2**3; rhs(2,1)=t2
        ax(3,1)=1.; ax(3,2)=y3; ax(3,3)=y3**2; ax(3,4)=y3**3; rhs(3,1)=t3
        ax(4,1)=1.; ax(4,2)=y4; ax(4,3)=y4**2; ax(4,4)=y4**3; rhs(4,1)=t4
        call minv(ax,4,4,rhs,1,determ)
        ti=rhs(1,1); a1=rhs(2,1); a2=rhs(3,1); a3=rhs(4,1)
        do idm=1,ndm1
          tx(idm)=tw+a1*y(idm)+a2*y(idm)**2+a3*y(idm)**3  
        end do
        write(6,20) beta(ndm1),y(ndm1),tx(ndm2),tx(ndm1),amdot(im),                     &
 &        flow,qm(ndm1),entot,qm(1),aint
        write(*,20) beta(ndm1),y(ndm1),tx(ndm2),tx(ndm1),amdot(im),                     &
 &        flow,qm(ndm1),entot,qm(1),aint
    20  format(                                                                         &
 &        ' beta(ndm1)=',1pe10.3,' y(ndm1) =',e10.3/                                    &
 &        ' tx(ndm2)  =',0pf10.1,' tx(ndm1)=',1pe10.3/                                  &
 &        ' amdot     =',1pe10.3,' flow    =',e10.3/                                    &
 &        ' qm(ndm1)  =',e10.3,  ' entot   =',e10.3/                                    &
 &        ' qm(1)     =',e10.3,  ' aint    =',e10.3  )

        write(20,17) im,facin2
        write(20,18) (tx(i),i=1,ndm1)
        write(13,90) im,amdot(im)
   90   format(i6,1pe10.3)
      end do
!
! reevaluate-------------------------------------------------------------
!
! outer layer------------------------------------------------------------
!
! intensity sent from inner layer to outer layer across interface
!
! iteration on outer layer profile iout begins---------------------------
      enth(ndm)=enths
      flow_in=rhoinf*vinf
      enflo_in=0.5*rhoinf*vinf**3
      qp(ndm2)=qp(ndm1)
      do iout=iout1+nout,iout1+2*nout-1
        do iw=1,nw
          do iang=1,10
          int_old(iang,iw)=int_e(iang,iw)
          end do
        end do
        call slope(ndm1,y(ndm2),tx(ndm2), dtdy(ndm2))
        do iw=1,nw
          do iang=1,10
            int_old(iang,nw)=int_e(iang,nw)
          end do
        end do
        call flux_outer(nwave,ndm,iout,nout,rhoinf,rnose,vinf,y,beta,tx,dtdy,         &
   &      int_old, dqdy,qps) 
 
 ! change enthalpy
        ndm4=0.2*ndm1+ndm1
        ndm5=0.4*ndm1+ndm1
        ndm6=0.6*ndm1+ndm1
        ndm7=0.8*ndm1+ndm1
        fac=facout2
        do idm=ndm-1,ndm4,-1
          dely=y(idm+1)-y(idm)
          rhovrat_av=0.5*(rhovrat(idm)+rhovrat(idm+1))
          dqdy_av=dqdy(idm+1)-dqdy(idm)
          enth(idm)=fac*(enth(idm+1)-(dqdy_av/(rhoinf*vinf))*(1./rhovrat_av)*dely)     &
  &         +(1.-fac)*enth(idm)
        end do
        y1=y(ndm)-y(ndm4); y2=y(ndm)-y(ndm5); y3=y(ndm)-y(ndm6); y4=y(ndm)-y(ndm7)
        h1=enth(ndm4)-enth(ndm); h2=enth(ndm5)-enth(ndm); h3=enth(ndm6)-enth(ndm)
          h4=enth(ndm7)-enth(ndm)
        ax(1,1)=y1; ax(1,2)=y1**2; ax(1,3)=y1**3; ax(1,4)=y1**4; rhs(1,1)=h1
        ax(2,1)=y2; ax(2,2)=y2**2; ax(2,3)=y2**3; ax(2,4)=y2**4; rhs(2,1)=h2
        ax(3,1)=y3; ax(3,2)=y3**2; ax(3,3)=y3**3; ax(3,4)=y3**4; rhs(3,1)=h3
        ax(4,1)=y4; ax(4,2)=y4**2; ax(4,3)=y4**3; ax(4,4)=y4**4; rhs(4,1)=h4
        call minv(ax,4,4,rhs,1,determ)
        a1=rhs(1,1); a2=rhs(2,1); a3=rhs(3,1); a4=rhs(4,1)
! construct enthalpy and temperature
        do idm=ndm2,ndm
          enthx=enths+a1*(y(ndm)-y(idm))+a2*(y(ndm)-y(idm))**2+a3*(y(ndm)-y(idm))**3    &
  &         +a4*(y(ndm)-y(idm))**4
          enth(idm)=enthx
          enth(idm)=(1.-fenth2)*enth3(idm)+fenth2*enthx
          enth3(idm)=enth(idm)
          call pH_air(1,pres,enth(idm), rhoa(idm),tx(idm))
        end do

! mass and energy out flow rates
        flow_air=0.
        enflo_air=0.
        b1=dsqrt(2.*rhoinf/rhoa(ndm2))
        do inode=ndm2+1,ndm
          rhobyrhos=rhoa(inode)/rhoa(ndm)
          ubyus=b1+(1.-b1)*(beta(inode)-beta(ndm2))/(beta(ndm)-beta(ndm2))
          flow_air=flow_air+rhobyrhos*ubyus*(y(inode)-y(inode-1))
          enflo_air=enflo_air+rhobyrhos*ubyus*enth(inode)*(y(inode)-y(inode-1))
        end do
        flow_air=flow_air*2.*rhoa(ndm)*vinf/rnose
        enflo_air=enflo_air*2.*rhoa(ndm)*vinf/rnose
        write(6,10) iout,enth(ndm2),tx(ndm2),flow_in,enflo_in,flow_air,enflo_air
        write(*,10) iout,enth(ndm2),tx(ndm2),flow_in,enflo_in,flow_air,enflo_air
! rescale beta
        deltax=beta(ndm)-beta(ndm2)
        ratio=flow_in/flow_air
        deltax=deltax*ratio
        do inode=ndm2,ndm
          beta(inode)=0.5*(beta(ndm2)+deltax*(inode-ndm2)/ndm3)+                        &
 &          0.5*beta(inode)
        end do
        y(ndm2)=0.
        do inode=ndm2+1,ndm
          rhoav=0.5*(rhoa(inode-1)+rhoa(inode))
          y(inode)=y(inode-1)+(rhos/rhoav)*(beta(inode)-beta(inode-1))
        end do
        write(12,80) iout,flow_air
      end do
!
      write(6,*) ' '
      write(*,*) ' '
      write(6,16) qm(ndm2)
      write(*,16) qm(ndm2)
  16  format(' qm at interface=',1pe11.4,' W/m2')      
!
! inner layer again-----------------------------------------------------------------
!
! iterate over ablation rate
      qm(ndm1)=qm(ndm2)
      do im=im1+nim,im1+2*nim-1
 
        write(6,*) ' '
        write(6,*) ' im=',im
        write(*,*) ' '
        write(*,*) ' im=',im
        if(im.eq.nim+1) then
          do inode=1,ndm1
            call pT_ivu(1,pres,tx(inode), rhoa(inode),enth(inode),cp)
          end do
        end if
        do inode=1,ndm1
          rhorat(inode)=rhoa(ndm1)/rhoa(inode)
        end do
        rhoe=rhoa(ndm1)
        rhorw=rhoa(ndm1)/rhoa(1)
!
        call ffp5(ndm,rhoinf,vinf,rnose,rhorat,amdot(im-1),rhos,rhoe,            &
    &     beta,f,fp,betae,fw)
        do inode=1,ndm1
          rhovrat(inode)=(f(inode)/f(1))*amdot(im-1)/(rhoinf*vinf)
        end do
        duedr=(vinf/rnose)*dsqrt(2.*rhoinf/rhoa(ndm1))
        y(1)=0.
        do inode=2,ndm1
          rhoav=0.5*(rhoa(inode-1)+rhoa(inode))
          y(inode)=y(inode-1)+(rhoa(ndm1)/rhoav)*(beta(inode)-beta(inode-1))
        end do

        flow=0.
        aint=0.
        do inode=2,ndm1 
          rhoav=0.5*(rhoa(inode-1)+rhoa(inode))
          rhorat_av=0.5*(rhorat(inode-1)+rhorat(inode))
          enthav=0.5*(enth(inode-1)+enth(inode))
          fpav=0.5*(fp(inode-1)+fp(inode))
          dely=y(inode)-y(inode-1)
          flow=flow+2.*rhoe*duedr*rhorat_av*fpav*dely
          aint=aint+2.*rhoav*duedr*(enthav-enthw)*fpav*dely
        end do
        entot=qm(1)-qp(1)+aint

! radiation
        call slope(ndm1,y,tx, dtdy)
        call flux_inner(nwave,ndm,im,nim,y,beta,tx,dtdy,sigma,int_old,         &
   &       dqdy)
        dqdy(ndm1-1)=0.5*dqdy(ndm1-2)+dqdy(ndm1)
        amdot(im)=(1.-famdot)*amdot(im-1)+famdot*(qm(1)-qp(1))/delH
        call ffp5(ndm,rhoinf,vinf,rnose,rhorat,amdot(im),rhos,rhoe,                     &
    &     beta,f,fp,betae,fw)
!
! change enthalpy
!
! determine 1/4, 1/2, 3/4 points
        ndm4=0; ndm5=0; ndm6=0
        do idm=1,ndm1
          if(y(idm).gt.0.25*y(ndm1)) then; ndm4=idm; go to 781; end if
        end do
 781    do idm=1,ndm1
          if(y(idm).gt.0.50*y(ndm1)) then; ndm5=idm; go to 782; end if
        end do
 782    do idm=1,ndm1
          if(y(idm).gt.0.75*y(ndm1)) then; ndm6=idm; go to 783; end if
        end do
 783    continue
 
        fac=facin2
        do idm=2,ndm6
          dely=y(idm)-y(idm-1)
          rhovrat_av=0.5*(rhovrat(idm)+rhovrat(idm-1))
          dqdy_av=dqdy(idm)-dqdy(idm-1)
          enth(idm)=fac*(enth(idm-1)+(dqdy_av/(rhoinf*vinf))                          &
 &          *(1./rhovrat_av)*dely) + (1.-fac)*enth(idm)
          call pH_ivu(1,pres,enth(idm), rhoax,tx(idm))
        end do
!
        y1=y(1); y2=y(ndm4); y3=y(ndm5); y4=y(ndm6)
        t1=tw; t2=tx(ndm4); t3=tx(ndm5); t4=tx(ndm6)
        ax(1,1)=1.; ax(1,2)=y1; ax(1,3)=y1**2; ax(1,4)=y1**3; rhs(1,1)=t1
        ax(2,1)=1.; ax(2,2)=y2; ax(2,3)=y2**2; ax(2,4)=y2**3; rhs(2,1)=t2
        ax(3,1)=1.; ax(3,2)=y3; ax(3,3)=y3**2; ax(3,4)=y3**3; rhs(3,1)=t3
        ax(4,1)=1.; ax(4,2)=y4; ax(4,3)=y4**2; ax(4,4)=y4**3; rhs(4,1)=t4
        call minv(ax,4,4,rhs,1,determ)
        ti=rhs(1,1); a2=rhs(2,1); a3=rhs(3,1); a4=rhs(4,1)
        do idm=1,ndm1
          tx(idm)=ti+a2*y(idm)+a3*y(idm)**2+a4*y(idm)**3
        end do

        write(6,20) beta(ndm1),y(ndm1),tx(ndm2),tx(ndm1),amdot(im),                     &
 &        flow,qm(ndm1),entot,qm(1),aint
        write(*,20) beta(ndm1),y(ndm1),tx(ndm2),tx(ndm1),amdot(im),                     &
 &        flow,qm(ndm1),entot,qm(1),aint

        write(20,17) im,facin2
   17   format(/' tx at end of im=',i3,' facin2=',f8.4)
        write(20,18) (tx(i),i=1,ndm1)
   18   format(10f8.1)
        write(13,90) im,amdot(im)
      end do 
      amdot_av=0.5*(amdot(2*nim)+amdot(2*nim-1))
!
      return
      end
!**************************************************************************
      subroutine calc1(nwave,ndm,tx,rhoinf,vinf,pres,tw,rnose,temps,rhos,               &
  &     enths,delta,delH,nout,nim,facout1,facin1,facout2,facin2,famdot,                 &
  &     sigma,hwhh,iout1,im1, amdot_out,delta1,dmix,qps)
!
! input parameters
!   nwave=number of wavelength points
!   ndm=number of spatial node points, must be an even number
!   tx(ndm)=temperature, K
!   rhoinf=freestream density, kg/m3
!   vinf=flight speed-freestream velocity, m/s
!   pres=stagnation point pressure, Pascal
!   tw=wall temperature, K
!   rnose=nose radius, m
!   temps=stagnation point gas temperature, K
!   rhos=stagnation point density, kg/m3
!   enths=stagnation point enthalpy, J/kg
!   delta=shock stand-off distance, m
!   delH=ablation energy, J/kg
!   nout=allowed number of iteration for air shock layer in one sweep
!   nim=allowed number of iteration for ablation-product vapor in one sweep
!   facout1=fraction by which an old solution is modified by the new solution
!     for air shock layer in the first two sweeps
!   facin1=fraction by which an old solution is modified by the new solution
!     for ablation product layer in the first two sweeps
!   facout2=fraction by which an old solution is modified by the new solution
!     for air shock layer in the late two sweeps
!   facin2=fraction by which an old solution is modified by the new solution
!     for ablation production layer in the later two sweeps
!   famdot=fraction by which an old ablation rate is modified by the new ablation
!     rate value
!   sigma=wall emissivity
!   hwhh=half-width at half-height of the Gaussian slit function, A
!   iout1=beginning index for air outer layer calc (3rd sweep)
!   im1=beginning index for ablation-product layer (3rd sweep)
! output parameters
!   amdot_out=ablation rate, kg/(m2-s)
!   delta1=improved shock stand-off distance, m
!   dmix=thickness of mixing region, m
!   qps=forward-facing radiative flux at shock wave, W/m2

     parameter (nw=400000)
      implicit real*8(a-h,o-z)
      character*4 dum(41)
      common/qpqm/qp(802),qm(802),int_s(10,nw),ang(11),sin2(11),                       &
  &     int_cam(nw) 
      dimension tx(802),qpa(802)
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)
      real*8 intw,int_e,int_old,int_s,int_grd,int_prec,int_cam,int_abl
      common/comcalc/beta(802),rhoa(802),rhorat(802),rhovrat(802),y(802),              &
   &    enth(802),enth3(802),amdot(0:441)
      dimension                                                                        &
   &    dqdy(802),             int_old(10,nw),                                         &
   &    f(802),fp(802),ax(4,4),rhs(4),sum(2),work(4),                                  &
   &    axy(3,3),rhsy(3,2),dtdy(802),ipvt(4)                                           
      save
!
      ndm1=ndm/2
      ndm2=ndm1+1
      ndm3=ndm1-1
      dusdr=vinf/rnose
      rootpi=sqrt(3.141592)
      flow_in=rhoinf*vinf
      enflo_in=rhoinf*vinf*enths
!
! iteration on outer layer profile iout begins---------------------------
      do iout=iout1,iout1+nout-1        
        call flux_outer(nwave,ndm,iout,nout,rhoinf,rnose,vinf,y,beta,tx,dtdy,          &
   &      int_old, dqdy,qps) 
!   
! change enthalpy
        ndm4=0.2*ndm1+ndm1
        ndm5=0.4*ndm1+ndm1
        ndm6=0.6*ndm1+ndm1
        ndm7=0.8*ndm1+ndm1
        fenth1=facout1
        do idm=ndm-1,ndm4,-1
          dely=(y(idm+1)-y(idm))
          rhovrat_av=0.5*(rhovrat(idm)+rhovrat(idm+1))
          dqdy_av=dqdy(idm+1)-dqdy(idm)
          enth(idm)=fenth1*(enth(idm+1)-(dqdy_av/(rhoinf*vinf))*(1./rhovrat_av)*dely)  &
  &         +(1.-fenth1)*enth(idm)
        end do
        y1=y(ndm)-y(ndm4); y2=y(ndm)-y(ndm5); y3=y(ndm)-y(ndm6); y4=y(ndm)-y(ndm7)
        h1=enth(ndm4)-enth(ndm); h2=enth(ndm5)-enth(ndm); h3=enth(ndm6)-enth(ndm)
          h4=enth(ndm7)-enth(ndm)
        ax(1,1)=y1; ax(1,2)=y1**2; ax(1,3)=y1**3; ax(1,4)=y1**4; rhs(1)=h1
        ax(2,1)=y2; ax(2,2)=y2**2; ax(2,3)=y2**3; ax(2,4)=y2**4; rhs(2)=h2
        ax(3,1)=y3; ax(3,2)=y3**2; ax(3,3)=y3**3; ax(3,4)=y3**4; rhs(3)=h3
        ax(4,1)=y4; ax(4,2)=y4**2; ax(4,3)=y4**3; ax(4,4)=y4**4; rhs(4)=h4
        call decomp(4,4,ax,cond,ipvt,work)                                       
        call solve(4,4,ax,rhs,ipvt)                                                 
        a1=rhs(1); a2=rhs(2); a3=rhs(3); a4=rhs(4)
! construct enthalpy and temperature
        fac=facout1
        do idm=ndm2,ndm                                            ! enths = enths, OK
          entha=enths+a1*(y(ndm)-y(idm))+a2*(y(ndm)-y(idm))**2+a3*(y(ndm)-y(idm))**3    &
  &         +a4*(y(ndm)-y(idm))**4
          enth(idm)=(1.-fac)*enth3(idm)+fac*entha
          enth3(idm)=enth(idm)
          call pH_air(1,pres,enth(idm), rhoa(idm),tx(idm))         ! enthx,enth(idm),tx(idm), OK
        end do
! mass and energy out flow rates
        flow_air=0.
        enflo_air=0.
        b1=dsqrt(2.*rhoinf/rhoa(ndm2))
        do inode=ndm2+1,ndm
          rhobyrhos=rhoa(inode)/rhoa(ndm)
          ubyus=b1+(1.-b1)*(beta(inode)-beta(ndm2))/(beta(ndm)-beta(ndm2))
          flow_air=flow_air+rhobyrhos*ubyus*(y(inode)-y(inode-1))
          enflo_air=enflo_air+rhobyrhos*ubyus*enth(inode)*(y(inode)-y(inode-1))
        end do
        flow_air=flow_air*2.*rhoa(ndm)*vinf/rnose
        enflo_air=enflo_air*2.*rhoa(ndm)*vinf/rnose
        write(6,10) iout,enth(ndm2),tx(ndm2),flow_in,enflo_in,flow_air,enflo_air
        write(*,10) iout,enth(ndm2),tx(ndm2),flow_in,enflo_in,flow_air,enflo_air
   10   format(/' iout =',i3/                                                           &
 &        ' enth(ndm2)  =',1pe10.3,' tx(ndm2)          =',e10.3/                        &
 &        ' rhoinf*vinf =',1pe10.3,' 0.5*rhoinf*vinf**3=',e10.3/                        &
 &        ' flow_air    =',e10.3,  ' enflo_air         =',e10.3)
!
! rescale beta
        deltax=beta(ndm)-beta(ndm2)
        ratio=flow_in/flow_air
        deltax=deltax*ratio
        do inode=ndm2,ndm
          beta(inode)=0.5*(beta(ndm2)+deltax*(inode-ndm2)/ndm3)+0.5*beta(inode)
        end do
        y(ndm2)=0.
        do inode=ndm2+1,ndm
          rhoav=0.5*(rhoa(inode-1)+rhoa(inode))
          y(inode)=y(inode-1)+(rhos/rhoav)*(beta(inode)-beta(inode-1))   ! beta(inode),y(inode), OK
        end do
        write(12,80) iout,flow_air
   80   format(i6,1pe10.3)
      end do
!
      write(*,37) qm(ndm2)
  37  format(/' wallward radiative heat flux crossing interface=',1pe10.3)
!
! inner layer------------------------------------------------------------
!
      enthw=enth(1)
!
! iterate over ablation rate
      qm(ndm1)=qm(ndm2)
! from wall to edge
      do im=im1,im1+nim-1
        write(6,*) ' '
        write(*,*) ' '
        write(6,*) ' im=',im
        write(*,*) ' im=',im
        if(im.eq.im1) then
          do inode=1,ndm1
            call pT_ivu(1,pres,tx(inode), rhoa(inode),enth(inode),cp)
          end do
        end if
! trouble shooting
        if(im.eq.im1) then
          write(22,*) '***********************************************************'
          write(22,*) ' A. im=',im
          write(22,*) ' A. tx='
          write(22,29) (tx(inode),inode=1,ndm1)
   29     format(8f10.1)
          write(22,*) ' A. enth='
          write(22,28) (enth(inode),inode=1,ndm1) 
   28     format(1p8e10.3)
        end if

        do inode=1,ndm1
          rhorat(inode)=rhoa(ndm1)/rhoa(inode)
        end do
        rhoe=rhoa(ndm1)
        rhorw=rhoa(ndm1)/rhoa(1)
        call ffp5(ndm,rhoinf,vinf,rnose,rhorat,amdot(im-1),rhos,rhoe,                     &
    &     beta,f,fp,betae,fw)
         do inode=1,ndm1
          rhovrat(inode)=(f(inode)/f(1))*amdot(im-1)/(rhoinf*vinf)
        end do
! trouble shooting
        if(im.eq.im1) then
          write(22,*) ' B. rhovrat='
          write(22,27) (rhovrat(inode),inode=1,ndm1)
   27     format(8f10.5)
        end if
        duedr=(vinf/rnose)*dsqrt(2.*rhoinf/rhoa(ndm1))
        y(1)=0.
        do inode=2,ndm1
          rhoav=0.5*(rhoa(inode-1)+rhoa(inode))
          y(inode)=y(inode-1)+(rhoa(ndm1)/rhoav)*(beta(inode)-beta(inode-1))   ! beta,y, OK
        end do
! trouble shooting
        if(im.eq.im1) then
          write(22,*) ' C. y='
          write(22,28) (y(inode),inode=1,ndm1)
        end if
        flow=0.
        aint=0.
        do inode=2,ndm1 
          rhoav=0.5*(rhoa(inode-1)+rhoa(inode))
          rhorat_av=0.5*(rhorat(inode-1)+rhorat(inode))
          enthav=0.5*(enth(inode-1)+enth(inode))
          fpav=0.5*(fp(inode-1)+fp(inode))
          dely=y(inode)-y(inode-1)
          flow=flow+2.*rhoe*duedr*rhorat_av*fpav*dely
          aint=aint+2.*rhoav*duedr*(enthav-enthw)*fpav*dely
        end do
        entot=qm(1)-qp(1)+aint
!
! radiation
        call slope(ndm1,y,tx, dtdy)
        call flux_inner(nwave,ndm,im,nim,y,beta,tx,dtdy,sigma,int_old,         &
   &      dqdy)
        dqdy(ndm1-1)=0.5*dqdy(ndm1-2)
        amdot(im)=(1.-famdot)*amdot(im-1)+famdot*(qm(im)-qp(im))/delh
        nimx=im+1
!
! change enthalpy
!
! determine 1/4, 1/2, 3/4 points
        ndm4=0; ndm5=0; ndm6=0
        do idm=1,ndm1
          if(y(idm).gt.0.25*y(ndm1)) then; ndm4=idm; go to 881; end if
        end do
 881    do idm=1,ndm1
          if(y(idm).gt.0.50*y(ndm1)) then; ndm5=idm; go to 882; end if
        end do
 882    do idm=1,ndm1
          if(y(idm).gt.0.75*y(ndm1)) then; ndm6=idm; go to 883; end if
        end do
 883    continue

        fac=facin1
        do idm=2,ndm6
          dely=y(idm)-y(idm-1)
          rhovrat_av=0.5*(rhovrat(idm)+rhovrat(idm-1))
          dqdy_av=dqdy(idm)-dqdy(idm-1)
          enth(idm)=fac*(enth(idm-1)+(dqdy_av/(rhoinf*vinf))                          &
 &          *(1./rhovrat_av)*dely) + (1.-fac)*enth(idm)       
          call pH_ivu(1,pres,enth(idm), rhoax,tx(idm))             ! enth(idm),tx(idm), OK
        end do
! trouble shooting
        if(im.eq.im1) then
          write(22,*) ' D. enth='
          write(22,28) (enth(idm),idm=1,ndm6)
          write(22,*) ' D. tx='
          write(22,29) (tx(idm),idm=1,ndm6)
        end if
!
        y1=y(1); y2=y(ndm4); y3=y(ndm5); y4=y(ndm6)
        t1=tw; t2=tx(ndm4); t3=tx(ndm5); t4=tx(ndm6)
        ax(1,1)=1.; ax(1,2)=y1; ax(1,3)=y1**2; ax(1,4)=y1**3; rhs(1)=t1
        ax(2,1)=1.; ax(2,2)=y2; ax(2,3)=y2**2; ax(2,4)=y2**3; rhs(2)=t2
        ax(3,1)=1.; ax(3,2)=y3; ax(3,3)=y3**2; ax(3,4)=y3**3; rhs(3)=t3
        ax(4,1)=1.; ax(4,2)=y4; ax(4,3)=y4**2; ax(4,4)=y4**3; rhs(4)=t4
        call decomp(4,4,ax,cond,ipvt,work)                                       
        call solve(4,4,ax,rhs,ipvt)                                                 
        ti=rhs(1); a1=rhs(2); a2=rhs(3); a3=rhs(4)
        do idm=1,ndm1
          tx(idm)=tw+a1*y(idm)+a2*y(idm)**2+a3*y(idm)**3             ! tx(idm), OK
        end do
! trouble shooting
        if(im.eq.im1) then
          write(22,*) ' E. tx='
          write(22,29) (tx(idm),idm=1,ndm1)
        end if
        write(6,20) beta(ndm1),y(ndm1),tx(ndm2),tx(ndm1),amdot(im),                     &
 &        flow,qm(ndm1),entot,qm(1),aint
        write(*,20) beta(ndm1),y(ndm1),tx(ndm2),tx(ndm1),amdot(im),                     &
 &        flow,qm(ndm1),entot,qm(1),aint
    20  format(                                                                         &
 &        ' beta(ndm1)=',1pe10.3,' y(ndm1) =',e10.3/                                    &
 &        ' tx(ndm2)  =',0pf10.1,' tx(ndm1)=',1pe10.3/                                  &
 &        ' amdot     =',1pe10.3,' flow    =',e10.3/                                    &
 &        ' qm(ndm1)  =',e10.3,  ' entot   =',e10.3/                                    &
 &        ' qm(1)     =',e10.3,  ' aint    =',e10.3  )
        write(20,17) im,facin2
   17   format(/' tx at end of im=',i3,' facin2=',f8.4)
        write(20,18) (tx(i),i=1,ndm1)
   18   format(10f8.1)
        write(13,90) im,amdot(im)
   90   format(i6,1pe10.3)
      end do
!
! reevaluate-------------------------------------------------------------
 
! outer layer------------------------------------------------------------
!
! iteration on outer layer profile iout begins
      enth(ndm)=enths
      flow_in=rhoinf*vinf
      enflo_in=rhoinf*vinf*enths
      qp(ndm2)=qp(ndm1)
      do iout=iout1+nout,iout1+2*nout-1
        do iw=1,nw
          do iang=1,10
          int_old(iang,iw)=int_e(iang,iw)
          end do
        end do
        call slope(ndm1,y(ndm2),tx(ndm2), dtdy(ndm2))
        do iw=1,nw
          do iang=1,10
            int_old(iang,nw)=int_e(iang,nw)
          end do
        end do
        call flux_outer(nwave,ndm,iout,nout,rhoinf,rnose,vinf,y,beta,tx,dtdy,           &
   &      int_old, dqdy,qps) 
! change enthalpy
        ndm4=0.2*ndm1+ndm1
        ndm5=0.4*ndm1+ndm1
        ndm6=0.6*ndm1+ndm1
        ndm7=0.8*ndm1+ndm1
        fac=facout2
        do idm=ndm-1,ndm4,-1
          dely=y(idm+1)-y(idm)
          rhovrat_av=0.5*(rhovrat(idm)+rhovrat(idm+1))
!          dqdy_av=0.5*(dqdy(idm)+dqdy(idm+1))
          dqdy_av=dqdy(idm+1)-dqdy(idm)
          enth(idm)=fac*(enth(idm+1)-(dqdy_av/(rhoinf*vinf))*(1./rhovrat_av)*dely)     &  ! enth OK
  &         +(1.-fac)*enth(idm)
        end do
        y1=y(ndm)-y(ndm4); y2=y(ndm)-y(ndm5); y3=y(ndm)-y(ndm6); y4=y(ndm)-y(ndm7)
        h1=enth(ndm4)-enth(ndm); h2=enth(ndm5)-enth(ndm); h3=enth(ndm6)-enth(ndm)
          h4=enth(ndm7)-enth(ndm)
        ax(1,1)=y1; ax(1,2)=y1**2; ax(1,3)=y1**3; ax(1,4)=y1**4; rhs(1)=h1
        ax(2,1)=y2; ax(2,2)=y2**2; ax(2,3)=y2**3; ax(2,4)=y2**4; rhs(2)=h2
        ax(3,1)=y3; ax(3,2)=y3**2; ax(3,3)=y3**3; ax(3,4)=y3**4; rhs(3)=h3
        ax(4,1)=y4; ax(4,2)=y4**2; ax(4,3)=y4**3; ax(4,4)=y4**4; rhs(4)=h4
        call decomp(4,4,ax,cond,ipvt,work)                                       
        call solve(4,4,ax,rhs,ipvt)                                                 
        a0=rhs(1); a1=rhs(2); a2=rhs(3); a3=rhs(4)
! construct enthalpy and temperature
        do idm=ndm2,ndm
          entha=enthx+a1*(y(ndm)-y(idm))+a2*(y(ndm)-y(idm))**2+a3*(y(ndm)-y(idm))**3    &
  &         +a4*(y(ndm)-y(idm))**4
          enth(idm)=(1.-fenth2)*enth3(idm)+fenth2*entha
          enth3(idm)=enth(idm)
          call pH_air(1,pres,enth(idm), rhoa(idm),tx(idm))
        end do
! mass and energy out flow rates
        flow_air=0.
        enflo_air=0.
        b1=dsqrt(2.*rhoinf/rhoa(ndm2))
        do inode=ndm2+1,ndm
          rhobyrhos=rhoa(inode)/rhoa(ndm)
          ubyus=b1+(1.-b1)*(beta(inode)-beta(ndm2))/(beta(ndm)-beta(ndm2))
          flow_air=flow_air+rhobyrhos*ubyus*(y(inode)-y(inode-1))
          enflo_air=enflo_air+rhobyrhos*ubyus*enth(inode)*(y(inode)-y(inode-1))
        end do
        flow_air=flow_air*2.*rhoa(ndm)*vinf/rnose
        enflo_air=enflo_air*2.*rhoa(ndm)*vinf/rnose
        write(6,10) iout,enth(ndm2),tx(ndm2),flow_in,enflo_in,flow_air,enflo_air
        write(*,10) iout,enth(ndm2),tx(ndm2),flow_in,enflo_in,flow_air,enflo_air
! rescale beta
        deltax=beta(ndm)-beta(ndm2)
        ratio=flow_in/flow_air
        deltax=deltax*ratio
        do inode=ndm2,ndm
          beta(inode)=0.5*(beta(ndm2)+deltax*(inode-ndm2)/ndm3)+            &
 &          0.5*beta(inode)
        end do
        y(ndm2)=0.
        do inode=ndm2+1,ndm
          rhoav=0.5*(rhoa(inode-1)+rhoa(inode))
          y(inode)=y(inode-1)+(rhos/rhoav)*(beta(inode)-beta(inode-1))
        end do
        write(12,80) iout,flow_air
      end do
! shock stand-off distance
      delta1=y(ndm)-y(ndm2)     
!
! radiation from outer layer to inner layer
      do iw=1,nw
        do iang=1,10
          int_old(iang,iw)=int_e(iang,iw)
        end do
      end do
      call slope(ndm1,y(ndm2),tx(ndm2), dtdy(ndm2))
        do iw=1,nw
          do iang=1,10
            int_old(iang,nw)=int_e(iang,nw)
          end do
        end do
      call flux_outer(nwave,ndm,iout,nout,rhoinf,rnose,vinf,y,beta,tx,dtdy,   &
   &     int_old, dqdy,qps) 
      write(6,*) ' '
      write(*,*) ' '
      write(6,16) qm(ndm2)
      write(*,16) qm(ndm2)
  16  format(' qm at interface=',1pe11.4)      
!
! inner layer again------------------------------------------------------------
!
! iterate over ablation rate
      qm(ndm1)=qm(ndm2)
!      do im=im1+nim,im1+2*nim-1
      do im=im1+nim,im1+2*nim+9
        write(6,*) ' '
        write(6,*) ' im=',im
        write(*,*) ' '
        write(*,*) ' im=',im
!        if(im.eq.nim+1) then
!          do inode=1,ndm1
!            call pT_ivu(1,pres,tx(inode), rhoa(inode),enth(inode),cp)
!          end do
!        end if
        do inode=1,ndm1
          rhorat(inode)=rhoa(ndm1)/rhoa(inode)
        end do
        rhoe=rhoa(ndm1)
        rhorw=rhoa(ndm1)/rhoa(1)
!
        call ffp5(ndm,rhoinf,vinf,rnose,rhorat,amdot(im-1),rhos,rhoe,            &
    &     beta,f,fp,betae,fw)
        do inode=1,ndm1
          rhovrat(inode)=(f(inode)/f(1))*amdot(im-1)/(rhoinf*vinf)
        end do
        duedr=(vinf/rnose)*dsqrt(2.*rhoinf/rhoa(ndm1))
        y(1)=0.
        do inode=2,ndm1
          rhoav=0.5*(rhoa(inode-1)+rhoa(inode))
          y(inode)=y(inode-1)+(rhoa(ndm1)/rhoav)*(beta(inode)-beta(inode-1))
        end do
        flow=0.
        aint=0.
        do inode=2,ndm1 
          rhoav=0.5*(rhoa(inode-1)+rhoa(inode))
          rhorat_av=0.5*(rhorat(inode-1)+rhorat(inode))
          enthav=0.5*(enth(inode-1)+enth(inode))
          fpav=0.5*(fp(inode-1)+fp(inode))
          dely=y(inode)-y(inode-1)
          flow=flow+2.*rhoe*duedr*rhorat_av*fpav*dely
          aint=aint+2.*rhoav*duedr*(enthav-enthw)*fpav*dely
        end do
        entot=qm(1)-qp(1)+aint

! radiation
        call slope(ndm1,y,tx, dtdy)
        call flux_inner(nwave,ndm,im,nim,y,beta,tx,dtdy,sigma,int_old,         &
   &       dqdy)
        dqdy(ndm1-1)=0.5*dqdy(ndm1-2)+dqdy(ndm1)
        amdot(im)=(1.-famdot)*amdot(im-1)+famdot*(qm(1)-qp(1))/delH
!
! change enthalpy
!
! determine 1/4, 1/2, 3/4 points
        ndm4=0; ndm5=0; ndm6=0
        do idm=1,ndm1
          if(y(idm).gt.0.25*y(ndm1)) then; ndm4=idm; go to 781; end if
        end do
 781    do idm=1,ndm1
          if(y(idm).gt.0.50*y(ndm1)) then; ndm5=idm; go to 782; end if
        end do
 782    do idm=1,ndm1
          if(y(idm).gt.0.75*y(ndm1)) then; ndm6=idm; go to 783; end if
        end do
 783    continue
 
        fac=facin2
        do idm=2,ndm6
          dely=y(idm)-y(idm-1)
          rhovrat_av=0.5*(rhovrat(idm)+rhovrat(idm-1))
          dqdy_av=dqdy(idm)-dqdy(idm-1)
          enth(idm)=fac*(enth(idm-1)+(dqdy_av/(rhoinf*vinf))                          &
 &          *(1./rhovrat_av)*dely) + (1.-fac)*enth(idm)
        end do
!
        y1=y(1); y2=y(ndm4); y3=y(ndm5); y4=y(ndm6)
        t1=tw; t2=tx(ndm4); t3=tx(ndm5); t4=tx(ndm6)
        ax(1,1)=1.; ax(1,2)=y1; ax(1,3)=y1**2; ax(1,4)=y1**3; rhs(1)=t1
        ax(2,1)=1.; ax(2,2)=y2; ax(2,3)=y2**2; ax(2,4)=y2**3; rhs(2)=t2
        ax(3,1)=1.; ax(3,2)=y3; ax(3,3)=y3**2; ax(3,4)=y3**3; rhs(3)=t3
        ax(4,1)=1.; ax(4,2)=y4; ax(4,3)=y4**2; ax(4,4)=y4**3; rhs(4)=t4
        call decomp(4,4,ax,cond,ipvt,work)                                       
        call solve(4,4,ax,rhs,ipvt)                                                 
        ti=rhs(1); a1=rhs(2); a2=rhs(3); a3=rhs(4)
        do idm=1,ndm1
          tx(idm)=ti+a1*y(idm)+a2*y(idm)**2+a3*y(idm)**3
        end do

        write(6,20) beta(ndm1),y(ndm1),tx(ndm2),tx(ndm1),amdot(im),                     &
 &        flow,qm(ndm1),entot,qm(1),aint
        write(*,20) beta(ndm1),y(ndm1),tx(ndm2),tx(ndm1),amdot(im),                     &
 &        flow,qm(ndm1),entot,qm(1),aint

        write(20,17) im,facin2
        write(20,18) (tx(i),i=1,ndm1)
        write(13,90) im,amdot(im)
      end do 
!     
! re-reevaluate-------------------------------------------------------------
!
! generate forward-cast radiation--------------------------
      enth(ndm)=enths
      flow_in=rhoinf*vinf
      enflo_in=rhoinf*vinf*enths
      qpa(ndm2)=qpa(ndm1)
!
! print out flowfield
      write(11,50) rhoinf,vinf,rnose
   50 format(/' rhoinf=',1pe10.3,' vinf=',e10.3,' rnose=',e10.3/                        &
 &      ' inode      y        rho       rhov       temp        qp         qm',          &
 &      '        dqdy       enth')
      do inode=1,ndm1
        write(11,60) inode,y(inode),rhoa(inode),-rhovrat(inode),tx(inode),              &
 &        qp(inode),qm(inode),dqdy(inode),enth(inode)
   60   format(i5,1p8e11.3)
      end do
       ymid=y(ndm1)
       do inode=ndm2,ndm
         rhovratz=rhovrat(inode)
         write(11,60) inode,y(inode)+ymid,rhoa(inode),rhovrat(inode),tx(inode),         &
 &         qp(inode),qm(inode),dqdy(inode),enth(inode)
       end do
!
! fw for viscous flow
      call pT_vis_air(pres,tx(ndm2), visc)
      fwv=0.5*(amdot(4*nim)+amdot(4*nim-1))/dsqrt(2.*rhoa(ndm2)*visc*duedr)
! thickness of mixing region dmix
      dmix=1./(dsqrt(2.*(rhoa(ndm2)/visc)*duedr))

      write(6,30) rhoinf,vinf,rnose,amdot(4*nim),fwv,                                   &
 &      ndm,qm(1)-qp(1),delH,delta,dmix,temps,tx(ndm2),tx(ndm1),tw
  30  format(/                                                                          &
 &      ' rhoinf                                   =',1pe11.4,' kg/m3.'/                &
 &      ' vinf                                     =',e11.4,' m/s.'/                    &
 &      ' rnose                                    =',e11.4,' m'/                       &
 &      ' amdot                                    =',e11.4,' kg/(m2-s).'/              &
 &      ' fwv                                      =',e11.4/                            &
 &      ' ndm                                      =',i5/                               &                          
 &      ' qm(1)-qp(1)                              =',e11.4,' W/m2'/                    &
 &      ' delH                                     =',e11.4,' J/kg.'/                   &
 &      ' shock stand-off                          =',e11.4,' m.'/                      &
 &      ' mixing thickness dmix                    =',e11.4,' m.'/                      &
 &      ' post-shock temps                         =',0pf10.1/                          &
 &      ' interface temp tx(ndm2)                  =',f10.1/                            &
 &      ' ablation product layer edge temp tx(ndm1)=',f10.1/                            &
 &      ' wall temp  tw                            =',f10.1)                            
      write(10,30) rhoinf,vinf,rnose,amdot(4*nim),fwv,                                  &
 &      ndm,qm(1)-qp(1),delH,delta,dmix,temps,tx(ndm2),tx(ndm1),tw

      amdot_out=amdot(4*nim)
!
WRITE(6,*) ' GETTING OUT OF CALC1'
      return
      end
!***********************************************************************                  
      subroutine calc_1x1x(isp,dev,bvu,bvl,dvu,dvl,geu,teu,               &               
     &  evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,         &               
     &  lam_u,lam_l,sou,sol)                                                              
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60)                                        
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom,                  &               
     & neq_factor_k,ls_u,ls_l                                                             
      character*5 dum(90),hund_diatom,hund                                                
      character*4 asterik,atomnm2(matoms),bandnm_diatom,                  &
     &    minus1,unknown                              
      character*4 atom_rads(3,168),diatom_bands(3,100),                   &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                     &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                         &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      integer charge_diatom,g_diatom,lo_state,s_diatom,up_state,          &               
     & g_atom1,g_atom2,gneq_diatom,check,ncentr(301)                                      
      integer vu,vl,spinu, spinl,sisi                                                     
      common/comi/nwave                                                                   
      common/comadiatom/ae_diatom(46,mdiatoms),                           &               
     & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms),    &               
     & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms),             &               
     & atomwt2(mdiatoms),be_diatom(46,mdiatoms),                          &               
     & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms),       &               
     & betae_diatom(46,mdiatoms),                                         &               
     & cross_diatom(11,121,21,mdiatoms),                                  &               
     & cross_imp_diatom(11,11,11,mdiatoms),                               &               
     & de_diatom(46,mdiatoms),diatom_mass(mdiatoms),                      &               
     & diatomwt(mdiatoms),                                                &               
     & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms),                    &               
     & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms),                 &               
     & FC_imp_diatom(0:11,0:11,11,11,mdiatoms),                           &               
     & e_elec_imp_diatom(11,11,11,mdiatoms),                              &               
     & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms),                     &               
     & lam2_diatom(46,mdiatoms),                                          &               
     & n_himp_bb_diatom(11,11,11,mdiatoms),                               &               
     & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms),    &               
     & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms),            &               
     & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms),          &               
     & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms),                    &               
     & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms),    &               
     & td_himp_bb_diatom(11,11,11,mdiatoms),                              &               
     & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms),         &               
     & wavel_cont_diatom(121,0:21,mdiatoms),                              &               
     & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms),                   &               
     & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms)                                  
      common/comidiatom/charge_diatom(mdiatoms),                          &               
     & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms),                        &               
     & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms),                   &               
     & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms),        &               
     & maxvl_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxvu_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxv_up_diatom(45,mdiatoms),                                       &               
     & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms),          &               
     & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms),           &               
     & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms),        &               
     & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms),                     &               
     & nup_diatom(45,mdiatoms),                                           &               
     & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms)                                 
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/comhund/hund_diatom(35,mdiatoms)                                             
      common/spect/calpha,slope_ratio,wavmin,wavmax,rangex                                             
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      real*8 jmin,norm                                                                    
      dimension emisj(nw)                                                                 
      jmin= real(j)                                                                       
! J and Lambda refer to the values of lower state involved in transition                  
!      select case (k)                                                                    
      go to (10,20,30) k                                                                  
!    case (1)  ! R branch, Dj= +1                                                         
  10  continue                                                                            
      rju  = jmin                                                                         
      rjl  = rju - 1.0                                                                    
      s_jj = (rjl+lam_l+1.0)*(rjl-lam_l+1.0) / (rjl+1.0)                                  
      if(s_jj.lt.0.) s_jj= 1.                                                             
      go to 40                                                                            
!    case (2)  ! Q branch, Dj=  0                                                         
  20  continue                                                                            
      rju  = jmin                                                                         
      rjl  = rju - 0.0                                                                    
      s_jj = lam_l**2*(2.0*rjl+1.0) / (rjl*(rjl+1.0))                                     
      if(s_jj.lt.0.) s_jj= 1.                                                             
      go to 40                                                                            
!    case (3)  ! P branch, Dj= -1                                                         
  30  continue                                                                            
       rju  = jmin - 1.0                                                                  
       rjl  = rju + 1.0                                                                   
       s_jj = (rjl+lam_l)*(rjl-lam_l) / rjl                                               
       if(s_jj.lt.0.) s_jj= 1.                                                            
       go to 40                                                                           
!    end select                                                                           
!                                                                                         
  40  continue                                                                            
      fpu=bvu*(rju*(rju+1.d0)-0.0**2)-dvu*(rju*(rju+1.d0)-0.0**2)**2                      
      fpl=bvl*(rjl*(rjl+1.d0)-0.0**2)-dvl*(rjl*(rjl+1.d0)-0.0**2)**2                      
                                                                                          
      ramda_jj_inv = dev + fpu - fpl                                                      
      wavelx = 1.0d8/ramda_jj_inv                                                         
      norm = 2.d0*rjl + 1.                                                                
      if( (lam_l.eq.2) .and. (rjl.eq.1.) ) norm=  6.d0                                    
      if( (lam_l.eq.3) .and. (rjl.eq.1.) ) norm= 13.5d0                                   
      if( (lam_l.eq.3) .and. (rjl.eq.2.) ) norm=  7.5d0                                   
                                                                                          
      popu = dens_diatom(isp)*geu*homo_fac(isp)*                          &               
     &  (2.0d0*rju+1.d0) * dexp(-1.43877d0 * (teu/tele                    &               
     &  + evu/tvib + fpu/trot))/qtot                ! number density of upper rotational s
      hnu = 1.9863d-23 * ramda_jj_inv                                     ! photon energy 
      trans_prob=(64.d0*(3.1415916d0**4)*(0.529167d-8*4.80298d-10)**2     &               
     &  *(re1**2)/(3.d0*6.6256d-27))*s_jj*ramda_jj_inv**3/norm                            
      e = popu * trans_prob * hnu/(4.d0 * 3.1415916d0)                       ! emission po
!                                                                                         
      ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))*(1./calpha)
!      ncentr(j) = (1.d0/wavmin**2 - 1.d0/wavelx**2)/estep + 1                                   
      emisj(j) = e                                                                        
                                                                                          
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine calc_1x1y(isp,dev,bvu,bvl,dvu,dvl,geu,teu,               &               
     &  evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,         &               
     &  lam_u,lam_l,sou,sol)                                                              
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60)                                        
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom,                  &               
     & neq_factor_k,ls_u,ls_l                                                             
      character*5 dum(90),hund_diatom,hund                                                
      character*4 asterik,atomnm2(matoms),bandnm_diatom,                  &
     &    minus1,unknown                              
      character*4 atom_rads(3,168),diatom_bands(3,100),                                 &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                                   &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                              &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                                       &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,           &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      integer charge_diatom,g_diatom,lo_state,s_diatom,up_state,          &               
     & g_atom1,g_atom2,gneq_diatom,check,ncentr(301)                                      
      integer vu,vl,spinu, spinl,sisi                                                     
      common/comi/nwave                                                                   
      common/comadiatom/ae_diatom(46,mdiatoms),                           &               
     & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms),    &               
     & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms),             &               
     & atomwt2(mdiatoms),be_diatom(46,mdiatoms),                          &               
     & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms),       &               
     & betae_diatom(46,mdiatoms),                                         &               
     & cross_diatom(11,121,21,mdiatoms),                                  &               
     & cross_imp_diatom(11,11,11,mdiatoms),                               &               
     & de_diatom(46,mdiatoms),diatom_mass(mdiatoms),                      &               
     & diatomwt(mdiatoms),                                                &               
     & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms),                    &               
     & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms),                 &               
     & FC_imp_diatom(0:11,0:11,11,11,mdiatoms),                           &               
     & e_elec_imp_diatom(11,11,11,mdiatoms),                              &               
     & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms),                     &               
     & lam2_diatom(46,mdiatoms),                                          &               
     & n_himp_bb_diatom(11,11,11,mdiatoms),                               &               
     & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms),    &               
     & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms),            &               
     & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms),          &               
     & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms),                    &               
     & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms),    &               
     & td_himp_bb_diatom(11,11,11,mdiatoms),                              &               
     & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms),         &               
     & wavel_cont_diatom(121,0:21,mdiatoms),                              &               
     & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms),                   &               
     & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms)                                  
      common/comidiatom/charge_diatom(mdiatoms),                          &               
     & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms),                        &               
     & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms),                   &               
     & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms),        &               
     & maxvl_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxvu_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxv_up_diatom(45,mdiatoms),                                       &               
     & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms),          &               
     & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms),           &               
     & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms),        &               
     & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms),                     &               
     & nup_diatom(45,mdiatoms),                                           &               
     & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms)                                 
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/comhund/hund_diatom(35,mdiatoms)                                             
      common/spect/calpha,slope_ratio,wavmin,wavmax,rangex                                             
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      real*8 jmin,norm                                                                    
      dimension emisj(nw)                                                                 
                                                                                          
      jmin= real(j)                                                                       
      if( lam_l .gt. lam_u) then                 ! Delta(Lambda) = -1                     
!        select case (k)                                                                  
        go to (10,20,30) k                                                                
!    case (1)  ! R branch                                                                 
   10   continue                                                                          
        rju  = jmin + 1.0                                                                 
        rjl  = jmin                                                                       
        s_jj = (rjl-lam_l+2.0)*(rjl-lam_l+1.0) / (2*(rjl+1.0))                            
        if(s_jj.lt.0.) s_jj= 1.                                                           
        go to 40                                                                          
!    case (2)  ! Q branch                                                                 
   20   continue                                                                          
        rju  = jmin                                                                       
        rjl  = jmin                                                                       
        s_jj = (rjl-lam_l+1.0)*(rjl+lam_l)*(2.0*rjl+1.0) /                &               
     &    (2.0*rjl*(rjl+1.0))                                                             
        if(j.eq.0) s_jj= 0.                                                               
        if(s_jj.lt.0.) s_jj= 1.                                                           
        go to 40                                                                          
!    case (3)  ! P branch                                                                 
   30   continue                                                                          
        rju  = jmin - 1.0                                                                 
        rjl  = jmin                                                                       
        s_jj = (rjl-1.0+lam_l)*(rjl+lam_l) / (2.0*rjl)                                    
        if(j.eq.0) s_jj= 0.                                                               
        if(s_jj.lt.0.) s_jj= 1.                                                           
        go to 40                                                                          
!    end select                                                                           
      end if                                                                              
   40 continue                                                                            
      if( lam_u .gt. lam_l) then                       ! Delta(Lambda) = +1               
!    select case (k)                                                                      
        go to (50,60,70) k                                                                
!    case (1)  ! R branch                                                                 
   50   continue                                                                          
        rju  = jmin + 1.0                                                                 
        rjl  = jmin                                                                       
        s_jj = (rjl+lam_l+2.0)*(rjl+lam_l+1.0) / (2.0*(rjl+1.0))                          
        if(s_jj.lt.0.) s_jj= 1.                                                           
        go to 80                                                                          
!    case (2)  ! Q branch                                                                 
   60  continue                                                                           
        rju  = jmin                                                                       
        rjl  = jmin                                                                       
        s_jj = (rjl+lam_l+1.0)*(rjl-lam_l)*(2.0*rjl+1.0)                  &               
     &    / (2.0*rjl*(rjl+1.0))                                                           
        if(s_jj.lt.0.) s_jj= 1.                                                           
        go to 80                                                                          
!    case (3)  ! P branch                                                                 
   70   continue                                                                          
        rju  = jmin - 1.0                                                                 
        rjl  = jmin                                                                       
        s_jj = (rjl-lam_l-1.0)*(rjl-lam_l) / (2.0*rjl)                                    
        if(s_jj.lt.0.) s_jj= 1.                                                           
        go to 80                                                                          
!    end select                                                                           
      end if                                                                              
!                                                                                         
   80 continue                                                                            
      fpu = bvu*(rju*(rju+1.d0)-0.0**2) - dvu*(rju*(rju+1.d0)-0.0**2)**2                  
      fpl = bvl*(rjl*(rjl+1.d0)-0.0**2) - dvl*(rjl*(rjl+1.d0)-0.0**2)**2                  
                                                                                          
      ramda_jj_inv = dev + fpu - fpl                                                      
      wavelx = 1.0d8/ramda_jj_inv                                                         
      norm = 2.d0*rjl + 1.d0                                                              
!    if( ((lam_u.eq.2).and. (lam_l.eq.3)) .and. (rjl.eq.1.) ) norm=  6.0                  
                                                                                          
      popu = dens_diatom(isp) * geu * homo_fac(isp) *                     &               
     &  (2.0*rju+1.0) * dexp(-1.43877d0 * (teu/trot                       &               
     &   + evu/tvib + fpu/trot))/qtot                  ! number density of upper rotationa
      hnu = 1.9863d-23 * ramda_jj_inv                                       ! photon energ
      trans_prob = (64.d0 * (3.1415916d0**4) * (0.529167d-8               &               
     &  * 4.80298d-10)**2* (re1**2)/(3.d0 * 6.6256d-27)) * s_jj           &               
     &  * ramda_jj_inv**3/norm                                                            
      e = popu * trans_prob * hnu/(4.d0 * 3.1415916d0)                       ! emission po
!                                                                                         
      ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha)
!      ncentr(j) = (1.d0/wavmin**2 - 1.d0/wavelx**2)/estep + 1                                   
      emisj(j) = e                                                                        
!                                                                                         
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine calc_2P2P(isp,dev,bvu,bvl,dvu,dvl, geu,                  &               
     & teu,evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,      &               
     & lam_u,lam_l,sou,sol)                                                               
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60)                                        
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom,                  &               
     & neq_factor_k,ls_u,ls_l                                                             
      character*5 dum(90),hund_diatom,hund                                                
      character*4 asterik,atomnm2(matoms),bandnm_diatom,                  &
     &    minus1,unknown                              
      character*4 atom_rads(3,168),diatom_bands(3,100),                                 &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                                   &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                              &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                                       &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,           &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      integer charge_diatom,g_diatom,lo_state,s_diatom,up_state,          &               
     & g_atom1,g_atom2,gneq_diatom,check,ncentr(301)                                      
      integer vu,vl,spinu, spinl,sisi                                                     
      common/comi/nwave                                                                   
      common/comadiatom/ae_diatom(46,mdiatoms),                           &               
     & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms),    &               
     & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms),             &               
     & atomwt2(mdiatoms),be_diatom(46,mdiatoms),                          &               
     & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms),       &               
     & betae_diatom(46,mdiatoms),                                         &               
     & cross_diatom(11,121,21,mdiatoms),                                  &               
     & cross_imp_diatom(11,11,11,mdiatoms),                               &               
     & de_diatom(46,mdiatoms),diatom_mass(mdiatoms),                      &               
     & diatomwt(mdiatoms),                                                &               
     & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms),                    &               
     & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms),                 &               
     & FC_imp_diatom(0:11,0:11,11,11,mdiatoms),                           &               
     & e_elec_imp_diatom(11,11,11,mdiatoms),                              &               
     & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms),                     &               
     & lam2_diatom(46,mdiatoms),                                          &               
     & n_himp_bb_diatom(11,11,11,mdiatoms),                               &               
     & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms),    &               
     & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms),            &               
     & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms),          &               
     & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms),                    &               
     & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms),    &               
     & td_himp_bb_diatom(11,11,11,mdiatoms),                              &               
     & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms),         &               
     & wavel_cont_diatom(121,0:21,mdiatoms),                              &               
     & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms),                   &               
     & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms)                                  
      common/comidiatom/charge_diatom(mdiatoms),                          &               
     & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms),                        &               
     & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms),                   &               
     & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms),        &               
     & maxvl_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxvu_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxv_up_diatom(45,mdiatoms),                                       &               
     & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms),          &               
     & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms),           &               
     & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms),        &               
     & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms),                     &               
     & nup_diatom(45,mdiatoms),                                           &               
     & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms)                                 
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/comhund/hund_diatom(35,mdiatoms)                                             
      common/spect/calpha,slope_ratio,wavmin,wavmax,rangex                                             
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      real*8 jmin,norm                                                                    
      dimension emisj(nw)                                                                 
                                                                                          
      jmin= real(j)                                                                       
!    select case (k)                                                                      
      go to (10,20,30,40,50,60,70,80,90,100,110,120) k                                    
                                                                                          
!    case(1)    ! R11(f1', f1")                                                           
   10 continue                                                                            
      rju = jmin+1.; rjl = jmin                                                                          
      s_jj= (rjl+0.)*(rjl+2.)**2/(rjl+1.)/(2.*rjl+3.)                                     
      cu1 =  1.0; cl1 =  1.0; cu2 =  0.0; cl2 =  0.0; go to 130                                                                           
!    case(2)    ! R22(f2', f2")                                                           
   20 continue                                                                            
      rju = jmin+1.; rjl = jmin                                                                          
      s_jj= rjl**2*(rjl+2.)/(rjl+1.)/(2.*rjl+1.)                                          
      cu1 = -1.0; cl1 = -1.0; cu2 =  1.0; cl2 =  1.0; go to 130                                                                           
!    case(3)    ! qR12(f1', f2")                                                          
   30 continue                                                                            
      rju = jmin+1.; rjl = jmin                                                                          
      s_jj= 1./rjl/(rjl+1.)/(2.*rjl+1.)                                                   
      cu1 =  1.0; cl1 = -1.0; cu2 =  0.0; cl2 =  1.0; go to 130                                                                           
!    case(4)    ! sR21(f2', f1")                                                          
   40 continue                                                                            
      rju = jmin+1.; rjl = jmin                                                                          
      s_jj=  0.0                                                                          
      cu1 = -1.0; cl1 =  1.0; cu2 =  1.0; cl2 =  0.0; go to 130                                                                           
!    case(5)    ! Q11(f1', f1")                                                           
   50 continue                                                                            
      rju = jmin; rjl = jmin                                                                          
      s_jj= (2.*rjl+3.)/(rjl+1.)/(2.*rjl+1.)                                              
      cu1 =  1.0; cl1 =  1.0; cu2 =  0.0; cl2 =  0.0; go to 130                                                                           
!    case(6)    ! Q22(f2', f2")                                                           
   60 continue                                                                            
      rju = jmin; rjl = jmin                                                                          
      s_jj= (2.*rjl-1.)/rjl/(2.*rjl+1.)                                                   
      cu1 = -1.0; cl1 = -1.0; cu2 =  1.0; cl2 =  1.0; go to 130                                                                           
!    case(7)    ! pQ12(f1', f2")                                                          
   70 continue                                                                            
      rju = jmin; rjl = jmin                                                                          
      s_jj= (rjl-1.)*(rjl+1.)/(rjl+0.)/(2.*rjl-1.)/(2.*rjl+1.)                            
      cu1 =  1.0; cl1 = -1.0; cu2 =  0.0; cl2 =  1.0; go to 130                                                                           
!    case(8)    ! rQ(f2', f1")                                                            
   80 continue                                                                            
      rju = jmin; rjl = jmin                                                                          
      s_jj= rjl*(rjl+2.)/(rjl+1.)/(2.*rjl+1.)/(2.*rjl+3.)                                 
      cu1 = -1.0; cl1 =  1.0; cu2 =  1.0; cl2 =  0.0; go to 130                                                                           
!    case(9)    ! P11(f1', f1")                                                           
   90 continue                                                                            
      rju = jmin-1.; rjl = jmin                                                                          
      s_jj= (rjl-1.)*(rjl+1.)**2/(rjl+0.)/(2.*rjl+1.)                                     
      cu1 =  1.0; cl1 =  1.0; cu2 =  0.0; cl2 =  0.0; go to 130                                                                           
!    case(10)    ! P22(f2', f2")                                                          
  100 continue                                                                            
      rju = jmin-1.; rjl = jmin                                                                          
      s_jj= (rjl+1.)*(rjl-1.)**2/rjl/(2.*rjl-1.)                                          
      cu1 = -1.0; cl1 = -1.0; cu2 =  1.0; cl2 =  1.0; go to 130                                                                           
!    case(11)    ! oP(f1', f2")                                                           
  110 continue                                                                            
      rju = jmin-1.; rjl = jmin                                                                          
      s_jj=  0.0                                                                          
      cu1 =  1.0; cl1 = -1.0; cu2 =  0.0; cl2 =  1.0; go to 130                                                                           
!    case(12)    ! qP(pf2', f1")                                                          
  120 continue                                                                            
      rju = jmin-1.; rjl = jmin                                                                          
      s_jj= 1./rjl/(rjl+1.)/(2.*rjl+1.)                                                   
      cu1 = -1.0; cl1 =  1.0; cu2 =  1.0; cl2 =  0.0; go to 130                                                                           
                                                                                          
! refer to kavacs, pp. 249, 222(v.16)                                                     
  130 continue                                                                            
      sou= 0.                                                                             
      sol= 0.                                                                             
      fpu=bvu*rju*(rju+1.)-dvu*rju**2*(rju+1.)**2+cu1/2.*sou*(rju+cu2)       !cu1= +1, cu2
      fpl=bvl*rjl*(rjl+1.)-dvl*rjl**2*(rjl+1.)**2+cl1/2.*sol*(rjl+cl2)       !cl1= -1, cl2
                                                                                          
      ramda_jj_inv = dev + fpu - fpl                                                      
      wavelx = 1.0d8/ramda_jj_inv                                                         
                                                                                          
      popu = dens_diatom(isp) * geu * homo_fac(isp) *                     &               
     & (2.0*rju+1.0) * dexp(-1.43877d0 * (teu/tele                        &               
     &  + evu/tvib + fpu/trot))/qtot                   ! number density of upper rotationa
      hnu = 1.9863d-23 * ramda_jj_inv                                     ! photon energy 
      trans_prob=(64.d0*(3.1415916d0**4)*(0.529167d-8*4.80298d-10)**2     &               
     &  *(re1**2)/(3.d0*6.6256d-27))*s_jj*ramda_jj_inv**3 /(2.*rjl+1.)                    
      e = popu * trans_prob * hnu/(4.d0 * 3.1415916d0)                       ! emission po
                                                                                          
      ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha)
!      ncentr(j) = (1.d0/wavmin**2 - 1.0/wavelx**2)/estep + 1                                    
      emisj(j) = e                                                                        
                                                                                          
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine calc_2S2P(isp,dev,bvu,bvl,dvu,dvl,geu,teu,               &               
     & evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,lam_u,    &               
     & lam_l,sou,sol)                                                                     
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60)                                        
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom,                  &               
     & neq_factor_k,ls_u,ls_l                                                             
      character*5 dum(90),hund_diatom,hund                                                
      character*4 asterik,atomnm2(matoms),bandnm_diatom,                  &
     &    minus1,unknown                              
      character*4 atom_rads(3,168),diatom_bands(3,100),                                 &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                                   &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                              &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                                       &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,           &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      integer charge_diatom,g_diatom,lo_state,s_diatom,up_state,          &               
     & g_atom1,g_atom2,gneq_diatom,check,ncentr(301)                                      
      integer vu,vl,spinu, spinl,sisi                                                     
      common/comi/nwave                                                                   
      common/comadiatom/ae_diatom(46,mdiatoms),                           &               
     & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms),    &               
     & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms),             &               
     & atomwt2(mdiatoms),be_diatom(46,mdiatoms),                          &               
     & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms),       &               
     & betae_diatom(46,mdiatoms),                                         &               
     & cross_diatom(11,121,21,mdiatoms),                                  &               
     & cross_imp_diatom(11,11,11,mdiatoms),                               &               
     & de_diatom(46,mdiatoms),diatom_mass(mdiatoms),                      &               
     & diatomwt(mdiatoms),                                                &               
     & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms),                    &               
     & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms),                 &               
     & FC_imp_diatom(0:11,0:11,11,11,mdiatoms),                           &               
     & e_elec_imp_diatom(11,11,11,mdiatoms),                              &               
     & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms),                     &               
     & lam2_diatom(46,mdiatoms),                                          &               
     & n_himp_bb_diatom(11,11,11,mdiatoms),                               &               
     & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms),    &               
     & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms),            &               
     & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms),          &               
     & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms),                    &               
     & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms),    &               
     & td_himp_bb_diatom(11,11,11,mdiatoms),                              &               
     & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms),         &               
     & wavel_cont_diatom(121,0:21,mdiatoms),                              &               
     & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms),                   &               
     & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms)                                  
      common/comidiatom/charge_diatom(mdiatoms),                          &               
     & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms),                        &               
     & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms),                   &               
     & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms),        &               
     & maxvl_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxvu_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxv_up_diatom(45,mdiatoms),                                       &               
     & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms),          &               
     & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms),           &               
     & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms),        &               
     & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms),                     &               
     & nup_diatom(45,mdiatoms),                                           &               
     & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms)                                 
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/comhund/hund_diatom(35,mdiatoms)                                             
      common/spect/calpha,slope_ratio,wavmin,wavmax,rangex                                             
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      real*8 jmin,norm                                                                    
      dimension emisj(nw)                                                                 
      real*8 lm                                                                           
                                                                                          
      sum_fact= 2.d0                                                                      
!    select case (k)  ! refer to pp 261 of herzberg                                       
      go to (10,20,30,40,50,60,70,80,90,100,110,120) k                                    
                                                                                          
!    case(1)    ! r(f1', f1")                                                             
   10 continue                                                                            
      rju =  real(j) + 0.5; rjl =  real(j) - 0.5                                                                
      cu1 = -1.0; cl1 = -1.0; cu2 =  0.0; cl2 =  0.0; go to 130                                                                           
!    case(2)    ! r(f2', f2")                                                             
   20 continue                                                                            
      rju =  real(j) + 0.5; rjl =  real(j) - 0.5                                                                
      cu1 =  1.0; cl1 =  1.0; cu2 =  1.0; cl2 =  1.0; go to 130                                                                           
!    case(3)    ! qr(f1', f2")                                                            
   30 continue                                                                            
      rju =  real(j) + 0.5; rjl =  real(j) - 0.5; cu1 = -1.0                                                                          
      cl1 =  1.0; cu2 =  0.0; cl2 =  1.0; go to 130                                                                           
!    case(4)    ! sr(f2', f1")                                                            
   40 continue                                                                            
      rju =  real(j) + 0.5; rjl =  real(j) - 0.5                                                                
      cu1 =  1.0; cl1 = -1.0; cu2 =  1.0; cl2 =  0.0; go to 130                                                                           
!    case(5)    ! q(f1', f1")                                                             
   50 continue                                                                            
      rju =  real(j) - 0.5; rjl =  real(j) - 0.5                                                                
      cu1 = -1.0; cl1 = -1.0; cu2 =  0.0; cl2 =  0.0; go to 130                                                                           
!    case(6)    ! q(f2', f2")                                                             
   60 continue                                                                            
      rju =  real(j) - 0.5; rjl =  real(j) - 0.5                                                                
      cu1 =  1.0; cl1 =  1.0; cu2 =  1.0; cl2 =  1.0; go to 130                                                                           
!    case(7)    ! pq(f1', f2")                                                            
   70 continue                                                                            
      rju =  real(j) - 0.5; rjl =  real(j) - 0.5                                                                
      cu1 = -1.0; cl1 =  1.0; cu2 =  0.0; cl2 =  1.0; go to 130                                                                           
!    case(8)    ! rq(f2', f1")                                                            
   80 continue                                                                            
      rju =  real(j) - 0.5; rjl =  real(j) - 0.5                                                                
      cu1 =  1.0; cl1 = -1.0; cu2 =  1.0; cl2 =  0.0; go to 130                                                                           
!    case(9)    ! p(f1', f1")                                                             
   90 continue                                                                            
      rju =  real(j) - 0.5; rjl =  real(j) + 0.5                                                                
      cu1 = -1.0; cl1 = -1.0; cu2 =  0.0; cl2 =  0.0; go to 130                                                                           
!    case(10)    ! p(f2', f2")                                                            
  100 continue                                                                            
      rju =  real(j) - 0.5; rjl =  real(j) + 0.5                                                                
      cu1 =  1.0; cl1 =  1.0; cu2 =  1.0; cl2 =  1.0; go to 130                                                                           
!    case(11)    ! op(f1', f2")                                                           
  110 continue                                                                            
      rju =  real(j) - 0.5; rjl =  real(j) + 0.5                                                                
      cu1 = -1.0; cl1 =  1.0; cu2 =  0.0; cl2 =  1.0;  go to 130                                                                           
!    case(12)    ! qp(f2', f1")                                                           
  120 continue                                                                            
      rju =  real(j) - 0.5; rjl =  real(j) + 0.5                                                                
      cu1 =  1.0; cl1 = -1.0; cu2 =  1.0; cl2 =  0.0; go to 130                                                                           
!    end select                                                                           
  130 continue                                                                            
      rju = rju + 0.5                                                                     
      rjl = rjl + 0.5                                                                     
! refer to kavacs, pp 61, 63, and 127                                                     
      yu = sou/bvu                                                                        
      yl = sol/bvl                                                                        
      jx = rju                                                                            
      yy = yu                                                                             
      if (lam_u .gt. lam_l) then                                                          
        yy = yl                                                                           
        jx = rjl                                                                          
      end if                                                                              
                                                                                          
      fpu= bvu*((rju+0.5d0)**2 - lam_u**2 + cu1/2.d0*dsqrt(4.d0           &               
     &  *(rju+0.5d0)**2 + (yu*lam_u)**2 - 4.d0*yu*lam_u**2))              &               
     &  - dvu*(rju+cu2)**4                                                                
      fpl= bvl*((rjl+0.5d0)**2 - lam_l**2 + cl1/2.*dsqrt                  &               
     &  (4.d0*(rjl+0.5d0)**2 + (yl*lam_l)**2 - 4.d0*yl*lam_l**2))         &               
     &  - dvl*(rjl+cl2)**4                                                                
      uu = 1.d0/dsqrt(yy**2-yy+(2.d0*jx+1.)**2)                                           
                                                                                          
      if( lam_l .gt. lam_u) then                                     ! 2S-2P              
!    select case (k)                                                                      
        go to (210,220,230,240,250,260,270,280,290,300,310,320) k                         
!    case(1)    ! R11(f1', f1")                                                           
  210   continue                                                                          
        s_jj = (2.d0*jx+1.)**2 + (2.d0*jx+1.d0)*uu*(4.d0*jx**2            &               
     &    +4.d0*jx-7.d0+2.d0*yy) / (16.d0*(jx+1.d0)) /sum_fact                            
        go to 330                                                                         
!    case(2)    ! R22(f2', f2")                                                           
  220   continue                                                                          
        s_jj = (2.d0*jx+1.d0)**2 + (2.d0*jx+1.d0)*uu*(4.d0*jx**2          &               
     &    +4.d0*jx+1.d0-2.d0*yy) / (16.d0*(jx+1.d0)) /sum_fact                            
        go to 330                                                                         
!    case(3)    ! qR12(f1', f2")                                                          
  230 continue                                                                            
        s_jj =(2.d0*jx+1.d0)**2-(2.d0*jx+1.d0)*uu*(4.d0*jx**2+4.d0*jx     &               
     &    -7.d0+2.d0*yy) / (16.d0*(jx+1.d0)) /sum_fact                                    
        go to 330                                                                         
!    case(4)    ! sR21(f2', f1")                                                          
  240 continue                                                                            
        s_jj = (2.d0*jx+1.d0)**2 - (2.d0*jx+1.d0)*uu*(4.d0*jx**2          &               
     &    +4.d0*jx+1.d0-2.d0*yy) / (16.d0*(jx+1.d0)) /sum_fact                            
        go to 330                                                                         
!    case(5)    ! Q11(f1', f1")                                                           
  250   continue                                                                          
        s_jj=(2.d0*jx+1.d0)*((4.d0*jx**2+4.d0*jx-1.d0)+uu*(8.d0*jx**3     &               
     &    +12.d0*jx**2-2.d0*jx-7.d0+2.d0*yy))/(16.d0*jx*(jx+1.d0))        &               
     &    /sum_fact                                                                       
        go to 330                                                                         
!    case(6)    ! Q22(f2', f2")                                                           
  260   continue                                                                          
        s_jj = (2.d0*jx+1.d0)*((4.d0*jx**2+4.d0*jx-1.d0)+uu*(8.d0*jx**3   &               
     &    +12.d0*jx**2-2.d0*jx+1.d0-2.d0*yy))/(16.d0*jx*(jx+1.d0))        &               
     &    /sum_fact                                                                       
        go to 330                                                                         
!    case(7)    ! pQ12(f1', f2")                                                          
  270   continue                                                                          
        s_jj = (2.d0*jx+1.d0)*((4.d0*jx**2+4.d0*jx-1.d0)-uu*(8.d0*jx**3   &               
     &    +12.d0*jx**2-2.d0*jx-7.d0+2.d0*yy))/(16.d0*jx*(jx+1.d0))        &               
     &    /sum_fact                                                                       
        go to 330                                                                         
!    case(8)    ! rQ21(f2', f1")                                                          
  280   continue                                                                          
        s_jj=(2.d0*jx+1.d0)*((4.d0*jx**2+4.d0*jx-1.d0)-uu*(8.d0*jx**3     &               
     &    +12.d0*jx**2-2.d0*jx+1.d0-2.d0*yy))/(16.d0*jx*(jx+1.d0))        &               
     &    /sum_fact                                                                       
        go to 330                                                                         
!    case(9)    ! P11(f1', f1")                                                           
  290   continue                                                                          
        s_jj = (2.d0*jx+1.d0)**2+(2.d0*jx+1.d0)*uu*(4.d0*jx**2+4.d0*jx    &               
     &    +1.d0-2.d0*yy) / (16.d0*jx) /sum_fact                                           
        go to 330                                                                         
!    case(10)   ! P22(f2', f2")                                                           
  300   continue                                                                          
        s_jj=(2.d0*jx+1.)**2 + (2.d0*jx+1.d0)*uu*(4.d0*jx**2+4.d0*jx      &               
     &    -7.d0+2.d0*yy) / (16.d0*jx) /sum_fact                                           
        go to 330                                                                         
!    case(11)    ! oP12(f1', f2")                                                         
  310   continue                                                                          
        s_jj = (2.d0*jx+1.d0)**2 - (2.d0*jx+1.d0)*uu*(4.d0*jx**2          &               
     &    +4.d0*jx+1.d0-2.d0*yy) / (16.d0*jx) /sum_fact                                   
        go to 330                                                                         
!    case(12)    ! qP21(f2', f1")                                                         
  320   continue                                                                          
        s_jj = (2.d0*jx+1.d0)**2 - (2.d0*jx+1.d0)*uu*(4.d0*jx**2          &               
     &    +4.d0*jx-7.d0+2.d0*yy) / (16.d0*jx) /sum_fact                                   
        go to 330                                                                         
!    end select                                                                           
  330   continue                                                                          
      end if                                                                              
                                                                                          
      if( lam_u .gt. lam_l) then   ! 2P-2S                                                
!    select case (k)                                                                      
        go to (410,420,430,440,450,460,470,480,490,500,510,520) k                         
!    case(1)    ! R11(f1', f1")                                                           
  410   continue                                                                          
        s_jj = (2.d0*jx+1.d0)**2 + (2.d0*jx+1.)*uu*(4.d0*jx**2+4.d0*jx    &               
     &    +1.d0-2.d0*yy) / (16.d0*jx) /sum_fact                                           
        go to 530                                                                         
!    case(2)    ! R22(f2', f2")                                                           
  420   continue                                                                          
        s_jj = (2.d0*jx+1.d0)**2+(2.d0*jx+1.d0)*uu*(4.d0*jx**2+4.d0*jx    &               
     &    -7.d0+2.d0*yy) / (16.*jx) /sum_fact                                             
        go to 530                                                                         
!    case(3)    ! qR12(f1', f2")                                                          
  430   continue                                                                          
        s_jj = (2.d0*jx+1.d0)**2-(2.d0*jx+1.d0)*uu*(4.d0*jx**2+4.d0*jx    &               
     &    -7.d0+2.*yy) / (16.*jx) /sum_fact                                               
        go to 530                                                                         
!    case(4)    ! sR21(f2', f1")                                                          
  440   continue                                                                          
        s_jj = (2.d0*jx+1.d0)**2-(2.d0*jx+1.d0)*uu*(4.d0*jx**2+4.d0*jx    &               
     &    +1.d0-2.d0*yy) / (16.d0*jx) /sum_fact                                           
        go to 530                                                                         
!    case(5)    ! Q11(f1', f1")                                                           
  450 continue                                                                            
        s_jj=(2.d0*jx+1.d0)*((4.d0*jx**2+4.d0*jx-1.d0)+uu*(8.d0*jx**3     &               
     &    +12.d0*jx**2-2.d0*jx-7.d0+2.d0*yy)) / (16.d0*jx*(jx+1.))        &               
     &    /sum_fact                                                                       
        go to 530                                                                         
!    case(6)    ! Q22(f2', f2")                                                           
  460   continue                                                                          
        s_jj = (2.d0*jx+1.d0)*((4.d0*jx**2+4.d0*jx-1.d0)+uu*(8.d0*jx**3   &               
     &    +12.d0*jx**2-2.d0*jx+1.d0-2.d0*yy)) / (16.d0*jx*(jx+1.))        &               
     &    /sum_fact                                                                       
        go to 530                                                                         
!    case(7)    ! pQ12(f1', f2")                                                          
  470   continue                                                                          
        s_jj = (2.d0*jx+1.d0)*((4.d0*jx**2+4.d0*jx-1.d0)-uu*(8.d0*jx**3   &               
     &    +12.d0*jx**2-2.*jx+1.-2.*yy)) / (16.*jx*(jx+1.)) /sum_fact                      
        go to 530                                                                         
!    case(8)    ! rQ21(f2', f1")                                                          
  480   continue                                                                          
        s_jj = (2.d0*jx+1.d0)*((4.d0*jx**2+4.d0*jx-1.d0)-uu*(8.d0*jx**3   &               
     &    +12.d0*jx**2-2.d0*jx-7.d0+2.d0*yy)) / (16.d0*jx*(jx+1.d0))      &               
     &    /sum_fact                                                                       
        go to 530                                                                         
!    case(9)    ! P11(f1', f1")                                                           
  490   continue                                                                          
        s_jj = (2.d0*jx+1.d0)**2+(2.d0*jx+1.d0)*uu*(4.d0*jx**2+4.d0*jx    &               
     &    -7.d0+2.d0*yy) / (16.d0*(jx+1.d0)) /sum_fact                                    
        go to 530                                                                         
!    case(10)   ! P22(f2', f2")                                                           
  500   continue                                                                          
        s_jj = (2.d0*jx+1.d0)**2+(2.d0*jx+1.d0)*uu*(4.d0*jx**2+4.d0*jx    &               
     &    +1.d0-2.d0*yy) / (16.*(jx+1.)) /sum_fact                                        
        go to 530                                                                         
!    case(11)    ! oP12(f1', f2")                                                         
  510   continue                                                                          
        s_jj = (2.d0*jx+1.d0)**2-(2.d0*jx+1.d0)*uu*(4.d0*jx**2+4.d0*jx    &               
     &    +1.d0-2.d0*yy) / (16.d0*(jx+1.d0)) /sum_fact                                    
        go to 530                                                                         
!    case(12)    ! qP21(f2', f1")                                                         
  520   continue                                                                          
        s_jj = (2.d0*jx+1.d0)**2-(2.d0*jx+1.d0)*uu*(4.d0*jx**2+4.d0*jx    &               
     &    -7.d0+2.d0*yy) / (16.d0*(jx+1.)) /sum_fact                                      
        go to 530                                                                         
!    end select                                                                           
  530   continue                                                                          
      end if                                                                              
                                                                                          
      ramda_jj_inv = dev + fpu - fpl                                                      
      wavelx = 1.0d8/ramda_jj_inv                                                         
                                                                                          
      popu = dens_diatom(isp) * geu * homo_fac(isp) *                     &               
     &  (2.0*rju+1.0) * dexp(-1.43877 * (teu/tele                         &               
     &  + evu/tvib + fpu/trot))/qtot                ! number density of upper rotational s
      hnu = 1.9863d-23 * ramda_jj_inv                                     ! photon energy 
      trans_prob = (64.d0 * (3.1415916d0**4) * (0.529167d-8               &               
     &  * 4.80298d-10)**2* (re1**2)/(3.d0 * 6.6256d-27)) * s_jj           &               
     &  * ramda_jj_inv**3 /(2.d0*jx+1.d0)                                                 
      e = popu * trans_prob * hnu/(4.d0 * 3.1415916d0)                    ! emission power
                                                                                          
      ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha)
!      ncentr(j) = (1.d0/wavmin**2 - 1.d0/wavelx**2)/estep + 1                                   
      emisj(j) = e                                                                        
                                                                                          
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine calc_2S2S(isp,dev,bvu,bvl,dvu,dvl,geu,teu,               &               
     &  evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,         &               
     &  lam_u,lam_l,sou,sol)                                                              
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60)                                        
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom,                  &               
     & neq_factor_k,ls_u,ls_l                                                             
      character*5 dum(90),hund_diatom,hund                                                
      character*4 asterik,atomnm2(matoms),bandnm_diatom,                  &
     &    minus1,unknown                              
      character*4 atom_rads(3,168),diatom_bands(3,100),                        &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                          &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                     &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                              &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,  &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      integer charge_diatom,g_diatom,lo_state,s_diatom,up_state,          &               
     & g_atom1,g_atom2,gneq_diatom,check,ncentr(301)                                      
      integer vu,vl,spinu, spinl,sisi                                                     
      common/comi/nwave                                                                   
      common/comadiatom/ae_diatom(46,mdiatoms),                           &               
     & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms),    &               
     & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms),             &               
     & atomwt2(mdiatoms),be_diatom(46,mdiatoms),                          &               
     & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms),       &               
     & betae_diatom(46,mdiatoms),                                         &               
     & cross_diatom(11,121,21,mdiatoms),                                  &               
     & cross_imp_diatom(11,11,11,mdiatoms),                               &               
     & de_diatom(46,mdiatoms),diatom_mass(mdiatoms),                      &               
     & diatomwt(mdiatoms),                                                &               
     & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms),                    &               
     & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms),                 &               
     & FC_imp_diatom(0:11,0:11,11,11,mdiatoms),                           &               
     & e_elec_imp_diatom(11,11,11,mdiatoms),                              &               
     & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms),                     &               
     & lam2_diatom(46,mdiatoms),                                          &               
     & n_himp_bb_diatom(11,11,11,mdiatoms),                               &               
     & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms),    &               
     & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms),            &               
     & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms),          &               
     & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms),                    &               
     & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms),    &               
     & td_himp_bb_diatom(11,11,11,mdiatoms),                              &               
     & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms),         &               
     & wavel_cont_diatom(121,0:21,mdiatoms),                              &               
     & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms),                   &               
     & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms)                                  
      common/comidiatom/charge_diatom(mdiatoms),                          &               
     & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms),                        &               
     & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms),                   &               
     & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms),        &               
     & maxvl_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxvu_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxv_up_diatom(45,mdiatoms),                                       &               
     & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms),          &               
     & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms),           &               
     & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms),        &               
     & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms),                     &               
     & nup_diatom(45,mdiatoms),                                           &               
     & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms)                                 
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/comhund/hund_diatom(35,mdiatoms)                                             
      common/spect/calpha,slope_ratio,wavmin,wavmax,rangex                                             
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      real*8 jmin,norm                                                                    
      dimension emisj(nw)                                                                 
                                                                                          
      jmin= real(j)                                                                       
!   s_jj's are taken from kovacs's, pp.127. these are exatly same as a.schadee (pp.327) fo
!    select case (k)  ! refer to pp 261 of herzberg                                       
      go to (10,20,30,40,50,60,70,80,90,100,110,120) k                                    
!                                                                                         
!    case(1)    ! R11(f1', f1")                                                           
   10 continue                                                                            
      rju = jmin + 1.                                                                     
      rjl = jmin                                                                          
      s_jj= (rjl+1.)*(rjl+2.)/(2.*rjl+3.)                                                 
      cu1 =  1.0; cl1 =  1.0                                                                          
      cu2 =  0.0; cl2 =  0.0                                                                          
      go to 130                                                                           
!    case(2)    ! R22(f2', f2")                                                           
   20 continue                                                                            
      rju = jmin + 1.                                                                     
      rjl = jmin                                                                          
      s_jj= (rjl+0.)*(rjl+1.)/(2.*rjl+1.)                                                 
      cu1 = -1.0; cl1 = -1.0                                                                          
      cu2 =  1.0; cl2 =  1.0                                                                          
      go to 130                                                                           
!    case(3)    ! qR(f1', f2")                                                            
   30 continue                                                                            
      rju = jmin + 1.                                                                     
      rjl = jmin                                                                          
      s_jj=  0.                                                                           
      cu1 =  1.0; cl1 = -1.0                                                                          
      cu2 =  0.0; cl2 =  1.0                                                                          
      go to 130                                                                           
!    case(4)    ! sR(f2', f1")                                                            
   40 continue                                                                            
      rju = jmin + 1.                                                                     
      rjl = jmin                                                                          
      s_jj=  0.                                                                           
      cu1 = -1.0; cl1 =  1.0                                                                          
      cu2 =  1.0; cl2 =  0.0                                                                          
      go to 130                                                                           
!    case(5)    ! Q11(f1', f1")                                                           
   50 continue                                                                            
      rju = jmin + 0.                                                                     
      rjl = jmin                                                                          
      s_jj= 0.                                                                            
      cu1 =  1.0; cl1 =  1.0                                                                          
      cu2 =  0.0; cl2 =  0.0                                                                          
      go to 130                                                                           
!    case(6)    ! Q22(f2', f2")                                                           
   60 continue                                                                            
      rju = jmin + 0.                                                                     
      rjl = jmin                                                                          
      s_jj= 0.                                                                            
      cu1 = -1.0; cl1 = -1.0                                                                          
      cu2 =  1.0; cl2 =  1.0                                                                          
      go to 130                                                                           
!    case(7)    ! pQ12(f1', f2")                                                          
   70 continue                                                                            
      rju = jmin + 0.                                                                     
      rjl = jmin                                                                          
      s_jj= (rjl+0.)/(2.*rjl-1.)/(2.*rjl+1.)                                              
      cu1 =  1.0; cl1 = -1.0                                                                          
      cu2 =  0.0; cl2 =  1.0                                                                          
      go to 130                                                                           
!    case(8)    ! rQ(f2', f1")                                                            
   80 continue                                                                            
      rju = jmin + 0.;    rjl = jmin                                                      
      s_jj= (rjl+1.)/(2.*rjl+1.)/(2.*rjl+3.)                                              
      cu1 = -1.0; cl1 =  1.0                                                                          
      cu2 =  1.0; cl2 =  0.0                                                                          
      go to 130                                                                           
!    case(9)    ! P11(f1', f1")                                                           
   90 continue                                                                            
      rju = jmin - 1.;                                                                    
      rjl = jmin                                                                          
      s_jj= (rjl+0.)*(rjl+1.)/(2.*rjl+1.)                                                 
      cu1 =  1.0; cl1 =  1.0                                                                          
      cu2 =  0.0; cl2 =  0.0                                                                          
      go to 130                                                                           
!    case(10)    ! P22(f2', f2")                                                          
  100 continue                                                                            
      rju = jmin - 1.;                                                                    
      rjl = jmin                                                                          
      s_jj= (rjl+0.)*(rjl-1.)/(2.*rjl-1.)                                                 
      cu1 = -1.0; cl1 = -1.0                                                                          
      cu2 =  1.0; cl2 =  1.0                                                                          
      go to 130                                                                           
!    case(11)    ! oP(f1', f2")                                                           
  110 continue                                                                            
      rju = jmin - 1.                                                                     
      rjl = jmin                                                                          
      s_jj=  0.                                                                           
      cu1 =  1.0; cl1 = -1.0                                                                          
      cu2 =  0.0; cl2 =  1.0                                                                          
      go to 130                                                                           
! case(12)    ! qP(pf2', f1")                                                             
  120 continue                                                                            
      rju = jmin - 1.                                                                     
      rjl = jmin                                                                          
      s_jj=  0.                                                                           
      cu1 = -1.0; cl1 =  1.0                                                                          
      cu2 =  1.0; cl2 =  0.0                                                                          
      go to 130                                                                           
!    end select                                                                           
                                                                                          
! refer to kavacs, pp. 249, 222(v.16)                                                     
  130 continue                                                                            
      fpu=bvu*rju*(rju+1.)-dvu*rju**2*(rju+1.)**2+cu1/2.*sou*(rju+cu2)                    
      fpl=bvl*rjl*(rjl+1.)-dvl*rjl**2*(rjl+1.)**2+cl1/2.*sol*(rjl+cl2)                    
                                                                                          
      ramda_jj_inv = dev + fpu - fpl                                                      
      wavelx = 1.0d8/ramda_jj_inv                                                         
                                                                                          
      popu = dens_diatom(isp) * geu * homo_fac(isp) *                     &               
     &  (2.0*rju+1.0) * dexp(-1.43877d0 * (teu/tele                       &               
     &  + evu/tvib + fpu/trot))/qtot                ! number density of upper rotational s
      hnu = 1.9863d-23 * ramda_jj_inv                                     ! photon energy 
      trans_prob = (64.d0 * (3.1415916d0**4) * (0.529167d-8               &               
     &  * 4.80298d-10)**2* (re1**2)/(3.d0 * 6.6256d-27)) * s_jj           &               
     &  * ramda_jj_inv**3 /(2.d0*rjl+1.)                                                  
      e = popu * trans_prob * hnu/(4.d0 * 3.1415916d0)                       ! emission po
!                                                                                         
      ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha)
!      ncentr(j) = (1.0/wavmin**2 - 1.0/wavelx**2)/estep + 1                                     
      emisj(j) = e                                                                        
!                                                                                         
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine calc_2X2X(isp,dev,bvu,bvl,dvu,dvl,                       &               
     & geu,teu,evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,               &               
     & emisj,ncentr,lam_u,lam_l,sou,sol)                                                  
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60)                                        
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom,                  &               
     & neq_factor_k,ls_u,ls_l                                                             
      character*5 dum(90),hund_diatom,hund                                                
      character*4 asterik,atomnm2(matoms),bandnm_diatom,                  &
     &    minus1,unknown                              
      character*4 atom_rads(3,168),diatom_bands(3,100),                        &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                          &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                     &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                              &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,  &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      integer charge_diatom,g_diatom,lo_state,s_diatom,up_state,          &               
     & g_atom1,g_atom2,gneq_diatom,check,ncentr(301)                                      
      integer vu,vl,spinu, spinl,sisi                                                     
      common/comi/nwave                                                                   
      common/comadiatom/ae_diatom(46,mdiatoms),                           &               
     & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms),    &               
     & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms),             &               
     & atomwt2(mdiatoms),be_diatom(46,mdiatoms),                          &               
     & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms),       &               
     & betae_diatom(46,mdiatoms),                                         &               
     & cross_diatom(11,121,21,mdiatoms),                                  &               
     & cross_imp_diatom(11,11,11,mdiatoms),                               &               
     & de_diatom(46,mdiatoms),diatom_mass(mdiatoms),                      &               
     & diatomwt(mdiatoms),                                                &               
     & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms),                    &               
     & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms),                 &               
     & FC_imp_diatom(0:11,0:11,11,11,mdiatoms),                           &               
     & e_elec_imp_diatom(11,11,11,mdiatoms),                              &               
     & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms),                     &               
     & lam2_diatom(46,mdiatoms),                                          &               
     & n_himp_bb_diatom(11,11,11,mdiatoms),                               &               
     & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms),    &               
     & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms),            &               
     & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms),          &               
     & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms),                    &               
     & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms),    &               
     & td_himp_bb_diatom(11,11,11,mdiatoms),                              &               
     & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms),         &               
     & wavel_cont_diatom(121,0:21,mdiatoms),                              &               
     & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms),                   &               
     & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms)                                  
      common/comidiatom/charge_diatom(mdiatoms),                          &               
     & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms),                        &               
     & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms),                   &               
     & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms),        &               
     & maxvl_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxvu_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxv_up_diatom(45,mdiatoms),                                       &               
     & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms),          &               
     & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms),           &               
     & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms),        &               
     & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms),                     &               
     & nup_diatom(45,mdiatoms),                                           &               
     & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms)                                 
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/comhund/hund_diatom(35,mdiatoms)                                             
      common/spect/calpha,slope_ratio,wavmin,wavmax,rangex                                             
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      real*8 jmin,norm                                                                    
      dimension emisj(nw)                                                                 
                                                                                          
      jmin= real(j)                                                                       
!    select case (k)  ! refer to pp 261 of Herzberg                                       
      go to (10,20,30,40,50,60,70,80,90,100,110,120) k                                    
                                                                                          
!    case(1)    ! R11(f1', f1")                                                           
   10 continue                                                                            
      rju =  jmin + 1.5; rjl =  jmin + 0.5                                                                   
      cu1 = -1.0; cl1 = -1.0                                                                          
      cu2 =  0.0; cl2 =  0.0                                                                          
      go to 130                                                                           
!    case(2)    ! R22(f2', f2")                                                           
   20 continue                                                                            
      rju =  jmin + 1.5; rjl =  jmin + 0.5                                                                   
      cu1 =  1.0; cl1 =  1.0                                                                          
      cu2 =  1.0                                                                          
      cl2 =  1.0                                                                          
!    case(3)    ! qR12(f1', f2")                                                          
   30 continue                                                                            
      rju =  jmin + 1.5; rjl =  jmin + 0.5                                                                   
      cu1 = -1.0; cl1 =  1.0                                                                          
      cu2 =  0.0; cl2 =  1.0                                                                          
      go to 130                                                                           
!    case(4)    ! sR21(f2', f1")                                                          
   40 continue                                                                            
      rju =  jmin + 1.5; rjl =  jmin + 0.5                                                                   
      cu1 =  1.0; cl1 = -1.0                                                                          
      cu2 =  1.0; cl2 =  0.0                                                                          
      go to 130                                                                           
!    case(5)    ! Q11(f1', f1")                                                           
   50 continue                                                                            
      rju =  jmin + 0.5; rjl =  jmin + 0.5                                                                   
      cu1 = -1.0; cl1 = -1.0                                                                          
      cu2 =  0.0; cl2 =  0.0                                                                          
      go to 130                                                                           
!    case(6)    ! Q22(f2', f2")                                                           
   60 continue                                                                            
      rju =  jmin + 0.5; rjl =  jmin + 0.5                                                                   
      cu1 =  1.0; cl1 =  1.0                                                                          
      cu2 =  1.0; cl2 =  1.0                                                                          
      go to 130                                                                           
!    case(7)    ! pQ12(f1', f2")                                                          
   70 continue                                                                            
      rju =  jmin + 0.5; rjl =  jmin + 0.5                                                                   
      cu1 = -1.0; cl1 =  1.0                                                                          
      cu2 =  0.0; cl2 =  1.0                                                                          
      go to 130                                                                           
!    case(8)    ! rQ21(f2', f1")                                                          
   80 continue                                                                            
      rju =  jmin + 0.5; rjl =  jmin + 0.5                                                                   
      cu1 =  1.0; cl1 = -1.0                                                                          
      cu2 =  1.0; cl2 =  0.0                                                                          
      go to 130                                                                           
!    case(9)    ! P11(f1', f1")                                                           
   90 continue                                                                            
      rju =  jmin - 0.5; rjl =  jmin + 0.5                                                                   
      cu1 = -1.0; cl1 = -1.0                                                                          
      cu2 =  0.0; cl2 =  0.0                                                                          
      go to 130                                                                           
!    case(10)    ! P22(f2', f2")                                                          
  100 continue                                                                            
      rju =  jmin - 0.5; rjl =  jmin + 0.5                                                                   
      cu1 =  1.0; cl1 =  1.0                                                                          
      cu2 =  1.0; cl2 =  1.0                                                                          
      go to 130                                                                           
!    case(11)    ! oP12(f1', f2")                                                         
  110 continue                                                                            
      rju =  jmin - 0.5; rjl =  jmin + 0.5                                                                   
      cu1 = -1.0; cl1 =  1.0                                                                          
      cu2 =  0.0; cl2 =  1.0                                                                          
      go to 130                                                                           
!    case(12)    ! qP21(f2', f1")                                                         
  120 continue                                                                            
      rju =  jmin - 0.5; rjl =  jmin + 0.5                                                                   
      cu1 =  1.0; cl1 = -1.0                                                                          
      cu2 =  1.0; cl2 =  0.0                                                                          
      go to 130                                                                           
!    end select                                                                           
                                                                                          
! refer to kavacs, pp 61, 63, and 127, Herzberg 232(v.8)                                  
  130 continue                                                                            
      yu = sou/bvu                                                                        
      yl = sol/bvl                                                                        
      fpu= bvu*((rju+0.5d0)**2 - lam_u**2 + cu1/2.d0                      &               
     &  *dsqrt(4.d0*(rju+0.5d0)**2+(yu*lam_u)**2-4.d0*yu*lam_u**2))       &               
     &  -dvu*(rju+cu2)**4                                                                 
      fpl= bvl*((rjl+0.5d0)**2 - lam_l**2 + cl1/2.d0                      &               
     &  *dsqrt(4.d0*(rjl+0.5d0)**2+(yl*lam_l)**2-4.d0*yl*lam_l**2))       &               
     &  -dvl*(rjl+cl2)**4                                                                 
      if(yu .lt. 0) yu= -yu                                                               
      if(yl .lt. 0) yl= -yl                                                               
      uuu=dsqrt(lam_u**2*yu*(yu-4.d0)+4.d0*(rju+0.5d0)**2)                &               
     &  +cu1*lam_u*(yu-2.d0)                                                              
      uul= dsqrt(lam_l**2*yl*(yl-4.d0) + 4.d0*(rjl+0.5d0)**2)             &               
     &  + cl1*lam_l*(yl-2.d0)                                                             
      ccu= 0.5d0*(uuu**2 + 4.d0*(rju+0.5d0)**2 - 4.d0*lam_u**2)                           
      ccl= 0.5d0*(uul**2 + 4.d0*(rjl+0.5d0)**2 - 4.d0*lam_l**2)                           
      if(ccu.eq.0) ccu= 1.d5                                                              
      if(ccl.eq.0) ccl= 1.d5                                                              
      jx = rjl                                                                            
                                                                                          
!    select case (k)                                                                      
      go to (210,220,230,240,250,260,270,280,290,300,310,320) k                           
!    case(1)    ! r(f1', f1")                                                             
  210 continue                                                                            
      s_jj = (jx-lam_u+0.5d0)*(jx+lam_u+1.5d0) * (uuu*uul                 &               
     &  + 4.d0*(jx-lam_u+1.5d0)*(jx+lam_u+0.5d0))**2 /                    &               
     &  (4.d0*(jx+1.d0)*ccu*ccl) /2.d0                                                    
      if(s_jj.lt.0.) s_jj= 0.25                                                             
      go to 330                                                                           
!    case(2)    ! r(f2', f2")                                                             
  220 continue                                                                            
      s_jj = (jx-lam_u+0.5d0)*(jx+lam_u+1.5d0) * (uuu*uul                 &               
     &  + 4.d0*(jx-lam_u+1.5d0)*(jx+lam_u+0.5d0))**2 /                    &               
     &  (4.d0*(jx+1.d0)*ccu*ccl) /2.d0                                                    
      if(s_jj.lt.0.) s_jj= 0.25                                                             
      go to 330                                                                           
!    case(3)    ! qr(f1', f2")                                                            
  230 continue                                                                            
      s_jj = (jx-lam_u+0.5d0)*(jx+lam_u+1.5d0) * (uuu*uul                 &               
     &  - 4.d0*(jx-lam_u+1.5d0)*(jx+lam_u+0.5d0))**2 /                    &               
     &  (4.d0*(jx+1.d0)*ccu*ccl) /2.d0                                                    
      if(s_jj.lt.0.) s_jj= 0.25                                                             
      go to 330                                                                           
!    case(4)    ! sr(f2', f1")                                                            
  240 continue                                                                            
      s_jj = (jx-lam_u+0.5d0)*(jx+lam_u+1.5d0) * (uuu*uul                 &               
     &  - 4.d0*(jx-lam_u+1.5d0)*(jx+lam_u+0.5d0))**2 /                    &               
     &  (4.d0*(jx+1.)*ccu*ccl) /2.                                                        
      if(s_jj.lt.0.) s_jj= 0.25                                                             
      go to 330                                                                           
!    case(5)    ! q(f1', f1")                                                             
  250 continue                                                                            
      s_jj = (jx+0.5d0) * ((lam_u+0.5d0)*uuu*uul + 4.d0*(lam_u-0.5d0)     &               
     &  *(jx-lam_u+0.5d0)*(jx+lam_u+0.5d0))**2 /                          &               
     &  (2.*jx*(jx+1.)*ccu*ccl) /2.d0                                                     
      if(s_jj.lt.0.) s_jj= 0.25                                                             
      go to 330                                                                           
!    case(6)    ! q(f2', f2")                                                             
  260 continue                                                                            
      s_jj = (jx+0.5) * ((lam_u+0.5)*uuu*uul + 4.*(lam_u-0.5)             &               
     &  *(jx-lam_u+0.5)*(jx+lam_u+0.5))**2 / (2.*jx*(jx+1.)               &               
     &  *ccu*ccl) /2.                                                                     
      if(s_jj.lt.0.) s_jj= 0.25                                                             
      go to 330                                                                           
!    case(7)    ! pq(f1', f2")                                                            
  270 continue                                                                            
      s_jj = (jx+0.5) * ((lam_u+0.5)*uuu*uul - 4.*(lam_u-0.5)             &               
     &  *(jx-lam_u+0.5)*(jx+lam_u+0.5))**2 /                              &               
     &  (2.*jx*(jx+1.)*ccu*ccl) /2.                                                       
      if(s_jj.lt.0.) s_jj= 0.25                                                             
      go to 330                                                                           
!    case(8)    ! rq(f2', f1")                                                            
  280 continue                                                                            
      s_jj = (jx+0.5d0) * ((lam_u+0.5d0)*uuu*uul - 4.d0*(lam_u-0.5d0)     &               
     &  *(jx-lam_u+0.5d0)*(jx+lam_u+0.5d0))**2/(2.d0*jx*(jx+1.d0)         &               
     &  *ccu*ccl)/2.d0                                                                    
      if(s_jj.lt.0.) s_jj= 0.25                                                             
      go to 330                                                                           
!    case(9)    ! p(f1', f1")                                                             
  290 continue                                                                            
      s_jj = (jx-lam_u-0.5d0)*(jx+lam_u+0.5d0) * (uuu*uul +               &               
     &  4.d0*(jx-lam_u+0.5d0)*(jx+lam_u-0.5d0))**2/(4.d0*jx*ccu*ccl)      &               
     &  /2.d0                                                                             
      if(s_jj.lt.0.) s_jj= 0.25                                                             
      go to 330                                                                           
!    case(10)    ! p(f2', f2")                                                            
  300 continue                                                                            
      s_jj = (jx-lam_u-0.5d0)*(jx+lam_u+0.5d0)*(uuu*uul+4.d0              &               
     & *(jx-lam_u+0.5d0)*(jx+lam_u-0.5d0))**2/(4.d0*jx*ccu*ccl)/2.d0                      
      if(s_jj.lt.0.) s_jj= 0.25                                                             
      go to 330                                                                           
!    case(11)    ! op(f1', f2")                                                           
  310 continue                                                                            
      s_jj = (jx-lam_u-0.5d0)*(jx+lam_u+0.5d0)*(uuu*uul-4.d0*(jx-lam_u    &               
     &  +0.5)*(jx+lam_u-0.5))**2 / (4.*jx*ccu*ccl) /2.                                    
      if(s_jj.lt.0.) s_jj= 0.25                                                             
      go to 330                                                                           
!    case(12)    ! qp(f2', f1")                                                           
  320 continue                                                                            
      s_jj = (jx-lam_u-0.5d0)*(jx+lam_u+0.5d0) * (uuu*uul                 &               
     &  - 4.d0*(jx-lam_u+0.5d0)*(jx+lam_u-0.5d0))**2 /                    &               
     &  (4.*jx*ccu*ccl) /2.d0                                                             
      if(s_jj.lt.0.) s_jj= 0.25                                                             
      go to 330                                                                           
!    end select                                                                           
  330 continue                                                                            
      ramda_jj_inv = dev + fpu - fpl                                                      
      wavelx = 1.0d8/ramda_jj_inv                                                         
      norm = 2.d0*rjl + 1.d0                                                              
! Note: these values are not correct, approximated ! depend on Y=A/B                      
      if( (lam_l.eq.1) .and. (rjl.eq.1.5) ) norm=  3.3333333333333d0                      
      if( (lam_l.eq.2) .and. (rjl.eq.1.5) ) norm=  3.34953d0                              
      if( (lam_l.eq.2) .and. (rjl.eq.2.5) ) norm=  5.2d0          ! for Yu=0.=Yl          
                                                                                          
      popu = dens_diatom(isp) * geu * homo_fac(isp) *                     &               
     &  (2.d0*rju+1.d0) * dexp(-1.43877d0 * (teu/tele                     &               
     &  + evu/tvib + fpu/trot))/qtot                              ! number density of uppe
      hnu = 1.9863d-23 * ramda_jj_inv                             ! photon energy in ergs 
      trans_prob = (64.d0 * (3.1415916d0**4) * (0.529167d-8               &               
     &  * 4.80298d-10)**2 * (re1**2)/(3.d0 * 6.6256d-27)) * s_jj          &               
     &  * ramda_jj_inv**3 /norm                                                           
      e = popu * trans_prob * hnu/(4.d0 * 3.1415916d0)            ! emission power, w/(cm3
!                                                                                         
      ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha)
!      ncentr(j) = (1.d0/wavmin**2 - 1.d0/wavelx**2)/estep + 1                                   
      emisj(j) = e                                                                        
!                                                                                         
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine calc_2X2Y(isp,dev,bvu,bvl,dvu,dvl,geu,                   &               
     &  teu,evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,     &               
     &  lam_u,lam_l,sou,sol)                                                              
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60)                                        
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom,                  &               
     & neq_factor_k,ls_u,ls_l                                                             
      character*5 dum(90),hund_diatom,hund                                                
      character*4 asterik,atomnm2(matoms),bandnm_diatom,                  &
     &    minus1,unknown                              
      character*4 atom_rads(3,168),diatom_bands(3,100),                       &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                         &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                    &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                             &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      integer charge_diatom,g_diatom,lo_state,s_diatom,up_state,          &               
     & g_atom1,g_atom2,gneq_diatom,check,ncentr(301)                                      
      integer vu,vl,spinu, spinl,sisi                                                     
      common/comi/nwave                                                                   
      common/comadiatom/ae_diatom(46,mdiatoms),                           &               
     & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms),    &               
     & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms),             &               
     & atomwt2(mdiatoms),be_diatom(46,mdiatoms),                          &               
     & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms),       &               
     & betae_diatom(46,mdiatoms),                                         &               
     & cross_diatom(11,121,21,mdiatoms),                                  &               
     & cross_imp_diatom(11,11,11,mdiatoms),                               &               
     & de_diatom(46,mdiatoms),diatom_mass(mdiatoms),                      &               
     & diatomwt(mdiatoms),                                                &               
     & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms),                    &               
     & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms),                 &               
     & FC_imp_diatom(0:11,0:11,11,11,mdiatoms),                           &               
     & e_elec_imp_diatom(11,11,11,mdiatoms),                              &               
     & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms),                     &               
     & lam2_diatom(46,mdiatoms),                                          &               
     & n_himp_bb_diatom(11,11,11,mdiatoms),                               &               
     & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms),    &               
     & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms),            &               
     & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms),          &               
     & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms),                    &               
     & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms),    &               
     & td_himp_bb_diatom(11,11,11,mdiatoms),                              &               
     & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms),         &               
     & wavel_cont_diatom(121,0:21,mdiatoms),                              &               
     & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms),                   &               
     & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms)                                  
      common/comidiatom/charge_diatom(mdiatoms),                          &               
     & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms),                        &               
     & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms),                   &               
     & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms),        &               
     & maxvl_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxvu_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxv_up_diatom(45,mdiatoms),                                       &               
     & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms),          &               
     & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms),           &               
     & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms),        &               
     & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms),                     &               
     & nup_diatom(45,mdiatoms),                                           &               
     & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms)                                 
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/comhund/hund_diatom(35,mdiatoms)                                             
      common/spect/calpha,slope_ratio,wavmin,wavmax,rangex                                             
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      real*8 jmin,norm,lm,jx                                                              
      dimension emisj(nw)                                                                 
                                                                                          
      sum_fact= 1.d0                                                                      
      if((lam_u.eq.0).and.(lam_u.eq.1)) sum_fact= 2.d0                                    
      jmin = real(j)                                                                      
!    select case (k)  ! refer to pp 261 of Herzberg                                       
      go to (10,20,30,40,50,60,70,80,90,100,110,120) k                                    
!    case(1)    ! R11(f1', f1")                                                           
   10 continue                                                                            
      rju =  jmin + 1.5; rjl =  jmin + 0.5                                                                   
      cu1 = -1.0; cl1 = -1.0                                                                          
      cu2 =  0.0; cl2 =  0.0                                                                          
      go to 130                                                                           
!    case(2)    ! r(f2', f2")                                                             
   20 continue                                                                            
      rju =  jmin + 1.5; rjl =  jmin + 0.5                                                                   
      cu1 =  1.0; cl1 =  1.0                                                                          
      cu2 =  1.0; cl2 =  1.0                                                                          
      go to 130                                                                           
!    case(3)    ! qr(f1', f2")                                                            
   30 continue                                                                            
      rju =  jmin + 1.5                                                                   
      rjl =  jmin + 0.5                                                                   
      cu1 = -1.0; cl1 =  1.0                                                                          
      cu2 =  0.0; cl2 =  1.0                                                                          
      go to 130                                                                           
!    case(4)    ! sr(f2', f1")                                                            
   40 continue                                                                            
      rju =  jmin + 1.5; rjl =  jmin + 0.5                                                                   
      cu1 =  1.0; cl1 = -1.0                                                                          
      cu2 =  1.0; cl2 =  0.0                                                                          
      go to 130                                                                           
!    case(5)    ! q(f1', f1")                                                             
   50 continue                                                                            
      rju =  jmin + 0.5; rjl =  jmin + 0.5                                                                   
      cu1 = -1.0; cl1 = -1.0                                                                          
      cu2 =  0.0; cl2 =  0.0                                                                          
      go to 130                                                                           
!    case(6)    ! q(f2', f2")                                                             
   60 continue                                                                            
      rju =  jmin + 0.5; rjl =  jmin + 0.5                                                                   
      cu1 =  1.0; cl1 =  1.0                                                                          
      cu2 =  1.0; cl2 =  1.0                                                                          
      go to 130                                                                           
!    case(7)    ! pq(f1', f2")                                                            
   70 continue                                                                            
      rju =  jmin + 0.5; rjl =  jmin + 0.5                                                                   
      cu1 = -1.0; cl1 =  1.0                                                                          
      cu2 =  0.0; cl2 =  1.0                                                                          
      go to 130                                                                           
!    case(8)    ! rq(f2', f1")                                                            
   80 continue                                                                            
      rju =  jmin + 0.5; rjl =  jmin + 0.5                                                                   
      cu1 =  1.0; cl1 = -1.0                                                                          
      cu2 =  1.0; cl2 =  0.0                                                                          
      go to 130                                                                           
!    case(9)    ! p(f1', f1")                                                             
   90 continue                                                                            
      rju =  jmin - 0.5; rjl =  jmin + 0.5                                                                   
      cu1 = -1.0; cl1 = -1.0                                                                          
      cu2 =  0.0; cl2 =  0.0                                                                          
      go to 130                                                                           
!    case(10)    ! p(f2', f2")                                                            
  100 continue                                                                            
      rju =  jmin - 0.5; rjl =  jmin + 0.5                                                                   
      cu1 =  1.0; cl1 =  1.0                                                                          
      cu2 =  1.0; cl2 =  1.0                                                                          
      go to 130                                                                           
!    case(11)    ! op(f1', f2")                                                           
  110 continue                                                                            
      rju =  jmin - 0.5; rjl =  jmin + 0.5                                                                   
      cu1 = -1.0; cl1 =  1.0                                                                          
      cu2 =  0.0; cl2 =  1.0                                                                          
      go to 130                                                                           
!    case(12)    ! qp(f2', f1")                                                           
  120 continue                                                                            
      rju =  jmin - 0.5; rjl =  jmin + 0.5                                                                   
      cu1 =  1.0; cl1 = -1.0                                                                          
      cu2 =  1.0; cl2 =  0.0                                                                          
      go to 130                                                                           
!   end select                                                                            
  130 continue                                                                            
!                                                                                         
! refer to kavacs, pp 61, 63, and 127                                                     
      yu = sou/bvu                                                                        
      yl = sol/bvl                                                                        
      if(yu .lt. 0.) yu= -yu                                                              
      if(yl .lt. 0.) yl= -yl                                                              
      fpu= bvu*((rju+0.5d0)**2 - lam_u**2 + cu1/2.d0*dsqrt(4.d0           &               
     &  *(rju+0.5d0)**2 + (yu*lam_u)**2 - 4.d0*yu*lam_u**2))              &               
     &  - dvu*(rju+cu2)**4                                                                
      fpl= bvl*((rjl+0.5d0)**2 - lam_l**2 + cl1/2.*dsqrt(4.d0*(rjl        &               
     & +0.5d0)**2 + (yl*lam_l)**2 - 4.d0*yl*lam_l**2))                    &               
     & - dvl*(rjl+cl2)**4                                                                 
      uuu= dsqrt(lam_u**2*yu*(yu-4.d0) + 4.d0*(rju+0.5d0)**2)             &               
     & + cu1*lam_u*(yu-2.d0)                                                              
      uul= dsqrt(lam_l**2*yl*(yl-4.d0) + 4.d0*(rjl+0.5d0)**2)             &               
     &  + cl1*lam_l*(yl-2.d0)                                                             
      ccu= 0.5d0*(uuu**2 + 4.d0*(rju+0.5d0)**2 - 4.d0*lam_u**2)                           
      ccl= 0.5d0*(uul**2 + 4.d0*(rjl+0.5d0)**2 - 4.d0*lam_l**2)                           
      if(ccu.eq.0.) ccu= 1.d5                                                             
      if(ccl.eq.0.) ccl= 1.d5                                                             
      jx = rjl                                                                            
      lm = real(lam_l)                                                                    
                                                                                          
      if( lam_l .gt. lam_u) then         ! 2P-2D, etc                                     
        jx = rju                                                                          
        lm = lam_u                                                                        
      end if                                                                              
                                                                                          
      if( lam_u .gt. lam_l) then         ! 2D-2P, etc                                     
!    select case (k)                                                                      
        go to (210,220,230,240,250,260,270,280,290,310,320) k                             
!    case(1)  ! R11(f1', f1")                                                             
  210   continue                                                                          
        s_jj=(jx+lm+1.5d0)*(jx+lm+2.5d0)*(uuu*uul+4.d0*(jx-lm+0.5d0)      &               
     &    *(jx+lm+0.5d0))**2 / (8.d0*(jx+1.d0)*ccu*ccl) /2.d0                             
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 330                                                                         
!    case(2)  ! R22(f2', f2")                                                             
  220   continue                                                                          
        s_jj=(jx+lm+1.5d0)*(jx+lm+2.5d0)*(uuu*uul+4.d0*(jx-lm+0.5d0)      &               
     &    *(jx+lm+0.5d0))**2 / (8.d0*(jx+1.d0)*ccu*ccl) /2.d0                             
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 330                                                                         
!    case(3)  ! qR12(f1', f2")                                                            
  230   continue                                                                          
        s_jj=(jx+lm+1.5d0)*(jx+lm+2.5d0)*(uuu*uul-4.d0*(jx-lm+0.5d0)      &               
     &   *(jx+lm+0.5d0))**2 / (8.d0*(jx+1.d0)*ccu*ccl) /2.d0                              
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 330                                                                         
!    case(4)  ! sR21(f2', f1")                                                            
  240   continue                                                                          
        s_jj=(jx+lm+1.5d0)*(jx+lm+2.5d0)*(uuu*uul-4.d0*(jx-lm+0.5d0)      &               
     &    *(jx+lm+0.5d0))**2 / (8.d0*(jx+1.)*ccu*ccl) /2.d0                               
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 330                                                                         
!    case(5)  ! Q11(f1', f1")                                                             
  250   continue                                                                          
        s_jj = (jx-lm-0.5d0)*(jx+0.5d0)*(jx+lm+1.5d0)*(uuu*uul            &               
     &    + 4.d0*(jx-lm+0.5d0)*(jx+lm+0.5d0))**2/(4.d0*jx*(jx+1.)         &               
     &    *ccu*ccl) /2.d0                                                                 
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 330                                                                         
!    case(6)  ! Q22(f2', f2")                                                             
  260   continue                                                                          
        s_jj = (jx-lm-0.5d0)*(jx+0.5d0)*(jx+lm+1.5d0)*(uuu*uul            &               
     &    + 4.d0*(jx-lm+0.5d0)*(jx+lm+0.5d0))**2 / (4.d0*jx*(jx+1.d0)     &               
     &    *ccu*ccl) /2.d0                                                                 
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 330                                                                         
!    case(7)  ! pQ12(f1', f2")                                                            
  270   continue                                                                          
        s_jj = (jx-lm-0.5d0)*(jx+0.5d0)*(jx+lm+1.5d0)*(uuu*uul            &               
     &    - 4.d0*(jx-lm+0.5d0)*(jx+lm+0.5d0))**2 /                        &               
     &    (4.d0*jx*(jx+1.d0)*ccu*ccl) /2.d0                                               
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 330                                                                         
!    case(8)  ! rQ21(f2', f1")                                                            
  280   continue                                                                          
        s_jj = (jx-lm-0.5d0)*(jx+0.5d0)*(jx+lm+1.5d0)*(uuu*uul            &               
     &    - 4.d0*(jx-lm+0.5d0)*(jx+lm+0.5d0))**2 / (4.d0*jx*(jx+1.d0)     &               
     &    *ccu*ccl) /2.                                                                   
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 330                                                                         
!    case(9)  ! P11(f1', f1")                                                             
  290   continue                                                                          
        s_jj=(jx-lm-1.5d0)*(jx-lm-0.5d0)*(uuu*uul+4.d0*(jx-lm+0.5d0)      &               
     &    *(jx+lm+0.5d0))**2 / (8.d0*jx*ccu*ccl) /2.d0                                    
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 330                                                                         
!    case(10) ! P22(f2', f2")                                                             
  300   continue                                                                          
        s_jj=(jx-lm-1.5d0)*(jx-lm-0.5d0)*(uuu*uul+4.d0*(jx-lm+0.5d0)      &               
     &    *(jx+lm+0.5d0))**2 / (8.d0*jx*ccu*ccl) /2.d0                                    
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 330                                                                         
!    case(11) ! oP12(f1', f2")                                                            
  310   continue                                                                          
        s_jj=(jx-lm-1.5d0)*(jx-lm-0.5d0)*(uuu*uul-4.d0*(jx-lm+0.5d0)      &               
     &    *(jx+lm+0.5d0))**2 / (8.d0*jx*ccu*ccl) /2.d0                                    
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 330                                                                         
!    case(12) ! qP21(f2', f1")                                                            
  320   continue                                                                          
        s_jj=(jx-lm-1.5d0)*(jx-lm-0.5d0)*(uuu*uul-4.d0*(jx-lm+0.5d0)      &               
     &    *(jx+lm+0.5d0))**2 / (8.d0*jx*ccu*ccl) /2.d0                                    
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 330                                                                         
!    end select                                                                           
  330   continue                                                                          
      end if                                                                              
                                                                                          
      if( lam_l .gt. lam_u) then                  ! 2P-2D, etc                            
!    select case (k)                                                                      
        go to (410,420,430,440,450,460,470,480,490,500,510,520) k                         
                                                                                          
!    case(1)  ! R11(f1', f1")                                                             
  410   continue                                                                          
        s_jj=(jx-lm-1.5d0)*(jx-lm-0.5d0)*(uuu*uul+4.d0*(jx-lm+0.5d0)      &               
     &    *(jx+lm+0.5d0))**2 / (8.d0*jx*ccu*ccl)/2.d0*sum_fact                            
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 530                                                                         
!    case(2)  ! R22(f2', f2")                                                             
  420   continue                                                                          
        s_jj=(jx-lm-1.5d0)*(jx-lm-0.5d0)*(uuu*uul+4.d0*(jx-lm+0.5d0)      &               
     &    *(jx+lm+0.5d0))**2 / (8.d0*jx*ccu*ccl)/2.d0*sum_fact                            
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 530                                                                         
!    case(3)  ! qR12(f1', f2")                                                            
  430   continue                                                                          
        s_jj=(jx-lm-1.5d0)*(jx-lm-0.5d0)*(uuu*uul-4.d0*(jx-lm+0.5d0)      &               
     &    *(jx+lm+0.5d0))**2 / (8.d0*jx*ccu*ccl)/2.d0*sum_fact                            
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 530                                                                         
!    case(4)  ! sR21(f2', f1")                                                            
  440   continue                                                                          
        s_jj=(jx-lm-1.5d0)*(jx-lm-0.5d0)*(uuu*uul-4.d0*(jx-lm+0.5d0)      &               
     &    *(jx+lm+0.5d0))**2 / (8.d0*jx*ccu*ccl)/2.d0*sum_fact                            
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 530                                                                         
!    case(5)  ! Q11(f1', f1")                                                             
  450   continue                                                                          
        s_jj=(jx-lm-0.5d0)*(jx+0.5d0)*(jx+lm+1.5d0)*(uuu*uul              &               
     &    +4.d0*(jx-lm+0.5d0)*(jx+lm+0.5d0))**2 /                         &               
     &    (4.d0*jx*(jx+1.d0)*ccu*ccl)/2.d0*sum_fact                                       
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 530                                                                         
!    case(6)  ! Q22(f2', f2")                                                             
  460   continue                                                                          
        s_jj=(jx-lm-0.5d0)*(jx+0.5d0)*(jx+lm+1.5d0)*(uuu*uul+4.d0         &               
     &    *(jx-lm+0.5d0)*(jx+lm+0.5d0))**2 /                              &               
     &    (4.d0*jx*(jx+1.)*ccu*ccl)/2.d0*sum_fact                                         
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 530                                                                         
!    case(7)  ! pQ12(f1', f2")                                                            
  470   continue                                                                          
        s_jj = (jx-lm-0.5d0)*(jx+0.5d0)*(jx+lm+1.5d0)*(uuu*uul            &               
     &    - 4.d0*(jx-lm+0.5d0)*(jx+lm+0.5d0))**2 /                        &               
     &    (4.d0*jx*(jx+1.)*ccu*ccl)/2.*sum_fact                                           
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 530                                                                         
!    case(8)  ! rQ21(f2', f1")                                                            
  480   continue                                                                          
        s_jj = (jx-lm-0.5d0)*(jx+0.5d0)*(jx+lm+1.5d0)*(uuu*uul            &               
     &    - 4.d0*(jx-lm+0.5d0)*(jx+lm+0.5d0))**2 /                        &               
     &    (4.d0*jx*(jx+1.d0)*ccu*ccl)/2.d0*sum_fact                                       
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 530                                                                         
!    case(9)  ! P11(f1', f1")                                                             
  490   continue                                                                          
        s_jj = (jx+lm+1.5d0)*(jx+lm+2.5d0)*(uuu*uul+4.d0*(jx-lm+0.5)      &               
     &    *(jx+lm+0.5d0))**2 /(8.d0*(jx+1.d0)*ccu*ccl)/2.d0*sum_fact                      
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 530                                                                         
!    case(10) ! P22(f2', f2")                                                             
  500   continue                                                                          
        s_jj=(jx+lm+1.5d0)*(jx+lm+2.5d0)*(uuu*uul+4.d0*(jx-lm+0.5d0)      &               
     &    *(jx+lm+0.5d0))**2/(8.d0*(jx+1.d0)*ccu*ccl)/2.d0*sum_fact                       
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 530                                                                         
!    case(11) ! oP12(f1', f2")                                                            
  510   continue                                                                          
        s_jj=(jx+lm+1.5d0)*(jx+lm+2.5d0)*(uuu*uul-4.d0*(jx-lm+0.5d0)      &               
     &    *(jx+lm+0.5))**2 / (8.d0*(jx+1.d0)*ccu*ccl)/2.d0*sum_fact                       
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 530                                                                         
!    case(12) ! qP21(f2', f1")                                                            
  520   continue                                                                          
        s_jj=(jx+lm+1.5d0)*(jx+lm+2.5d0)*(uuu*uul-4.d0*(jx-lm+0.5)        &               
     &    *(jx+lm+0.5d0))**2 /(8.d0*(jx+1.d0)*ccu*ccl)/2.*sum_fact                        
        if(s_jj .lt. 0.) s_jj= 0.25                                                        
        go to 530                                                                         
! end select                                                                              
  530   continue                                                                          
      end if                                                                              
                                                                                          
      ramda_jj_inv = dev + fpu - fpl                                                      
      wavelx = 1.0d8/ramda_jj_inv                                                         
      norm = 2.d0*rjl+1.d0                                                                
      if(((lam_u.eq.1).and.(lam_l.eq.0)).and.(jx.eq.1.5)) norm=3.66667d0                  
      if(((lam_u.eq.2).and.(lam_l.eq.1)).and.(jx.eq.1.5)) norm= 3.2d0                     
      if(((lam_u.eq.2).and.(lam_l.eq.1)).and.(jx.eq.2.5)) norm= 5.8d0                     
      if(((lam_u.eq.1).and.(lam_l.eq.2)).and.(jx.eq.1.5)) norm= 2.d0                      
                                                                                          
      popu = dens_diatom(isp) * geu * homo_fac(isp) *                     &               
     &  (2.d0*rju+1.d0) * dexp(-1.43877d0 * (teu/tele                     &               
     &  + evu/tvib + fpu/trot))/qtot                ! number density of upper rotational s
      hnu = 1.9863d-23 * ramda_jj_inv               ! photon energy in ergs               
      trans_prob = (64.d0 * (3.1415916d0**4) * (0.529167d-8               &               
     &  * 4.80298d-10)**2* (re1**2)/(3.d0 * 6.6256d-27)) * s_jj           &               
     &  * ramda_jj_inv**3 /norm                                                           
      e = popu * trans_prob * hnu/(4.d0 * 3.1415916d0)                       ! emission po
                                                                                          
      ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha)
!      ncentr(j) = (1.d0/wavmin**2 - 1.d0/wavelx**2)/estep + 1                                   
      emisj(j) = e                                                                        
                                                                                          
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine calc_3P3P(isp,dev,bvu,bvl,dvu,dvl,geu,teu,               &               
     &  evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,         &               
     &  lam_u,lam_l,sou,sol,ls_u,ls_l)                                                    
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60)                                        
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom,                  &               
     & neq_factor_k,ls_u,ls_l                                                             
      character*5 dum(90),hund_diatom,hund                                                
      character*4 asterik,atomnm2(matoms),bandnm_diatom,                  &
     &    minus1,unknown                              
      character*4 atom_rads(3,168),diatom_bands(3,100),                        &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                          &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                     &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                              &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,  &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      integer charge_diatom,g_diatom,lo_state,s_diatom,up_state,          &               
     & g_atom1,g_atom2,gneq_diatom,check,ncentr(301)                                      
      integer vu,vl,spinu, spinl,sisi                                                     
      common/comi/nwave                                                                   
      common/comadiatom/ae_diatom(46,mdiatoms),                           &               
     & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms),    &               
     & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms),             &               
     & atomwt2(mdiatoms),be_diatom(46,mdiatoms),                          &               
     & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms),       &               
     & betae_diatom(46,mdiatoms),                                         &               
     & cross_diatom(11,121,21,mdiatoms),                                  &               
     & cross_imp_diatom(11,11,11,mdiatoms),                               &               
     & de_diatom(46,mdiatoms),diatom_mass(mdiatoms),                      &               
     & diatomwt(mdiatoms),                                                &               
     & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms),                    &               
     & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms),                 &               
     & FC_imp_diatom(0:11,0:11,11,11,mdiatoms),                           &               
     & e_elec_imp_diatom(11,11,11,mdiatoms),                              &               
     & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms),                     &               
     & lam2_diatom(46,mdiatoms),                                          &               
     & n_himp_bb_diatom(11,11,11,mdiatoms),                               &               
     & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms),    &               
     & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms),            &               
     & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms),          &               
     & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms),                    &               
     & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms),    &               
     & td_himp_bb_diatom(11,11,11,mdiatoms),                              &               
     & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms),         &               
     & wavel_cont_diatom(121,0:21,mdiatoms),                              &               
     & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms),                   &               
     & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms)                                  
      common/comidiatom/charge_diatom(mdiatoms),                          &               
     & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms),                        &               
     & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms),                   &               
     & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms),        &               
     & maxvl_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxvu_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxv_up_diatom(45,mdiatoms),                                       &               
     & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms),          &               
     & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms),           &               
     & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms),        &               
     & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms),                     &               
     & nup_diatom(45,mdiatoms),                                           &               
     & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms)                                 
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/comhund/hund_diatom(35,mdiatoms)                                             
      common/spect/calpha,slope_ratio,wavmin,wavmax,rangex                                             
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      dimension emisj(nw)                                                                 
      real*8 jmin, norm,jx,lm,lmu,lml                                                     
                                                                                          
      jmin= real(j)                                                                       
! Only for Hund's case Pi(b)-Pi(b)                                                        
!    select case (k)                                                                      
      go to (1,2,3,4,5,6,7,8,9,10, 11,12,13,14,15,16,17,18,19,20,         &               
     &  21,22,23,24,25,26,27) k                                                           
!    case (1)   ! P11                                                                     
    1 continue                                                                            
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                                   
      su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0; su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0                                                                            
      sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0; sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0                                                                            
      go to 28                                                                            
!    case (2)   ! Q11                                                                     
    2 continue                                                                            
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                                   
      su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0; su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0                                                                            
      sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0; sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0                                                                            
      go to 28                                                                            
!    case (3)   ! R11                                                                     
    3 continue                                                                            
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                                   
      su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0; su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0                                                                            
      sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0; sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0                                                                            
      go to 28                                                                            
!    case (4)   ! qP21                                                                    
    4 continue                                                                            
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                                   
      su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0; su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0                                                                            
      sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0; sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0                                                                            
      go to 28                                                                            
!    case (5)   ! rQ21                                                                    
    5 continue                                                                            
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                                   
      su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0; su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0                                                                            
      sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0; sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0                                                                            
      go to 28                                                                            
!    case (6)   ! sR21                                                                    
    6 continue                                                                            
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                                   
      su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0; su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0                                                                            
      sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0; sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0                                                                            
      go to 28                                                                            
!    case (7)   ! rP31                                                                    
    7 continue                                                                            
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                          
      su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0                                                        
      su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0                                                        
      sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0                                                        
      go to 28                                                                                                          
!    case (8)   ! sQ31                                                                                                  
    8 continue                                                                                                          
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                        
      su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0                                                        
      su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0                                                        
      sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0                                                        
      go to 28                                                                                                          
!    case (9)   ! tR31                                                                                                  
    9 continue                                                                                                          
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                        
      su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0                                                        
      su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0                                                        
      sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0                                                        
      go to 28                                                                                                          
!    case(10)   ! oP12                                                                                                  
   10 continue                                                                                                          
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                        
      su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0                                                        
      su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0                                                        
      sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0                                                        
      sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(11)   ! pQ12                                                                                                  
   11 continue                                                                                                          
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                        
      su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0                                                        
      su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0                                                        
      sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0                                                        
      sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(12)   ! qR12                                                                                                  
   12 continue                                                                                                          
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                        
      su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0                                                        
      su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0                                                        
      sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0                                                        
      sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(13)   ! P22                                                                                                   
   13 continue                                                                                                          
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                        
      su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0                                                        
      su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0                                                        
      sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0                                                        
      sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(14)   ! Q22                                                                                                   
   14 continue                                                                                                          
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                        
      su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0                                                        
      su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0                                                        
      sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0                                                        
      sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(15)   ! R22                                                                                                   
   15 continue                                                                                                          
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                        
      su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0                                                        
      su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0                                                        
      sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0                                                        
      sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(16)   ! qP32                                                                                                  
   16 continue                                                                                                          
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                        
      su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0                                                        
      su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0                                                        
      sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0                                                        
      sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(17)   ! rQ32                                                                                                  
   17 continue                                                                                                          
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                        
      su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0                                                        
      su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0                                                        
      sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0                                                        
      sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(18)   ! sR32                                                                                                  
   18 continue                                                                                                          
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                        
      su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0                                                        
      su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0                                                        
      sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0                                                        
      sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(19)   ! nP13                                                                                                  
   19 continue                                                                                                          
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                        
      su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0                                                        
      su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0                                                        
      sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(20)   ! oQ13                                                                                                  
   20 continue                                                                                                          
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                        
      su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0                                                        
      su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0                                                        
      sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(21)   ! pR13                                                                                                  
   21 continue                                                                                                          
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                        
      su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0                                                        
      su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0                                                        
      sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(22)   ! oP23                                                                                                  
   22 continue                                                                                                          
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                        
      su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0                                                        
      su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0                                                        
      sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(23)   ! pQ23                                                                                                  
   23 continue                                                                                                          
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                        
      su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0                                                        
      su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0                                                        
      sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(24)   ! qR23                                                                                                  
   24 continue                                                                                                          
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                        
      su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0                                                        
      su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0                                                        
      sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(25)   ! P33                                                                                                   
   25 continue                                                                                                          
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                        
      su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0                                                        
      su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0                                                        
      sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(26)   ! Q33                                                                                                   
   26 continue                                                                                                          
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                        
      su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0                                                        
      su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0                                                        
      sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(27)   ! R33                                                                                                   
   27 continue
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                          
      su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0                                                        
      su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0                                                        
      sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0                                                        
      go to 28                                                                                                          
   28 continue                                                                            
                                                                                          
      jx = rjl                                                                            
! for 3sigma of o2 molecule, herzberg pp. 223, Compare with Eq.18 (pp.72) of Kovacs       
      fpu = bvu*(rju+0.)*(rju+1.) + su1*(2.*rju+1.+su2)*bvu + su3*ls_u    &               
     & + su4*sqrt( ((2.*rju+1.+su2)*bvu)**2 + su5*ls_u**2                 &               
     & + su6*ls_u*bvu ) + su7*sou*(rju+su8) - dvu*(rju*(rju+1.))**2                       
      fpl = bvl*(rjl+0.)*(rjl+1.) + sl1*(2.*rjl+1.+sl2)*bvl + su3*ls_l    &               
     & + sl4*sqrt( ((2.*rjl+1.+sl2)*bvl)**2 + sl5*ls_l**2                 &               
     & + su6*ls_l*bvl ) + sl7*sol*(rjl+sl8) - dvl*(rjl*(rjl+1.))**2                       
                                                                                          
! check this table and compare with the table in Tatum, 1966, Canadian Journal of Physics 
!    select case(k)                                                                       
!    case (1) ! P11                                                                       
      if(k.eq.1) then                                                                     
        s_jj = jx*(jx-2.)*(2.*jx+1.)/3./(jx-1.)/(2.*jx-1.)                                
        if( jx .eq. 1.) s_jj= 0.                                                          
      end if                                                                              
!    case (2) ! Q11                                                                       
      if(k.eq.2) s_jj = (jx+1.)*(2.*jx+1.)/3./jx**3                                       
!    case (3) ! R11                                                                       
      if(k.eq.3) s_jj = (jx+1.)*(jx-1.)*(2.*jx+3.)/3./jx/(2.*jx+1.)                       
!    case (4) ! qP21                                                                      
      if(k.eq.4) then                                                                     
        s_jj = (2.*jx+1.)/3./jx**3/(jx-1.)                                                
        if( jx .eq. 1.) s_jj= 0.                                                          
      end if                                                                              
!    case (5) ! rQ21                                                                      
      if(k.eq.5) s_jj = (jx+1.)*(jx-1.)/3./jx**3                                          
!    case (6) ! sR21                                                                      
      if(k.eq.6) s_jj = 0.0                                                               
!    case (7) ! rP31                                                                      
      if(k.eq.7) s_jj = (jx+1.)*(jx-1.)/3./jx**3/(2.*jx+1.)/(2.*jx-1.)                    
!    case (8) ! sQ31                                                                      
      if(k.eq.8) s_jj = 0.0                                                               
!    case (9) ! tR31                                                                      
      if(k.eq.9) s_jj = 0.0                                                               
!    case (10) ! oP12                                                                     
      if(k.eq.10) s_jj = 0.0                                                              
!    case (11) ! pQ12                                                                     
      if(k.eq.11) s_jj = (jx-1.)*(jx+1.)/3./jx**3                                         
!    case (12) ! qR12                                                                     
      if(k.eq.12) s_jj = (2.*jx+3.)/3./jx/(jx+1.)**3                                      
!    case (13) ! P22                                                                      
      if(k.eq.13) s_jj = (jx+1.)**2*(jx-1.)**2/jx**3/3.                                   
!    case (14) ! Q22                                                                      
      if(k.eq.14) s_jj = (2.*jx+1.)*(jx**2+jx-1.)**2/                     &               
     &  (3.*jx**3*(jx+1.)**3)                                                             
!    case (15) ! R22                                                                      
      if(k.eq.15) s_jj = jx**2*(jx+2.)**2/(3.*(jx+1.)**3)                                 
!    case (16) ! qP32                                                                     
      if(k.eq.16) s_jj = (2.*jx-1.)/(3.*jx**3*(jx+1.))                                    
!    case (17) ! rQ32                                                                     
      if(k.eq.17) s_jj = jx*(jx+2.)/(3.*(jx+1.)**3)                                       
!    case (18) ! sR32                                                                     
      if(k.eq.18) s_jj = 0.0                                                              
!    case (19) ! nP13                                                                     
      if(k.eq.19) s_jj = 0.0                                                              
!    case (20) ! oQ13                                                                     
      if(k.eq.20) s_jj = 0.0                                                              
!    case (21) ! pR13                                                                     
      if(k.eq.21) s_jj = jx*(jx+2.)/(jx+1.)**3/(2.*jx+3.)/(2.*jx+1.)/3.                   
!    case (22) ! oP23                                                                     
      if(k.eq.22) s_jj = 0.0                                                              
!    case (23) ! pQ23                                                                     
      if(k.eq.23) s_jj = jx*(jx+2.)/3./(jx+1.)**3                                         
!    case (24) ! qR23                                                                     
      if(k.eq.24) s_jj = (2.*jx+1.)/3./(jx+2.)/(jx+1.)**3                                 
!    case (25) ! P33                                                                      
      if(k.eq.25) s_jj = jx*(jx+2.)*(2.*jx-1.)/3./(jx+1.)/(2.*jx+1.)                      
!    case (26) ! Q33                                                                      
      if(k.eq.26) s_jj = jx*(2.*jx+1.)/3./(jx+1.)**3                                      
!    case (27) ! R33                                                                      
      if(k.eq.27) s_jj=(jx+3.)*(jx+1.)*(2.*jx+1.)/3./(jx+2.)/(2.*jx+3.)                   
!    end select                                                                           
                                                                                          
      ramda_jj_inv = dev + fpu - fpl                                                      
      wavelx = 1.0e8/ramda_jj_inv                                                         
      norm = 2.*rjl+1.                                                                    
      if(rjl.eq.1.) norm= 4.                                                              
                                                                                          
      popu = dens_diatom(isp) * geu * homo_fac(isp) *                     &               
     &  (2.0*rju+1.0) * exp(-1.43877 * (teu/tele                          &               
     &  + evu/tvib + fpu/trot))/qtot                ! number density of upper rotational s
      hnu = 1.9863e-23 * ramda_jj_inv                                     ! photon energy 
      trans_prob = (64.0 * (3.1415916**4) * (0.529167e-8                  &               
     &  * 4.80298e-10)**2 * (re1**2)/(3.0 * 6.6256e-27))                  &               
     &  * s_jj * ramda_jj_inv**3/norm                                                     
      e = popu * trans_prob * hnu/(4.0 * 3.1415916)                       ! emission power
!                                                                                         
      ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha)
!      ncentr(j) = (1.0/wavmin**2 - 1.0/wavelx**2)/estep + 1                                     
      emisj(j) = e                                                                        
!                                                                                         
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine calc_3S3P(isp,dev,bvu,bvl,dvu,dvl,geu,teu,               &               
     &  evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,         &               
     &  lam_u,lam_l,sou,sol)                                                              
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60)                                        
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom,                  &               
     & neq_factor_k,ls_u,ls_l                                                             
      character*5 dum(90),hund_diatom,hund                                                
      character*4 asterik,atomnm2(matoms),bandnm_diatom,                  &
     &    minus1,unknown                              
      character*4 atom_rads(3,168),diatom_bands(3,100),                        &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                          &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                     &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                              &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,  &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      integer charge_diatom,g_diatom,lo_state,s_diatom,up_state,          &               
     & g_atom1,g_atom2,gneq_diatom,check,ncentr(301)                                      
      integer vu,vl,spinu, spinl,sisi                                                     
      common/comi/nwave                                                                   
      common/comadiatom/ae_diatom(46,mdiatoms),                           &               
     & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms),    &               
     & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms),             &               
     & atomwt2(mdiatoms),be_diatom(46,mdiatoms),                          &               
     & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms),       &               
     & betae_diatom(46,mdiatoms),                                         &               
     & cross_diatom(11,121,21,mdiatoms),                                  &               
     & cross_imp_diatom(11,11,11,mdiatoms),                               &               
     & de_diatom(46,mdiatoms),diatom_mass(mdiatoms),                      &               
     & diatomwt(mdiatoms),                                                &               
     & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms),                    &               
     & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms),                 &               
     & FC_imp_diatom(0:11,0:11,11,11,mdiatoms),                           &               
     & e_elec_imp_diatom(11,11,11,mdiatoms),                              &               
     & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms),                     &               
     & lam2_diatom(46,mdiatoms),                                          &               
     & n_himp_bb_diatom(11,11,11,mdiatoms),                               &               
     & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms),    &               
     & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms),            &               
     & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms),          &               
     & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms),                    &               
     & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms),    &               
     & td_himp_bb_diatom(11,11,11,mdiatoms),                              &               
     & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms),         &               
     & wavel_cont_diatom(121,0:21,mdiatoms),                              &               
     & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms),                   &               
     & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms)                                  
      common/comidiatom/charge_diatom(mdiatoms),                          &               
     & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms),                        &               
     & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms),                   &               
     & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms),        &               
     & maxvl_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxvu_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxv_up_diatom(45,mdiatoms),                                       &               
     & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms),          &               
     & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms),           &               
     & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms),        &               
     & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms),                     &               
     & nup_diatom(45,mdiatoms),                                           &               
     & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms)                                 
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/comhund/hund_diatom(35,mdiatoms)                                             
      common/spect/calpha,slope_ratio,wavmin,wavmax,rangex                                            
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      dimension emisj(nw)                                                                 
      real*8 jx                                                                           
      select case (k)                                                                     
      case (1)   ! P11                                                                    
      rju  = real(j) - 0.0;       rjl  = real(j) + 1.0                                    
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                         
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                         
      case (2)   ! Q11                                                                    
      rju  = real(j) - 0.0;       rjl  = real(j) + 0.0                                    
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                         
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                         
      case (3)   ! R11                                                                    
      rju  = real(j) + 1.0;       rjl  = real(j) + 0.0                                    
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                         
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                         
      case (4)   ! qP21                                                                   
      rju  = real(j) - 0.0;       rjl  = real(j) + 1.0                                    
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                         
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                         
      case (5)   ! rQ21                                                                   
      rju  = real(j) - 0.0;       rjl  = real(j) + 0.0                                    
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                         
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                         
      case (6)   ! sR21                                                                   
      rju  = real(j) + 1.0;       rjl  = real(j) + 0.0                                    
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                         
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                         
      case (7)   ! rP31                                                                   
      rju  = real(j) - 0.0;       rjl  = real(j) + 1.0                                    
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                         
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                         
      case (8)   ! sQ31                                                                   
      rju  = real(j) - 0.0;       rjl  = real(j) + 0.0                                    
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                         
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                         
      case (9)   ! tR31                                                                   
      rju  = real(j) + 1.0;       rjl  = real(j) + 0.0                                    
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                         
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                         
      case(10)   ! oP12                                                                   
      rju  = real(j) - 0.0;       rjl  = real(j) + 1.0                                    
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                         
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                         
      case(11)   ! pQ12                                                                   
      rju  = real(j) - 0.0;       rjl  = real(j) + 0.0                                    
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                         
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                         
      case(12)   ! qR12                                                                   
      rju  = real(j) + 1.0;       rjl  = real(j) + 0.0                                    
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                         
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                         
      case(13)   ! P22                                                                    
      rju  = real(j) - 0.0;       rjl  = real(j) + 1.0                                    
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                         
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                         
      case(14)   ! Q22                                                                    
      rju  = real(j) - 0.0;       rjl  = real(j) + 0.0                                    
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                         
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                         
      case(15)   ! R22                                                                    
      rju  = real(j) + 1.0;       rjl  = real(j) + 0.0                                    
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                         
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                         
      case(16)   ! qP32                                                                   
      rju  = real(j) - 0.0;       rjl  = real(j) + 1.0                                    
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                         
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                         
      case(17)   ! rQ32                                                                   
      rju  = real(j) - 0.0;       rjl  = real(j) + 0.0                                    
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                         
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                         
      case(18)   ! sR32                                                                   
      rju  = real(j) + 1.0;       rjl  = real(j) + 0.0                                    
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                         
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                         
      case(19)   ! nP13                                                                   
      rju  = real(j) - 0.0;       rjl  = real(j) + 1.0                                    
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                         
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                         
      case(20)   ! oQ13                                                                   
      rju  = real(j) - 0.0;       rjl  = real(j) + 0.0                                    
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                         
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                         
      case(21)   ! pR13                                                                   
      rju  = real(j) + 1.0;       rjl  = real(j) + 0.0                                    
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                         
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                         
      case(22)   ! oP23                                                                   
      rju  = real(j) - 0.0;       rjl  = real(j) + 1.0                                    
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                         
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                         
      case(23)   ! pQ23                                                                   
      rju  = real(j) - 0.0;       rjl  = real(j) + 0.0                                    
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                         
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                         
      case(24)   ! qR23                                                                   
      rju  = real(j) + 1.0;       rjl  = real(j) + 0.0                                    
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                         
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                         
      case(25)   ! P33                                                                    
      rju  = real(j) - 0.0;       rjl  = real(j) + 1.0                                    
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                         
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                         
      case(26)   ! Q33                                                                    
      rju  = real(j) - 0.0;       rjl  = real(j) + 0.0                                    
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                         
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                         
      case(27)   ! R33                                                                    
      rju  = real(j) + 1.0;       rjl  = real(j) + 0.0                                    
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                         
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                         
      end select                                                                          
                                                                                          
      yu = sou/bvu                                                                        
      yl = sol/bvl                                                                        
      yx = yl                                                                             
      jx = rjl                                                                            
      if (lam_u .gt. lam_l) then                                                          
        yx = yu                                                                           
        jx = rju                                                                          
      end if                                                                              
                                                                                          
! herzberg pp. 235                                                                        
      zu1 =  lam_u**2*yu*(yu-4.) + 4./3. + 4.*rju*(rju+1.)                                
      zl1 =  lam_l**2*yl*(yl-4.) + 4./3. + 4.*rjl*(rjl+1.)                                
      zu2 = (lam_u**2*yu*(yu-1.) - 4./9. - 2.*rju*(rju+1.) ) / (3.*zu1)                   
      zl2 = (lam_l**2*yl*(yl-1.) - 4./9. - 2.*rjl*(rjl+1.) ) / (3.*zl1)                   
                                                                                          
      fpu = bvu*(rju*(rju+1.) + su2*sqrt(zu1) + su3*zu2) + su4*dvu        &               
     & *(rju+su5)**4                                                                      
      fpl = bvl*(rjl*(rjl+1.) + su2*sqrt(zl1) + su3*zl2) + su4*dvl        &               
     & *(rjl+su5)**4                                                                      
                                                                                          
!   1u: su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                       
!   1l: sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                       
!   2u: su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                       
!   2l: sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                       
!   3u: su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                       
!   3l: sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                       
                                                                                          
                                                                                          
! a.schadee pp. 326, compare with kovacs, the last term of +-lam*(y-2) shown at pp.80 is n
! see Budo 1937 also                                                                      
      u1 = sqrt(yx*(yx-4.) + 4.*(jx+0.)**2)                                               
      u3 = sqrt(yx*(yx-4.) + 4.*(jx+1.)**2)                                               
      if(yx.ge.0) then                                                                    
        c1 = jx*(jx+1.)*yx*(yx-4.) + 2.*jx*(2.*jx+1.)*(jx-1.)*(jx+1.)                     
        c2 = yx*(yx-4.) + 4.*jx*(jx+1.)                                                   
        c3 = (jx+2.)*(jx-1.)*yx*(yx-4.) + 2.*jx*(2.*jx+1.)*(jx+1.)        &               
     &    *(jx+2.)                                                                        
      else                                                                                
        c1 = (jx+2.)*(jx-1.)*yx*(yx-4.) + 2.*jx*(2.*jx+1.)*(jx-1.)        &               
     &    *(jx+1.)                                                                        
        c2 = yx*(yx-4.) + 4.*jx*(jx+1.)                                                   
        c3 = jx*(jx+1.)*yx*(yx-4.) + 2.*jx*(2.*jx+1.)*(jx+1.)*(jx+2.)                     
      endif                                                                               
      if ( lam_l .gt. lam_u ) then   ! 3S-3P                                              
      select case(k)                                                                      
      case (1) ! P11                                                                      
      s_jj = ( (jx**2-1.)*((jx+1.)*u1 - yx + 2.*jx**2)**2 ) /             &               
     &  (12.*(2.*jx-1.)*c1)                                                               
      case (2) ! Q11                                                                      
      s_jj = ( (jx**2+jx-1.0)*u1 + (yx - 2.0)+ 2.0*jx*(jx**2-1.0) )**2/   &               
     &  (12.*jx*c1)                                                                       
      case (3) ! R11                                                                      
      s_jj = (jx*(jx+2.)*u1 + (jx+2.)*(yx-2.) + 2.*(jx-1.)*(jx+1.)**2)    &               
     &  **2 *jx / (12.*(jx+1.)*(2.*jx+3.)*c1)                                             
      case (4) ! qP21                                                                     
      s_jj = (jx**2-1.)*((jx+1.)*(yx-2.) - u1)**2 / (12.*jx*c1)                           
      case (5) ! rQ21                                                                     
      s_jj = (2.*jx+1.)*((jx**2+jx-1.)*(yx-2.) + u1)**2 /                 &               
     & (12.*jx*(jx+1.)*c1)                                                                
      case (6) ! sR21                                                                     
      s_jj = jx*(jx+2.)*(jx*(yx-2.) + u1)**2 / (12.*(jx+1.)*c1)                           
      case (7) ! rP31                                                                     
      s_jj = (jx-1.)**2*(jx+1.)*((jx+1.)*u1 - (yx-2.) - 2.*jx*(jx+1.))    &               
     &  **2 / (12.*jx*(2.*jx-1.)*c1)                                                      
      case (8) ! sQ31                                                                     
      s_jj = ((jx**2+jx-1.)*u1 + yx - 2. - 2.*(jx-1.)*(jx+1.)**2 )**2 /   &               
     & (12.*(jx+1.)*c1)                                                                   
      case (9) ! tR31                                                                     
      s_jj = jx*(jx+2.)*(jx*u1 + yx - 2.*jx**2)**2 / (12.*(2.*jx+3.)*c1)                  
      case(10) ! oP12                                                                     
      s_jj = 2.*(jx**2-1.)*yx**2 / (12.*(2.*jx-1.)*c2)                                    
      case(11) ! pQ12                                                                     
      s_jj = 2.*(jx*(yx-2.) - 2.)**2 / (12.*jx*c2)                                        
      case(12) ! qR12                                                                     
      s_jj = 2.*jx*((jx+1.)*yx - 2.*(2.*jx+3.))**2 /                      &               
     &  (12.*(jx+1)*(2.*jx+3)*c2)                                                         
      case(13) ! P22                                                                      
      s_jj = 8.*(jx+1.)**3*(jx-1.) / (12.*jx*c2)                                          
      case(14) ! Q22                                                                      
      s_jj = 8.*(2.*jx+1.)*(jx**2+jx-1.)**2 / (12.*jx*(jx+1.)*c2)                         
      case(15) ! R22                                                                      
      s_jj = 8.*jx**3*(jx+2.) / (12.*(jx+1.)*c2)                                          
      case(16) ! qP32                                                                     
      s_jj = 2.*(jx+1.)*(jx*(yx-4.) + 2.)**2 / (12.*jx*(2.*jx-1.)*c2)                     
      case(17) ! rQ32                                                                     
      s_jj = 2.*((jx+1.)*yx - 2.*jx)**2 / (12.*(jx+1.)*c2)                                
      case(18) ! sR32                                                                     
      s_jj = 2.*jx*(jx+2.)*yx**2 / (12.*(2.*jx+3.)*c2)                                    
      case(19) ! nP13                                                                     
      s_jj = (jx**2-1.)*((jx+1.)*u3 + yx - 2. - 2.*jx*(jx+2.))**2 /       &               
     & (12.*(2.*jx-1.)*c3)                                                                
      case(20) ! oQ13                                                                     
      s_jj = ((jx**2+jx-1.)*u3 -(yx-2.) - 2.*jx**2*(jx+2.))**2 /          &               
     & (12.*jx*c3)                                                                        
      case(21) ! pR13                                                                     
      s_jj = jx*(jx+2.)**2*(jx*u3 - (yx-2.) - 2.*jx*(jx+1.))**2 /         &               
     & (12.*(jx+1.)*(2.*jx+3.)*c3)                                                        
      case(22) ! oP23                                                                     
      s_jj = (jx**2-1.)*(u3 + (jx+1.)*(jx-2.))**2 / (12.*jx*c3)                           
      case(23) ! pQ23                                                                     
      s_jj = (2.*jx+1.)*((jx**2+jx-1.)*(yx-2.) - u3)**2 /                 &               
     & (12.*jx*(jx+1.)*c3)                                                                
      case(24) ! qR23                                                                     
      s_jj = jx*(jx+2.)*(jx*(yx-2.) - u3)**2 / (12.*(jx+1.)*c3)                           
      case(25) ! P33                                                                      
      s_jj = (jx+1.)*((jx**2-1.)*u3 + (jx-1.)*(yx-2.) + 2.*jx**2          &               
     & *(jx+2.))**2 / (12.*jx*(2.*jx-1.)*c3)                                              
      case(26) ! Q33                                                                      
      s_jj = ((jx**2+jx-1.)*u3 - (yx-2.) + 2.*jx*(jx+1.)*(jx+2.))**2 /    &               
     & (12.*(jx+1.)*c3)                                                                   
      case(27) ! R33                                                                      
      s_jj = jx*(jx+2.)*(jx*u3 - (yx-2.) + 2.*jx*(jx+2))**2 /             &               
     & (12.*(2.*jx+3.)*c3)                                                                
      end select                                                                          
      end if                                                                              
                                                                                          
      if ( lam_u .gt. lam_l ) then   ! 3P-3S                                              
      select case(k)                                                                      
      case (1) ! P11                                                                      
      s_jj = (jx*(jx+2.)*u1 + (jx+2.)*(yx-2.) + 2.*(jx-1.)*(jx+1.)**2 )   &               
     & **2 *jx / (12.*(jx+1.)*(2.*jx+3.)*c1)                                              
      case (2) ! Q11                                                                      
      s_jj = ( (jx**2+jx-1.0)*u1 + (yx - 2.0) + 2.0*jx*(jx**2-1.0) )**2   &               
     &  / (12.*jx*c1)                                                                     
      case (3) ! R11                                                                      
      s_jj = ( (jx**2-1.)*((jx+1.)*u1 - yx + 2.*jx**2)**2 ) /             &               
     & (12.*(2.*jx-1.)*c1)                                                                
      case (4) ! qP21                                                                     
      s_jj = 2.*jx*((jx+1.)*yx - 2.*(2.*jx+3.))**2 / (12.*(jx+1)          &               
     &  *(2.*jx+3)*c2)                                                                    
      case (5) ! rQ21                                                                     
      s_jj = 2.*(jx*(yx-2.) - 2.)**2 / (12.*jx*c2)                                        
      case (6) ! sR21                                                                     
      s_jj = 2.*(jx**2-1.)*yx**2 / (12.*(2.*jx-1.)*c2)                                    
      case (7) ! rP31                                                                     
      s_jj = jx*(jx+2.)**2*(jx*u3 - (yx-2.) - 2.*jx*(jx+1.))**2 /         &               
     & (12.*(jx+1.)*(2.*jx+3.)*c3)                                                        
      case (8) ! sQ31                                                                     
      s_jj = ((jx**2+jx-1.)*u3 -(yx-2.) - 2.*jx**2*(jx+2.))**2 /          &               
     & (12.*jx*c3)                                                                        
      case (9) ! tR31                                                                     
      s_jj = (jx**2-1.)*((jx+1.)*u3 + yx - 2. - 2.*jx*(jx+2.))**2 /       &               
     & (12.*(2.*jx-1.)*c3)                                                                
      case(10) ! oP12                                                                     
      s_jj = jx*(jx+2.)*(jx*(yx-2.) + u1)**2 / (12.*(jx+1.)*c1)                           
      case(11) ! pQ12                                                                     
      s_jj = (2.*jx+1.)*((jx**2+jx-1.)*(yx-2.) + u1)**2 /                 &               
     & (12.*jx*(jx+1.)*c1)                                                                
      case(12) ! qR12                                                                     
      s_jj = (jx**2-1.)*((jx+1.)*(yx-2.) - u1)**2 / (12.*jx*c1)                           
      case(13) ! P22                                                                      
      s_jj = 8.*jx**3*(jx+2.) / (12.*(jx+1.)*c2)                                          
      case(14) ! Q22                                                                      
      s_jj = 8.*(2.*jx+1.)*(jx**2+jx-1.)**2 / (12.*jx*(jx+1.)*c2)                         
      case(15) ! R22                                                                      
      s_jj = 8.*(jx+1.)**3*(jx-1.) / (12.*jx*c2)                                          
      case(16) ! qP32                                                                     
      s_jj = jx*(jx+2.)*(jx*(yx-2.) - u3)**2 / (12.*(jx+1.)*c3)                           
      case(17) ! rQ32                                                                     
      s_jj = (2.*jx+1.)*((jx**2+jx-1.)*(yx-2.) - u3)**2 /                 &               
     &  (12.*jx*(jx+1.)*c3)                                                               
      case(18) ! sR32                                                                     
      s_jj = (jx**2-1.)*(u3 + (jx+1.)*(jx-2.))**2 / (12.*jx*c3)                           
      case(19) ! nP13                                                                     
      s_jj = jx*(jx+2.)*(jx*u1 + yx - 2.*jx**2)**2 / (12.*(2.*jx+3.)*c1)                  
      case(20) ! oQ13                                                                     
      s_jj = ((jx**2+jx-1.)*u1 + yx - 2. - 2.*(jx-1.)*(jx+1.)**2 )**2 /   &               
     & (12.*(jx+1.)*c1)                                                                   
      case(21) ! pR13                                                                     
      s_jj = (jx-1.)**2*(jx+1.)*((jx+1.)*u1 - (yx-2.) - 2.*jx*(jx+1.))    &               
     & **2 / (12.*jx*(2.*jx-1.)*c1)                                                       
      case(22) ! oP23                                                                     
      s_jj = 2.*jx*(jx+2.)*yx**2 / (12.*(2.*jx+3.)*c2)                                    
      case(23) ! pQ23                                                                     
      s_jj = 2.*((jx+1.)*yx - 2.*jx)**2 / (12.*(jx+1.)*c2)                                
      case(24) ! qR23                                                                     
      s_jj = 2.*(jx+1.)*(jx*(yx-4.) + 2.)**2 / (12.*jx*(2.*jx-1.)*c2)                     
      case(25) ! P33                                                                      
      s_jj = jx*(jx+2.)*(jx*u3 - (yx-2.) + 2.*jx*(jx+2))**2 /             &               
     & (12.*(2.*jx+3.)*c3)                                                                
      case(26) ! Q33                                                                      
      s_jj = ((jx**2+jx-1.)*u3 - (yx-2.) + 2.*jx*(jx+1.)*(jx+2.))**2 /    &               
     & (12.*(jx+1.)*c3)                                                                   
      case(27) ! R33                                                                      
      s_jj = (jx+1.)*((jx**2-1.)*u3 + (jx-1.)*(yx-2.)+ 2.*jx**2*(jx+2.))  &               
     &  **2 / (12.*jx*(2.*jx-1.)*c3)                                                      
      end select                                                                          
      end if                                                                              
                                                                                          
      ramda_jj_inv = dev + fpu - fpl                                                      
      wavelx = 1.0e8/ramda_jj_inv                                                         
                                                                                          
      popu = dens_diatom(isp) * geu * homo_fac(isp) *                     &               
     & (2.0*rju+1.0) * exp(-1.43877 * (teu/tele                           &               
     &  + evu/tvib + fpu/trot))/qtot                ! number density of upper rotational s
      hnu = 1.9863e-23 * ramda_jj_inv                                     ! photon energy 
      trans_prob = (64.0 * (3.1415916**4) * (0.529167e-8                  &               
     & * 4.80298e-10)**2 * (re1**2)/(3.0 * 6.6256e-27))                   &               
     & * s_jj * ramda_jj_inv**3/(2.*jx+1.)                                                
      e = popu * trans_prob * hnu/(4.0 * 3.1415916)                       ! emission power
!                                                                                         
      ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha)
!      ncentr(j) = (1.0/wavmin**2 - 1.0/wavelx**2)/estep + 1                                     
      emisj(j) = e                                                                        
!                                                                                         
      return                                                                              
      end                                                                                 
!*********************************************************************                    
      subroutine calc_3S3S(isp,dev,bvu,bvl,dvu,dvl,geu,teu,               &               
     &  evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,         &               
     &  lam_u,lam_l,sou,sol,ls_u,ls_l)                                                    
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60)                                        
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom,                  &               
     & neq_factor_k,ls_u,ls_l                                                             
      character*5 dum(90),hund_diatom,hund                                                
      character*4 asterik,atomnm2(matoms),bandnm_diatom,                  &
     &    minus1,unknown                              
      character*4 atom_rads(3,168),diatom_bands(3,100),                       &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                         &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                    &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                             &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      integer charge_diatom,g_diatom,lo_state,s_diatom,up_state,          &               
     & g_atom1,g_atom2,gneq_diatom,check,ncentr(301)                                      
      integer vu,vl,spinu, spinl,sisi                                                     
      common/comi/nwave                                                                   
      common/comadiatom/ae_diatom(46,mdiatoms),                           &               
     & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms),    &               
     & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms),             &               
     & atomwt2(mdiatoms),be_diatom(46,mdiatoms),                          &               
     & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms),       &               
     & betae_diatom(46,mdiatoms),                                         &               
     & cross_diatom(11,121,21,mdiatoms),                                  &               
     & cross_imp_diatom(11,11,11,mdiatoms),                               &               
     & de_diatom(46,mdiatoms),diatom_mass(mdiatoms),                      &               
     & diatomwt(mdiatoms),                                                &               
     & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms),                    &               
     & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms),                 &               
     & FC_imp_diatom(0:11,0:11,11,11,mdiatoms),                           &               
     & e_elec_imp_diatom(11,11,11,mdiatoms),                              &               
     & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms),                     &               
     & lam2_diatom(46,mdiatoms),                                          &               
     & n_himp_bb_diatom(11,11,11,mdiatoms),                               &               
     & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms),    &               
     & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms),            &               
     & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms),          &               
     & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms),                    &               
     & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms),    &               
     & td_himp_bb_diatom(11,11,11,mdiatoms),                              &               
     & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms),         &               
     & wavel_cont_diatom(121,0:21,mdiatoms),                              &               
     & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms),                   &               
     & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms)                                  
      common/comidiatom/charge_diatom(mdiatoms),                          &               
     & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms),                        &               
     & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms),                   &               
     & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms),        &               
     & maxvl_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxvu_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxv_up_diatom(45,mdiatoms),                                       &               
     & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms),          &               
     & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms),           &               
     & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms),        &               
     & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms),                     &               
     & nup_diatom(45,mdiatoms),                                           &               
     & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms)                                 
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/comhund/hund_diatom(35,mdiatoms)                                             
      common/spect/calpha,slope_ratio,wavmin,wavmax,rangex                                             
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      dimension emisj(nw)                                                                 
      real*8 jmin,jx,lm,lmu,lml                                                           
                                                                                          
      jmin= real(j)                                                                       
      sum_fact = 6.                                                                       
!  This table was not verified !                                                          
!    select case (k)                                                                      
      go to (1,2,3,4,5,6,7,8,9,10, 11,12,13,14,15,16,17,18,19,20,         &               
     & 21,22,23,24,25,26,27) k                                                            
!    case (1)   ! P11                                                                     
    1 continue                                                                                                          
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                          
      su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0                                                        
      su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0                                                        
      sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0                                                        
      go to 28                                                                                                          
!    case (2)   ! Q11                                                                                                   
    2 continue                                                                                                          
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                        
      su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0                                                        
      su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0                                                        
      sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0                                                        
      go to 28                                                                                                          
!    case (3)   ! R11                                                                                                   
    3 continue                                                                                                          
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                        
      su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0                                                        
      su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0                                                        
      sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0                                                        
      go to 28                                                                                                          
!    case (4)   ! qP21                                                                                                  
    4 continue                                                                                                          
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                        
      su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0                                                        
      su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0                                                        
      sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0                                                        
      go to 28                                                                                                          
!    case (5)   ! rQ21                                                                                                  
    5 continue                                                                                                          
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                        
      su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0                                                        
      su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0                                                        
      sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0                                                        
      go to 28                                                                                                          
!    case (6)   ! sR21                                                                                                  
    6 continue                                                                                                          
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                        
      su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0                                                        
      su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0                                                        
      sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0                                                        
      go to 28                                                                                                          
!    case (7)   ! rP31                                                                                                  
    7 continue                                                                                                          
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                        
      su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0                                                        
      su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0                                                        
      sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0                                                        
      go to 28                                                                                                          
!    case (8)   ! sQ31                                                                                                  
    8 continue                                                                                                          
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                        
      su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0                                                        
      su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0                                                        
      sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0                                                        
      go to 28                                                                                                          
!    case (9)   ! tR31                                                                                                  
    9 continue                                                                                                          
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                        
      su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0                                                        
      su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0                                                        
      sl1= 1.0; sl2= 2.0; sl3=-1.0; sl4=-1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0                                                        
      go to 28                                                                                                          
!    case(10)   ! oP12                                                                                                  
   10 continue                                                                                                          
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                        
      su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0                                                        
      su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0                                                        
      sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0                                                        
      sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(11)   ! pQ12                                                                                                  
   11 continue                                                                                                          
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                        
      su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0                                                        
      su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0                                                        
      sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0                                                        
      sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(12)   ! qR12                                                                                                  
   12 continue                                                                                                          
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                        
      su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0                                                        
      su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0                                                        
      sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0                                                        
      sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0                                                        
!    case(13)   ! P22                                                                                                   
   13 continue                                                                                                          
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                        
      su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0                                                        
      su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0                                                        
      sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0                                                        
      sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(14)   ! Q22                                                                                                   
   14 continue                                                                                                          
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                        
      su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0                                                        
      su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0                                                        
      sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0                                                        
      sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(15)   ! R22                                                                                                   
   15 continue                                                                                                          
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                        
      su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0                                                        
      su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0                                                        
      sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0                                                        
      sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(16)   ! qP32                                                                                                  
   16 continue                                                                                                          
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                        
      su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0                                                        
      su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0                                                        
      sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0                                                        
      sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(17)   ! rQ32                                                                                                  
   17 continue                                                                                                          
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                        
      su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0                                                        
      su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0                                                        
      sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0                                                        
      sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(18)   ! sR32                                                                                                  
   18 continue                                                                                                          
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                        
      su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0                                                        
      su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0                                                        
      sl1= 0.0; sl2= 0.0; sl3= 0.0; sl4= 0.0                                                        
      sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(19)   ! nP13                                                                                                  
   19 continue                                                                                                          
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                        
      su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0                                                        
      su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0                                                        
      sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(20)   ! oQ13                                                                                                  
   20 continue                                                                                                          
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                        
      su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0                                                        
      su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0                                                        
      sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(21)   ! pR13                                                                                                  
   21 continue                                                                                                          
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                        
      su1= 1.0; su2= 2.0; su3=-1.0; su4=-1.0                                                        
      su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0                                                        
      sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(22)   ! oP23                                                                                                  
   22 continue                                                                                                          
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                        
      su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0                                                        
      su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0                                                        
      sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(23)   ! pQ23                                                                                                  
   23 continue                                                                                                          
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                        
      su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0                                                        
      su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0                                                        
      sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(24)   ! qR23                                                                                                  
   24 continue                                                                                                          
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                        
      su1= 0.0; su2= 0.0; su3= 0.0; su4= 0.0                                                        
      su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0                                                        
      sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(25)   ! P33                                                                                                   
   25 continue                                                                                                          
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                        
      su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0                                                        
      su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0                                                        
      sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(26)   ! Q33                                                                                                   
   26 continue                                                                                                          
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                        
      su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0                                                        
      su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0                                                        
      sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0                                                        
      go to 28                                                                                                          
!    case(27)   ! R33                                                                                                   
   27 continue                                                                                                          
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                        
      su1=-1.0; su2=-2.0; su3=-1.0; su4= 1.0                                                        
      su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0                                                        
      sl1=-1.0; sl2=-2.0; sl3=-1.0; sl4= 1.0                                                        
      sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0                                                        
      go to 28                                                                            
!    end select                                                                           
   28 continue                                                                            
                                                                                          
      jx = rjl                                                                            
! for 3sigma of o2 molecule, herzberg pp. 223, Compare with Eq.18 (pp.72) of Kovacs       
      fpu = bvu*(rju+0.)*(rju+1.) + su1*(2.*rju+1.+su2)*bvu + su3*ls_u    &               
     &  + su4*dsqrt( ((2.*rju+1.+su2)*bvu)**2 + su5*ls_u**2               &               
     & + su6*ls_u*bvu ) + su7*sou*(rju+su8) - dvu*(rju*(rju+1.))**2                       
      fpl = bvl*(rjl+0.)*(rjl+1.) + sl1*(2.*rjl+1.+sl2)*bvl + su3*ls_l    &               
     & + sl4*sqrt( ((2.*rjl+1.+sl2)*bvl)**2 + sl5*ls_l**2                 &               
     & + su6*ls_l*bvl ) + sl7*sol*(rjl+sl8) - dvl*(rjl*(rjl+1.))**2                       
!     1u: su1= 1.0;  su2= 2.0; su3=-1.0; su4=-1.0; su5= 1.0; su6=-2.0; su7= 1.0; su8= 1.0 
!     1l: sl1= 1.0;  sl2= 2.0; sl3=-1.0; sl4=-1.0; sl5= 1.0; sl6=-2.0; sl7= 1.0; sl8= 1.0 
!     2u: su1= 0.0;  su2= 0.0; su3= 0.0; su4= 0.0; su5= 0.0; su6= 0.0; su7= 0.0; su8= 0.0 
!     2l: sl1= 0.0;  sl2= 0.0; sl3= 0.0; sl4= 0.0; sl5= 0.0; sl6= 0.0; sl7= 0.0; sl8= 0.0 
!     3u: su1=-1.0;  su2=-2.0; su3=-1.0; su4= 1.0; su5= 1.0; su6=-2.0; su7=-1.0; su8= 0.0 
!     3l: sl1=-1.0;  sl2=-2.0; sl3=-1.0; sl4= 1.0; sl5= 1.0; sl6=-2.0; sl7=-1.0; sl8= 0.0 
                                                                                          
! check this table and compare with the table in Tatum, 1966, Canadian Journal of Physics 
!    select case(k)                                                                       
!    case (1) ! P11                                                                       
      if(k.eq.1)                                                          &               
     & s_jj = (jx-1.)*(2.*jx+1.)/(2.*jx-1.)/sum_fact  ! check this formula                
!    case (2) ! Q11                                                                       
      if(k.eq.2)                                                          &               
     & s_jj = (jx-0.)*(2.*jx+3.)/(2.*jx-1.)/sum_fact                                      
!    case (3) ! R11                                                                       
      if(k.eq.3)                                                          &               
     & s_jj = (jx-0.)*(2.*jx+3.)/(2.*jx-1.)/sum_fact                                      
!    case (4) ! qP21                                                                      
      if(k.eq.4) s_jj = 0.0                                                               
!    case (5) ! rQ21                                                                      
      if(k.eq.5) s_jj = 1./jx/sum_fact                                                    
!    case (6) ! sR21                                                                      
      if(k.eq.6) s_jj = 0.0                                                               
!    case (7) ! rP31                                                                      
      if(k.eq.7) s_jj = 1./jx/(2.*jx-1.)/(2.*jx+1.)/sum_fact                              
!    case (8) ! sQ31                                                                      
      if(k.eq.8) s_jj = 0.0                                                               
!    case (9) ! tR31                                                                      
      if(k.eq.9) s_jj = 0.0                                                               
!    case (10) ! oP12                                                                     
      if(k.eq.10) s_jj = 0.0                                                              
!    case (11) ! pQ12                                                                     
      if(k.eq.11) s_jj = 1./jx/sum_fact                                                   
!    case (12) ! qR12                                                                     
      if(k.eq.12) s_jj = 0.0                                                              
!    case (13) ! P22                                                                      
      if(k.eq.13) s_jj = (jx-1.)*(jx+1.)/(jx+0.)/sum_fact                                 
!    case (14) ! Q22                                                                      
      if(k.eq.14) s_jj = (jx-0.)*(jx+2.)/(jx+1.)/sum_fact                                 
!    case (15) ! R22                                                                      
      if(k.eq.15) s_jj = (jx-0.)*(jx+2.)/(jx+1.)/sum_fact                                 
!    case (16) ! qP32                                                                     
      if(k.eq.16) s_jj = 0.0                                                              
!    case (17) ! rQ32                                                                     
      if(k.eq.17) s_jj = 1./(jx+1.)                                                       
!    case (18) ! sR32                                                                     
      if(k.eq. 18) s_jj = 0.0                                                             
!    case (19) ! nP13                                                                     
      if(k.eq.19) s_jj = 0.0                                                              
!    case (20) ! oQ13                                                                     
      if(k.eq.20) s_jj = 0.0                                                              
!    case (21) ! pR13                                                                     
      if(k.eq.21) s_jj = 1./(jx+1.)/(2.*jx+1.)/(2.*jx+3.)/sum_fact                        
!    case (22) ! oP23                                                                     
      if(k.eq.22) s_jj = 0.0                                                              
!    case (23) ! pQ23                                                                     
      if(k.eq.23) s_jj = 1./(jx+1.)/sum_fact                                              
!    case (24) ! qR23                                                                     
      if(k.eq.24) s_jj = 0.0                                                              
!    case (25) ! P33                                                                      
      if(k.eq.2) s_jj = (jx+1.)*(2.*jx-1.)/(2.*jx+1.)/sum_fact                            
!    case (26) ! Q33                                                                      
      if(k.eq.26) s_jj = (jx+2.)*(2.*jx+1.)/(2.*jx+3.)/sum_fact                           
!    case (27) ! R33                                                                      
      if(k.eq.27) s_jj = (jx+2.)*(2.*jx+1.)/(2.*jx+3.)/sum_fact                           
!    end select                                                                           
                                                                                          
      ramda_jj_inv = dev + fpu - fpl                                                      
      wavelx = 1.0e8/ramda_jj_inv                                                         
                                                                                          
      popu = dens_diatom(isp) * geu * homo_fac(isp) *                     &               
     &  (2.0*rju+1.0) * dexp(-1.43877 * (teu/tele                         &               
     &  + evu/tvib + fpu/trot))/qtot                 ! number density of upper rotational 
      hnu = 1.9863e-23 * ramda_jj_inv                                     ! photon energy 
      trans_prob=(64.0*(3.1415916**4)*(0.529167e-8 * 4.80298e-10)**2      &               
     &  * (re1**2)/(3.0 * 6.6256e-27)) * s_jj * ramda_jj_inv**3/          &               
     &  (2.*rjl+1.)                                                                       
      e = popu * trans_prob * hnu/(4.0 * 3.1415916)                       ! emission power
!                                                                                         
      ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha)
!      ncentr(j) = (1.0/wavmin**2 - 1.0/wavelx**2)/estep + 1                                     
      emisj(j) = e                                                                        
!                                                                                         
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine calc_3X3X(isp,dev,bvu,bvl,dvu,dvl,geu,teu,               &               
     & evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,          &               
     & lam_u,lam_l,sou,sol)                                                               
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60)                                        
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom,                  &               
     & neq_factor_k,ls_u,ls_l                                                             
      character*5 dum(90),hund_diatom,hund                                                
      character*4 asterik,atomnm2(matoms),bandnm_diatom,                  &
     &    minus1,unknown                              
      character*4 atom_rads(3,168),diatom_bands(3,100),                         &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                           &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                      &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                               &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,   &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      integer charge_diatom,g_diatom,lo_state,s_diatom,up_state,          &               
     & g_atom1,g_atom2,gneq_diatom,check,ncentr(301)                                      
      integer vu,vl,spinu, spinl,sisi                                                     
      common/comi/nwave                                                                   
      common/comadiatom/ae_diatom(46,mdiatoms),                           &               
     & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms),    &               
     & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms),             &               
     & atomwt2(mdiatoms),be_diatom(46,mdiatoms),                          &               
     & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms),       &               
     & betae_diatom(46,mdiatoms),                                         &               
     & cross_diatom(11,121,21,mdiatoms),                                  &               
     & cross_imp_diatom(11,11,11,mdiatoms),                               &               
     & de_diatom(46,mdiatoms),diatom_mass(mdiatoms),                      &               
     & diatomwt(mdiatoms),                                                &               
     & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms),                    &               
     & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms),                 &               
     & FC_imp_diatom(0:11,0:11,11,11,mdiatoms),                           &               
     & e_elec_imp_diatom(11,11,11,mdiatoms),                              &               
     & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms),                     &               
     & lam2_diatom(46,mdiatoms),                                          &               
     & n_himp_bb_diatom(11,11,11,mdiatoms),                               &               
     & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms),    &               
     & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms),            &               
     & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms),          &               
     & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms),                    &               
     & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms),    &               
     & td_himp_bb_diatom(11,11,11,mdiatoms),                              &               
     & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms),         &               
     & wavel_cont_diatom(121,0:21,mdiatoms),                              &               
     & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms),                   &               
     & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms)                                  
      common/comidiatom/charge_diatom(mdiatoms),                          &               
     & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms),                        &               
     & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms),                   &               
     & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms),        &               
     & maxvl_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxvu_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxv_up_diatom(45,mdiatoms),                                       &               
     & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms),          &               
     & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms),           &               
     & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms),        &               
     & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms),                     &               
     & nup_diatom(45,mdiatoms),                                           &               
     & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms)                                 
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/comhund/hund_diatom(35,mdiatoms)                                             
      common/spect/calpha,slope_ratio,wavmin,wavmax,rangex                                             
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      dimension emisj(nw)                                                                 
      real*8 jx,lm,lmu,lml,l21,l22,l41,l42,jmin,norm                                      
                                                                                          
!   s_sum = 0.                                                                            
!    do m=1, 20                                                                           
      jmin= real(j)                                                                       
!    do k=1, 27                                                                           
! When Y=0, Sum-Rule is exactrly satisfied,                                               
! but when Y.ne.0, small errors (less than 0.5)                                           
!    select case (k)                                                                      
      go to (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,          &               
     &  21,22,23,24,25,26,27) k                                                           
!    case (1)   ! P11                                                                     
    1 continue                                                                            
      rju  = jmin - 1.0;                                                                  
      rjl  = jmin + 0.0                                                                   
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                                                          
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                                                          
      u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 1.0                                                                           
      u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 =-1.0                                                                           
      go to 28                                                                            
!   case (2)   ! Q11                                                                      
    2 continue                                                                            
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                                   
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                                                          
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                                                          
      u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 1.0                                                                           
      u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 =-1.0                                                                           
      go to 28                                                                            
!    case (3)   ! R11                                                                     
    3 continue                                                                            
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                                   
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                                                          
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                                                          
      u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 1.0                                                                           
      u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 =-1.0                                                                           
      go to 28                                                                            
!    case (4)   ! qP21                                                                    
    4 continue                                                                            
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                                   
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                                                          
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                                                          
      u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 1.0                                                                           
      u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 =-1.0                                                                           
      go to 28                                                                            
!    case (5)   ! rQ21                                                                    
    5 continue                                                                            
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                                   
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                                                          
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                                                          
      u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 1.0                                                                           
      u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 =-1.0                                                                           
      go to 28                                                                            
!    case (6)   ! sR21                                                                    
    6 continue                                                                            
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                                   
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                                                          
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                                                          
      u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 1.0                                                                           
      u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 =-1.0                                                                           
      go to 28                                                                            
!    case (7)   ! rP31                                                                    
    7 continue                                                                            
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                                   
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                                                          
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                                                          
      u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 1.0                                                                           
      u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 =-1.0                                                                           
      go to 28                                                                            
!    case (8)   ! sQ31                                                                    
    8 continue                                                                            
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                                   
      su2=  1.0; su3= -2.0; su4= -1.0; su5 = 1.5                                                                           
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                                                          
      u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 1.0                                                                           
      u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 =-1.0                                                                           
      go to 28                                                                            
!    case (9)   ! tR31                                                                    
    9 continue                                                                            
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                                   
      su2=  1.0; su3= -2.0; su4= -1.0; su5 = 1.5                                                                           
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                                                          
      u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 1.0                                                                           
      u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 =-1.0                                                                           
      go to 28                                                                            
!    case(10)   ! oP12                                                                    
   10 continue                                                                            
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                                   
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                                                          
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                                                          
      u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 0.0                                                                           
      u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 = 0.0                                                                           
      go to 28                                                                            
!    case(11)   ! pQ12                                                                    
   11 continue                                                                            
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                                   
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                                                          
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                                                          
      u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 0.0                                                                           
      u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 = 0.0                                                                           
      go to 28                                                                            
!    case(12)   ! qR12                                                                    
   12 continue                                                                            
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                                   
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                                                          
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 = 0.5                                                                           
      u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 0.0                                                                           
      u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 = 0.0                                                                           
      go to 28                                                                            
!    case(13)   ! P22                                                                     
   13 continue                                                                            
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                                   
      su2=  0.0; su3=  4.0; su4= -1.0; su5=  0.5                                                                           
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                                                          
      u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 0.0                                                                           
      u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 = 0.0                                                                           
      go to 28                                                                            
!    case(14)   ! Q22                                                                     
   14 continue                                                                            
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                                   
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                                                          
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                                                          
      u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 0.0                                                                           
      u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 = 0.0                                                                           
      go to 28                                                                            
!    case(15)   ! R22                                                                     
   15 continue                                                                            
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                                   
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                                                          
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                                                          
      u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 0.0                                                                           
      u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 = 0.0                                                                           
      go to 28                                                                            
!    case(16)   ! qP32                                                                    
   16 continue                                                                            
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                                   
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                                                          
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                                                          
      u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 0.0                                                                           
      u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 = 0.0                                                                           
      go to 28                                                                            
!    case(17)   ! rQ32                                                                    
   17 continue                                                                            
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                                   
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                                                          
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                                                          
      u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 0.0                                                                           
      u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 = 0.0                                                                           
      go to 28                                                                            
!    case(18)   ! sR32                                                                    
   18 continue                                                                            
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                                   
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                                                          
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                                                          
      u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 0.0                                                                           
      u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 = 0.0                                                                           
      go to 28                                                                            
!    case(19)   ! nP13                                                                    
   19 continue                                                                            
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                                   
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                                                          
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                                                          
      u11 = 0.0; u12 = 1.0; l21 = 1.0; l22 =-1.0                                                                           
      u31 = 0.0; u32 =-1.0; l41 = 1.0; l42 = 1.0                                                                           
      go to 28                                                                            
!    case(20)   ! oQ13                                                                    
   20 continue                                                                            
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                                   
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                                                          
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                                                          
      u11 = 0.0; u12 = 1.0; l21 = 1.0; l22 =-1.0                                                                           
      u31 = 0.0; u32 =-1.0; l41 = 1.0; l42 = 1.0                                                                           
      go to 28                                                                            
!    case(21)   ! pR13                                                                    
   21 continue                                                                            
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                                   
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                                                          
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                                                          
      u11 = 0.0; u12 = 1.0; l21 = 1.0; l22 =-1.0                                                                           
      u31 = 0.0; u32 =-1.0; l41 = 1.0; l42 = 1.0                                                                           
      go to 28                                                                            
!    case(22)   ! oP23                                                                    
   22 continue                                                                            
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                                   
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                                                          
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                                                          
      u11 = 0.0; u12 = 0.0; l21 = 1.0; l22 =-1.0                                                                           
      u31 = 0.0; u32 = 0.0; l41 = 1.0; l42 = 1.0                                                                           
      go to 28                                                                            
!    case(23)   ! pQ23                                                                    
   23 continue                                                                            
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                                   
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                                                          
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                                                          
      u11 = 0.0; u12 = 0.0; l21 = 1.0; l22 =-1.0                                                                           
      u31 = 0.0; u32 = 0.0; l41 = 1.0; l42 = 1.0                                                                           
      go to 28                                                                            
!    case(24)   ! qR23                                                                    
   24 continue                                                                            
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                                   
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                                                          
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                                                          
      u11 = 0.0; u12 = 0.0; l21 = 1.0; l22 =-1.0                                                                           
      u31 = 0.0; u32 = 0.0; l41 = 1.0; l42 = 1.0                                                                           
      go to 28                                                                            
!    case(25)   ! P33                                                                     
   25 continue                                                                            
      rju  = jmin - 1.0; rjl  = jmin + 0.0                                                                   
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                                                          
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                                                          
      u11 = 1.0; u12 =-1.0; l21 = 1.0; l22 =-1.0                                                                           
      u31 = 1.0; u32 = 1.0; l41 = 1.0; l42 = 1.0                                                                           
      go to 28                                                                            
!    case(26)   ! Q33                                                                     
   26 continue                                                                            
      rju  = jmin - 0.0; rjl  = jmin + 0.0                                                                   
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                                                          
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                                                          
      u11 = 1.0; u12 =-1.0; l21 = 1.0; l22 =-1.0                                                                           
      u31 = 1.0; u32 = 1.0; l41 = 1.0; l42 = 1.0                                                                           
      go to 28                                                                            
!    case(27)   ! R33                                                                     
   27 continue                                                                            
      rju  = jmin + 1.0; rjl  = jmin + 0.0                                                                   
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                                                          
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                                                          
      u11 = 1.0; u12 =-1.0; l21 = 1.0; l22 =-1.0                                                                           
      u31 = 1.0; u32 = 1.0; l41 = 1.0; l42 = 1.0                                                          
      go to 28                                                                            
!    end select                                                                           
   28 continue                                                                            
                                                                                          
      yu = sou/bvu;                                                                       
      yl = sol/bvl                                                                        
!   yu = 0.;            yl= 0.                                                            
      jx = rjl    ;                                                                       
      lm = real(lam_l)                                                                    
                                                                                          
      lmu = real(lam_u);                                                                  
      lml= real(lam_l)                                                                    
      if( yu .lt. 0. ) then                                                               
        yu = -yu;                                                                         
        lmu= -real(lam_u)                                                                 
      end if                                                                              
      if( yl .lt. 0. ) then                                                               
        yl= -yl;                                                                          
        lml= -real(lam_l)                                                                 
      end if                                                                              
                                                                                          
      zu1 =  lam_u**2*yu*(yu-4.) + 4./3. + 4.*rju*(rju+1.)                                
      zu2 = (lam_u**2*yu*(yu-1.) - 4./9. - 2.*rju*(rju+1.)) / (3.*zu1)                    
      zl1 =  lam_l**2*yl*(yl-4.) + 4./3. + 4.*rjl*(rjl+1.)                                
      zl2 = (lam_l**2*yl*(yl-1.) - 4./9. - 2.*rjl*(rjl+1.)) / (3.*zl1)                    
                                                                                          
      fpu = bvu*(rju*(rju+1.) + su2*sqrt(zu1) + su3*zu2)                  &               
     &  + su4*dvu*(rju+su5)**4                                                            
      fpl = bvl*(rjl*(rjl+1.) + su2*sqrt(zl1) + su3*zl2)                  &               
     & + su4*dvl*(rjl+su5)**4                                                             
                                                                                          
      u1u = sqrt(lam_u**2*yu*(yu-4.) + 4.*(rju+u11)**2)                   &               
     &  + u12*lam_u*(yu-2.)                                                               
        u2l = sqrt(lam_l**2*yl*(yl-4.) + 4.*(rjl+l21)**2)                 &               
     &  + l22*lam_l*(yl-2.)                                                               
      u3u = sqrt(lam_u**2*yu*(yu-4.) + 4.*(rju+u31)**2)                   &               
     &  + u32*lam_u*(yu-2.)                                                               
      u4l = sqrt(lam_l**2*yl*(yl-4.) + 4.*(rjl+l41)**2)                   &               
     &  + l42*lam_l*(yl-2.)                                                               
                                                                                          
      c1u = lmu**2*yu*(yu-4)*(rju-lmu+1.)*(rju+lmu) + 2.*(2.*rju+1)       &               
     &  *(rju-lmu)*rju*(rju+lmu)                                                          
      c1l = lml**2*yl*(yl-4)*(rjl-lml+1.)*(rjl+lml) + 2.*(2.*rjl+1)       &               
     & *(rjl-lml)*rjl*(rjl+lml)                                                           
      c2u = lmu**2*yu*(yu-4.) + 4.*rju*(rju+1.)                                           
      c2l = lml**2*yl*(yl-4.) + 4.*rjl*(rjl+1.)                                           
      c3u = lmu**2*yu*(yu-4)*(rju-lmu)*(rju+lmu+1.) + 2.*(2.*rju+1)       &               
     & *(rju-lmu+1.)*(rju+1.)*(rju+lmu+1.)                                                
      c3l = lml**2*yl*(yl-4)*(rjl-lml)*(rjl+lml+1.) + 2.*(2.*rjl+1)       &               
     & *(rjl-lml+1.)*(rjl+1.)*(rjl+lml+1.)                                                
                                                                                          
      if(c1u.eq.0.) c1u=1.e5; if(c1l.eq.0.) c1l=1.e5                                      
      if(c2u.eq.0.) c2u=1.e5; if(c2l.eq.0.) c2l=1.e5                                      
      if(c3u.eq.0.) c3u=1.e5; if(c3l.eq.0.) c3l=1.e5                                      
                                                                                          
!    select case(k)                                                                       
!    case (1) ! p11                                                                       
      if(k.eq.1) then                                                                     
        s_jj = (jx-lm)*(jx+lm)*((jx-lm+1.)*(jx+lm-1.)*u1u*u2l             &               
     &    + (jx-lm-1.)*(jx+lm+1.)*u3u*u4l+ 8.*(jx-lm-1.)*(jx-lm)          &               
     &    *(jx+lm-1.)*(jx+lm))**2 /(16.*jx*c1u*c1l) /3.                                   
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!        s_sum= s_sum + s_jj                                                              
      end if                                                                              
!    case (2) ! q11                                                                       
      if(k.eq.2) then                                                                     
        s_jj = (2.*jx+1.)*((lm-1.)*(jx-lm+1.)*(jx+lm)*u1u*u2l             &               
     &    + (lm+1.)*(jx-lm)*(jx+lm+1.)*u3u*u4l+ 8.*lm*(jx-lm)**2          &               
     &    *(jx+lm)**2)**2 /(16.*jx*(jx+1.)*c1u*c1l) /3.                                   
       if(s_jj .lt. 0.) s_jj= 1./9.                                                         
        s_sum= s_sum + s_jj                                                               
      end if                                                                              
!    case (3) ! r11                                                                       
      if(k.eq.3) then                                                                     
        s_jj = (jx-lm+1.)*(jx+lm+1.)*((jx-lm+2.)*(jx+lm)*u1u*u2l          &               
     &    + (jx-lm)*(jx+lm+2.)*u3u*u4l + 8.*(jx-lm)*(jx-lm+1.)            &               
     &    *(jx+lm)*(jx+lm+1.))**2 /(16.*(jx+1.)*c1u*c1l) /3.                              
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!         s_sum= s_sum + s_jj                                                             
      end if                                                                              
!    case (4) ! qp21                                                                      
      if(k.eq.4) then                                                                     
        s_jj = (jx-lm)*(jx+lm)*((jx-lm+1.)*(jx+lm-1.)*u2l - (jx-lm-1.)    &               
     &    *(jx+lm+1.)*u4l - 2.*lm*(jx-lm)*(jx+lm)*(yu-2.))**2 /           &               
     &    (2.*jx*c2u*c1l) /3.                                                             
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!       s_sum= s_sum + s_jj                                                               
      end if                                                                              
!    case (5) ! rq21                                                                      
      if(k.eq.5) then                                                                     
        s_jj = (2.*jx+1.)*((lm-1.)*(jx-lm+1.)*(jx+lm)*u2l - (lm+1.)       &               
     &    *(jx-lm)*(jx+lm+1.)*u4l- 2.*lm**2*(jx-lm)*(jx+lm)*(yu-2.))      &               
     &    **2 /(2.*jx*(jx+1.)*c2u*c1l) /3.                                                
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!         s_sum= s_sum + s_jj                                                             
      end if                                                                              
!    case (6) ! sr21                                                                      
      if(k.eq.6) then                                                                     
        s_jj = (jx-lm+1.)*(jx+lm+1.)*((jx-lm+2.)*(jx+lm)*u2l - (jx-lm)    &               
     &    *(jx+lm+2.)*u4l - 2.*lm*(jx-lm)*(jx+lm)*(yu-2.))**2 /           &               
     &    (2.*(jx+1.)*c2u*c1l) /3.                                                        
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!       s_sum= s_sum + s_jj                                                               
      end if                                                                              
!    case (7) ! rp31                                                                      
      if(k.eq.7) then                                                                     
        s_jj = (jx-lm)*(jx+lm)*((jx-lm+1.)*(jx+lm-1.)*u1u*u2l             &               
     &    + (jx-lm-1.)*(jx+lm+1.)*u3u*u4l- 8.*(jx-lm)*(jx-lm)*(jx+lm)     &               
     &    *(jx+lm))**2 /(16.*jx*c3u*c1l) /3.                                              
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!       s_sum= s_sum + s_jj                                                               
      end if                                                                              
!    case (8) ! sq31                                                                      
      if(k.eq.8) then                                                                     
        s_jj = (2.*jx+1.)*((lm-1.)*(jx-lm+1.)*(jx+lm)*u1u*u2l + (lm+1.)   &               
     &    *(jx-lm)*(jx+lm+1.)*u3u*u4l - 8.*lm*(jx-lm)*(jx-lm+1.)*(jx+lm)  &               
     &    *(jx+lm+1.))**2 /(16.*jx*(jx+1.)*c3u*c1l) /3.                                   
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!        s_sum= s_sum + s_jj                                                              
      end if                                                                              
!    case (9) ! tr31                                                                      
      if(k.eq.9) then                                                                     
        s_jj = (jx-lm+1.)*(jx+lm+1.)*((jx-lm+2.)*(jx+lm)*u1u*u2l          &               
     &    + (jx-lm)*(jx+lm+2.)*u3u*u4l - 8.*(jx-lm)*(jx-lm+2.)*(jx+lm)    &               
     &    *(jx+lm+2.))**2 /(16.*(jx+1.)*c3u*c1l) /3.                                      
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!       s_sum= s_sum + s_jj                                                               
      end if                                                                              
!    case (10) ! op12                                                                     
      if(k.eq.10) then                                                                    
        s_jj = (jx-lm)*(jx+lm)*((jx-lm+1.)*(jx+lm-1.)*u1u - (jx-lm-1.)    &               
     &    *(jx+lm+1.)*u3u - 2.*lm*(jx-lm-1.)*(jx+lm-1.)*(yl-2.))**2 /     &               
     &    (2.*jx*c1u*c2l) /3.                                                             
        if(s_jj .lt. 0.) s_jj= 1./9.                                                        
!        s_sum= s_sum + s_jj                                                              
      end if                                                                              
!    case (11) ! pq12                                                                     
      if(k.eq.11) then                                                                    
        s_jj = (2.*jx+1.)*((lm-1.)*(jx-lm+1.)*(jx+lm)*u1u - (lm+1.)       &               
     &    *(jx-lm)*(jx+lm+1.)*u3u - 2.*lm**2*(jx-lm)*(jx+lm)*(yl-2.))     &               
     &    **2 /(2.*jx*(jx+1.)*c1u*c2l) /3.                                                
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!       s_sum= s_sum + s_jj                                                               
      end if                                                                              
!    case (12) ! qr12                                                                     
      if(k.eq.12) then                                                                    
        s_jj = (jx-lm+1.)*(jx+lm+1.)*((jx-lm+2.)*(jx+lm)*u1u - (jx-lm)    &               
     &    *(jx+lm+2.)*u3u - 2.*lm*(jx-lm+1.)*(jx+lm+1.)*(yl-2.))**2 /     &               
     &    (2.*(jx+1.)*c1u*c2l) /3.                                                        
        if(s_jj .lt. 0.) s_jj= 1./9.                                                        
!       s_sum= s_sum + s_jj                                                               
      end if                                                                              
!    case (13) ! p22                                                                      
      if(k.eq.13) then                                                                    
        s_jj = 4.*(jx-lm)*(jx+lm)*(0.5*lm**2*(yu-2.)*(yl-2.)              &               
     &    + (jx-lm-1.)*(jx+lm+1.) + (jx-lm+1.)*(jx+lm-1.))**2 /           &               
     &    (jx*c2u*c2l) /3.                                                                
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!       s_sum= s_sum + s_jj                                                               
      end if                                                                              
!    case (14) ! q22                                                                      
      if(k.eq.14) then                                                                    
        s_jj = 4.*(2.*jx+1.)*(0.5*lm**3*(yu-2.)*(yl-2.) + (lm+1.)         &               
     &    *(jx-lm)*(jx+lm+1.) + (lm-1.)*(jx-lm+1.)*(jx+lm))**2 /          &               
     &    (jx*(jx+1.)*c2u*c2l) /3.                                                        
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!        s_sum= s_sum + s_jj                                                              
      end if                                                                              
!    case (15) ! r22                                                                      
      if(k.eq.15) then                                                                    
        s_jj = 4.*(jx-lm+1.)*(jx+lm+1.)*(0.5*lm**2*(yu-2.)*(yl-2.)        &               
     &    + (jx-lm)*(jx+lm+2.) + (jx-lm+2.)*(jx+lm))**2 /((jx+1.)         &               
     &    *c2u*c2l) /3.                                                                   
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!       s_sum= s_sum + s_jj                                                               
      end if                                                                              
!    case (16) ! qp32                                                                     
      if(k.eq.16) then                                                                    
        s_jj = (jx-lm)*(jx+lm)*((jx-lm+1.)*(jx+lm-1.)*u1u - (jx-lm-1.)    &               
     &    *(jx+lm+1.)*u3u + 2.*lm*(jx-lm)*(jx+lm)*(yl-2.))**2 /           &               
     &    (2.*jx*c3u*c2l) /3.                                                             
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!       s_sum= s_sum + s_jj                                                               
      end if                                                                              
!    case (17) ! rq32                                                                     
      if(k.eq.17) then                                                                    
        s_jj = (2.*jx+1.)*((lm-1.)*(jx-lm+1.)*(jx+lm)*u1u - (lm+1.)       &               
     &    *(jx-lm)*(jx+lm+1.)*u3u + 2.*lm**2*(jx-lm+1.)*(jx+lm+1.)        &               
     &    *(yl-2.))**2 /(2.*jx*(jx+1.)*c3u*c2l) /3.                                       
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!       s_sum= s_sum + s_jj                                                               
      end if                                                                              
!    case (18) ! sr32                                                                     
      if(k.eq.18) then                                                                    
        s_jj = (jx-lm+1.)*(jx+lm+1.)*((jx-lm+2.)*(jx+lm)*u1u - (jx-lm)    &               
     &    *(jx+lm+2.)*u3u + 2.*lm*(jx-lm+2.)*(jx+lm+2.)*(yl-2.))**2 /     &               
     &    (2.*(jx+1.)*c3u*c2l) /3.                                                        
        if(s_jj .lt. 0.) s_jj= 1./9.                                                       
!       s_sum= s_sum + s_jj                                                               
      end if                                                                              
!    case (19) ! np13                                                                     
      if(k.eq.19) then                                                                    
        s_jj = (jx-lm)*(jx+lm)*((jx-lm+1.)*(jx+lm-1.)*u1u*u2l             &               
     &    + (jx-lm-1.)*(jx+lm+1.)*u3u*u4l - 8.*(jx-lm-1.)*(jx-lm+1.)      &               
     &    *(jx+lm-1.)*(jx+lm+1.))**2 /(16.*jx*c1u*c3l) /3.                                
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!        s_sum= s_sum + s_jj                                                              
      end if                                                                              
!    case (20) ! oq13                                                                     
      if(k.eq.20) then                                                                    
        s_jj = (2.*jx+1.)*((lm-1.)*(jx-lm+1.)*(jx+lm)*u1u*u2l + (lm+1.)   &               
     &    *(jx-lm)*(jx+lm+1.)*u3u*u4l -8.*lm*(jx-lm)*(jx-lm+1.)*(jx+lm)   &               
     &    *(jx+lm+1.))**2 /(16.*jx*(jx+1.)*c1u*c3l) /3.                                   
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!       s_sum= s_sum + s_jj                                                               
      end if                                                                              
!    case (21) ! pr13                                                                     
      if(k.eq.21) then                                                                    
        s_jj = (jx-lm+1.)*(jx+lm+1.)*((jx-lm+2.)*(jx+lm)*u1u*u2l          &               
     &    + (jx-lm)*(jx+lm+2.)*u3u*u4l - 8.*(jx-lm+1.)**2*(jx+lm+1.)**2)  &               
     &    **2 /(16.*(jx+1.)*c1u*c3l) /3.                                                  
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!       s_sum= s_sum + s_jj                                                               
      end if                                                                              
!    case (22) ! op23                                                                     
      if(k.eq.22) then                                                                    
        s_jj = (jx-lm)*(jx+lm)*((jx-lm+1.)*(jx+lm-1.)*u2l - (jx-lm-1.)    &               
     &    *(jx+lm+1.)*u4l + 2.*lm*(jx-lm+1.)*(jx+lm+1.)*(yu-2.))**2 /     &               
     &    (2.*jx*c2u*c3l) /3.                                                             
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!       s_sum= s_sum + s_jj                                                               
      end if                                                                              
!    case (23) ! pq23                                                                     
      if(k.eq.23) then                                                                    
        s_jj = (2.*jx+1.)*((lm-1.)*(jx-lm+1.)*(jx+lm)*u2l - (lm+1.)       &               
     &    *(jx-lm)*(jx+lm+1.)*u4l + 2.*lm**2*(jx-lm+1.)*(jx+lm+1.)        &               
     &    *(yu-2.))**2 /(2.*jx*(jx+1.)*c2u*c3l) /3.                                       
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!       s_sum= s_sum + s_jj                                                               
      end if                                                                              
!    case (24) ! qr23                                                                     
      if(k.eq.24) then                                                                    
        s_jj = (jx-lm+1.)*(jx+lm+1.)*((jx-lm+2.)*(jx+lm)*u2l - (jx-lm)    &               
     &    *(jx+lm+2.)*u4l + 2.*lm*(jx-lm+1.)*(jx+lm+1.)*(yu-2.))**2 /     &               
     &    (2.*(jx+1.)*c2u*c3l) /3.                                                        
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!       s_sum= s_sum + s_jj                                                               
      end if                                                                              
!    case (25) ! p33                                                                      
      if(k.eq.25) then                                                                    
        s_jj = (jx-lm)*(jx+lm)*((jx-lm+1.)*(jx+lm-1.)*u1u*u2l             &               
     &    + (jx-lm-1.)*(jx+lm+1.)*u3u*u4l + 8.*(jx-lm)*(jx-lm+1.)         &               
     &    *(jx+lm)*(jx+lm+1.))**2 /(16.*jx*c3u*c3l) /3.                                   
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!       s_sum= s_sum + s_jj                                                               
      end if                                                                              
!    case (26) ! q33                                                                      
      if(k.eq.26) then                                                                    
        s_jj = (2.*jx+1.)*((lm-1.)*(jx-lm+1.)*(jx+lm)*u1u*u2l + (lm+1.)   &               
     &    *(jx-lm)*(jx+lm+1.)*u3u*u4l + 8.*lm*(jx-lm+1.)**2*(jx+lm+1.)    &               
     &    **2)**2 / (16.*jx*(jx+1.)*c3u*c3l) /3.                                          
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!       s_sum= s_sum + s_jj                                                               
      end if                                                                              
!    case (27) ! r33                                                                      
      if(k.eq.27) then                                                                    
        s_jj = (jx-lm+1.)*(jx+lm+1.)*((jx-lm+2.)*(jx+lm)*u1u*u2l          &               
     &    + (jx-lm)*(jx+lm+2.)*u3u*u4l + 8.*(jx-lm+1.)*(jx-lm+2.)         &               
     &    *(jx+lm+1.)*(jx+lm+2.))**2 /(16.*(jx+1.)*c3u*c3l) /3.                           
        if(s_jj .lt. 0.) s_jj= 1./9.                                                         
!        s_sum= s_sum + s_jj                                                              
      end if                                                                              
                                                                                          
      ramda_jj_inv = dev + fpu - fpl                                                      
      wavelx = 1.0e8/ramda_jj_inv                                                         
      norm = 2.*rjl+1.                                                                    
      if( (lam_u.eq.1).and.(rjl.eq.1.).and.(yu.eq.0.).and.(yl.eq.0.))     &               
     &  norm= 1.66667                                                                     
      if( (lam_u.eq.2).and.(rjl.eq.1.).and.(yu.eq.0.).and.(yl.eq.0.))     &               
     &  norm= 7.16715                                                                     
      if( (lam_u.eq.2).and.(rjl.eq.2.).and.(yu.eq.0.).and.(yl.eq.0.))     &               
     &  norm= 2.83333                                                                     
! C2 Swan                                                                                 
      if( (lam_u.eq.1).and.(rjl.eq.1.) ) norm= 1.2133831                                  
      if( (lam_u.eq.1).and.(rjl.eq.2.) ) norm= 4.5492405                                  
      if( (lam_u.eq.1).and.(rjl.eq.3.) ) norm= 7.75791                                    
      if( (lam_u.eq.1).and.(rjl.eq.4.) ) norm= 9.3495579                                  
! N2 2+                                                                                   
      if( (lam_u.eq.1).and.(rjl.eq.1.) ) norm= 2.5890816                                  
      if( (lam_u.eq.1).and.(rjl.eq.2.) ) norm= 5.2574128                                  
                                                                                          
      popu = dens_diatom(isp) * geu * homo_fac(isp) *                     &               
     &  (2.0*rju+1.0) * exp(-1.43877 * (teu/tele                          &               
     &  + evu/tvib + fpu/trot))/qtot                ! number density of upper rotational s
      hnu = 1.9863e-23 * ramda_jj_inv                                     ! photon energy 
      trans_prob = (64.0 * (3.1415916**4) * (0.529167e-8                  &               
     &  * 4.80298e-10)**2 * (re1**2)/(3.0 * 6.6256e-27)) * s_jj           &               
     &  * ramda_jj_inv**3/norm                                                            
      e = popu * trans_prob * hnu/(4.0 * 3.1415916)                       ! emission power
!                                                                                         
      ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha)
!      ncentr(j) = (1.0/wavmin**2 - 1.0/wavelx**2)/estep + 1                                     
      emisj(j) = e                                                                        
!                                                                                         
      return                                                                              
      end                                                                                 
!***********************************************************************                  
       subroutine calc_3X3Y(isp,dev,bvu,bvl,dvu,dvl,geu,teu,              &               
     &  evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,         &               
     & lam_u,lam_l,sou,sol)                                                               
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60)                                        
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom,                  &               
     & neq_factor_k,ls_u,ls_l                                                             
      character*5 dum(90),hund_diatom,hund                                                
      character*4 asterik,atomnm2(matoms),bandnm_diatom,                  &
     &    minus1,unknown                              
      character*4 atom_rads(3,168),diatom_bands(3,100),                        &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                          &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                     &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                              &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,  &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      integer charge_diatom,g_diatom,lo_state,s_diatom,up_state,          &               
     & g_atom1,g_atom2,gneq_diatom,check,ncentr(301)                                      
      integer vu,vl,spinu, spinl,sisi                                                     
      common/comi/nwave                                                                   
      common/comadiatom/ae_diatom(46,mdiatoms),                           &               
     & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms),    &               
     & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms),             &               
     & atomwt2(mdiatoms),be_diatom(46,mdiatoms),                          &               
     & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms),       &               
     & betae_diatom(46,mdiatoms),                                         &               
     & cross_diatom(11,121,21,mdiatoms),                                  &               
     & cross_imp_diatom(11,11,11,mdiatoms),                               &               
     & de_diatom(46,mdiatoms),diatom_mass(mdiatoms),                      &               
     & diatomwt(mdiatoms),                                                &               
     & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms),                    &               
     & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms),                 &               
     & FC_imp_diatom(0:11,0:11,11,11,mdiatoms),                           &               
     & e_elec_imp_diatom(11,11,11,mdiatoms),                              &               
     & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms),                     &               
     & lam2_diatom(46,mdiatoms),                                          &               
     & n_himp_bb_diatom(11,11,11,mdiatoms),                               &               
     & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms),    &               
     & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms),            &               
     & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms),          &               
     & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms),                    &               
     & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms),    &               
     & td_himp_bb_diatom(11,11,11,mdiatoms),                              &               
     & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms),         &               
     & wavel_cont_diatom(121,0:21,mdiatoms),                              &               
     & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms),                   &               
     & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms)                                  
      common/comidiatom/charge_diatom(mdiatoms),                          &               
     & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms),                        &               
     & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms),                   &               
     & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms),        &               
     & maxvl_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxvu_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxv_up_diatom(45,mdiatoms),                                       &               
     & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms),          &               
     & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms),           &               
     & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms),        &               
     & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms),                     &               
     & nup_diatom(45,mdiatoms),                                           &               
     & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms)                                 
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/comhund/hund_diatom(35,mdiatoms)                                             
      common/spect/calpha,slope_ratio,wavmin,wavmax,rangex                                             
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      dimension emisj(nw)                                                                 
      real*8 jmin,norm,jx,lm,lmu,lml,l21,l22,u31,u32,l41,l42                              
      sum_fact = 1.                                                                       
      if( (lam_u.eq.0).and.(lam_l.eq.1) ) sum_fact= 2.                                    
!    s_sum= 0.                                                                            
!    do m=1, 10                                                                           
      jmin = real(j)                                                                      
!   do k= 1, 27                                                                           
! when Y= 0 and DL=+1, sum_rule is correct,                                               
! When Y= 0 and Dl=-1, sum_rule has small error (less than 0.5)                           
! When Y.ne.0, sum_rule has small error (less than 0.5)                                   
      select case (k)                                                                     
      case (1)   ! P11                                                                    
      rju  = jmin - 1.0;       rjl  = jmin + 0.0                                          
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                         
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                         
      u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 1.0                                          
      u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 =-1.0                                          
      case (2)   ! Q11                                                                    
      rju  = jmin - 0.0;       rjl  = jmin + 0.0                                          
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                         
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                         
      u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 1.0                                          
      u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 =-1.0                                          
      case (3)   ! R11                                                                    
      rju  = jmin + 1.0;       rjl  = jmin + 0.0                                          
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                         
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                         
      u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 1.0                                          
      u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 =-1.0                                          
      case (4)   ! qP21                                                                   
      rju  = jmin - 1.0;       rjl  = jmin + 0.0                                          
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                         
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                         
      u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 1.0                                          
      u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 =-1.0                                          
      case (5)   ! rQ21                                                                   
      rju  = jmin - 0.0;       rjl  = jmin + 0.0                                          
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                         
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                         
      u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 1.0                                          
      u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 =-1.0                                          
      case (6)   ! sR21                                                                   
      rju  = jmin + 1.0;       rjl  = jmin + 0.0                                          
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                         
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                         
      u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 1.0                                          
      u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 =-1.0                                          
      case (7)   ! rP31                                                                   
      rju  = jmin - 1.0;       rjl  = jmin + 0.0                                          
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                         
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                         
      u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 1.0                                          
      u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 =-1.0                                          
      case (8)   ! sQ31                                                                   
      rju  = jmin - 0.0;       rjl  = jmin + 0.0                                          
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                         
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                         
      u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 1.0                                          
      u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 =-1.0                                          
      case (9)   ! tR31                                                                   
      rju  = jmin + 1.0;       rjl  = jmin + 0.0                                          
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                         
      sl2= -1.0; sl3= -2.0; sl4= -1.0; sl5 = -0.5                                         
      u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 1.0                                          
      u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 =-1.0                                          
      case(10)   ! oP12                                                                   
      rju  = jmin - 1.0;       rjl  = jmin + 0.0                                          
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                         
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                         
      u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 0.0                                          
      u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 = 0.0                                          
      case(11)   ! pQ12                                                                   
      rju  = jmin - 0.0;       rjl  = jmin + 0.0                                          
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                         
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                         
      u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 0.0                                          
      u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 = 0.0                                          
      case(12)   ! qR12                                                                   
      rju  = jmin + 1.0;       rjl  = jmin + 0.0                                          
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                         
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                         
      u11 = 0.0; u12 = 1.0; l21 = 0.0; l22 = 0.0                                          
      u31 = 0.0; u32 =-1.0; l41 = 0.0; l42 = 0.0                                          
      case(13)   ! P22                                                                    
      rju  = jmin - 1.0;       rjl  = jmin + 0.0                                          
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                         
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                         
      u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 0.0                                          
      u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 = 0.0                                          
      case(14)   ! Q22                                                                    
      rju  = jmin - 0.0;       rjl  = jmin + 0.0                                          
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                         
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                         
      u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 0.0                                          
      u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 = 0.0                                          
      case(15)   ! R22                                                                    
      rju  = jmin + 1.0;       rjl  = jmin + 0.0                                          
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                         
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                         
      u11 = 0.0; u12 = 0.0; l21 = 0.0; l22 = 0.0                                          
      u31 = 0.0; u32 = 0.0; l41 = 0.0; l42 = 0.0                                          
      case(16)   ! qP32                                                                   
      rju  = jmin - 1.0;       rjl  = jmin + 0.0                                          
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                         
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                         
      u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 0.0                                          
      u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 = 0.0                                          
      case(17)   ! rQ32                                                                   
      rju  = jmin - 0.0;       rjl  = jmin + 0.0                                          
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                         
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                         
      u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 0.0                                          
      u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 = 0.0                                          
      case(18)   ! sR32                                                                   
      rju  = jmin + 1.0;       rjl  = jmin + 0.0                                          
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                         
      sl2=  0.0; sl3=  4.0; sl4= -1.0; sl5 =  0.5                                         
      u11 = 1.0; u12 =-1.0; l21 = 0.0; l22 = 0.0                                          
      u31 = 1.0; u32 = 1.0; l41 = 0.0; l42 = 0.0                                          
      case(19)   ! nP13                                                                   
      rju  = jmin - 1.0;       rjl  = jmin + 0.0                                          
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                         
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                         
      u11 = 0.0; u12 = 1.0; l21 = 1.0; l22 =-1.0                                          
      u31 = 0.0; u32 =-1.0; l41 = 1.0; l42 = 1.0                                          
      case(20)   ! oQ13                                                                   
      rju  = jmin - 0.0;       rjl  = jmin + 0.0                                          
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                         
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                         
      u11 = 0.0; u12 = 1.0; l21 = 1.0; l22 =-1.0                                          
      u31 = 0.0; u32 =-1.0; l41 = 1.0; l42 = 1.0                                          
      case(21)   ! pR13                                                                   
      rju  = jmin + 1.0;       rjl  = jmin + 0.0                                          
      su2= -1.0; su3= -2.0; su4= -1.0; su5 = -0.5                                         
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                         
      u11 = 0.0; u12 = 1.0; l21 = 1.0; l22 =-1.0                                          
      u31 = 0.0; u32 =-1.0; l41 = 1.0; l42 = 1.0                                          
      case(22)   ! oP23                                                                   
      rju  = jmin - 1.0;       rjl  = jmin + 0.0                                          
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                         
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                         
      u11 = 0.0; u12 = 0.0; l21 = 1.0; l22 =-1.0                                          
      u31 = 0.0; u32 = 0.0; l41 = 1.0; l42 = 1.0                                          
      case(23)   ! pQ23                                                                   
      rju  = jmin - 0.0;       rjl  = jmin + 0.0                                          
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                         
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                         
      u11 = 0.0; u12 = 0.0; l21 = 1.0; l22 =-1.0                                          
      u31 = 0.0; u32 = 0.0; l41 = 1.0; l42 = 1.0                                          
      case(24)   ! qR23                                                                   
      rju  = jmin + 1.0;       rjl  = jmin + 0.0                                          
      su2=  0.0; su3=  4.0; su4= -1.0; su5 =  0.5                                         
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                         
      u11 = 0.0; u12 = 0.0; l21 = 1.0; l22 =-1.0                                          
      u31 = 0.0; u32 = 0.0; l41 = 1.0; l42 = 1.0                                          
      case(25)   ! P33                                                                    
      rju  = jmin - 1.0;       rjl  = jmin + 0.0                                          
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                         
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                         
      u11 = 1.0; u12 =-1.0; l21 = 1.0; l22 =-1.0                                          
      u31 = 1.0; u32 = 1.0; l41 = 1.0; l42 = 1.0                                          
      case(26)   ! Q33                                                                    
      rju  = jmin - 0.0;       rjl  = jmin + 0.0                                          
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                         
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                         
      u11 = 1.0; u12 =-1.0; l21 = 1.0; l22 =-1.0                                          
      u31 = 1.0; u32 = 1.0; l41 = 1.0; l42 = 1.0                                          
      case(27)   ! R33                                                                    
      rju  = jmin + 1.0;       rjl  = jmin + 0.0                                          
      su2=  1.0; su3= -2.0; su4= -1.0; su5 =  1.5                                         
      sl2=  1.0; sl3= -2.0; sl4= -1.0; sl5 =  1.5                                         
      u11 = 1.0; u12 =-1.0; l21 = 1.0; l22 =-1.0                                          
      u31 = 1.0; u32 = 1.0; l41 = 1.0; l42 = 1.0                                          
      end select                                                                          
                                                                                          
      yu = sou/bvu                                                                        
      yl = sol/bvl                                                                        
      jx = rjl                                                                            
      lm = real(lam_l)                                                                    
      if( lam_l .gt. lam_u) then                                                          
        jx = rju;   lm = lam_u                                                            
      end if                                                                              
      if( yu .lt. 0. ) then                                                               
        yu = -yu;   lmu = -real(lam_u)                                                    
      end if                                                                              
      if( yl .lt. 0. ) then                                                               
        yl= -yl;    lml = -real(lam_l)                                                    
      end if                                                                              
                                                                                          
      zu1 =  lam_u**2*yu*(yu-4.) + 4./3. + 4.*rju*(rju+1.)                                
      zu2 = (lam_u**2*yu*(yu-1.) - 4./9. - 2.*rju*(rju+1.)) / (3.*zu1)                    
      zl1 =  lam_l**2*yl*(yl-4.) + 4./3. + 4.*rjl*(rjl+1.)                                
      zl2 = (lam_l**2*yl*(yl-1.) - 4./9. - 2.*rjl*(rjl+1.)) / (3.*zl1)                    
                                                                                          
      fpu = bvu*(rju*(rju+1.) + su2*sqrt(zu1) + su3*zu2)                  &               
     &  + su4*dvu*(rju+su5)**4                                                            
      fpl = bvl*(rjl*(rjl+1.) + su2*sqrt(zl1) + su3*zl2)                  &               
     &  + su4*dvl*(rjl+su5)**4                                                            
                                                                                          
      u1u = sqrt(lam_u**2*yu*(yu-4.) + 4.*(rju+u11)**2)                   &               
     & + u12*lam_u*(yu-2.)                                                                
      u2l = sqrt(lam_l**2*yl*(yl-4.) + 4.*(rjl+l21)**2)                   &               
     & + l22*lam_l*(yl-2.)                                                                
      u3u = sqrt(lam_u**2*yu*(yu-4.) + 4.*(rju+u31)**2)                   &               
     & + u32*lam_u*(yu-2.)                                                                
      u4l = sqrt(lam_l**2*yl*(yl-4.) + 4.*(rjl+l41)**2)                   &               
     & + l42*lam_l*(yl-2.)                                                                
                                                                                          
      lmu = real(lam_u)                                                                   
      lml = real(lam_l)                                                                   
      if( yu .lt. 0. ) lmu = -real(lam_u)                                                 
      if( yl .lt. 0. ) lml = -real(lam_l)                                                 
      c1u = lmu**2*yu*(yu-4)*(rju-lmu+1.)*(rju+lmu) + 2.*(2.*rju+1)       &               
     & *(rju-lmu)*rju*(rju+lmu)                                                           
      c1l = lml**2*yl*(yl-4)*(rjl-lml+1.)*(rjl+lml) + 2.*(2.*rjl+1)       &               
     & *(rjl-lml)*rjl*(rjl+lml)                                                           
      c2u = lmu**2*yu*(yu-4.) + 4.*rju*(rju+1.)                                           
      c2l = lml**2*yl*(yl-4.) + 4.*rjl*(rjl+1.)                                           
      c3u = lmu**2*yu*(yu-4)*(rju-lmu)*(rju+lmu+1.) + 2.*(2.*rju+1)       &               
     & *(rju-lmu+1.)*(rju+1.)*(rju+lmu+1.)                                                
      c3l = lml**2*yl*(yl-4)*(rjl-lml)*(rjl+lml+1.) + 2.*(2.*rjl+1)       &               
     & *(rjl-lml+1.)*(rjl+1.)*(rjl+lml+1.)                                                
                                                                                          
      if(c1u.eq.0.) c1u=1.e5; if(c1l.eq.0.) c1l=1.e5                                      
      if(c2u.eq.0.) c2u=1.e5; if(c2l.eq.0.) c2l=1.e5                                      
      if(c3u.eq.0.) c3u=1.e5; if(c3l.eq.0.) c3l=1.e5                                      
                                                                                          
      if(lam_u .gt. lam_l) then  
      select case(k)                                                                      
      case (1) ! p11      
      s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u*u2l +(jx-lm-2.)  &               
     & *(jx+lm+1.)*u3u*u4l+ 8.*(jx-lm-2.)*(jx-lm)*(jx+lm)**2 )**2/        &               
     &  (32.*jx*c1u*c1l)/3.  
                                                                  
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (2) ! q11                                                                      
      s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l   &               
     & + (jx-lm-1.)*(jx+lm+2.)*u3u*u4l+ 8.*(jx-lm-1.)*(jx-lm)*(jx+lm)     &               
     & *(jx+lm+1.) )**2 /(32.*jx*(jx+1.)*c1u*c1l) /3.                                     
      if(s_jj.le.0.) s_jj= 1.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (3) ! r11                                                                      
      s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l+(jx-lm)   &               
     &  *(jx+lm+3.)*u3u*u4l+ 8.*(jx-lm)**2*(jx+lm)*(jx+lm+2.) )**2 /      &               
     &  (32.*(jx+1.)*c1u*c1l) /3.                                                         
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (4) ! qp21                                                                     
      s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u2l - (jx-lm-2.)     &               
     & *(jx+lm+1.)*u4l - 2.*(lm+1.)*(jx-lm)*(jx+lm)*(yu-2.) )**2 /        &               
     & (4.*jx*c2u*c1l)/3.                                                                 
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (5) ! rq21                                                                     
      s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u2l       &               
     &  - (jx-lm-1.)*(jx+lm+2.)*u4l - 2.*(lm+1.)*(jx-lm)*(jx+lm)*(yu-2.)  &               
     &   )**2 /(4.*jx*(jx+1.)*c2u*c1l) /3.                                                
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (6) ! sr21                                                                     
      s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u2l - (jx-lm)     &               
     & *(jx+lm+3.)*u4l - 2.*(lm+1.)*(jx-lm)*(jx+lm)*(yu-2.) )**2 /        &               
     & (4.*(jx+1.)*c2u*c1l) /3.                                                           
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (7) ! rp31                                                                     
      s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u*u2l +(jx-lm-2.)  &               
     &  *(jx+lm+1.)*u3u*u4l - 8.*(jx-lm-1.)*(jx-lm)*(jx+lm)*(jx+lm+1.) )  &               
     &  **2 /(32.*jx*c3u*c1l) /3.                                                         
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (8) ! sq31                                                                     
      s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l   &               
     &  + (jx-lm-1.)*(jx+lm+2.)*u3u*u4l - 8.*(jx-lm)**2*(jx+lm)           &               
     &  *(jx+lm+2.) )**2 /(32.*jx*(jx+1.)*c3u*c1l) /3.                                    
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (9) ! tr31                                                                     
      s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l +(jx-lm)  &               
     &  *(jx+lm+3.)*u3u*u4l - 8.*(jx-lm)*(jx-lm+1.)*(jx+lm)*(jx+lm+3.) )  &               
     &  **2 /(32.*(jx+1.)*c3u*c1l) /3.                                                    
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (10) ! op12                                                                    
      s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u - (jx-lm-2.)     &               
     &  *(jx+lm+1.)*u3u - 2.*lm*(jx-lm-2.)*(jx+lm)*(yl-2.) )**2 /         &               
     &  (4.*jx*c1u*c2l) /3.                                                               
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (11) ! pq12                                                                    
      s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u       &               
     & - (jx-lm-1.)*(jx+lm+2.)*u3u - 2.*lm*(jx-lm-1.)*(jx+lm+1.)*(yl-2.)  &               
     &  )**2 /(4.*jx*(jx+1.)*c1u*c2l) /3.                                                 
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (12) ! qr12                                                                    
      s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u - (jx-lm)     &               
     & *(jx+lm+3.)*u3u - 2.*lm*(jx-lm)*(jx+lm+2.)*(yl-2.) )**2 /          &               
     &  (4.*(jx+1.)*c1u*c2l) /3.                                                          
      if(s_jj.le.0.) s_jj= 1./9.                                                            
!     s_sum= s_sum + s_jj                                                                 
      case (13) ! p22                                                                     
      s_jj = 2.*(jx-lm-1.)*(jx-lm)*( 0.5*lm*(lm+1.)*(yu-2.)*(yl-2.)       &               
     &  + (jx-lm+1.)*(jx+lm) + (jx-lm-2.)*(jx+lm+1.) )**2 /               &               
     &  (jx*c2u*c2l) /3.                                                                  
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (14) ! q22                                                                     
      s_jj = 2.*(jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( 0.5*lm*(lm+1.)*(yu-2.)    &               
     &  *(yl-2.) + (jx-lm+1.)*(jx+lm) + (jx-lm-1.)*(jx+lm+2.) )**2 /      &               
     &  (jx*(jx+1.)*c2u*c2l) /3.                                                          
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (15) ! r22                                                                     
      s_jj = 2.*(jx+lm+1.)*(jx+lm+2.)*( 0.5*lm*(lm+1.)*(yu-2.)*(yl-2.)    &               
     &  + (jx-lm+1.)*(jx+lm) + (jx-lm)*(jx+lm+3.) )**2 /((jx+1.)          &               
     &  *c2u*c2l) /3.                                                                     
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (16) ! qp32                                                                    
      s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u - (jx-lm-2.)     &               
     & *(jx+lm+1.)*u3u + 2.*lm*(jx-lm-1.)*(jx+lm+1.)*(yl-2.) )**2 /       &               
     & (4.*jx*c3u*c2l) /3.                                                                
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (17) ! rq32                                                                    
      s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u       &               
     & - (jx-lm-1.)*(jx+lm+2.)*u3u + 2.*lm*(jx-lm)*(jx+lm+2.)*(yl-2.)     &               
     & )**2 /(4.*jx*(jx+1.)*c3u*c2l) /3.                                                  
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (18) ! sr32                                                                    
      s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u - (jx-lm)     &               
     & *(jx+lm+3.)*u3u + 2.*lm*(jx-lm+1.)*(jx+lm+3.)*(yl-2.) )**2 /       &               
     &  (4.*(jx+1.)*c3u*c2l) /3.                                                          
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (19) ! np13                                                                    
      s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u*u2l +(jx-lm-2.)  &               
     & *(jx+lm+1.)*u3u*u4l - 8.*(jx-lm-2.)*(jx-lm+1.)*(jx+lm)*(jx+lm+1.)  &               
     & )**2 /(32.*jx*c1u*c3l) /3.                                                         
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (20) ! oq13                                                                    
      s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l   &               
     &  + (jx-lm-1.)*(jx+lm+2.)*u3u*u4l - 8.*(jx-lm-1.)*(jx-lm+1.)        &               
     &  *(jx+lm+1.)**2 )**2 /(32.*jx*(jx+1.)*c1u*c3l) /3.                                 
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (21) ! pr13                                                                    
      s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l           &               
     & + (jx-lm)*(jx+lm+3.)*u3u*u4l - 8.*(jx-lm)*(jx-lm+1.)*(jx+lm+1.)    &               
     & *(jx+lm+2.) )**2 /(32.*(jx+1.)*c1u*c3l) /3.                                        
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (22) ! op23                                                                    
      s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u2l - (jx-lm-2.)     &               
     &  *(jx+lm+1.)*u4l + 2.*(lm+1.)*(jx-lm+1.)*(jx+lm+1.)*(yu-2.) )      &               
     &  **2 /(4.*jx*c2u*c3l) /3.                                                          
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (23) ! pq23                                                                    
      s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u2l       &               
     & - (jx-lm-1.)*(jx+lm+2.)*u4l + 2.*(lm+1.)*(jx-lm+1.)*(jx+lm+1.)     &               
     & *(yu-2.) )**2 /(4.*jx*(jx+1.)*c2u*c3l) /3.                                         
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (24) ! qr23                                                                    
      s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u2l - (jx-lm)     &               
     &  *(jx+lm+3.)*u4l + 2.*(lm+1.)*(jx-lm+1.)*(jx+lm+1.)*(yu-2.) )      &               
     &  **2 /(4.*(jx+1.)*c2u*c3l) /3.                                                     
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (25) ! p33                                                                     
      s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u*u2l +(jx-lm-2.)  &               
     &  *(jx+lm+1.)*u3u*u4l + 8.*(jx-lm-1.)*(jx-lm+1.)*(jx+lm+1.)**2)**2  &               
     &  /(32.*jx*c3u*c3l) /3.                                                             
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      case (26) ! q33                                                                     
      s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l   &               
     & + (jx-lm-1.)*(jx+lm+2.)*u3u*u4l+8.*(jx-lm)*(jx-lm+1.)*(jx+lm+1.)   &               
     & *(jx+lm+2.) )**2 /(32.*jx*(jx+1.)*c3u*c3l) /3.                                     
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!    s_sum= s_sum + s_jj                                                                  
      case (27) ! r33                                                                     
      s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l +(jx-lm)  &               
     & *(jx+lm+3.)*u3u*u4l + 8.*(jx-lm+1.)**2*(jx+lm+1.)*(jx+lm+3.) )**2  &               
     & /(32.*(jx+1.)*c3u*c3l) /3.                                                         
      if(s_jj.le.0.) s_jj= 1./9.                                                             
!     s_sum= s_sum + s_jj                                                                 
      end select                                                                          
      end if                                                                              
                                                                                          
      if(lam_l .gt. lam_u) then   
      select case(k)                                                                      
      case (1) ! p11                                                                      
      s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l+ (jx-lm)  &               
     & *(jx+lm+3.)*u3u*u4l + 8.*(jx-lm)**2*(jx+lm)*(jx+lm+2.) )**2 /      &               
     &  (32.*(jx+1.)*c1u*c1l) /3.*sum_fact                                                
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (2) ! q11                                                                      
      s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l   &               
     & + (jx-lm-1.)*(jx+lm+2.)*u3u*u4l + 8.*(jx-lm-1.)*(jx-lm)*(jx+lm)    &               
     & *(jx+lm+1.) )**2 /(32.*jx*(jx+1.)*c1u*c1l) /3.*sum_fact                            
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (3) ! r11                                                                      
      s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u*u2l +(jx-lm-2.)  &               
     & *(jx+lm+1.)*u3u*u4l + 8.*(jx-lm-2.)*(jx-lm)*(jx+lm)**2 )**2 /      &               
     &  (32.*jx*c1u*c1l) /3.*sum_fact                                                     
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (4) ! qp21                                                                     
      s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u - (jx-lm)     &               
     & *(jx+lm+3.)*u3u - 2.*lm*(jx-lm)*(jx+lm+2.)*(yl-2.) )**2 /          &               
     & (4.*(jx+1.)*c1u*c2l) /3.*sum_fact                                                  
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (5) ! rq21                                                                     
      s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u       &               
     & - (jx-lm-1.)*(jx+lm+2.)*u3u - 2.*lm*(jx-lm-1.)*(jx+lm+1.)*(yl-2.)  &               
     &  )**2 /(4.*jx*(jx+1.)*c1u*c2l) /3.*sum_fact                                        
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (6) ! sr21                                                                     
      s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u - (jx-lm-2.)     &               
     & *(jx+lm+1.)*u3u - 2.*lm*(jx-lm-2.)*(jx+lm)*(yl-2.) )**2 /          &               
     & (4.*jx*c1u*c2l) /3.*sum_fact                                                       
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (7) ! rp31                                                                     
      s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l           &               
     & + (jx-lm)*(jx+lm+3.)*u3u*u4l - 8.*(jx-lm)*(jx-lm+1.)*(jx+lm+1.)    &               
     & *(jx+lm+2.) )**2 /(32.*(jx+1.)*c1u*c3l) /3.*sum_fact                               
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (8) ! sq31                                                                     
      s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l   &               
     &  + (jx-lm-1.)*(jx+lm+2.)*u3u*u4l - 8.*(jx-lm-1.)*(jx-lm+1.)        &               
     &  *(jx+lm+1.)**2 )**2 /(32.*jx*(jx+1.)*c1u*c3l) /3.*sum_fact                        
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (9) ! tr31                                                                     
      s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u*u2l+ (jx-lm-2.)  &               
     &  *(jx+lm+1.)*u3u*u4l -8.*(jx-lm-2.)*(jx-lm+1.)*(jx+lm)*(jx+lm+1.)  &               
     &  )**2 /(32.*jx*c1u*c3l) /3.*sum_fact                                               
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (10) ! op12                                                                    
      s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u2l - (jx-lm)     &               
     &  *(jx+lm+3.)*u4l - 2.*(lm+1.)*(jx-lm)*(jx+lm)*(yu-2.) )**2 /       &               
     &  (4.*(jx+1.)*c2u*c1l) /3.*sum_fact                                                 
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (11) ! pq12                                                                    
      s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u2l       &               
     &  - (jx-lm-1.)*(jx+lm+2.)*u4l - 2.*(lm+1.)*(jx-lm)*(jx+lm)*(yu-2.)  &               
     &  )**2 /(4.*jx*(jx+1.)*c2u*c1l) /3.*sum_fact                                        
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (12) ! qr12                                                                    
      s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u2l - (jx-lm-2.)     &               
     & *(jx+lm+1.)*u4l - 2.*(lm+1.)*(jx-lm)*(jx+lm)*(yu-2.) )**2 /        &               
     & (4.*jx*c2u*c1l) /3.*sum_fact                                                       
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (13) ! p22                                                                     
      s_jj = 2.*(jx+lm+1.)*(jx+lm+2.)*( 0.5*lm*(lm+1.)*(yu-2.)*(yl-2.)    &               
     & + (jx-lm+1.)*(jx+lm) + (jx-lm)*(jx+lm+3.) )**2 /((jx+1.)*c2u*c2l)  &               
     & /3.*sum_fact                                                                       
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (14) ! q22                                                                     
      s_jj = 2.*(jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( 0.5*lm*(lm+1.)*(yu-2.)    &               
     & *(yl-2.) + (jx-lm+1.)*(jx+lm) + (jx-lm-1.)*(jx+lm+2.) )**2 /       &               
     & (jx*(jx+1.)*c2u*c2l) /3.*sum_fact                                                  
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (15) ! r22                                                                     
      s_jj = 2.*(jx-lm-1.)*(jx-lm)*( 0.5*lm*(lm+1.)*(yu-2.)*(yl-2.)       &               
     & + (jx-lm+1.)*(jx+lm) + (jx-lm-2.)*(jx+lm+1.) )**2 /(jx*c2u*c2l)    &               
     & /3.*sum_fact                                                                       
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (16) ! qp32                                                                    
      s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u2l - (jx-lm)     &               
     & *(jx+lm+3.)*u4l + 2.*(lm+1.)*(jx-lm+1.)*(jx+lm+1.)*(yu-2.) )**2    &               
     & /(4.*(jx+1.)*c2u*c3l) /3.*sum_fact                                                 
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (17) ! rq32                                                                    
      s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u2l       &               
     & - (jx-lm-1.)*(jx+lm+2.)*u4l + 2.*(lm+1.)*(jx-lm+1.)*(jx+lm+1.)     &               
     & *(yu-2.) )**2 /(4.*jx*(jx+1.)*c2u*c3l) /3.*sum_fact                                
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (18) ! sr32                                                                    
      s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u2l - (jx-lm-2.)     &               
     & *(jx+lm+1.)*u4l + 2.*(lm+1.)*(jx-lm+1.)*(jx+lm+1.)*(yu-2.) )**2    &               
     & /(4.*jx*c2u*c3l) /3.*sum_fact                                                      
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (19) ! np13                                                                    
      s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l           &               
     &  + (jx-lm)*(jx+lm+3.)*u3u*u4l - 8.*(jx-lm)*(jx-lm+1.)*(jx+lm)      &               
     &  *(jx+lm+3.) )**2 /(32.*(jx+1.)*c3u*c1l) /3.*sum_fact                              
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (20) ! oq13                                                                    
      s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l   &               
     & + (jx-lm-1.)*(jx+lm+2.)*u3u*u4l -8.*(jx-lm)**2*(jx+lm)*(jx+lm+2.)  &               
     & )**2 /(32.*jx*(jx+1.)*c3u*c1l) /3.*sum_fact                                        
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (21) ! pr13                                                                    
      s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u*u2l +(jx-lm-2.)  &               
     & *(jx+lm+1.)*u3u*u4l - 8.*(jx-lm-1.)*(jx-lm)*(jx+lm)*(jx+lm+1.) )   &               
     & **2 /(32.*jx*c3u*c1l) /3.*sum_fact                                                 
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (22) ! op23                                                                    
      s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u - (jx-lm)     &               
     &  *(jx+lm+3.)*u3u+ 2.*lm*(jx-lm+1.)*(jx+lm+3.)*(yl-2.) )**2 /       &               
     &  (4.*(jx+1.)*c3u*c2l) /3.*sum_fact                                                 
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (23) ! pq23                                                                    
      s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u       &               
     & - (jx-lm-1.)*(jx+lm+2.)*u3u+ 2.*lm*(jx-lm)*(jx+lm+2.)*(yl-2.) )    &               
     & **2 /(4.*jx*(jx+1.)*c3u*c2l) /3.*sum_fact                                          
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (24) ! qr23                                                                    
      s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u - (jx-lm-2.)     &               
     & *(jx+lm+1.)*u3u + 2.*lm*(jx-lm-1.)*(jx+lm+1.)*(yl-2.) )**2 /       &               
     & (4.*jx*c3u*c2l) /3.*sum_fact                                                       
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (25) ! p33                                                                     
      s_jj = (jx+lm+1.)*(jx+lm+2.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l           &               
     & + (jx-lm)*(jx+lm+3.)*u3u*u4l + 8.*(jx-lm+1.)**2*(jx+lm+1.)         &               
     & *(jx+lm+3.) )**2 /(32.*(jx+1.)*c3u*c3l) /3.*sum_fact                               
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (26) ! q33                                                                     
      s_jj = (jx-lm)*(jx+lm+1.)*(2.*jx+1.)*( (jx-lm+1.)*(jx+lm)*u1u*u2l   &               
     & + (jx-lm-1.)*(jx+lm+2.)*u3u*u4l +8.*(jx-lm)*(jx-lm+1.)*(jx+lm+1.)  &               
     & *(jx+lm+2.) )**2 /(32.*jx*(jx+1.)*c3u*c3l) /3.*sum_fact                            
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      case (27) ! r33                                                                     
      s_jj = (jx-lm-1.)*(jx-lm)*( (jx-lm+1.)*(jx+lm)*u1u*u2l +(jx-lm-2.)  &               
     & *(jx+lm+1.)*u3u*u4l + 8.*(jx-lm-1.)*(jx-lm+1.)*(jx+lm+1.)**2 )**2  &               
     & /(32.*jx*c3u*c3l) /3.*sum_fact                                                     
      if(s_jj.le.0.) s_jj= 1./9.                                                             
      end select                                                                          
      end if                                                                              
                                                                                          
      ramda_jj_inv = dev + fpu - fpl                                                      
      wavelx = 1.0e8/ramda_jj_inv                                                         
      norm = 2.*rjl+1.                                                                    
! in case of N2, rjl=1 --> norm= 2.886                                                    
      if( (lam_u.eq.1).and.(lam_l.eq.0).and.(rjl.eq.1.).and.(yu.eq.0.)    &               
     &  .and.(yl.eq.0.) ) norm= 2.6666667                                                 
      if( (lam_u.eq.2).and.(lam_l.eq.1).and.(rjl.eq.1.).and.(yu.eq.0.)    &               
     & .and.(yl.eq.0.) ) norm= 1.50                                                       
      if( (lam_u.eq.2).and.(lam_l.eq.1).and.(rjl.eq.2.).and.(yu.eq.0.)    &               
     & .and.(yl.eq.0.) ) norm= 4.833333                                                   
      if( (lam_u.eq.0).and.(lam_l.eq.1).and.(rjl.eq.1.).and.(yu.eq.0.)    &               
     & .and.(yl.eq.0.) ) norm= 3. ! 1.3632437                                             
      if( (lam_u.eq.1).and.(lam_l.eq.2).and.(rjl.eq.1.).and.(yu.eq.0.)    &               
     & .and.(yl.eq.0.) ) norm= 7.0e-5                                                     
      if( (lam_u.eq.1).and.(lam_l.eq.2).and.(rjl.eq.2.).and.(yu.eq.0.)    &               
     & .and.(yl.eq.0.) ) norm= 3.270867                                                   
      if( (lam_u.eq.1).and.(lam_l.eq.2).and.(rjl.eq.3.).and.(yu.eq.0.)    &               
     & .and.(yl.eq.0.) ) norm= 7.9253698                                                  
      if( (lam_u.eq.1).and.(lam_l.eq.2).and.(rjl.eq.4.).and.(yu.eq.0.)    &               
     & .and.(yl.eq.0.) ) norm= 9.55393                                                    
                                                                                          
      popu = dens_diatom(isp) * geu * homo_fac(isp) *                     &               
     & (2.0*rju+1.0) * exp(-1.43877 * (teu/tele                           &               
     &  + evu/tvib + fpu/trot))/qtot                    ! number density of upper rotation
      hnu = 1.9863e-23 * ramda_jj_inv                                         ! photon ene
      trans_prob = (64.0 * (3.1415916**4) * (0.529167e-8                  &               
     &  * 4.80298e-10)**2* (re1**2)/(3.0 * 6.6256e-27))                   &               
     &  * s_jj * ramda_jj_inv**3/norm                                                     
      e = popu * trans_prob * hnu/(4.0 * 3.1415916)                           ! emission p
!                                                                                         
      ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha)
!      ncentr(j) = (1.0/wavmin**2 - 1.0/wavelx**2)/estep + 1                                     
      emisj(j) = e                                                                        
!                                                                                         
      return                                                                              
      end                                                                                 
!***********************************************************************                  
! this subroutine for lambda splitting + spin-orbit splitting                             
! lambda_upper > 1, if lambda_upper = 0, then sj'j'' should *2.                           
      subroutine calc_bb2x2ylam(isp,dev,bvu,bvl,dvu,dvl,geu,              &               
     &  teu,evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,     &               
     &  lam_u,lam_l,sou,sol)                                                              
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60)                                        
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom,                  &               
     & neq_factor_k,ls_u,ls_l                                                             
      character*5 dum(90),hund_diatom,hund                                                
      character*4 asterik,atomnm2(matoms),bandnm_diatom,                  &
     &    minus1,unknown                              
      character*4 atom_rads(3,168),diatom_bands(3,100),                                 &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                                   &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                              &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                                       &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,            &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      integer charge_diatom,g_diatom,lo_state,s_diatom,up_state,          &               
     & g_atom1,g_atom2,gneq_diatom,check,ncentr(301)                                      
      integer vu,vl,spinu, spinl,sisi                                                     
      common/comi/nwave                                                                   
      common/comadiatom/ae_diatom(46,mdiatoms),                           &               
     & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms),    &               
     & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms),             &               
     & atomwt2(mdiatoms),be_diatom(46,mdiatoms),                          &               
     & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms),       &               
     & betae_diatom(46,mdiatoms),                                         &               
     & cross_diatom(11,121,21,mdiatoms),                                  &               
     & cross_imp_diatom(11,11,11,mdiatoms),                               &               
     & de_diatom(46,mdiatoms),diatom_mass(mdiatoms),                      &               
     & diatomwt(mdiatoms),                                                &               
     & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms),                    &               
     & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms),                 &               
     & FC_imp_diatom(0:11,0:11,11,11,mdiatoms),                           &               
     & e_elec_imp_diatom(11,11,11,mdiatoms),                              &               
     & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms),                     &               
     & lam2_diatom(46,mdiatoms),                                          &               
     & n_himp_bb_diatom(11,11,11,mdiatoms),                               &               
     & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms),    &               
     & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms),            &               
     & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms),          &               
     & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms),                    &               
     & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms),    &               
     & td_himp_bb_diatom(11,11,11,mdiatoms),                              &               
     & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms),         &               
     & wavel_cont_diatom(121,0:21,mdiatoms),                              &               
     & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms),                   &               
     & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms)                                  
      common/comidiatom/charge_diatom(mdiatoms),                          &               
     & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms),                        &               
     & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms),                   &               
     & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms),        &               
     & maxvl_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxvu_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxv_up_diatom(45,mdiatoms),                                       &               
     & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms),          &               
     & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms),           &               
     & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms),        &               
     & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms),                     &               
     & nup_diatom(45,mdiatoms),                                           &               
     & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms)                                 
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/comhund/hund_diatom(35,mdiatoms)                                             
      common/spect/calpha,slope_ratio,wavmin,wavmax,rangex                                             
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      real*8 jx,lm                                                                        
      dimension emisj(nw)                                                                 
                                                                                          
!   test lambda splitting for ch x2pi-a2delta                                             
      pl = 0.034d0                                                                        
      ql = 0.0389d0   ! from m. zachwieja (1997)                                          
      pu = 2.07d-7 ;                                                                      
      qu = 4.58d-8    ! from m. zachwieja (1997)                                          
!    pu = -3.34e-7                                                                        
!     qu = 3.29e-7  ! from brazier(can.j.phys,1984,pp1576)                                
      geu = 1.0    ! only for lambda splitting                                            
!     pl=0.; ql=0.; pu=0.; qu=0.                                                          
                                                                                          
      jmin = j - 0                                                                        
      if( (lam_u.eq.1) .and. (lam_l.eq.0) ) jmin = j                                      
      if( (lam_u.eq.2) .and. (lam_l.eq.1) ) jmin = j + 1                                  
!   s_jj's are taken from kovacs's, pp.127. these are exatly same as a.schadee (pp.327) fo
!   but, s_jj of kovacs should be divided by 2.                                           
                                                                                          
!   select case (k)  ! refer to pp 261 of herzberg                                        
      go to (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,          &               
     & 21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,       &               
     & 41,42,43,44,45,46,47,48) K                                                         
                                                                                          
!    case(1)    ! r(f1', f1")  d-d                                                        
    1 continue                                                                            
      rju = real(jmin) + 1.5; rjl =  rju  - 1.0                                                                   
      cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0; cu3 = +1.0; cl3 = +1.0                                                                          
      go to 49                                                                            
!    case(2)    ! r(f1', f1")  d-c                                                        
    2 continue                                                                            
      rju = real(jmin) + 1.5; rjl =  rju  - 1.0                                                                   
      cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0; cu3 = +1.0; cl3 = -1.0                                                                          
      go to 49                                                                            
!    case(3)    ! r(f1', f1")  c-c                                                        
    3 continue                                                                            
      rju = real(jmin) + 1.5; rjl =  rju  - 1.0                                                                   
      cu1 = -1.0; cl1 = -1.0; cu2 = +0.0;  cl2 = +0.0; cu3 = -1.0; cl3 = -1.0                                                                          
      go to 49                                                                            
!    case(4)    ! r(f1', f1")  c-d                                                        
    4 continue                                                                            
      rju = real(jmin) + 1.5; rjl =  rju  - 1.0                                                                   
      cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0; cu3 = -1.0; cl3 = +1.0                                                                          
      go to 49                                                                            
!    case(5)    ! r(f2', f2") d-d                                                         
    5 continue                                                                            
      rju = real(jmin) + 1.5; rjl =  rju  - 1.0                                                                   
      cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0; cu3 = +1.0; cl3 = +1.0                                                                          
      go to 49                                                                            
!    case(6)    ! r(f2', f2") d-c                                                         
    6 continue                                                                            
      rju = real(jmin) + 1.5; rjl =  rju  - 1.0                                                                    
      cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0; cu3 = +1.0; cl3 = -1.0                                                                          
      go to 49                                                                            
!    case(7)    ! r(f2', f2") c-c                                                         
    7 continue                                                                            
      rju = real(jmin) + 1.5; rjl =  rju  - 1.0                                                                   
      cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0; cu3 = -1.0; cl3 = -1.0                                                                          
      go to 49                                                                            
!    case(8)    ! r(f2', f2") c-d                                                         
    8 continue                                                                            
      rju = real(jmin) + 1.5; rjl =  rju  - 1.0                                                                   
      cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0; cu3 = -1.0; cl3 = +1.0                                                                          
      go to 49                                                                            
!    case(9)    ! qr(f1', f2")  d-d                                                       
    9 continue                                                                            
      rju = real(jmin) + 1.5; rjl =  rju  - 1.0                                                                   
      cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0; cu3 = +1.0; cl3 = +1.0                                                                          
      go to 49                                                                            
!    case(10)    ! qr(f1', f2") d-c                                                       
   10 continue                                                                            
      rju = real(jmin) + 1.5; rjl =  rju  - 1.0                                                                   
      cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0; cu3 = +1.0; cl3 = -1.0                                                                          
      go to 49                                                                            
!    case(11)    ! qr(f1', f2") c-c                                                       
   11 continue                                                                            
      rju = real(jmin) + 1.5; rjl =  rju  - 1.0 
      cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0; cu3 = -1.0; cl3 = -1.0                                                                          
      go to 49                                                                            
!    case(12)    ! qr(f1', f2") c-d                                                       
   12 continue                                                                                                          
      rju = real(jmin) + 1.5; rjl =  rju  - 1.0 
      cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0                                                
      go to 49                                                                                                          
!    case(13)    ! sr(f2', f1") d-d                                                                                     
   13 continue                                                                                                          
      rju = real(jmin) + 1.5; rjl =   rju  - 1.0
      cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0                                                
      go to 49                                                                                                          
!    case(14)    ! sr(f2', f1") d-c                                                                                     
   14 continue                                                                                                          
      rju = real(jmin) + 1.5; rjl =   rju  - 1.0
      cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0                                                
      go to 49                                                                                                          
!    case(15)    ! sr(f2', f1") c-c                                                                                     
   15 continue                                                                                                          
      rju = real(jmin) + 1.5; rjl =   rju  - 1.0
      cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0                                                
      go to 49                                                                                                          
!    case(16)    ! sr(f2', f1") c-d                                                                                     
   16 continue                                                                                                          
      rju = real(jmin) + 1.5; rjl =   rju  - 1.0
      cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0                                                
      go to 49                                                                                                          
!    case(17)    ! q(f1', f1") d-d                                                                                      
   17 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  - 0.0 
      cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0                                                
      go to 49                                                                                                          
!    case(18)    ! q(f1', f1") d-c                                                                                      
   18 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  - 0.0 
      cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0                                                
      go to 49                                                                                                          
!    case(19)    ! q(f1', f1") c-c                                                                                      
   19 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  - 0.0 
      cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0                                                
      go to 49                                                                                                          
!    case(20)    ! q(f1', f1") c-d                                                                                      
   20 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  - 0.0 
      cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0                                                
      go to 49                                                                                                          
!    case(21)    ! q(f2', f2") d-d                                                                                      
   21 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  - 0.0 
      cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0                                                
      go to 49                                                                                                          
!    case(22)    ! q(f2', f2") d-c                                                                                      
   22 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  - 0.0 
      cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0                                                
      go to 49                                                                                                          
!    case(23)    ! q(f2', f2") c-c                                                                                      
   23 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  - 0.0 
      cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0                                                
      go to 49                                                                                                          
!    case(24)    ! q(f2', f2") c-d                                                                                      
   24 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  - 0.0 
      cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0                                                
      go to 49                                                                                                          
!    case(25)    ! pq(f1', f2") d-d                                                                                     
   25 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  - 0.0 
      cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0                                                
      go to 49                                                                                                          
!    case(26)    ! pq(f1', f2") d-c                                                                                     
   26 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  - 0.0 
      cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0                                                
      go to 49                                                                                                          
!    case(27)    ! pq(f1', f2") c-c                                                                                     
   27 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  - 0.0 
      cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0                                                
      go to 49                                                                                                          
!    case(28)    ! pq(f1', f2") c-d                                                                                     
   28 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  - 0.0 
      cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0                                                
      go to 49                                                                                                          
!    case(29)    ! rq(f2', f1") d-d                                                                                     
   29 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  - 0.0 
      cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0                                                
      go to 49                                                                                                          
!    case(30)    ! rq(f2', f1") d-c                                                                                     
   30 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  - 0.0 
      cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0                                                
      go to 49                                                                                                          
!    case(31)    ! rq(f2', f1") c-c                                                                                     
   31 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  - 0.0 
      cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0                                                
      go to 49                                                                                                          
!    case(32)    ! rq(f2', f1") c-d                                                                                     
   32 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  - 0.0 
      cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0                                                
      go to 49                                                                                                          
!    case(33)    ! p(f1', f1") d-d                                                                                      
   33 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  + 1.0 
      cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0                                                
      go to 49                                                                                                          
!    case(34)    ! p(f1', f1") d-c                                                                                      
   34 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  + 1.0 
      cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0                                                
      go to 49                                                                                                          
!    case(35)    ! p(f1', f1") c-c                                                                                      
   35 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  + 1.0 
      cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0                                                
      go to 49                                                                                                          
!    case(36)    ! p(f1', f1") c-d                                                                                      
   36 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  + 1.0 
      cu1 = -1.0; cl1 = -1.0; cu2 = +0.0; cl2 = +0.0                                                
      go to 49                                                                                                          
!    case(37)    ! p(f2', f2") d-d                                                                                      
   37 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  + 1.0 
      cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0                                                
      go to 49                                                                                                          
!    case(38)    ! p(f2', f2") d-c                                                                                      
   38 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  + 1.0 
      cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0                                                
      go to 49                                                                                                          
!    case(39)    ! p(f2', f2") c-c                                                                                      
   39 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  + 1.0 
      cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0                                                
      go to 49                                                                                                          
!    case(40)    ! p(f2', f2") c-d                                                                                      
   40 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  + 1.0 
      cu1 = +1.0; cl1 = +1.0; cu2 = +1.0; cl2 = +1.0                                                
      go to 49                                                                                                          
!    case(41)    ! op(f1', f2") d-d                                                                                     
   41 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  + 1.0 
      cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0                                                
      go to 49                                                                                                          
!    case(42)    ! op(f1', f2") d-c                                                                                     
   42 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  + 1.0 
      cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0                                                
      go to 49                                                                                                          
!    case(43)    ! op(f1', f2") c-c                                                                                     
   43 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  + 1.0 
      cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0                                                
      go to 49                                                                                                          
!    case(44)    ! op(f1', f2") c-d                                                                                     
   44 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  + 1.0 
      cu1 = -1.0; cl1 = +1.0; cu2 = +0.0; cl2 = +1.0                                                
      go to 49                                                                                                          
!    case(45)    ! qp(f2', f1") d-                                                                                      
   45 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  + 1.0 
      cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0                                                
      go to 49                                                                                                          
!    case(46)    ! qp(f2', f1") d-c                                                                                     
   46 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  + 1.0 
      cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0                                                
      go to 49                                                                                                          
!    case(47)    ! qp(f2', f1") c-c                                                                                     
   47 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  + 1.0 
      cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0                                                
      go to 49                                                                                                          
!    case(48)    ! qp(f2', f1") c-d                                                                                     
   48 continue                                                                                                          
      rju = real(jmin) + 0.5; rjl =  rju  + 1.0 
      cu1 = +1.0; cl1 = -1.0; cu2 = +1.0; cl2 = +0.0                                                
      go to 49                                                                                                          
!    end select                                                                           
   49 continue                                                                            
                                                                                          
! refer to kavacs, pp 61, 63, and 127, mulliken and christy (phys.rev. 1931)              
      yu = sou/bvu                                                                        
      yl = sol/bvl                                                                        
                                                                                          
      xu = dsqrt(4.d0*(rju+0.5d0)**2 + (yu*lam_u)**2 - 4.d0*yu*lam_u**2)                  
      xl = dsqrt(4.d0*(rjl+0.5d0)**2 + (yl*lam_l)**2 - 4.d0*yl*lam_l**2)                  
                                                                                          
      fpu= bvu*((rju+0.5)**2 - lam_u**2 + cu1/2.*xu) - dvu*(rju+cu2)**4   &               
     &  + cu3*0.5*(rju+0.5)*((cu1*1.+(2.-yu)/xu)*(0.5*pu+qu)              &               
     &  + 2.*qu/xu*(rju-0.5)*(rju+1.5))                                                   
                                                                                          
      fpl= bvl*((rjl+0.5)**2 - lam_l**2 + cl1/2.*xl) - dvl*(rjl+cl2)**4   &               
     &   + cl3*0.5*(rjl+0.5)*((cl1*1.+(2.-yl)/xl)*(0.5*pl+ql)             &               
     &   + 2.*ql/xl*(rjl-0.5)*(rjl+1.5))                                                  
                                                                                          
      uuu= dsqrt(lam_u**2*yu*(yu-4.0) + 4.0*(rju+0.5)**2)                 &               
     &   + cu1*lam_u*(yu-2.0)                                                             
      uul= dsqrt(lam_l**2*yl*(yl-4.0) + 4.0*(rjl+0.5)**2)                 &               
     &   + cl1*lam_l*(yl-2.0)                                                             
      ccu= 0.5*(uuu**2 + 4.0*(rju+0.5)**2 - 4.0*lam_u**2)                                 
      ccl= 0.5*(uul**2 + 4.0*(rjl+0.5)**2 - 4.0*lam_l**2)                                 
                                                                                          
      lm = real(lam_l)                                                                    
      jx = rjl                                                                            
                                                                                          
      if( lam_u .gt. lam_l) then                                                          
!    select case (k)                                                                      
                                                                                          
!    case(1:8)    ! rr(f1', f1"), rr22                                                    
      if((k.ge.1).and.(k.le.8))                                           &               
     &   s_jj = (jx+lm+1.5)*(jx+lm+2.5) * (uuu*uul + 4.*(jx-lm+0.5)       &               
     &   *(jx+lm+0.5))**2 / (8.*(jx+1.)*ccu*ccl) /2.                                      
!    case(9:16)   ! qr(f1', f2"), sr21                                                    
      if((k.ge.9).and.(k.le.16))                                          &               
     & s_jj = (jx+lm+1.5)*(jx+lm+2.5) * (uuu*uul - 4.*(jx-lm+0.5)         &               
     & *(jx+lm+0.5))**2 / (8.*(jx+1.)*ccu*ccl) /2.                                        
!    case(17:24)  ! qq(f1', f1"), qq22                                                    
      if((k.gt.17).and.(k.le.24))                                         &               
     &  s_jj = (jx-lm-0.5)*(jx+0.5)*(jx+lm+1.5)*(uuu*uul                  &               
     &  + 4.*(jx-lm+0.5)*(jx+lm+0.5))**2 /                                &               
     &  (4.*jx*(jx+1.)*ccu*ccl) /2.                                                       
!    case(25:32)  ! pq(f1', f2"), rq21                                                    
      if((k.ge.25).and.(k.le.32))                                         &               
     &  s_jj = (jx-lm-0.5)*(jx+0.5)*(jx+lm+1.5)*(uuu*uul                  &               
     &  - 4.*(jx-lm+0.5)*(jx+lm+0.5))**2 /                                &               
     &  (4.*jx*(jx+1.)*ccu*ccl) /2.                                                       
!    case(33:40)  ! pp(f1', f1"), pp22                                                    
      if((k.ge.33).and.(k.le.40))                                         &               
     &  s_jj = (jx-lm-1.5)*(jx-lm-0.5) * (uuu*uul + 4.*(jx-lm+0.5)        &               
     &  *(jx+lm+0.5))**2 / (8.*jx*ccu*ccl) /2.                                            
!    case(41:48)  ! op(f1', f2"), qp21                                                    
      if((k.ge.41).and.(k.le.48))                                         &               
     &  s_jj = (jx-lm-1.5)*(jx-lm-0.5) * (uuu*uul - 4.*(jx-lm+0.5)        &               
     &  *(jx+lm+0.5))**2 / (8.*jx*ccu*ccl) /2.                                            
!    end select                                                                           
      end if                                                                              
                                                                                          
      if( lam_u .lt. lam_l) then                                                          
!    select case (k)                                                                      
                                                                                          
!    case(1:8)      ! rr(f1', f1"), rr22                                                  
      if((k.ge.1).and.(k.le.8))                                           &               
     &  s_jj = (jx-lm-1.5)*(jx-lm-0.5) * (uuu*uul + 4.*(jx-lm+0.5)        &               
     &  *(jx+lm+0.5))**2 / (8.*jx*ccu*ccl) /2.                                            
!    case(9:16)     ! qr(f1', f2"), sr21                                                  
      if((k.ge.9).and.(k.le.16))                                          &               
     &  s_jj = (jx-lm-1.5)*(jx-lm-0.5) * (uuu*uul - 4.*(jx-lm+0.5)        &               
     &  *(jx+lm+0.5))**2 / (8.*jx*ccu*ccl) /2.                                            
!    case(17:24)    ! qq(f1', f1"), qq22                                                  
      if((k.ge.17).and.(k.le.24))                                         &               
     &  s_jj = (jx-lm-0.5)*(jx+0.5)*(jx+lm+1.5)*(uuu*uul +4.*(jx-lm+0.5)  &               
     &  *(jx+lm+0.5))**2 / (4.*jx*(jx+1.)*ccu*ccl) /2.                                    
!    case(25:32)    ! pq(f1', f2"), rq21                                                  
      if((k.ge.25).and.(k.le.32))                                         &               
     &  s_jj = (jx-lm-0.5)*(jx+0.5)*(jx+lm+1.5)*(uuu*uul -4.*(jx-lm+0.5)  &               
     &  *(jx+lm+0.5))**2 / (4.*jx*(jx+1.)*ccu*ccl) /2.                                    
!    case(33:40)   ! pp(f1', f1"), pp22                                                   
      if((k.ge.33).and.(k.le.40))                                         &               
     &  s_jj = (jx+lm+1.5)*(jx+lm+2.5) * (uuu*uul + 4.*(jx-lm+0.5)        &               
     &  *(jx+lm+0.5))**2 / (8.*(jx+1.)*ccu*ccl) /2.                                       
!    case(41:48)  ! op(f1', f2"), qp21                                                    
      if((k.ge.41).and.(k.le.48))                                         &               
     &  s_jj = (jx+lm+1.5)*(jx+lm+2.5) * (uuu*uul - 4.*(jx-lm+0.5)        &               
     &  *(jx+lm+0.5))**2 / (8.*(jx+1.)*ccu*ccl) /2.                                       
!    end select                                                                           
      end if                                                                              
                                                                                          
      ramda_jj_inv = dev + fpu - fpl                                                      
      wavelx = 1.0e8/ramda_jj_inv                                                         
                                                                                          
      popu = dens_diatom(isp) * geu * homo_fac(isp) *                     &               
     & (2.0*rju+1.0) * dexp(-1.43877 * (teu/tele                          &               
     & + evu/tvib + fpu/trot))/qtot                                                       
      hnu = 1.9863e-23 * ramda_jj_inv                                                     
      trans_prob = (64.0 * (3.1415916**4)*(0.529167e-8*4.80298e-10)**2    &               
     & * (re1**2)/(3.0 * 6.6256e-27)) * s_jj * ramda_jj_inv**3            &               
     & /(2.*rjl+1.)                                                                       
      e = popu * trans_prob * hnu/(4.0 * 3.1415916)                                       
!                                                                                         
      ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha)
!      ncentr(j) = (1.0/wavmin**2 - 1.0/wavelx**2)/estep + 1                                     
      emisj(j) = e                                                                        
!                                                                                         
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine calc_bb5p5p(isp,dev,bvu,bvl,dvu,dvl,geu,teu,             &               
     & evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,          &               
     & lam_u,lam_l,sou,sol)                                                               
!   5Pi-5Pi transition                                                                    
!   Kovacs, Journal of Molecular Spectroscopy, 98, (1983), 41-47, Pi state                
!   k varies from 1 to 300                                                                
!                                                                                         
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60)                                        
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom,                  &               
     & neq_factor_k,ls_u,ls_l                                                             
      character*5 dum(90),hund_diatom,hund                                                
      character*4 asterik,atomnm2(matoms),bandnm_diatom,                  &
     &    minus1,unknown                              
      character*4 atom_rads(3,168),diatom_bands(3,100),                        &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                          &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                     &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                              &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,  &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      integer charge_diatom,g_diatom,lo_state,s_diatom,up_state,          &               
     & g_atom1,g_atom2,gneq_diatom,check,ncentr(301)                                      
      integer vu,vl,spinu, spinl,sisi                                                     
      common/comi/nwave                                                                   
      common/comadiatom/ae_diatom(46,mdiatoms),                           &               
     & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms),    &               
     & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms),             &               
     & atomwt2(mdiatoms),be_diatom(46,mdiatoms),                          &               
     & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms),       &               
     & betae_diatom(46,mdiatoms),                                         &               
     & cross_diatom(11,121,21,mdiatoms),                                  &               
     & cross_imp_diatom(11,11,11,mdiatoms),                               &               
     & de_diatom(46,mdiatoms),diatom_mass(mdiatoms),                      &               
     & diatomwt(mdiatoms),                                                &               
     & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms),                    &               
     & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms),                 &               
     & FC_imp_diatom(0:11,0:11,11,11,mdiatoms),                           &               
     & e_elec_imp_diatom(11,11,11,mdiatoms),                              &               
     & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms),                     &               
     & lam2_diatom(46,mdiatoms),                                          &               
     & n_himp_bb_diatom(11,11,11,mdiatoms),                               &               
     & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms),    &               
     & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms),            &               
     & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms),          &               
     & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms),                    &               
     & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms),    &               
     & td_himp_bb_diatom(11,11,11,mdiatoms),                              &               
     & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms),         &               
     & wavel_cont_diatom(121,0:21,mdiatoms),                              &               
     & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms),                   &               
     & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms)                                  
      common/comidiatom/charge_diatom(mdiatoms),                          &               
     & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms),                        &               
     & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms),                   &               
     & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms),        &               
     & maxvl_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxvu_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxv_up_diatom(45,mdiatoms),                                       &               
     & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms),          &               
     & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms),           &               
     & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms),        &               
     & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms),                     &               
     & nup_diatom(45,mdiatoms),                                           &               
     & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms)                                 
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/comhund/hund_diatom(35,mdiatoms)                                             
      common/spect/calpha,slope_ratio,wavmin,wavmax,rangex                                             
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      dimension emisj(nw)                                                                 
      logical frpi                                                                        
      real*8 jx,lm,lmu,lml,l21,l22,l41,l42                                                
!                                                                                         
! determine kl=low state k value, ku=upper state k value, kj=P,Q,R choice, kso=spin orbit 
      akc=k                                                                               
      akd=akc/75.-0.01                                                                    
      kso=int(akd)+1                                                                      
      kold=k-75*(kso-1)                                                                   
!                                                                                         
      aka=kold                                                                            
      akb=aka/25.-0.01                                                                    
      kj=int(akb)+1                                                                       
      knew=kold-25*(kj-1)                                                                 
!                                                                                         
      ak=knew                                                                             
      ak1=ak/5.0-0.01                                                                     
      kl=int(ak1)+1                                                                       
      ku=(ak/5.0-real(kl-1))*5.0+0.01                                                     
                                                                                          
      jmin = j                                                                            
                                                                                          
! j refers to the lower state                                                             
!                                                                                         
! P-brabch                                                                                
      if(kj.eq.1) then                                                                    
         rju  = real(j) - 1.0                                                             
         rjl  = rju + 1.0                                                                 
      end if                                                                              
      if(kj.eq.2) then                                                                    
         rju  = real(j)                                                                   
         rjl  = rju - 0.0                                                                 
      end if                                                                              
      if(kj.eq.3) then                                                                    
         rju  = real(j)                                                                   
         rjl  = rju - 1.0                                                                 
      end if                                                                              
      xu=rju*(rju+1)                                                                      
      xl=rjl*(rjl+1)                                                                      
      yu=sou/bvu                                                                          
      yl=sol/bvl                                                                          
      tauu=4.*xu/((yu-2.)**2+4.*xu)                                                       
      taul=4.*xl/((yl-2.)**2+4.*xl)                                                       
      dlu=0.1*rju*rju                                                                     
      dll=0.1*rjl*rjl                                                                     
                                                                                          
      if(ku.eq.1) fu=bvu*(xu-3.+2.*sqrt((yu-2.+tauu)**2+4.*xu)+6.*tauu    &               
     & -(14./5.)*tauu*(1.-tauu)-tauu**2*(1.-tauu)**2)                                     
      if(ku.eq.2) fu=bvu*(xu+3.+sqrt((yu-2.+tauu)**2+4.*xu)-3.*tauu       &               
     & -(8./5.)*tauu*(1.-tauu)+0.5*tauu**2*(1.-tauu)**2)                                  
      if(ku.eq.3) fu=bvu*(xu+5.-6.*tauu+tauu**2*(1.-tauu)**2)                             
      if(ku.eq.4) fu=bvu*(xu+3.-sqrt((yu-2.+tauu)**2+4.*xu)-3.*tauu       &               
     &  +(8./5.)*tauu*(1.-tauu)+0.5*tauu**2*(1.-tauu)**2)                                 
      if(ku.eq.5) fu=bvu*(xu-3.-2.*sqrt((yu-2.+tauu)**2+4.*xu)+6.*tauu    &               
     & +(14./5.)*tauu*(1.-tauu)-tauu**2*(1.-tauu)**2)                                     
                                                                                          
      if(kl.eq.1) fl=bvl*(xl-3.+2.*sqrt((yl-2.+taul)**2+4.*xl)+6.*taul    &               
     & -(14./5.)*taul*(1.-taul)-taul**2*(1.-taul)**2)                                     
      if(kl.eq.2) fl=bvl*(xl+3.+sqrt((yl-2.+taul)**2+4.*xl)-3.*taul       &               
     & -(8./5.)*taul*(1.-taul)+0.5*taul**2*(1.-taul)**2)                                  
      if(kl.eq.3) fl=bvl*(xl+5.-6.*taul+taul**2*(1.-taul)**2)                             
      if(kl.eq.4) fl=bvl*(xl+3.-sqrt((yl-2.+taul)**2+4.*xl)-3.*taul       &               
     & +(8./5.)*taul*(1.-taul)+0.5*taul**2*(1.-taul)**2)                                  
      if(kl.eq.5) fl=bvl*(xl-3.-2.*sqrt((yl-2.+taul)**2+4.*xl)+6.*taul    &               
     &  +(14./5.)*taul*(1.-taul)-taul**2*(1.-taul)**2)                                    
                                                                                          
      if(kso.eq.1) then                                                                   
        fu=fu+dlu; fl=fl+dll                                                                         
      end if                                                                              
      if(kso.eq.2) then                                                                   
        fu=fu+dlu; fl=fl-dll                                                                         
      end if                                                                              
      if(kso.eq.3) then                                                                   
        fu=fu-dlu; fl=fl+dll                                                                         
      end if                                                                              
      if(kso.eq.4) then                                                                   
        fu=fu-dlu; fl=fl-dll                                                                         
      end if                                                                              
                                                                                          
      fpu = fu; fpl = fl                                                                            
                                                                                          
      s_jj=0.05                                                                           
                                                                                          
      ramda_jj_inv = dev + fpu - fpl                                                      
      wavelx = 1.0e8/ramda_jj_inv                                                         
                                                                                          
      popu = dens_diatom(isp) * geu * homo_fac(isp) *                     &               
     & (2.0*rju+1.0) * exp(-1.43877 * (teu/tele                           &               
     &  + evu/tvib + fpu/trot))/qtot                  ! number density of upper rotational
      hnu = 1.9863e-23 * ramda_jj_inv                                     ! photon energy 
!      a = 64* pi**4 * (a0 * e)**2 * s * (delta e)**3 * re**2/(3 * h)                     
      trans_prob = (64.0 * (3.1415916**4) * (0.529167e-8                  &               
     & * 4.80298e-10)**2 * (re1**2)/(3.0 * 6.6256e-27)) * s_jj            &               
     & * ramda_jj_inv**3/(2.*rjl+1.)                                                      
      e = popu * trans_prob * hnu/(4.0 * 3.1415916)                       ! emission power
!                                                                                         
      ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha)
!      ncentr(j) = (1.0/wavmin**2 - 1.0/wavelx**2)/estep + 1                                     
      emisj(j) = e                                                                        
!                                                                                         
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine calc_bb5p5s(isp,dev,bvu,bvl,dvu,dvl,geu,teu,             &               
     & evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,          &               
     & lam_u,lam_l,sou,sol)                                                               
!   5Pi(upper state)-5Sigma(lower state) transition                                       
!   Kovacs, Journal of Molecular Spectroscopy, 98, (1983), 41-47, Pi state                
!     and Kovacs, Rotational Structure in the spectra of diatomic molecules, 1969, for Sig
!   k varies from 1 to 300                                                                
!                                                                                         
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60)                                        
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom,                  &               
     & neq_factor_k,ls_u,ls_l                                                             
      character*5 dum(90),hund_diatom,hund                                                
      character*4 asterik,atomnm2(matoms),bandnm_diatom,                  &
     &    minus1,unknown                              
      character*4 atom_rads(3,168),diatom_bands(3,100),                                 &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                                   &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                              &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                                       &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,           &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      integer charge_diatom,g_diatom,lo_state,s_diatom,up_state,          &               
     & g_atom1,g_atom2,gneq_diatom,check,ncentr(301)                                      
      integer vu,vl,spinu, spinl,sisi                                                     
      common/comi/nwave                                                                   
      common/comadiatom/ae_diatom(46,mdiatoms),                           &               
     & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms),    &               
     & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms),             &               
     & atomwt2(mdiatoms),be_diatom(46,mdiatoms),                          &               
     & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms),       &               
     & betae_diatom(46,mdiatoms),                                         &               
     & cross_diatom(11,121,21,mdiatoms),                                  &               
     & cross_imp_diatom(11,11,11,mdiatoms),                               &               
     & de_diatom(46,mdiatoms),diatom_mass(mdiatoms),                      &               
     & diatomwt(mdiatoms),                                                &               
     & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms),                    &               
     & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms),                 &               
     & FC_imp_diatom(0:11,0:11,11,11,mdiatoms),                           &               
     & e_elec_imp_diatom(11,11,11,mdiatoms),                              &               
     & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms),                     &               
     & lam2_diatom(46,mdiatoms),                                          &               
     & n_himp_bb_diatom(11,11,11,mdiatoms),                               &               
     & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms),    &               
     & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms),            &               
     & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms),          &               
     & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms),                    &               
     & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms),    &               
     & td_himp_bb_diatom(11,11,11,mdiatoms),                              &               
     & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms),         &               
     & wavel_cont_diatom(121,0:21,mdiatoms),                              &               
     & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms),                   &               
     & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms)                                  
      common/comidiatom/charge_diatom(mdiatoms),                          &               
     & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms),                        &               
     & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms),                   &               
     & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms),        &               
     & maxvl_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxvu_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxv_up_diatom(45,mdiatoms),                                       &               
     & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms),          &               
     & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms),           &               
     & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms),        &               
     & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms),                     &               
     & nup_diatom(45,mdiatoms),                                           &               
     & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms)                                 
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/comhund/hund_diatom(35,mdiatoms)                                             
      common/spect/calpha,slope_ratio,wavmin,wavmax,rangex                                             
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      dimension emisj(nw)                                                                 
      logical frpi                                                                        
      real*8 jx,lm,lmu,lml,l21,l22,u31,u32,l41,l42                                        
! arbitrary values of epsilon and gamma                                                   
      epsil=1.; gamma=1.                                                                  
                                                                                          
!                                                                                         
! determine kl=low state k value, ku=upper state k value, kj=P,Q,R choice, kso=spin orbit 
      akc=k                                                                               
      akd=akc/75.-0.01                                                                    
      kso=int(akd)+1                                                                      
      kold=k-75*(kso-1)                                                                   
!                                                                                         
      aka=kold                                                                            
      akb=aka/25.-0.01                                                                    
      kj=int(akb)+1                                                                       
      knew=kold-25*(kj-1)                                                                 
!                                                                                         
      ak=knew                                                                             
      ak1=ak/5.0-0.01                                                                     
      kl=int(ak1)+1                                                                       
      ku=(ak/5.0-real(kl-1))*5.0+0.01                                                     
                                                                                          
      jmin = j                                                                            
                                                                                          
! j refers to the lower state                                                             
!                                                                                         
! P-brabch                                                                                
      if(kj.eq.1) then                                                                    
       rju  = real(j) - 1.0                                                               
       rjl  = rju + 1.0                                                                   
      end if                                                                              
      if(kj.eq.2) then                                                                    
       rju  = real(j)                                                                     
       rjl  = rju - 0.0                                                                   
      end if                                                                              
      if(kj.eq.3) then                                                                    
       rju  = real(j)                                                                     
       rjl  = rju - 1.0                                                                   
      end if                                                                              
      xu=rju*(rju+1)                                                                      
      xl=rjl*(rjl+1)                                                                      
      yu=sou/bvu                                                                          
      yl=sol/bvl                                                                          
      tauu=4.*xu/((yu-2.)**2+4.*xu)                                                       
      taul=4.*xl/((yl-2.)**2+4.*xl)                                                       
      dlu=0.1*rju*rju                                                                     
      dll=0.1*rjl*rjl                                                                     
                                                                                          
      if(ku.eq.1) fu=bvu*(xu-3.+2.*sqrt((yu-2.+tauu)**2+4.*xu)            &               
     &  +6.*tauu -(14./5.)*tauu*(1.-tauu)-tauu**2*(1.-tauu)**2)                           
      if(ku.eq.2) fu=bvu*(xu+3.+sqrt((yu-2.+tauu)**2+4.*xu)               &               
     &  -3.*tauu -(8./5.)*tauu*(1.-tauu)+0.5*tauu**2*(1.-tauu)**2)                        
      if(ku.eq.3) fu=bvu*(xu+5.-6.*tauu+tauu**2*(1.-tauu)**2)                             
      if(ku.eq.4) fu=bvu*(xu+3.-sqrt((yu-2.+tauu)**2+4.*xu)-3.*tauu       &               
     & +(8./5.)*tauu*(1.-tauu)+0.5*tauu**2*(1.-tauu)**2)                                  
      if(ku.eq.5) fu=bvu*(xu-3.-2.*sqrt((yu-2.+tauu)**2+4.*xu)+6.*tauu    &               
     & +(14./5.)*tauu*(1.-tauu)-tauu**2*(1.-tauu)**2)                                     
                                                                                          
      if(kl.eq.1) fl=bvl*xl-dvl*xl**2-6.*epsil*rjl/(2.*rjl+3.)            &               
     & + 2.*gamma*rjl                                                                     
      if(kl.eq.2) fl=bvl*xl-dvl*xl**2+3.*epsil*(rjl+6.)/(2.*rjl+3.)       &               
     &  +gamma*(rjl-2.)                                                                   
      if(kl.eq.3) fl=bvl*xl-dvl*xl**2+3.*epsil*(1.+3./(2.*rjl+3.)-3./     &               
     & (2.*rjl-1.))-3.*gamma                                                              
      if(kl.eq.4) fl=bvu*xl-dvl*xl**2+3.*epsil*(rjl-5.)/(2.*rjl-1.)       &               
     & -gamma*(rjl+3.)                                                                    
      if(kl.eq.5) fl=bvu*xl-dvl*xl**2-6.*epsil*(rjl+1.)/(2.*rjl-1.)       &               
     & -2.*gamma*(rjl+1.)                                                                 
                                                                                          
      if(kso.eq.1) then                                                                   
        fu=fu+dlu                                                                         
        fl=fl+dll                                                                         
      end if                                                                              
      if(kso.eq.2) then                                                                   
        fu=fu+dlu                                                                         
        fl=fl-dll                                                                         
      end if                                                                              
      if(kso.eq.3) then                                                                   
        fu=fu-dlu                                                                         
        fl=fl+dll                                                                         
      end if                                                                              
      if(kso.eq.4) then                                                                   
        fu=fu-dlu                                                                         
        fl=fl-dll                                                                         
      end if                                                                              
                                                                                          
      fpu = fu                                                                            
      fpl = fl                                                                            
                                                                                          
      s_jj=0.05                                                                           
                                                                                          
      ramda_jj_inv = dev + fpu - fpl                                                      
      wavelx = 1.0e8/ramda_jj_inv                                                         
                                                                                          
      popu = dens_diatom(isp) * geu * homo_fac(isp) *                     &               
     &  (2.0*rju+1.0) * exp(-1.43877 * (teu/tele                          &               
     &  + evu/tvib + fpu/trot))/qtot                  ! number density of upper rotational
      hnu = 1.9863e-23 * ramda_jj_inv                                     ! photon energy 
!      a = 64* pi**4 * (a0 * e)**2 * s * (delta e)**3 * re**2/(3 * h)                     
      trans_prob = (64.0 * (3.1415916**4) * (0.529167e-8                  &               
     & * 4.80298e-10)**2 * (re1**2)/(3.0 * 6.6256e-27)) * s_jj            &               
     & * ramda_jj_inv**3/(2.*rjl+1.)                                                      
      e = popu * trans_prob * hnu/(4.0 * 3.1415916)                       ! emission power
!                                                                                         
      ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha)
!      ncentr(j) = (1.0/wavmin**2 - 1.0/wavelx**2)/estep + 1                                     
      emisj(j) = e                                                                        
!                                                                                         
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine calc_bb5s5p(isp,dev,bvu,bvl,dvu,dvl,geu,teu,             &               
     &  evu,tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,         &               
     & lam_u,lam_l,sou,sol)                                                               
!   5Sigma(upper state)-5Pi(lower state) transition                                       
!   Kovacs, Journal of Molecular Spectroscopy, 98, (1983), 41-47, Pi state                
!   and Kovacs, Rotational Structure in the spectra of diatomic molecules, 1969, for Sigma
!   k varies from 1 to 300                                                                
!                                                                                         
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60)                                        
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom,                  &               
     & neq_factor_k,ls_u,ls_l                                                             
      character*5 dum(90),hund_diatom,hund                                                
      character*4 asterik,atomnm2(matoms),bandnm_diatom,                  &
     &    minus1,unknown                              
      character*4 atom_rads(3,168),diatom_bands(3,100),                           &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                             &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                        &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                                 &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,     &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      integer charge_diatom,g_diatom,lo_state,s_diatom,up_state,          &               
     & g_atom1,g_atom2,gneq_diatom,check,ncentr(301)                                      
      integer vu,vl,spinu, spinl,sisi                                                     
      common/comi/nwave                                                                   
      common/comadiatom/ae_diatom(46,mdiatoms),                           &               
     & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms),    &               
     & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms),             &               
     & atomwt2(mdiatoms),be_diatom(46,mdiatoms),                          &               
     & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms),       &               
     & betae_diatom(46,mdiatoms),                                         &               
     & cross_diatom(11,121,21,mdiatoms),                                  &               
     & cross_imp_diatom(11,11,11,mdiatoms),                               &               
     & de_diatom(46,mdiatoms),diatom_mass(mdiatoms),                      &               
     & diatomwt(mdiatoms),                                                &               
     & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms),                    &               
     & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms),                 &               
     & FC_imp_diatom(0:11,0:11,11,11,mdiatoms),                           &               
     & e_elec_imp_diatom(11,11,11,mdiatoms),                              &               
     & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms),                     &               
     & lam2_diatom(46,mdiatoms),                                          &               
     & n_himp_bb_diatom(11,11,11,mdiatoms),                               &               
     & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms),    &               
     & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms),            &               
     & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms),          &               
     & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms),                    &               
     & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms),    &               
     & td_himp_bb_diatom(11,11,11,mdiatoms),                              &               
     & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms),         &               
     & wavel_cont_diatom(121,0:21,mdiatoms),                              &               
     & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms),                   &               
     & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms)                                  
      common/comidiatom/charge_diatom(mdiatoms),                          &               
     & g_diatom(46,mdiatoms),g_atom1(11,mdiatoms),                        &               
     & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms),                   &               
     & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms),        &               
     & maxvl_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxvu_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxv_up_diatom(45,mdiatoms),                                       &               
     & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms),          &               
     & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms),           &               
     & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms),        &               
     & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms),                     &               
     & nup_diatom(45,mdiatoms),                                           &               
     & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms)                                 
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/comhund/hund_diatom(35,mdiatoms)                                             
      common/spect/calpha,slope_ratio,wavmin,wavmax,rangex                                             
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      dimension emisj(nw)                                                                 
      real*8 jx,lm,lmu,lml,l21,l22,u31,u32,l41,l42                                        
      logical frpi                                                                        
! arbitrary values of epsilon and gamma                                                   
      epsil=1.; gamma=1.                                                                  
                                                                                          
!                                                                                         
! determine kl=low state k value, ku=upper state k value, kj=P,Q,R choice, kso=spin orbit 
      akc=k                                                                               
      akd=akc/75.-0.01                                                                    
      kso=int(akd)+1                                                                      
      kold=k-75*(kso-1)                                                                   
!                                                                                         
      aka=kold                                                                            
      akb=aka/25.-0.01                                                                    
      kj=int(akb)+1                                                                       
      knew=kold-25*(kj-1)                                                                 
!                                                                                         
      ak=knew                                                                             
      ak1=ak/5.0-0.01                                                                     
      kl=int(ak1)+1                                                                       
      ku=(ak/5.0-real(kl-1))*5.0+0.01                                                     
                                                                                          
      jmin = j                                                                            
                                                                                          
! j refers to the lower state                                                             
!                                                                                         
! P-brabch                                                                                
      if(kj.eq.1) then                                                                    
        rju  = real(j) - 1.0                                                              
        rjl  = rju + 1.0                                                                  
      end if                                                                              
      if(kj.eq.2) then                                                                    
        rju  = real(j)                                                                    
        rjl  = rju - 0.0                                                                  
      end if                                                                              
      if(kj.eq.3) then                                                                    
        rju  = real(j)                                                                    
        rjl  = rju - 1.0                                                                  
      end if                                                                              
      xu=rju*(rju+1)                                                                      
      xl=rjl*(rjl+1)                                                                      
      yu=sou/bvu                                                                          
      yl=sol/bvl                                                                          
      tauu=4.*xu/((yu-2.)**2+4.*xu)                                                       
      taul=4.*xl/((yl-2.)**2+4.*xl)                                                       
      dlu=0.1*rju*rju                                                                     
      dll=0.1*rjl*rjl                                                                     
                                                                                          
      if(ku.eq.1) fu=bvu*xu-dvu*xu**2-6.*epsil*rju/(2.*rju+3.)            &               
     & + 2.*gamma*rju                                                                     
      if(ku.eq.2) fu=bvu*xu-dvu*xu**2+3.*epsil*(rju+6.)/(2.*rju+3.)       &               
     & +gamma*(rju-2.)                                                                    
      if(ku.eq.3) fu=bvu*xu-dvu*xu**2+3.*epsil*(1.+3./(2.*rju+3.)-3./     &               
     & (2.*rju-1.))-3.*gamma                                                              
      if(ku.eq.4) fu=bvu*xu-dvu*xu**2+3.*epsil*(rju-5.)/(2.*rju-1.)       &               
     & -gamma*(rju+3.)                                                                    
      if(ku.eq.5) fu=bvu*xu-dvu*xu**2-6.*epsil*(rju+1.)/(2.*rju-1.)       &               
     & -2.*gamma*(rju+1.)                                                                 
                                                                                          
      if(kl.eq.1) fl=bvl*(xl-3.+2.*sqrt((yl-2.+taul)**2+4.*xl)+6.*taul    &               
     &  -(14./5.)*taul*(1.-taul)-taul**2*(1.-taul)**2)                                    
      if(kl.eq.2) fl=bvl*(xl+3.+sqrt((yl-2.+taul)**2+4.*xl)-3.*taul       &               
     & -(8./5.)*taul*(1.-taul)+0.5*taul**2*(1.-taul)**2)                                  
      if(kl.eq.3) fl=bvl*(xl+5.-6.*taul+taul**2*(1.-taul)**2)                             
      if(kl.eq.4) fl=bvl*(xl+3.-sqrt((yl-2.+taul)**2+4.*xl)-3.*taul       &               
     & +(8./5.)*taul*(1.-taul)+0.5*taul**2*(1.-taul)**2)                                  
      if(kl.eq.5) fl=bvl*(xl-3.-2.*sqrt((yl-2.+taul)**2+4.*xl)+6.*taul    &               
     & +(14./5.)*taul*(1.-taul)-taul**2*(1.-taul)**2)                                     
                                                                                          
      if(kso.eq.1) then                                                                   
        fu=fu+dlu                                                                         
        fl=fl+dll                                                                         
      end if                                                                              
      if(kso.eq.2) then                                                                   
        fu=fu+dlu                                                                         
        fl=fl-dll                                                                         
      end if                                                                              
      if(kso.eq.3) then                                                                   
        fu=fu-dlu                                                                         
        fl=fl+dll                                                                         
      end if                                                                              
      if(kso.eq.4) then                                                                   
        fu=fu-dlu                                                                         
        fl=fl-dll                                                                         
      end if                                                                              
                                                                                          
      fpu = fu                                                                            
      fpl = fl                                                                            
                                                                                          
      s_jj=0.05                                                                           
                                                                                          
      ramda_jj_inv = dev + fpu - fpl                                                      
      wavelx = 1.0e8/ramda_jj_inv                                                         
                                                                                          
      popu = dens_diatom(isp) * geu * homo_fac(isp) *                     &               
     & (2.0*rju+1.0) * exp(-1.43877 * (teu/tele                           &               
     &  + evu/tvib + fpu/trot))/qtot                  ! number density of upper rotational
      hnu = 1.9863e-23 * ramda_jj_inv                                     ! photon energy 
!      a = 64* pi**4 * (a0 * e)**2 * s * (delta e)**3 * re**2/(3 * h)                     
      trans_prob = (64.0 * (3.1415916**4) * (0.529167e-8                  &               
     &  * 4.80298e-10)**2 * (re1**2)/(3.0 * 6.6256e-27)) * s_jj           &               
     &  * ramda_jj_inv**3/(2.*rjl+1.)                                                     
      e = popu * trans_prob * hnu/(4.0 * 3.1415916)                       ! emission power
!                                                                                         
      ncentr(j) = nwave*((wavelx-wavmin)/(wavmax-wavmin))**(1./calpha)
!      ncentr(j) = (1.0/wavmin**2 - 1.0/wavelx**2)/estep + 1                                     
      emisj(j) = e                                                                        
!                                                                                         
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine chmtx(amtrx, bvtr, iprb)                                                 
      implicit real*8(a-h,o-z)                                                            
      common /spcdat/ eltbl(8,2),    sptbl(9,32),   fln(8,32),            &               
     &                tdc(8,32,4),   spm(32),                             &               
     &                        ne,            ns,                          &               
     &                itchm,         ioutch,        elms(8)                               
!                                                                                         
      common /node  / spv(32),       t,             p,                    &               
     &                brm,           speth(32),     spgfz(32),            &               
     &                spcsp(32),     bzro(8),       ethm                                  
!                                                                                         
      dimension       amtrx(16,16),  bvtr(16),      beta(16,32),          &               
     &                gfe(32)                                                             
!                                                                                         
      pln=dlog(p)                                                                         
      nep1=ne+1                                                                           
!                                                                                         
!     set beta and gibbs free energy                                                      
!                                                                                         
      do 1 j=1,ns                                                                         
      if(spv(j) .le. 0.0) spv(j) = 1.0e-20                                                
      gfe(j)=spgfz(j)+pln+dlog(spv(j))                                                    
      do 1 i=1,ne                                                                         
      beta(i,j)=fln(i,j)*spv(j)                                                           
  1   continue                                                                            
!                                                                                         
!     set element submatrix                                                               
!                                                                                         
      do 2 k=1,ne                                                                         
      do 2 i=k,ne                                                                         
      amtrx(k,i)=0.0                                                                      
      do 2 j=1,ns                                                                         
      amtrx(k,i)=amtrx(k,i)+fln(k,j)*beta(i,j)                                            
  2   continue                                                                            
!                                                                                         
!     set molar mass column down thru ne                                                  
!                                                                                         
      do 3 k=1,ne                                                                         
      amtrx(k,nep1)=0.0                                                                   
      do 3 j=1,ns                                                                         
      amtrx(k,nep1)=amtrx(k,nep1)-beta(k,j)                                               
  3   continue                                                                            
!                                                                                         
!     set pressure element                                                                
!                                                                                         
      amtrx(nep1,nep1)=1.0                                                                
      do 4 j=1,ns                                                                         
      amtrx(nep1,nep1)=amtrx(nep1,nep1)-spv(j)                                            
  4   continue                                                                            
!                                                                                         
!     reflect amtrx about diagonal except for mass column                                 
!                                                                                         
      do 5 k=2,ne                                                                         
      km1=k-1                                                                             
      do 5 i=1,km1                                                                        
      amtrx(k,i)=amtrx(i,k)                                                               
  5   continue                                                                            
!                                                                                         
!     reflect negative of mass column to pressure row                                     
!                                                                                         
      do 8 i=1,ne                                                                         
      amtrx(nep1,i)=-amtrx(i,nep1)                                                        
  8   continue                                                                            
!                                                                                         
!.....if t,p problem, skip temp col & enthalpy row....................                    
      nep2=ne+2                                                                           
      if(iprb.ne.2)go to 9                                                                
      do 10 i=1,ne                                                                        
      amtrx(i,nep2)=0.0                                                                   
      do 11 j=1,ns                                                                        
      amtrx(i,nep2)=amtrx(i,nep2)+fln(i,j)*spv(j)*speth(j)                                
  11  continue                                                                            
  10  continue                                                                            
!.....fill the pressure element of temp col............................                   
      amtrx(nep1,nep2)=0.0                                                                
      do 12 j=1,ns                                                                        
      amtrx(nep1,nep2)=amtrx(nep1,nep2)+spv(j)*speth(j)                                   
  12  continue                                                                            
!.....fill the enthalpy-temperature element........................                       
      amtrx(nep2,nep2)=0.0                                                                
      do 13 j=1,ns                                                                        
      amtrx(nep2,nep2)=amtrx(nep2,nep2)+spv(j)*(spcsp(j)+speth(j)**2)                     
  13  continue                                                                            
!.....reflect temp col into enthalpy row down thru ne................                     
      do 14 k=1,ne                                                                        
      amtrx(nep2,k)=amtrx(k,nep2)                                                         
  14  continue                                                                            
!.....reflect negative of pressure element to pressure row............                    
      amtrx(nep2,nep1)=-amtrx(nep1,nep2)                                                  
!                                                                                         
  9   continue                                                                            
!                                                                                         
!     set rhs down thru ne                                                                
!                                                                                         
      do 6 k=1,ne                                                                         
      bvtr(k)=brm*bzro(k)+amtrx(k,nep1)                                                   
      do 6 j=1,ns                                                                         
      bvtr(k)=bvtr(k)+beta(k,j)*gfe(j)                                                    
  6   continue                                                                            
!                                                                                         
!     pressure row rhs                                                                    
!                                                                                         
      bvtr(nep1)=amtrx(nep1,nep1)                                                         
      do 7 j=1,ns                                                                         
      bvtr(nep1)=bvtr(nep1)+spv(j)*gfe(j)                                                 
  7   continue                                                                            
!                                                                                         
      if(iprb.ne.2)go to 99                                                               
!.....sset rhs of enthalpy row(enthalpy units=j/kg)...................                    
      data gc/8.31434e3/                                                                  
      bvtr(nep2)=ethm*brm/(gc*t)                                                          
      do 15 j=1,ns                                                                        
      bvtr(nep2)=bvtr(nep2)+spv(j)*speth(j)*(gfe(j)-1.)                                   
  15  continue                                                                            
!                                                                                         
!                                                                                         
  99  return                                                                              
      end                                                                                 
!************************************************************************* 
      subroutine comet_lbl(nwave,rhoinf,vinf,pres,enths,tw,delH,rnose,          &
  &   spallf,ndm,nout,nim,facout1,facin1,facout2,facin2,famdot,elev_ang,        &
  &   hwhh,enfac,sigma)
! meteor inviscid line-by-line code
! input parameters
!   nwave=number of wavelength points
!   rhoinf=freestream density, kg/m3
!   vinf=freestream velocity, m/s
!   pres=shock layer pressure, Pa
!   enths=enthalpy behind shock wave, J/kg
!   tw=wall temperature
!   delH=ablation energy, J/kg
!   rnose=body radius, m
!   ndm=number of node points throughout the shock layer-ablation product layer
!   nout=allowed number of iteration over the air shock layer in one sweep
!      there are total of 4 sweeps
!   nim=allowed number of iteration over the ablation-product layer in one sweep
!      there are total of 4 sweeps
!   facout1=fraction by which an old solution is modified by the new solution
!     for air shock layer in the first two sweeps
!   facin1=fraction by which an old solution is modified by the new solution
!     for ablation product layer in the first two sweeps
!   facout2=fraction by which an old solution is modified by the new solution
!     for air shock layer in the late two sweeps
!   facin2=fraction by which an old solution is modified by the new solution
!     for ablation production layer in the later two sweeps
!   famdot=fraction by which an old ablation rate is modified by the new ablation
!     rate value
!   elev_ang=elevation angle, deg
!   hwhh=half-width at half-height in Gaussian slit function, A
!   enfac=enthalpy entering shock wave divided by 0.5*vinf*vinf
!   sigma=wall emissivity
!   
      parameter(nw=400000)
      implicit real*8(a-h,o-z)
      character*4 dum(41)
      dimension wallt(4),pwall(4),tx(802),int_prec(nw),int_grd(nw),             &
  &     wav_sh(1000),edge(1000),shk(1000),prec(1000),grd(1000)
      common/qpqm/qp(802),qm(802),int_s(10,nw),ang(11),sin2(11),                &
  &     int_cam(nw)
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)
      common/compe/compef(14),solid_dens(14),solid_dens_av,wtmolc
      common/scratch/any(nw)
      real*8 int_s,intw,int_e,int_prec,int_grd,int_cam,int_abl,mfp,magnit,mass
      save
      data wallt/3151.0,3624.2,4268.2,4601.3/
      data pwall/5.,6.,7.,8./ 
      data pi/3.14159265/,itime/0/     
!
      if(itime.eq.0) then
! take the log of absorption coefficients for air
        do iw=1,nwave
          do it=1,5
            absb_air(it,iw)=dlog(absb_air(it,iw))
          end do
        end do

! take log of absorption coefficients for ablation product
        do iw=1,nwave
          do it=1,11
            absb_cho(it,iw)=dlog(absb_cho(it,iw))
          end do
        end do

! take the log of absorption coefficients for freestream
        do iw=1,nwave
          do it=1,11
            absb_low(it,iw)=dlog(absb_low(it,iw))
          end do
        end do
      end if
      
      itime=itime+1
!
! wall conditions
      mon=0
! h0cho=condensed phase formation energy at 298 K, J/kg
! h0chog=gas phase formation energy at 298 K, J/kg
! h0sens=condensed phase sensible energy at tw, J/kg
      call pT_ivu(1,pres,tw, rhow,enthw,cpw)
      write(6,70) pres,tw,rhow,enthw,cpw,delH
      WRITE(*,70) PRES,TW,RHOW,ENTHW,CPW,DELH
  70  format(/                                                                          &
  &       ' pres=',1pe11.4,' Pa.       tw   =',0pf10.1,' K'/                            &
  &       ' rhow=',1pe11.4,' kg/m3.    enthw=',e11.4,' J/kg'/                           &
  &       ' cpw =',e11.4  ' J/(kg-K). delH =',e11.4,' J/kg')
!
! asorption coefficient and intensity at wall
      tx(1)=tw
      twall=10000./tx(1)
      do iw=1,nwave
        ax=dexp(-1.43877d0*1.0d8/(wavel(iw)*tx(1)))
        do iang=1,10
          intw(iang,iw)=1.1904d-16*ax/((1.0d-8*wavel(iw))**5*(1.d0-ax))   ! W/(cm2-mic-sr)
          intw(iang,iw)=dmax1(sigma*intw(iang,iw),1.0d-30)
          intw(iang,iw)=0.
        end do
        call intpl1(tcho,absb_cho(1,iw),twall,absbx,11)
      end do
!
! radiative flux at wall
      qp(1)=sigma*5.679e-12*tx(1)**4*1.e4               ! W/m2
      if(itime.eq.0) write(6,60) qp(1)
   60 format(/' black body wall radiative flux=',1pe10.3,' W/m2')
!
! shock conditions
      enths=0.5*vinf*vinf*enfac                 ! enthalpy, J/kg
      call pH_air(1,pres,enths, rhos,temps)
      write(6,80) pres,enths,rhos,temps
   80 format(/                                                                        &
  &     ' equilibrium calculation by pH_air using ps and enths'/                      &
  &     ' pres =',1pe11.4,' Pa.    enths =',e11.4,  ' J/kg'/                          &
  &     ' rhos =',e11.4,  ' kg/m3. temps =',0pf10.1,' K')
      call pT_air(1,pres,temps, rhos1,enths1,cps)
      write(6,90) pres,temps, rhos1,enths1,cps
   90 format(/                                                                        &
  &     ' equilibrium calculation by pT_air using ps and temps'/                      &
  &     ' pres =',1pe11.4,' Pa.    temps =',0pf10.1,' K'/                             &
  &     ' rhos1=',1pe11.4,' kg/m3. enths1=',e11.4,  ' J/kg'/                          &
  &     ' cps  =',e11.4,' J/(kg-K)')
!
! density ratio across shock
      denrat=rhoinf/rhos
! ratio of shock stand-off distance to nose radius
! from Park, JQSRT 28,29 (1982)
      del_rat=denrat*(1.0-2.*denrat+5.5*denrat**2)
! shock stand-off distance
      delta=rnose*del_rat
      write(6,150) delta
  150   format(' shock standoff distance delta=',1pe10.3,' m')
!      write(10,30) 
   30 format('   rhoinf      vinf      rnose     amdot       fw         ndm',         &
  &     '    qm1-qp1    delH       dmix         Ts        Ti        Tw    eff_lum')
      read(5,120) (dum(i),i=1,25)
  120 format(25a4)
      write(6,120) (dum(i),i=1,25)
      read(5,120) (dum(i),i=1,25)
      write(6,120) (dum(i),i=1,25)
!     
      write(12,160) rhoinf,vinf,rnose
  160 format(/' rhoinf=',1pe10.3,' vinf=',e10.3,' rnose=',e10.3/                      &
 &        ' iout      flow')
      write(13,170) rhoinf,vinf,rnose
  170 format(/' rhoinf=',1pe10.3,' vinf=',e10.3,' rnose=',e10.3/                      &
 &        '  im      amdot')
      enths=0.5*vinf*vinf*enfac

      iout1=1
      im1=1
      call calc(nwave,ndm,tx,rhoinf,vinf,pres,tw,rnose,temps,rhos,                    &
  &     enths,delta,delH,spallf,nout,nim,facout1,facin1,facout2,facin2,famdot,        &
  &     enfac,sigma,iout1,im1)
      if(spallf.lt.1.0e-6) go to 220 
      write(6,*) ' '
      iout1=2*nout+1
      im1=2*nim+1
      call calc1(nwave,ndm,tx,rhoinf,vinf,pres,tw,rnose,temps,rhos,                   &
  &     enths,delta,delH,nout,nim,facout1,facin1,facout2,facin2,famdot,               &
  &     sigma,hwhh,iout1,im1, amdot_out,delta1,dmix,qps)
! shock stand-off distance considerations
  220 continue      
! mean free path
      mfp=7.171e-8*1.225/rhoinf                  ! mean-free-path in meters
! assume relaxation distance to be 7 mfps
      relax_dist=7.*mfp                          ! relaxation distance, m
! equiiibrium shock stand-off distance
      eqinv_delta=delta1-relax_dist-dmix         ! m
      write(6,40) delta,relax_dist,dmix,eqinv_delta
   40 format(/                                                                        &
 &      ' frozen inviscid shock standoff distance      =',1pe12.5,' m'/               &
 &      ' chemical relaxation distance                 =',e12.5,' m'/                 &
 &      ' viscous mixing/cooling distance              =',e12.5,' m'/                 &      
 &      ' equilibrium inviscid shock standoff distance =',e12.5,' m')
!
! calculate precursor region
      call precurs(mwave,nwave,int_s,qps, rhoinf,vinf,rnose, flux_s,flux_prec,int_prec)
! luminous efficiency calc
      pwrrad=flux_prec*3.1416*rnose**2
      pwrabl=0.5*vinf*vinf*amdot_out*3.1416*rnose**2
      if(spallf.gt.1.0e-6) eff_lum=pwrrad/pwrabl
      if(spallf.le.1.0e-6) eff_lum=0.
!
! calculate atmospheric absorption
      call atm_absb(mwave,nwave,flux_prec,int_prec,altit,elev_ang,rhoinf,      &
  &     flux_grd,int_grd)
!
! radiation intensity in magnitude
      call magnitf(nwave,rnose,flux_s,flux_prec,flux_grd,       &
  &     altit,elev_ang, magnit)
!
! Gaussian slit 
      wav1=3000.; wav2=8000.; nskip=5
      call gausst(nwave,hwhh,wav1,wav2,wavel,nskip,int_grd,int_cam)
!
! energy considerations 
      engy_sum2=enths + flux_prec/(rhoinf*vinf)
      error=engy_sum2/(0.5*vinf*vinf) - 1.0
      prec_loss=flux_s-flux_prec
!
      pwrrad=flux_grd*3.1416*rnose**2
      pwrabl=enths*amdot_out*3.1416*rnose**2
      eff_lum=pwrrad/pwrabl
      hloss=0.5*eff_lum*vinf*amdot_out/rhoinf

      write(*,20) 0.5*vinf*vinf,enths,flux_s,flux_s/(rhoinf*vinf),flux_prec,          &
  &     flux_prec/(rhoinf*vinf),prec_loss,prec_loss/(rhoinf*vinf),flux_grd,           &
  &     flux_grd/(rhoinf*vinf),eff_lum,hloss,engy_sum2,error,magnit,eff_lum  
      write(6,20) 0.5*vinf*vinf,enths,flux_s,flux_s/(rhoinf*vinf),flux_prec,          &
  &     flux_prec/(rhoinf*vinf),prec_loss,prec_loss/(rhoinf*vinf),flux_grd,           &
  &     flux_grd/(rhoinf*vinf),eff_lum,hloss,engy_sum2,error,magnit,eff_lum  

   20 format(/' Energy tally'                                                 /       &
  &     ' 0.5*vinf*vinf (freestream enthalpy)               =',1pe11.4,' J/kg'/       &   
  &     ' enths (assumed shock layer enthalpy)              =',e11.4,' J/kg'/         &                                                                             
  &     ' flux_s (radiative power at shock)                 =',e11.4,' W'/            &
  &     '   flux_s/(rhoinf*vinf) (enthalpy in flux_s)       =',e11.4,' J/kg'/         &
  &     ' flux_prec  (rad flux at end of precursor region)  =',e11.4,' W'/            &
  &     '   flux_prec/(rhoinf*vinf) (enthalpy in flux_prec) =',e11.4,' J/kg'/         &
  &     ' prec_loss (radiation power absorbed in precursor region'          /         &
  &     '   and recaptured by shock layer)                  =',e11.4,' W'/            &
  &     '   prec_loss/(rhoinf*vinf) (enthalpy in prec_loss) =',e11.4,' J/kg'/         &
  &     ' flux_grd (radiative flux falling on ground)       =',e11.4,' W'/            &
  &     '   flux_grd/(rhoinf*vinf) (enthalpy in flux_grd)   =',e11.4,' J/kg'/         &
  &     ' eff_lum (lum efficiency based on qgrd)            =',e11.4/                 &
  &     ' hloss (enthalpy in eff_lum)                       =',e11.4,' J/kg'/         &
  &     ' engy_sum2 (enthalpy sum)                          =',e11.4,' J/kg'/         &
  &     ' error fraction = engy_sum2/(0.5*vinf*vinf) - 1.0) =',e11.4/                 &
  &     ' brightness magnitude                              =',0pf10.3/               &
  &     ' eff_lum(luminous efficiency)                      =',1pe10.3)
!
! plot absorption coef behind shock (absb(s)), normal intensity ahead of shock(int_s).
!   normal intensity at end of precursor region(int_prec), normal intensity at
!   ground(int_grd), and intensity caught on spectrographic camera with a Gaussian
!   slita(camera)

      write(14,210) rhoinf,vinf,rnose
  210 format(/' rhoinf=',1pe11.4,' vinf=',e11.4,' rnose=',e11.4/                      &
  &     '   iw    wavel     int_s     int_prec    int_grd    camera')
      do iw=1,nwave
        write(14,110) iw,wavel(iw),int_s(1,iw),int_prec(iw),int_grd(iw),    &
  &       int_cam(iw)
      end do
  110 format(i6,f10.3,1p6e11.4)

! plot absorption coef at edge of ablation product layer(absb(e)), norma lintensity
!   at edge(int-e), outward normal intensity at wall(wall(+)), and inward normal
!   intensity at wall(wall(-)) 
      write(15,50) rhoinf,vinf,rnose
   50 format(/' rhoinf=',1pe11.4,' vinf=',e11.4,' rnose=',e11.4/                      &
  &     '   iw    wavel     int_e      wall(+) ')
      do iw=1,nwave
        write(15,110) iw,wavel(iw),int_e(1,iw),intw(1,iw)
      end do
      close(15)
!
! smoothed signals
      do iw=1,nwave
        any(iw)=int_e(1,iw)
      end do
      call smooth(nwave,wavel,any, wav_sh,edge)
      do iw=1,nwave
        any(iw)=int_s(1,iw)
      end do
      call smooth(nwave,wavel,any, wav_sh,shk)
      call smooth(nwave,wavel,int_prec, wav_sh,prec)
      call smooth(nwave,wavel,int_grd, wav_sh,grd)
      write(21,100)
  100 format(/' smoothed profiles:'/                                    &
  &     ' edge=at edge of vapor layer'                                  &
  &     ' shk=in front of shock wave'/                                  &
  &     ' prec=at end of precursor region'/                             &
  &     ' grd=at ground'/                                               &
  &     '   i     wavel     edge      shk       prec       grd' )
      do iw=1,1000
        write(21,10) iw,wav_sh(iw),edge(iw),shk(iw),prec(iw),grd(iw)
   10   format(i5,f10.1,1p6e10.3)
      end do
!
! Borovicka parameters
! volume
      vol=(4./3.)*pi*rnose**3
! mass
      solid_dens_av1=2000.
      mass=vol*solid_dens_av1
! shape factor
      shape_fac=pi*rnose**2/(vol**0.6666667) 
! drag cofficient
      drag_coef=0.5
! shape-density coefficient
      shape_dens_coef=drag_coef*shape_fac/(solid_dens_av1**0.6666667)
! heat transfer coef
      heat_tr_coef=delH*(amdot_out*pi*rnose**2)*2./                     &
  &     (shape_fac*vol**0.666667*rhoinf*vinf**3)
! ablation coefficient
      abl_coef=heat_tr_coef/(2.*drag_coef*delH)
      write(6,171) vol,mass,shape_fac,drag_coef,shape_dens_coef,        &
  &     heat_tr_coef,abl_coef
  171 format(/' Borovicka parameters'/                                  &
  &     ' volume               =',1pe11.4,' m3'/                        &
  &     ' mass                 =',e11.4,' kg'/                          &
  &     ' shape_factor         =',e11.4/                                &
  &     ' drag_coef            =',e11.4/                                &
  &     ' shape-density coef   =',e11.4/                                &
  &     ' heat transfer coef   =',e11.4/                                &
  &     ' abl_coef             =',e11.4)
!
! write goodbye
      write(6,*) ' '
      write(*,*) ' '
      write(6,*) ' goodbye'
      write(*,*) ' goodbye'
      return
      end
!***********************************************************************
      subroutine compos(elmnm1,elmwt1,elmf1)
! calculates elemental mass fractions from given compositions of meteoroid
! output parameters:
!   elmnm1(14)=elemental name
!   elmwt1(14)=elemental mass, kg/mol
!   elmsf1(14)=elemental mass fraction
      implicit real*8(a-h,o-z)
      character*4 dum(51),elmnm(13),elmnm1(13)
      dimension compmf(14),elmwt(13),compwt(14),elmmf(14),elmf(14),                &
  &     elmef(14),elmwt1(13),elmf1(14)
      character*6 compnm
      common/compi/compnm(14)
      common/compe/compef(14),solid_dens(14),solid_dens_av,wtmolc
      real*8 mg_K,mgo_c_K,mgo_K,mgo_L_K
      dimension tw(9),tw1(9),twx(9),plogx(9),psum(9),psumlog(9),                   &
     & p(9,7),delK(10,7),delHz(4),coeft(4),coefH(4),                               &
     & o_K(9),o2_K(9),al2o3_L_K(9),alo_K(9),cao_K(9),cao_L_K(9),                   &
     & sio2_c_K(6),sio2_L_K(9),sio2_K(9),sio_K(9),                                 &
     & fe2o3_c_K(6),fe2o3_L_K(9),feo_L_K(9),feo_K(9),                              &
     & mgo_c_K(8),mgo_L_K(9),mgo_K(9),                                             &
     & h2o_L_K(9),oh_K(9),h2_K(9),h_K(9),fes_c_K(6),fes_L_K(9),fes_K(9),           &
     & c_c_K(9),c3_K(9),sens_SiO2(9),sens_FeO(9),sens_FeS(9),sens_H2O(9),          &
     & sens_MgO(9),sens_C(9)  
      dimension aa(4,4),bb(4,2),cc(4,2)
      dimension twz(51),ploglog(51),ppb(51),delH_wt(51)
!      
      data compnm/                                                                 &
!         1        2        3        4        5
  &     'SiO2  ','TiO2  ','Al2O3 ','CrO2  ','Fe2O3 ',                              &
!         6        7        8        9       10
  &     'FeO   ','MgO   ','CaO   ','Na2O  ','H2O   ',                              &
!        11       12       13       14
  &     'Fe    ','Ni    ','FeS   ','C     '/
!
      data elmnm/                                                                  &
!         1        2        3       4       5
  &     'S   ',  'H   ',  'C   ', 'O   ', 'Si  ',                                  &
!         6        7        8       9      10
  &     'Mg  ',  'Fe  ',  'Ca  ', 'Al  ', 'Na  ',                                  &
!        11       12       13
  &     'Ti  ',  'Cr  ',  'Ni  '/
!
      data elmwt/                                                                  &
  &     0.032064, 0.001008, 0.012011, 0.016,    0.028086,                          &
  &     0.024312, 0.055847, 0.04008,  0.026982, 0.022990,                          &
  &     0.047880, 0.051996, 0.058690/
! 
      data solid_dens/                                                             &
  &     2.468 ,    4.486,     3.97,     2.90,   5.255,                             &
  &     6.0,       3.6,       3.35,     2.27,    1.0,                              &
  &     7.87,      8.90,      4.70,     2.20/
!
      data tw/500.,1000.,1500.,2000.,2500.,3000.,3500.,4000.,4500./
      data twx/500.,1000.,1500.,2000.,2500.,3000.,3500.,4000.,4500./
      do i=1,14
        compef(i)=0.
      end do
!
! equilibrium constants---------------------------------------------------------- 
!
! O2 --> 2 O
      data o2_K/    0.,     0.,    0.,    0.,    0.,   0., 0.,0.,0./ 
  
! SiO2(L) --> SiO + 0.5*O2
      data sio2_c_K/85.444,38.137,22.443,14.388,9.463,6.197/
      data sio2_L_K/85.617,38.145,22.415,14.388,9.528,6.322,4.056,1.665,-0.186/
      data sio2_K/32.142,16.114,10.743,7.796,5.902,4.631,3.717,2.318,1.222/
      data sio_K/15.168,9.790,7.926,6.706,5.836,5.240,4.802,3.757,2.934/
!
! Al2O3 -->2AlO + 0.5*O
      data al2o3_L_K/158.659,71.114,41.067,27.008,18.433,12.325,7.157,3.365,-0.427/
      data alo_K/-2.470,0.800,1.614,1.981,2.186,1.933,1.301,0.832,0.470/
      data o_K/-22.936,-9.803,-5.392,-3.175,-1.839,-0.946,-0.307,0.173,0.547/
!
! CaO --> CaO
      data cao_L_K/53.971,24.918,15.121,9.720,6.044,3.630,1.930,0.778,-0.310/
      data cao_K/  -0.690,1.185,1.817,1.461,0.783,0.359,0.080,-0.116,-0.364/

! Fe2O3(L) --> 2FeO + 0.5 O2
      data fe2o3_c_K/71.972,29.349,15.265,8.185,3.837,-0.511/
      data feo_L_K/23.271,10.355,6.033,3.877,2.766,1.661,0.428,-0.673,-1.517/
      data feo_K/-20.427,-7.561,-3.492,-1.588,-0.565,0.071,-0.112,-0.451,-0.721/

! FeO(L) --> FeO
      data feo_L_K/23.271,10.355,6.033,3.877,2.544,1.661,0.428,0.673,-1.517/
!      data feo_K/-20.427,-7.561,-3.492,-1.588,-0.565,0.071,-0.112,-0.451,-0.721/

! MgO(L) --> MgO
      data mgo_c_K/57.153,25.749,14.722,8.358,4.582,2.095,0.341,-0.957/
      data mgo_L_K/57.153,25.749,14.722,8.358,4.582,2.095,0.491,-0.654,-1.527/
      data mgo_K/-2.040,0.894,1.327,0.679,0.305,0.059,-0.115,-0.246,-0.350/

! H2O(L) --> OH + 0.5 H2
      data h2o_L_K/20.534,6.458,1.934, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/
      data oh_K/ -3.246, -1.222, -0.563, -0.240, -0.050,0.074,0.160, 0.223,0.270/
      data h2_K/0.,0.,0.,0.,0.,0.,0.,0.,0./
      data h_K/-20.158,-8.644,-4.754,-2.788,-1.599,-0.801,-0.228,0.203,0.539/

! FeS(c) --> FeS
      data fes_c_K/10.707,5.102,2.401,1.297,0.577,0.091/
      data fes_L_K/10.707,5.102,2.401,1.297,0.577,0.091,-0.867,-1.806,-2.544/
      data fes_K/-28.832,-10.510,-5.481,-3.099,-1.791,-0.967,-1.017,-1.256,-1.448/

! C(c) --> (1/3) C3
      data c_c_K/0.,0.,0.,0.,0.,0.,0.,0.,0./
      data c3_K/-74.143,-31.400,-17.322,-10.384,-6.285,-3.596,-1.708,-0.317,0.745/
!
! read in compound mass fractions
      sum=0.
      do i=1,14
        read(5,10) compmf(i),(dum(j),j=1,10)
  10    format(e10.3,20a4)
        write(6,20) compmf(i),(dum(j),j=1,10)
  20    format(f10.7,20a4)
        sum=sum+compmf(i)
      end do
! normalize compound mass fractions
      do i=1,14
        compmf(i)=compmf(i)/sum
      end do
!
! average density
      sum=0.
      do i=1,14
        sum=sum+compmf(i)/solid_dens(i)
      end do
      solid_dens_av=1./sum
      write(6,60) solid_dens_av
   60 format(/' ideal density of meteoroid, solid=',1pe11.4,' g/cm3')
!
! component weight                               !  kg/mol
      compwt(1)=elmwt(5)+2.*elmwt(4)             !  SiO2      1
      compwt(2)=elmwt(11)+2.*elmwt(4)            !  TiO2      2
      compwt(3)=2.*elmwt(9)+3.*elmwt(4)          !  Al2O3     3
      compwt(4)=elmwt(12)+2.*elmwt(4)            !  CrO2      4
      compwt(5)=2.*elmwt(7)+3.*elmwt(4)          !  Fe2O3     5
      compwt(6)=elmwt(7)+elmwt(4)                !  FeO       6
      compwt(7)=elmwt(6)+elmwt(4)                !  MgO       7
      compwt(8)=elmwt(8)+elmwt(4)                !  CaO       8
      compwt(9)=2.*elmwt(10)+elmwt(4)            !  Na2O      9
      compwt(10)=2.*elmwt(2)+elmwt(4)            !  H2O      10
      compwt(11)=elmwt(7)                        !  Fe       11
      compwt(12)=elmwt(13)                       !  Ni       12
      compwt(13)=elmwt(7)+elmwt(1)               !  FeS      13
      compwt(14)=elmwt(3)                        !  C        14
!
! compound mole fractions
      sum=0.
      do i=1,14
        compef(i)=compmf(i)/compwt(i)
        sum=sum+compef(i)
      end do
      do i=1,14
        compef(i)=compef(i)/sum
      end do
! compound molecular weight
      wtmolc=0.
      do i=1,14
        wtmolc=wtmolc+compwt(i)*compef(i)
      end do
      write(6,30) wtmolc
  30  format(/' molecular weight of condensate = ',1pe12.5,' kg/mol'/  &
  &     /' normalized compound mass and mole fractions'/               &
  &      '   i   species      massf       molef')
      do i=1,14
        write(6,40) i,compnm(i),compmf(i),compef(i)
  40    format(i5,2x,a4,4x,1p4e12.5)
      end do
!
! elemental mole fractions
      elmmf(1)=compef(13)                                   !  S
      elmmf(2)=2.*compef(10)                                !  H
      elmmf(3)=compef(14)                                   !  C
      elmmf(4)=2.*compef(1)+2.*compef(2)+3.*compef(3)      &!  
  &     +2.*compef(4)+3.*compef(5)+compef(6)+compef(7)     &!
  &     +compef(8)+compef(9)+compef(10)                     !  O
      elmmf(5)=compef(1)                                    !  Si
      elmmf(6)=compef(7)                                    !  Mg
      elmmf(7)=2.*compef(5)+compef(6)+compef(11)+compef(13) !  Fe    
      elmmf(8)=compef(8)                                    !  Ca
      elmmf(9)=2.*compef(3)                                 !  Al
      elmmf(10)=2.*compef(9)                                !  Na
      elmmf(11)=compef(2)                                   !  Ti
      elmmf(12)=compef(4)                                   !  Cr
      elmmf(13)=compef(12)                                  !  Ni
!
! elemental mass fractions
      sum=0.
      do i=1,13
        elmf(i)=elmmf(i)*elmwt(i)
        sum=sum+elmf(i)
      end do
      do i=1,13
        elmf(i)=elmf(i)/sum
      end do
! elemental mol fractions
      sum=0.
      do i=1,13
        sum=sum+elmmf(i)
      end do
      do i=1,13
        elmmf(i)=elmmf(i)/sum
      end do

      write(6,50) 
  50  format(/'   i  specie       elmwt      massfrac     molfrac') 
      do i=1,13
        write(6,40) i,elmnm(i),elmwt(i),elmf(i),elmmf(i)
        elmnm1(i)=elmnm(i); elmwt1(i)=elmwt(i); elmf1(i)=elmf(i)
      end do
!
      return
      end   
!***********************************************************************                  
      subroutine conv(gamsp,gamsp1,nprt)                                                  
! this subroutine and accompanying subroutine conv1 shrink and restore
!   species list by ivoking elemental conservation 
! assumes the first nelem species are to be removed and put back in                                 
! input: gamsp(i),i=1,nsp: original species list                                                               
!        nprt=print index                                                                 
! output: gamsp1(i),i=1,nsp-nelem; shrunken species list                                                         
      parameter(msp=60)                                                                   
      implicit real*8(a-h,o-z)                                                            
      common/eqcoma/elemwt(15),                                           &               
     & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp),            &               
     & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp),             &               
     & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp),                     &               
     & akb(5,msp),akd(5,msp),avmw0                                                        
      common/eqcomb/elemnm(12)                                                            
      common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc,  &               
     & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp),   &               
     & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp)                        
      dimension gamsp(msp),gamsp1(msp)                                                    
      character*4 elemnm,spnm                                                             
!
      do isp=nelem+1,nsp
        gamsp1(isp-nelem)=gamsp(isp)
      end do

      return                                                                              
      end                                                                                 
!************************************************************************************     
      subroutine conv1(gamsp1,gamsp,nprt)                                                 
! this subroutine and accompanying subroutine conv shrink and restore
!   species list by ivoking elemental conservation 
! assumes the first nelem species are to be removed and put back in                                 
! input: gamsp1(i),i=1,nsp: shrunken species list                                                               
!        nprt=print index                                                                 
! output: gamsp(i),i=1,nsp-nelem; restored species list                                                         
!
      parameter(msp=60)                                                                   
      implicit real*8(a-h,o-z)                                                            
      common/eqcoma/elemwt(15),                                           &               
 &    felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp),             &               
 &    atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp),              &               
 &    hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp),                      &               
 &    akb(5,msp),akd(5,msp),avmw0                                                        
      common/eqcomb/elemnm(12)                                                            
      common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc,  &               
 &    neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp),    &               
 &    im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp)                        
      dimension gamsp(msp),gamsp1(msp),amat(15,15),rhs(15),ipvt(15),      &
 &    work(15),bmat(15,15)                                                    
      character*4 elemnm,spnm 
      save
      data itime/0/                                                            
      itime=itime+1
!
! first nelem-1 lines
      do j=1,nelem-1
! left-hand matrix
! i=column number; j=line number
        do i=1,nelem
          amat(j,i)=(spwt(j)/felem(j))*ielem(i,j)                       &    ! amat(j,i) correct
  &                -(spwt(j+1)/felem(j+1))*ielem(i,j+1)
        end do
! right-hand side vector
        rhs(j)=0.
        do i=nelem+1,nsp
          rhs(j)=rhs(j)-(spwt(j)/felem(j))*ielem(i,j)*gamsp1(i-nelem)   &
  &              +(spwt(j+1)/felem(j+1))*ielem(i,j+1)*gamsp1(i-nelem)
        end do
      end do
!
! last line. element sum = 1
! left-hand matrix 
      do i=1,nelem
        amat(nelem,i)=0.
        do j=1,nelem
          amat(nelem,i)=amat(nelem,i)+ielem(i,j)*spwt(j)
!          if(itime.eq.2408016) then
!            write(6,50) i,j,ielem(i,j),spwt(j),amat(nelem,i)
!   50       format(' i=',i3,' j=',i3,' ielem=',i3,' spwt=',1pe9.2,' amat=',e10.3)
!          end if
        end do
      end do
! right-hand vector
      rhs(nelem)=1.
      do i=nelem+1,nsp
        do j=1,nelem
          rhs(nelem)=rhs(nelem)-ielem(i,j)*spwt(j)*gamsp1(i-nelem)
        end do
      end do
!
! copy left-hand matrix for later display      
      do ir=1,nelem
        do ic=1,nelem
          bmat(ir,ic)=amat(ir,ic)
        end do
      end do
!
! solve

      call decomp(15,nelem,amat,cond,ipvt,work)

! display amat if cond .gt. 1.e8
!      if(cond.gt.1.0e8) then
!        write(6,*) ' itime=',itime
!        write(6,20) cond
!   20   format(' in conv1. cond=',1pe10.3)
!        do ir=1,nelem
!          write(6,10) ir,(bmat(ir,ic),ic=1,nelem)
!   10     format(i3,1p15e9.2)
!        end do
!        if(itime.ge.100) stop
!      end if

      call solve(15,nelem,amat,rhs,ipvt)                                        
!
      do j=1,nelem
        gamsp(j)=rhs(j)
      end do
      do j=nelem+1,nsp
        gamsp(j)=gamsp1(j-nelem)
      end do

      return
      end
!***********************************************************************                  
      subroutine decomp(ndim,n,a,cond,ipvt,work)                                          
      implicit real*8(a-h,o-z)                                                                                        
      integer ndim, n                                                                     
      real*8 a(ndim,n), cond, work(n)                                                       
      integer ipvt(n)                                                                     
!                                                                                         
!     decomposes a real matrix by gaussian elimination and estimates                      
!     the condition of the matrix.                                                        
!                                                                                         
!     use subroutine solve to compute solutions to linear systems.                        
!                                                                                         
!     input...                                                                            
!                                                                                         
!       ndim = declared row dimension of the array containing a.                          
!                                                                                         
!       n = order of the matrix.                                                          
!                                                                                         
!       a = matrix to be triangularized.                                                  
!                                                                                         
!     output...                                                                           
!                                                                                         
!       a contains an upper triangular matrix u and a permuted version                    
!        of a lower triangular matrix i-l so that                                         
!        (permutation matrix)*a = l*u                                                     
!                                                                                         
!       cond = an estimate of the condition of a. for the linear system                   
!        a*x = b, changes in a and b may cause changes cond times as                      
!        large in x. if (cond+1.0) equals cond, a is singular to working                  
!        precision. cond is set to 1.0e+32 if exact singularity is detected.              
!                                                                                         
!       ipvt = the pivot vector                                                           
!        ipvt(k) = the index of the k-th pivot row                                        
!        ipvt(n) = (-1)**(number of interchanges)                                         
!                                                                                         
!     work space...                                                                       
!                                                                                         
!      the vector work must be declared and included in the call. its                     
!      input contents are ignored. its output contents are usually                        
!      unimportant.                                                                       
!                                                                                         
!     the determinant of a can be obtained on output by                                   
!      det(a) = ipvt(n)*a(1,1)*a(2,2)*...*a(n,n)                                          
!                                                                                         
      real*8 ek, t, anorm, ynorm, znorm                                                     
      integer nm1, i, j, k, kp1, kb, km1, m                                               
!                                                                                         
      ipvt(n) = 1                                                                         
      if(n .eq. 1) go to 80                                                               
      nm1 = n - 1                                                                         
!                                                                                         
!     compute 1-norm of a                                                                 
!                                                                                         
      anorm = 0.0                                                                         
      do 10 j = 1, n                                                                      
        t = 0.0                                                                           
        do 5 i = 1, n                                                                     
          t = t + abs(a(i,j))                                                             
    5   continue                                                                          
        if(t .gt. anorm) anorm = t                                                        
   10 continue                                                                            
!                                                                                         
!     gaussian elimination with partial pivoting                                          
!                                                                                         
      do 35 k = 1, nm1                                                                    
        kp1 = k + 1                                                                       
!                                                                                         
!       find pivot                                                                        
!                                                                                         
        m = k                                                                             
        do 15 i = kp1, n                                                                  
          if(abs(a(i,k)) .gt. abs(a(m,k))) m = i                                          
   15   continue                                                                          
        ipvt(k) = m                                                                       
        if(m .ne. k) ipvt(n) = -ipvt(n)                                                   
        t = a(m,k)                                                                        
        a(m,k) = a(k,k)                                                                   
        a(k,k) = t                                                                        
!                                                                                         
!       skip step if pivot is zero                                                        
!                                                                                         
        if(t .eq. 0.0) go to 35                                                           
!                                                                                         
!       compute multipliers                                                               
!                                                                                         
        do 20 i = kp1, n                                                                  
          a(i,k) = -a(i,k)/t                                                              
   20   continue                                                                          
!                                                                                         
!       interchange and eliminate by columns                                              
!                                                                                         
        do 30 j = kp1, n                                                                  
          t = a(m,j)                                                                      
          a(m,j) = a(k,j)                                                                 
          a(k,j) = t                                                                      
          if(t .eq. 0.0) go to 30                                                         
          do 25 i = kp1, n                                                                
            a(i,j) = a(i,j) + a(i,k)*t                                                    
   25     continue                                                                        
   30   continue                                                                          
   35 continue                                                                            
!                                                                                         
!     cond = (1-norm of a)*(an estimate of 1-norm of a-inverse)                           
!     estimate obtained by one step of inverse iteration for the small                    
!     singular vector. this involves solving two systems of equations,                    
!     (a-transpose)*y = e and a*z = y where e is a vector of +1 or -1                     
!     chosen to cause growth in y.                                                        
!     estimate = (1-norm of z)/(1-norm of y)                                              
!                                                                                         
!     solve (a-transpose)*y = e                                                           
!                                                                                         
      do 50 k = 1, n                                                                      
        t = 0.0                                                                           
        if(k .eq. 1) go to 45                                                             
        km1 = k - 1                                                                       
        do 40 i = 1, km1                                                                  
          t = t + a(i,k)*work(i)                                                          
   40   continue                                                                          
   45   ek = 1.0                                                                          
        if(t .lt. 0.0) ek = -1.0                                                          
        if(a(k,k) .eq. 0.0) go to 90                                                      
        work(k) = -(ek + t)/a(k,k)                                                        
   50 continue                                                                            
      do 60 kb = 1, nm1                                                                   
        k = n - kb                                                                        
        t = 0.0                                                                           
        kp1 = k + 1                                                                       
        do 55 i = kp1, n                                                                  
          t = t + a(i,k)*work(k)                                                          
   55   continue                                                                          
        work(k) = t                                                                       
        m = ipvt(k)                                                                       
        if(m .eq. k) go to 60                                                             
        t = work(m)                                                                       
        work(m) = work(k)                                                                 
        work(k) = t                                                                       
   60 continue                                                                            
!                                                                                         
      ynorm = 0.0                                                                         
      do 65 i = 1, n                                                                      
        ynorm = ynorm + abs(work(i))                                                      
   65 continue                                                                            
!                                                                                         
!     solve a*z = y                                                                       
!                                                                                         
      call solve(ndim, n, a, work, ipvt)                                                  
      znorm = 0.0                                                                         
      do 70 i = 1, n                                                                      
        znorm = znorm + abs(work(i))                                                      
   70 continue                                                                            
!                                                                                         
!     estimate condition                                                                  
!                                                                                         
      cond = anorm*znorm/ynorm                                                            
      if(cond .lt. 1.0) cond = 1.0                                                        
      return                                                                              
!                                                                                         
!     1-by-1                                                                              
!                                                                                         
   80 cond = 1.0                                                                          
      if(a(1,1) .ne. 0.0) return                                                          
!                                                                                         
!     exact singularity                                                                   
!                                                                                         
   90 cond = 1.0e+32                                                                      
      return                                                                              
      end                                                                                 
!**********************************************************************                   
      subroutine der1(neq,t,yy,dydx,istep,nprt)                                           
! steering subroutine for der2 for equilibrium calculation eqcal1                         
! inputs:                                                                                 
!   neq=number of equations                                                               
!   t=time                                                                                
!   yy(i)=species concentration, mol/kg                                                   
!   dydx(i)=rate of change                                                                
!   istep=time step number                                                                
!   nprt=print index                                                                      
! outputs:                                                                                
!   yy(40)=solution                                                                       
!   dydx(40)=slope                                                                        
      parameter(msp=60)                                                                   
      implicit real*8(a-h,o-z)                                                            
      common/eqcoma/elemwt(15),                                           &               
     & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp),            &               
     & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp),             &               
     & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp),                     &               
     & akb(5,msp),akd(5,msp),avmw0                                                        
      common/eqcomb/elemnm(12)                                                            
      common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc,  &               
     & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp),   &               
     & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp)                        
      common/eqcomb/pres,temp,rho,enth,spgam(msp),amdot                                   
      dimension y(msp),yy(msp),dydx(msp),dydx1(msp),w(msp)                                
      character*4 elemnm,spnm                                                             
!                                                                                         
      call conv1(yy,y,0) 
!
! suppress negative species concentration
      do isp=1,nsp
        if(y(isp).lt.0.) y(isp)=1.0e-8
      end do                                                                 
!                                                                                         
! determine density rho                                                                   
      y(nsp1)=0.                                                                          
      do isp=1,nsp                                                                        
        y(nsp1)=y(nsp1)+y(isp)*ie(isp)                                                    
      end do                                                                              
!                                                                                         
      rho1=rho*1.0d-3                                                                     
      do 10 i=1,nsp1                                                                      
        y(i)=y(i)*1.0d-3                                                                  
!        y(i)=dmax1(y(i)*1.0d-3,1.0d-20)                                                  
   10 continue                                                                            
      call der2(rho1,y,temp,dydx1,w,istep,nprt)                                           
      do 20 i=1,nsp                                                                       
   20 dydx1(i)=dydx1(i)*1.0d3                                                             
      call conv(dydx1,dydx,0)                                                             
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine der2(rho,g,tk,rate,w,istep,nprt)                                         
! determines rate of production for equilibrium calculation                               
!   for der1 for eqcal1                                                                   
! input parameters:                                                                       
!   rho=density, gram/cm3                                                                 
!   g(i)=species mol concentrations, mol/gram                                             
!   tk=temperature, k                                                                     
!   istep=step number                                                                     
!   nprt=print index                                                                      
! output parameters:                                                                      
!   rate(i),i=1,nsp1: rate of production of species i, mol/(gram-sec)                     
!   w(i),i=1,n10: rate of production by reaction i, mol/(gram-sec)                        
!   ier=error message. 0=no error. 1=error                                                
!                                                                                         
      parameter(msp=60)                                                                   
      implicit real*8(a-h,o-z)                                                            
      common/eqcoma/elemwt(15),                                           &               
     & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp),            &               
     & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp),             &               
     & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp),                     &               
     & akb(5,msp),akd(5,msp),avmw0                                                        
      common/eqcomb/elemnm(12)                                                            
      common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc,  &               
     & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp),   &               
     & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp)                        
      dimension rate(msp),g(msp),g1(msp),ckf(msp),ckr(msp),w(msp)                         
      character*4 elemnm,spnm                                                             
      data itime/0/                                                                       
!                                                                                         
! set rate coefs                                                                          
      if(istep.lt.2) then                                                                 
!                                                                                         
! set variable parameters                                                                 
        do k=1,n10                                                                        
          ckf(k)=0.d0                                                                     
          ckr(k)=0.d0                                                                     
        end do                                                                            
        t1=1.d0/tk                                                                        
        tlog=dlog(tk)                                                                     
!                                                                                         
! construct forward rate coef ckf(j) and reverse rate coef ckr(j)                         
!    arrays                                                                               
!                                                                                         
! a+m-->b+c+m type                                                                        
        z=10000.d0*t1                                                                     
        do j=n1,n6                                                                        
          akej=aka(1,j)/z+aka(2,j)+aka(3,j)*(-tlog+9.21034d0)+aka(4,j)*z  &               
     &     + aka(5,j)*z*z                                                                 
          ckf(j)=1.0d0                                                                    
          ckr(j)=rho*ckf(j)*dexp(-akej)                                                   
        end do                                                                            
!                                                                                         
! a+b-->c+d type                                                                          
        do j=n7,n10                                                                       
          akej=aka(1,j)/z+aka(2,j)+aka(3,j)*(-tlog+9.21034d0)+aka(4,j)*z  &               
     &      + aka(5,j)*z*z                                                                
          ckf(j)=1.0d0                                                                    
          ckr(j)=ckf(j)*dexp(-akej)                                                       
        end do                                                                            
!                                                                                         
! reduce the magnitudes of ckf and ckr                                                    
        do j=1,n10                                                                        
          ckf(j)=ckf(j)/ckr(j)                                                            
          ckr(j)=1.0d0                                                                    
        end do                                                                            
!                                                                                         
      endif                                                                               
!                                                                                         
! sum up individual reactions to compute rates                                            
      do k=1,nsp                                                                          
        rate(k)=0.d0                                                                      
      end do                                                                              
      do jr=1,n10                                                                         
        ji1=lid(1,jr)                                                                     
        ji2=lid(2,jr)                                                                     
        jf1=lid(3,jr)                                                                     
        jf2=lid(4,jr)                                                                     
! type a+m=b+c+m                                                                          
        if(jr.le.n6) then                                                                 
          w(jr)=ckf(jr)*g(ji1)-ckr(jr)*g(jf1)*g(jf2)                                      
          rate(ji1)=rate(ji1)-w(jr)                                                       
          rate(jf1)=rate(jf1)+w(jr)                                                       
          rate(jf2)=rate(jf2)+w(jr)                                                       
        endif                                                                             
! exchange reactions                                                                      
        if(jr.ge.n7) then                                                                 
          w(jr)=ckf(jr)*g(ji1)*g(ji2)-ckr(jr)*g(jf1)*g(jf2)                               
          rate(ji1)=rate(ji1)-w(jr)                                                       
          rate(ji2)=rate(ji2)-w(jr)                                                       
          rate(jf1)=rate(jf1)+w(jr)                                                       
          rate(jf2)=rate(jf2)+w(jr)                                                       
        endif                                                                             
      end do                                                                              
!      write(6,60) (w(jr),jr=1,n10)                                                       
!   60 format(/' w='/(2x,1p7e11.3))                                                        
!      write(6,10) rho,tk,(g(k),k=1,nsp)                                                  
!   10 format(' der2. rho,tk=',1p2e10.3,' g='/(1p8e9.2))                                   
!      write(6,20) (rate(k),k=1,nsp)                                                      
!   20 format(' rate='/(1p8e9.2))                                                          
!                                                                                         
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine diatom_bb(isp,tran,trot,tvib,tele)                                                                 
! bound-bound transition in diatoms                                                       
! strength of each rotational line is from spradian                                       
! line profile and template procedure are from neqair 
! input parameters:
!   isp=species index
!   diatomnm(mdiatoms)=name of diatom
!   tran=translational temperature, K
!   trot=rotational temperature, K
!   tvib=vibrational temperature, K
!   tele=electron-electronic temperature, K
!   diatom_bands(3,100)=list of diatom radiation mechanisms to be calculated                                    
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60)                                        
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom,                  &               
     & neq_factor_k,ls_u,ls_l                                                             
      character*5 dum(90),hund_diatom,hund                                                
      character*4 asterik,atomnm2(matoms),bandnm_diatom,minus1,unknown                              
      character*4 atom_rads(3,168),diatom_bands(3,100),contnm_diatom,                   &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                                   &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                              &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                                       &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,           &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      integer charge_diatom,g_diatom,lo_state,s_diatom,up_state,          &               
     & g_atom1,g_atom2,gneq_diatom,check,ncentr(301)                                      
      integer vu,vl,spinu, spinl,sisi                                                     
      common/comi/nwave                                                                   
      common/comadiatom/ae_diatom(46,mdiatoms),                           &               
     & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms),    &               
     & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms),             &               
     & atomwt2(mdiatoms),be_diatom(46,mdiatoms),                          &               
     & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms),       &               
     & betae_diatom(46,mdiatoms),                                         &               
     & cross_diatom(11,121,21,mdiatoms),                                  &               
     & cross_imp_diatom(11,11,11,mdiatoms),                               &               
     & de_diatom(46,mdiatoms),diatom_mass(mdiatoms),                      &               
     & diatomwt(mdiatoms),                                                &               
     & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms),                    &               
     & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms),                 &               
     & FC_imp_diatom(0:11,0:11,11,11,mdiatoms),                           &               
     & e_elec_imp_diatom(11,11,11,mdiatoms),                              &               
     & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms),                     &               
     & lam2_diatom(46,mdiatoms),                                          &               
     & n_himp_bb_diatom(11,11,11,mdiatoms),                               &               
     & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms),    &               
     & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms),            &               
     & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms),          &               
     & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms),                    &               
     & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms),    &               
     & td_himp_bb_diatom(11,11,11,mdiatoms),                              &               
     & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms),         &               
     & wavel_cont_diatom(121,0:21,mdiatoms),                              &               
     & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms),                   &               
     & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms)                                  
      common/comidiatom/charge_diatom(mdiatoms),contnm_diatom             &               
     & (2,5,mdiatoms),g_diatom(46,mdiatoms),g_atom1(11,mdiatoms),         &               
     & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms),                   &               
     & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms),        &               
     & maxvl_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxvu_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxv_up_diatom(45,mdiatoms),                                       &               
     & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms),          &               
     & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms),           &               
     & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms),        &               
     & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms),                     &               
     & nup_diatom(45,mdiatoms),                                           &               
     & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms)                                 
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/comhund/hund_diatom(35,mdiatoms)                                             
      common/spect/calpha,slope_ratio,wavmin,wavmax,rangex                                             
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      dimension emisj(nw)                                                                 
      common/scratch/ y(-nw:nw)                                                           
!                                                                                         
      write(6,15) diatomnm(isp),dens_diatom(isp)                                          
  15  format(' In diatom_bb. species = ',a4,1pe10.3,' cm-3')                              
! 
      ineq=0                                                                              
!                                                                                         
! total partition function qtot                                                           
      qtot = 0.                                                                           
      do ie = 1,nlev_diatom(isp)                                                          
        ge = g_diatom(ie,isp)                                                             
        te = te_diatom(ie,isp)                                                            
        we = we_diatom(ie,isp)                                                            
        wexe = wexe_diatom(ie,isp)                                                        
        weye = weye_diatom(ie,isp)                                                        
        weze = weze_diatom(ie,isp)                                                        
        be = be_diatom(ie,isp)                                                            
        ae = ae_diatom(ie,isp)                                                            
        de = de_diatom(ie,isp)                                                            
        betae = betae_diatom(ie,isp)                                                      
        do iv = 0, 22                                                                     
          rv = real(iv)                                                                   
          bv = be - ae*(rv+0.5)                                                           
          dv = de + betae*(rv+0.5)                                                        
          ev = we*(rv+0.5) - wexe*(rv+0.5)**2 + weye*(rv+0.5)**3          &               
     &      + weze*(rv+0.5)**4                                                            
          if((bv.lt.0.0).or.(ev.lt.0.0)) go to 98                                         
! partition function. use rigid rotator approximation for each v                          
          qtot = qtot + ge * dexp(-1.43877*(te/tele + ev/tvib))           &               
     &      * homo_fac(isp) * (trot/(1.43877d0*bv))                                       
        end do                                                                            
 98     continue                                                                          
      end do                                                                              
!                                                                                         
!-----------------------------------------------------------------------------------------
! cycle over transitions                                                                  
      do itr=1,nbb_diatom(isp)    
!                                                                                         
! skip if not required                                                                    
        ido = 0                                                                           
        do i = 1,195                                                                      
          if((bandnm_diatom(1,itr,isp).eq.diatom_bands(1,i)).and.         &               
     &       (bandnm_diatom(2,itr,isp).eq.diatom_bands(2,i))) ido = 1                     
        end do                                                                            
        if(ido.eq.0) go to 20                                                             
!                                                                                         
! echo status                                                                             
!        write(6,30) diatomnm(isp)                                                        
!   30   format(' in diatom_bb. species = ',a4)                                           
        write(6,10) itr,(bandnm_diatom(k,itr,isp),k=1,2)                                  
   10   format(' itr=',i3,1x,2a4)                                                         
                                                                                          
        neq_factor_k = 1.0                                                                
        ie_up = nup_diatom(itr,isp)                                                       
        ie_lo = nlo_diatom(itr,isp)                                                       
        hund = hund_diatom(itr,isp)                                                       
!                                                                                         
! vibrational matrix                                                                      
        do vu = 0, maxv_up_diatom(itr,isp)                                                
          do vl = 0,maxv_lo_diatom(itr,isp)                                               
            maxj =min(jim_v_diatom(vu,ie_up,isp),                         &               
     &        jim_v_diatom(vl,ie_lo,isp))                                                 
!                                                                                         
! determine the band origin parameters                                                    
            geu = g_diatom(nup_diatom(itr,isp),isp)                                       
            gel = g_diatom(nlo_diatom(itr,isp),isp)                                       
            teu = te_diatom(nup_diatom(itr,isp),isp)                                      
            tel = te_diatom(nlo_diatom(itr,isp),isp)                                      
            weu = we_diatom(nup_diatom(itr,isp),isp)                                      
            wel = we_diatom(nlo_diatom(itr,isp),isp)                                      
            wexeu = wexe_diatom(nup_diatom(itr,isp),isp)                                  
            wexel = wexe_diatom(nlo_diatom(itr,isp),isp)                                  
            weyeu = weye_diatom(nup_diatom(itr,isp),isp)                                  
            weyel = weye_diatom(nlo_diatom(itr,isp),isp)                                  
            wezeu = weze_diatom(nup_diatom(itr,isp),isp)                                  
            wezel = weze_diatom(nlo_diatom(itr,isp),isp)                                  
            beu = be_diatom(nup_diatom(itr,isp),isp)                                      
            bel = be_diatom(nlo_diatom(itr,isp),isp)                                      
            aeu = ae_diatom(nup_diatom(itr,isp),isp)                                      
            ael = ae_diatom(nlo_diatom(itr,isp),isp)                                      
            deu = de_diatom(nup_diatom(itr,isp),isp)                                      
            del = de_diatom(nlo_diatom(itr,isp),isp)                                      
            betau = betae_diatom(nup_diatom(itr,isp),isp)                                 
            betal = betae_diatom(nlo_diatom(itr,isp),isp)                                 
!                                                                                         
            rvu = real(vu)                                                                
            rvl = real(vl)                                                                
            evu=weu*(rvu+0.5) - wexeu*(rvu+0.5)**2 + weyeu*(rvu+0.5)**3   &               
     &        + wezeu*(rvu+0.5)**4                                                        
            evl=wel*(rvl+0.5) - wexel*(rvl+0.5)**2 + weyel*(rvl+0.5)**3   &               
     &        + wezel*(rvl+0.5)**4                                                        
            dev = teu + evu - (tel + evl)             ! band origin energy, cm-1          
            bvu = beu - aeu*(rvu+0.5)                                                     
            bvl = bel - ael*(rvl+0.5)                                                     
            dvu = deu + betau*(rvu+0.5)                                                   
            dvl = del + betal*(rvl+0.5)                                                   
            if(dev .le. 100.0) go to 999                                                  
! electronic transition moment including franck-condon factor                             
            re1 = re1_diatom(vl,vu,itr,isp)                                               
! wavelength of band origin (j = 0), angstrom                                             
            wavel0 = 1.0d8/dev                                                            
                                                                                          
! generate voigt profile for band origin                                                  
!                                                                                         
! gaussian width, angstrom ! slit function                                                
            widthg = 7.16d-7*wavel0*dsqrt(tran/diatomwt(isp))                             
!                                                                                         
! classical natural width, angstrom                                                       
            width1 = 1.18d-4                                                              
                                                                                          
! stark width, angstrom                                                                   
!   approximate default formula, assume energy to ionization to be 100000 cm-1            
            gam=0.042d0*(wavel0**2)/(100000.d0)**2                                        
            expn = 0.33d0                                                                 
            width2 = 2.0d0*gam*(1.d04*tele)**expn*dens_elec*1.d-16                        
                                                                                          
! pressure broadening by non-resonant collisions, traving                                 
            cw3 = 5.85d-30*dsqrt(2.d0/diatomwt(isp))                                      
            width3 = cw3 * wavel0**2                                                      
!                                                                                         
! lorenz width                                                                            
            widthl = width1 + width2 + width3                                             
!                                                                                         
! voigt line half-width at half-height                                                    
            widthv = widthl/2.d0 + dsqrt(widthl**2/4.d0 + widthg**2)                      
! range over which the line shape must be drawn, in the units of half-half width          
            range = 10.d0                                                                
!                                                                                         
! determine the wavelength node for line center for band origin    
!        ncentr=nwave*((wavel_atom(k,isp)-wavmin)/(wavmax-wavmin))**(1./calpha)
            ncentr0=nwave*((wavel0-wavmin)/(wavmax-wavmin))**(1./calpha)
!            ncentr0 = (1./dsqrt(wavmin) - 1./dsqrt(wavel0))/estep + 1                       
!                                                                                         
! determine wavelength interval at line center for band origin in angstrom                
            witv = ((wavmax-wavmin)/float(nwave)**calpha)*calpha*float(ncentr0)**(calpha-1.)
!            witv = 1.d0/(1.d0/dsqrt(wavmin) - estep*(ncentr0-1))**2        &
!      &          - 1.d0/(1.d0/dsqrt(wavmin) - estep*ncentr0)**2
!            witv = dabs(witv)
!                                                                                         
! determine line shape spreading index nspred                                             
            nspred = 1 + range * widthv/witv                                              
            if(nspred.ge.1000) nspred= 1000                                               

! generate voight profile function y                                                      
            wd1=1/widthv
            csprd2=widthl/widthv
            csprd3=(1.065+0.447*csprd2+0.058*csprd2**2)*widthv*1.0e-4
            csprd1=(1.-csprd2)/csprd3
            csprd2=csprd2/csprd3
            do m = 1,nspred                                                               
              wavctr=wavel(ncentr0)
              csprd3=dabs((wavctr-wavel(m))*wd1)
              csp2=csprd3**2
              csp3=csp2*dsqrt(dsqrt(csprd3))   
              y(m) = csprd1*dexp(-2.772*csp2)+csprd2/(1.+4.*csp2)+0.016*     &
  &             csprd2*(1.0-widthl*wd1)*(dexp(-0.4*csp3)-10.0/(10.0+csp3))
              ratio=1.52*withv/witv                                                         
              if((m.eq.1).and.(ratio.lt.0.3)) y(0)=y(0)*ratio                                                                                        
              y(-m) = y(m)                                                                
            end do                                                                        
            lam_u = lambda_diatom(nup_diatom(itr,isp),isp)                                
            lam_l = lambda_diatom(nlo_diatom(itr,isp),isp)                                
            spinu = s_diatom(nup_diatom(itr,isp),isp)                                     
            spinl = s_diatom(nlo_diatom(itr,isp),isp)                                     
            sou = spinorb_diatom(nup_diatom(itr,isp),isp)                                 
            sol = spinorb_diatom(nlo_diatom(itr,isp),isp)                                 
            ls_u = lam2_diatom(nup_diatom(itr,isp),isp)                                   
            ls_l = lam2_diatom(nlo_diatom(itr,isp),isp)                                   
            sisi = 0   ! When 1, all transition should be singlet to singlet transition   
            if(sisi.eq.1) then                                                            
              spinu = 1                                                                   
              spinl = 1                                                                   
              hund= 'aa   '                                                               
            end if                                                                        
!=========================================================================                
!   1X(a)-1X(a) transition                                                                
            if( ( ((lam_u.eq.0) .and. (lam_l.eq.0)) .or.                  &               
     &          ((lam_u.eq.1) .and. (lam_l.eq.1)) .or.                    &               
     &          ((lam_u.eq.2) .and. (lam_l.eq.2)) .or.                    &               
     &          ((lam_u.eq.3) .and. (lam_l.eq.3))) .and.                  &               
     &          ((spinu.eq.1) .and. (spinl.eq.1)) .and.                   &               
     &          (hund.eq.'aa   ') )  then     
!                                                                                         
              if((vu.eq.0).and.(vl.eq.9)) write(6,*)                      &               
     &          ' 1X-1X: Hund case = aa. ',bandnm_diatom(1,itr,isp),      &               
     &          bandnm_diatom(2,itr,isp)                                                    
              do j= 1, maxj                                                                 
                do k= 1, 3                                                                  
                  call calc_1X1X(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu,     &               
     &              tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr, &               
     &              lam_u,lam_l,sou,sol)                                                    
                  do m = -nspred,nspred                                                     
                    if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then                  
                      emission = emisj(j) * y(m)                                            
                      ax = dexp(-1.43877d0*1.d8/(wavel(ncentr(j)+m)*tele))                  
                      blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5*  &               
     &                  (1.d0-ax))                                                          
                      cross=(emission/blam)/dens_diatom(isp)                                
                      absorption=cross*dens_diatom(isp)                                       
                      absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption                      
                    end if                                                                  
                  end do                                                                     
                end do                                                                      
              end do                                                                        
            end if                                                                          
!=======================================================================                  
!   1X(a)-1Y(a) transition                                                                
            if((((lam_u.eq.0).and.(lam_l.eq.1)) .or.                        &               
     &        ((lam_u.eq.1).and.(lam_l.eq.0)) .or.                          &               
     &        ((lam_u.eq.1).and.(lam_l.eq.2)) .or.                          &               
     &        ((lam_u.eq.2).and.(lam_l.eq.1)) .or.                          &               
     &        ((lam_u.eq.2).and.(lam_l.eq.3)) .or.                          &               
     &        ((lam_u.eq.3).and.(lam_l.eq.2))) .and.                        &               
     &        ((spinu.eq.1).and.(spinl.eq.1)).and.(hund.eq.'aa   ')) then                   
              if((vu.eq.0).and.(vl.eq.9)) write(6,*)                        &               
     &          ' 1X-1Y: Hund case = aa. ',bandnm_diatom(1,itr,isp),        &               
     &        bandnm_diatom(2,itr,isp)                                                    
              do j= 1, maxj                                                                 
                do k = 1, 3                                                                 
                  call calc_1X1Y(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu,       &               
     &              tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,   &               
     &              lam_u,lam_l,sou,sol)                                                    
                  do m = -nspred,nspred                                                     
                    if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then                  
                      emission = emisj(j) * y(m)                                            
                      ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele))                   
                      blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5*  &               
     &                  (1.d0-ax))                                                          
                      cross=(emission/blam)/dens_diatom(isp)                                
                      absorption=cross*dens_diatom(isp)                                       
                      absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption                      
                    end if                                                                  
                  enddo                                                                     
                end do                                                                      
              end do                                                                        
            end if                                                                          
!=======================================================================                  
!   2S - 2S transition (Hund's b): see Schadee, 1964                                      
            if( ((lam_u.eq.0).and.(lam_l.eq.0)).and.((spinu.eq.2).and.      &               
     &        (spinl.eq.2)).and.(hund.eq.'bb   ')) then                                     
              if((vu.eq.0).and.(vl.eq.9)) write(6,*)                        &               
     &          ' 2S-2S: Hund case = bb. ',bandnm_diatom(1,itr,isp),        &               
     &          bandnm_diatom(2,itr,isp)                                                    
              do j= 1, maxj                                                                 
                do k=1, 12                                                                  
                  call calc_2S2S(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu,       &               
     &              tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,          &               
     &              ncentr,lam_u,lam_l,sou,sol)                                             
                  do m = -nspred,nspred                                                     
                    if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then                  
                      emission = emisj(j) * y(m)                                            
                      ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele))                   
                      blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5*  &               
     &                  (1.d0-ax))                                                          
                      cross=(emission/blam)/dens_diatom(isp)                                
                      absorption=cross*dens_diatom(isp)                                       
                      absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption                      
                    end if                                                                  
                  enddo                                                                     
                enddo                                                                       
              end do                                                                        
            end if                                                                          
!=======================================================================                  
!   2P - 2P transition (Hund's b): see Schadee, 1964                                      
            if( ((lam_u.eq.1).and.(lam_l.eq.1)).and.((spinu.eq.2).and.      &               
     &        (spinl.eq.2)).and.(hund.eq.'bbpp ') ) then                                    
                if((vu.eq.0).and.(vl.eq.0)) write(6,*)                      &               
     &            ' 2P-2P: Hund case = bbpp. ',bandnm_diatom(1,itr,isp),    &               
     &            bandnm_diatom(2,itr,isp)                                                  
!
              do j= 1, maxj                                                                 
                do k= 1, 12                                                                 
                  call calc_2P2P(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu,       &               
     &              tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,          &               
     &              ncentr,lam_u,lam_l,sou,sol)                                             
                  do m = -nspred,nspred                                                     
                    if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then                  
                      emission = emisj(j) * y(m)                                            
                      ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele))                   
                      blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5*  &               
     &                  (1.d0-ax))                                                          
                      cross=(emission/blam)/dens_diatom(isp)                                
                      absorption=cross*dens_diatom(isp)                                       
                      absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption                      
                    end if                                                                  
                  enddo                                                                     
                enddo                                                                       
              end do                                                                        
            end if                                                                          
!=======================================================================                  
!   2X - 2X transition (intermediate states), See Kovacs                                  
            if((((lam_u.eq.0).and.(lam_l.eq.0)) .or.                         &               
     &        ((lam_u.eq.1).and.(lam_l.eq.1)) .or.                           &               
     &        ((lam_u.eq.2).and.(lam_l.eq.2))) .and.                         &               
     &        ((spinu.eq.2).and.(spinl.eq.2)).and.(hund .eq. 'intd ')) then                  
              if((vu.eq.0).and.(vl.eq.9)) write(6,*)                         &               
     &           ' 2X-2X: Hund case = intd(intermediate) ',                  &               
     &           bandnm_diatom(1,itr,isp),bandnm_diatom(2,itr,isp)                           
! 
              do j= 1, maxj                                                                 
                do k=1, 12                                                                  
                  call calc_2X2X(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu,       &               
     &              tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,          &               
     &              ncentr,lam_u,lam_l,sou,sol)                                             
                  do m = -nspred,nspred                                                     
                    if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then                  
                      emission = emisj(j) * y(m)                                            
                      ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele))                   
                      blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5*  &               
     &                  (1.d0-ax))                                                          
                      cross=(emission/blam)/dens_diatom(isp)                                
                      absorption=cross*dens_diatom(isp)                                       
                      absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption                      
                    end if                                                                  
                  end do                                                                     
                enddo                                                                       
              end do                                                                        
            end if                                                                          
!=======================================================================                  
!   2S-2P, 2P-2S transitions (intermediate states), See Arnold 1969                       
            if((((lam_u.eq.1).and.(lam_l.eq.0)).or.                         &               
     &        ((lam_u.eq.0).and.(lam_l.eq.1))) .and.                        &               
     &        ((spinu.eq.2).and.(spinl.eq.2)).and.(hund .eq.'insp ')) then                  
              if((vu.eq.0).and.(vl.eq.9)) write(6,*)                        &               
     &          ' 2S-2P: Hund case = insp(intermediate) ',                  &               
     &          bandnm_diatom(1,itr,isp),bandnm_diatom(2,itr,isp)  
              do j= 1, maxj                                                                 
                do k= 1, 12                                                                 
                  call calc_2S2P(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu,       &               
     &            tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,            &               
     &            ncentr,lam_u,lam_l,sou,sol)                                               
                  do m = -nspred,nspred                                                     
                    if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then                  
                      emission = emisj(j) * y(m)                                            
                      ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele))                   
                      blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5*  &               
     &                  (1.d0-ax))                                                          
                      cross=(emission/blam)/dens_diatom(isp)                                
                      absorption=cross*dens_diatom(isp)                                       
                      absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption                      
                    end if                                                                  
                  enddo                                                                     
                enddo                                                                       
              enddo                                                                         
            end if                                                                          
!=======================================================================                  
!   2X - 2Y transition (intermediate states), See Kovacs                                  
            if((((lam_u.eq.1).and.(lam_l.eq.0)).or.                          &               
     &        ((lam_u.eq.0).and.(lam_l.eq.1)) .or.                           &               
     &        ((lam_u.eq.1).and.(lam_l.eq.2)) .or.                           &               
     &        ((lam_u.eq.2).and.(lam_l.eq.1))) .and.                         &               
     &        ((spinu.eq.2).and.(spinl.eq.2)).and.(hund.eq.'intd ') ) then                   
!  
                if((vu.eq.0).and.(vl.eq.0)) write(6,*)                          &               
     &            '2X-2Y: Hund.s case = intd (intermediate). ',                 &               
     &            bandnm_diatom(1,itr,isp),bandnm_diatom(2,itr,isp)                             
                do j= 1, maxj                                                                 
                  do k= 1, 12                                                                 
                    call calc_2X2Y(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu,       &               
     &              tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,          &               
     &              ncentr,lam_u,lam_l,sou,sol)                                             
                    do m = -nspred,nspred                                                     
                      if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then                  
                        emission = emisj(j) * y(m)                                            
                        ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele))                   
                        blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5*  &               
     &                    (1.d0-ax))                                                          
                        cross=(emission/blam)/dens_diatom(isp)                                
                        absorption=cross*dens_diatom(isp)                                       
                        absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption                      
                      end if                                                                  
                    end do                                                                     
                  end do                                                                       
                end do                                                                        
            end if                                                                          
!=======================================================================                  
!   3S - 3S transition (Hund's case b)                                                    
            if((((lam_u.eq.0).and.(lam_l.eq.0))).and.((spinu.eq.3).and.      &               
     &        (spinl.eq.3)).and.(hund.eq.'bb   ')) then                                      
!                                                                                         
              if((vu.eq.0).and.(vl.eq.0)) write(6,*)                        &               
     &          ' 3S-3S: Hund case = bb. ',bandnm_diatom(1,itr,isp),        &               
     &          bandnm_diatom(2,itr,isp)     
              do j= 1, maxj                                                                 
                do k= 1, 27                                                                 
                  call calc_3S3S(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu,       &               
     &              tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,   &               
     &              lam_u,lam_l,sou,sol,ls_u,ls_l)                                          
                  do m = -nspred,nspred                                                     
                    if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then                  
                      emission = emisj(j) * y(m)                                            
                      ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele))                   
                      blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5*  &               
     &                  (1.d0-ax))                                                          
                      cross=(emission/blam)/dens_diatom(isp)                                
                      absorption=cross*dens_diatom(isp)                                       
                      absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption                      
                    end if                                                                  
                  end do                                                                     
                end do                                                                       
              end do                                                                         
            end if                                                                           
!=======================================================================                  
!   3P - 3P transition (Hund's case b)                                                    
            if((((lam_u.eq.1).and.(lam_l.eq.1))).and.((spinu.eq.3).and.     &               
     &        (spinl.eq.3)).and.(hund.eq.'bbpp ')) then                                     
              if((vu.eq.0).and.(vl.eq.0)) write(6,*)                        &               
     &          ' 3P-3P: Hund case = bbpp. ',bandnm_diatom(1,itr,isp),      &               
     &          bandnm_diatom(2,itr,isp)    
              do j= 1, maxj                                                                 
                do k= 1, 27                                                                 
                  call calc_3P3P(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu,       &               
     &            tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,     &               
     &            lam_u,lam_l,sou,sol,ls_u,ls_l)                                            
                  do m = -nspred,nspred                                                     
                    if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then                  
                      emission = emisj(j) * y(m)                                            
                      ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele))                   
                      blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5*  &               
     &                  (1.d0-ax))                                                          
                      cross=(emission/blam)/dens_diatom(isp)                                
                      absorption=cross*dens_diatom(isp)                                       
                      absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption                      
                    end if                                                                  
                  end do                                                                     
                end do                                                                       
              end do                                                                         
            end if                                                                           
!=======================================================================                  
!   3X - 3X transition (intermediate states)                                              
            if((((lam_u.eq.0).and.(lam_l.eq.0)).or.                         &               
     &        ((lam_u.eq.1).and.(lam_l.eq.1)) .or.                          &               
     &        ((lam_u.eq.2).and.(lam_l.eq.2))) .and.                        &               
     &        ((spinu.eq.3).and.(spinl.eq.3)).and.(hund.eq.'intd ')) then                   
              if((vu.eq.0).and.(vl.eq.0)) write(6,*)                        &               
     &          ' 3X-3X: Hund case = intd(intermediate). ',                 &               
     &          bandnm_diatom(1,itr,isp),bandnm_diatom(2,itr,isp)                           
!  
              do j= 1, maxj                                                                 
                do k=1, 27                                                                  
                  call calc_3X3X(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu,       &               
     &            tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,     &               
     &              lam_u,lam_l,sou,sol)                                                    
                  do m = -nspred,nspred                                                     
                    if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then                  
                      emission = emisj(j) * y(m)                                            
                      ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele))                   
                      blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5*  &               
     &                  (1.d0-ax))                                                          
                      cross=(emission/blam)/dens_diatom(isp)                                
                      absorption=cross*dens_diatom(isp)                                       
                      absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption                      
                    end if                                                                  
                  end do                                                                     
                end do                                                                       
              end do                                                                         
            end if                                                                           
!=======================================================================                  
!   3S-3P, 3P-3S transitions                                                              
            if((((lam_u.eq.0).and.(lam_l.eq.1)) .or.                        &               
     &        ((lam_u.eq.1).and.(lam_l.eq.0))) .and.                        &               
     &        ((spinu.eq.3).and.(spinl.eq.3)).and.(hund.eq.'insp ') ) then                  
              if((vu.eq.0).and.(vl.eq.0)) write(6,*)                        &               
     &          ' 3S-3P or 3P-3S: Hund case = insp(intermediate). ',        &               
     &          bandnm_diatom(1,itr,isp),bandnm_diatom(2,itr,isp)                           
!  
              do j= 1, maxj                                                                 
                do k = 1, 27                                                                
                  call calc_3S3P(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu,       &               
     &            tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,     &               
     &            lam_u,lam_l,sou,sol)                                                      
                  do m = -nspred,nspred                                                     
                    if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then                  
                      emission = emisj(j) * y(m)                                            
                      ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele))                   
                      blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5*  &               
     &                  (1.d0-ax))                                                          
                      cross=(emission/blam)/dens_diatom(isp)                                
                      absorption=cross*dens_diatom(isp)                                       
                      absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption                      
                    end if                                                                  
                  end do                                                                     
                end do                                                                       
              end do                                                                         
            end if                                                                           
!=======================================================================                  
!   3X - 3Y transition (intermediate states)                                              
            if((((lam_u.eq.0).and.(lam_l.eq.1)) .or.                        &               
     &        ((lam_u.eq.1).and.(lam_l.eq.0))  .or.                         &               
     &        ((lam_u.eq.1).and.(lam_l.eq.2))  .or.                         &               
     &        ((lam_u.eq.2).and.(lam_l.eq.1))) .and.                        &               
     &        ((spinu.eq.3).and.(spinl.eq.3)).and.(hund.eq.'intd ')) then                   
              if((vu.eq.0).and.(vl.eq.0)) write(6,*)                        &               
     &          ' 3X-3Y: Hund case = intd(intermediate). ',                 &               
     &          bandnm_diatom(1,itr,isp),bandnm_diatom(2,itr,isp)   
                    
              do j= 1, maxj                                                                 
                do k=1, 27  
                  call calc_3X3Y(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu,       &               
     &            tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,     &               
     &            lam_u,lam_l,sou,sol)     
                  do m = -nspred,nspred     
                    if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then  
                      emission = emisj(j) * y(m)                                            
                      ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele))                   
                      blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5*  &               
     &                  (1.d0-ax))                                                          
                      cross=(emission/blam)/dens_diatom(isp)                                
                      absorption=cross*dens_diatom(isp)                                       
                      absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption 
                    end if                                                                  
                  end do                                                                     
                end do                                                                       
              end do                                                                         
            end if                                                                           
!=======================================================================                  
!   5X - 5Y TRANSITION, X = PI, DEL, OR FI                                                
            if((lam_u.ge.1).and.(lam_l.ge.1) .and.                          &               
     &        (spinu.eq.5).and.(spinl.eq.5)) then                                           
              if((lam_u.eq.0).and.(lam_l.eq.1)) go to 888                                   
              if((lam_u.eq.1).and.(lam_l.eq.0)) go to 888                                   
              if((vu.eq.0).and.(vl.eq.0)) write(6,*)                        &               
     &          ' 5X-5X: no Hund case identifiable. ',                      &               
     &          bandnm_diatom(1,itr,isp),bandnm_diatom(2,itr,isp)                           
              do k = 1, 300                                                                 
                do j=1, maxj                                                                
                  call calc_bb5p5p(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu,     &               
     &              tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,   &               
     &              lam_u,lam_l,sou,sol)                                                    
                  do m = -nspred,nspred                                                     
                    if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then                  
                      emission = emisj(j) * y(m)                                            
                      ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele))                   
                      blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5*  &               
     &                  (1.d0-ax))                                                          
                      cross=(emission/blam)/dens_diatom(isp)                                
                      absorption=cross*dens_diatom(isp)                                       
                      absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption                      
                    end if                                                                  
                  end do                                                                     
                end do                                                                       
              end do                                                                         
 888          continue                                                                        
            endif                                                                           
!=======================================================================                  
!   5S - 5P TRANSITION                                                                    
            if((lam_u.eq.0).and.(lam_l.eq.1) .and.                          &               
     &        (spinu.eq.5).and.(spinl.eq.5))  then                                          
              if((vu.eq.0).and.(vl.eq.0)) write(6,*)                        &               
     &          ' 5SIGMA - 5PI: no Hund case identifiable. ',               &               
     &          bandnm_diatom(1,itr,isp),bandnm_diatom(2,itr,isp)                           
              do k = 1, 300                                                                 
                do j=1, maxj                                                                
                  call calc_bb5s5p(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu,     &               
     &              tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,   &               
     &              lam_u,lam_l,sou,sol)                                                    
                  do m = -nspred,nspred                                                     
                    if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then                  
                      emission = emisj(j) * y(m)                                            
                      ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele))                   
                      blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5*  &               
     &                  (1.d0-ax))                                                          
                      cross=(emission/blam)/dens_diatom(isp)                                
                      absorption=cross*dens_diatom(isp)                                       
                      absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption                      
                    end if                                                                  
                  end do                                                                     
                end do                                                                       
              end do                                                                         
            end if                                                                           
!=======================================================================                  
!   5P - 5S TRANSITION                                                                    
           if((lam_u.eq.1) .and. (lam_l.eq.0) .and.                         &               
     &       (spinu.eq.5).and.(spinl.eq.5))  then                                           
              if((vu.eq.0).and.(vl.eq.0)) write(6,*)                        &               
     &          ' 5P5S: no Hund case identifiable. ',                       &               
     &          bandnm_diatom(1,itr,isp),bandnm_diatom(2,itr,isp)                           
              do k = 1, 300                                                                 
                do j=1, maxj                                                                
                  call calc_bb5p5s(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu,     &               
     &              tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,   &               
     &              lam_u,lam_l,sou,sol)                                                    
                  do m = -nspred,nspred                                                     
                    if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then                  
                      emission = emisj(j) * y(m)                                            
                      ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele))                   
                      blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5*  &               
     &                  (1.d0-ax))                                                          
                      cross=(emission/blam)/dens_diatom(isp)                                
                      absorption=cross*dens_diatom(isp)                                       
                      absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption                      
                    end if                                                                  
                  end do                                                                     
                end do                                                                       
              end do                                                                         
            end if                                                                           
!=======================================================================                  
!   7X - 7Y TRANSITION                                                                    
           if((spinu.eq.7) .and. (spinl.eq.7) ) then                                        
              if((vu.eq.0).and.(vl.eq.0)) write(6,*)                        &               
     &          ' 7X-7Y: no Hund case identifiable. ',                      &               
     &          bandnm_diatom(1,itr,isp),bandnm_diatom(2,itr,isp)                           
              do k = 1, 300                                                                 
                do j=1, maxj                                                                
                  call calc_bb5p5p(isp,dev,bvu,bvl,dvu,dvl,geu,teu,evu,     &               
     &              tran,trot,tvib,tele,qtot,re1,j,k,wavelx,emisj,ncentr,   &               
     &              lam_u,lam_l,sou,sol)                                                    
                  do m = -nspred,nspred                                                     
                    if((ncentr(j)+m.gt.0).and.(ncentr(j)+m.le.nwave)) then                  
                      emission = emisj(j) * y(m)                                            
                      ax=dexp(-1.43877d0*1.0d8/(wavel(ncentr(j)+m)*tele))                   
                      blam = 1.1904d-16*ax/((1.d-8*wavel(ncentr(j)+m))**5*  &               
     &                  (1.d0-ax))                                                          
                      cross=(emission/blam)/dens_diatom(isp)                                
                      absorption=cross*dens_diatom(isp)                                       
                      absb(ncentr(j)+m) = absb(ncentr(j)+m)+absorption                      
                    end if                                                                  
                  end do                                                                     
                end do                                                                       
              end do                                                                         
            end if                                                                           
!---------------------------------------------------------                                
999         continue             ! dev is negative ! Check input data for two states !      
          end do                 ! end of cycle over vl (lower v)                           
        end do                   ! end of cycle over vu (upper v)                           
20      continue                                                                            
      end do                     ! end of cycle over transition                           
!                                                                                         
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine diatom_bf(isp,temp)                                             
! continuum of diatomic molecules                                                         
! input parameters:                                                                       
!   isp=species index                                                                                   
!   diatomnm(mdiatoms)=name of diatom                                                                              
!   temp=temperature, K                                                                                  
       parameter(matoms=56,nlev_tot_atom=999,                             &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60)                                        
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom,                  &               
     & neq_factor_k,ls_u,ls_l                                                             
      character*5 dum(90),hund_diatom,hund                                                
      character*4 asterik,atomnm2(matoms),bandnm_diatom,contnm_diatom,                  &
     &    minus1,unknown                              
      character*4 atom_rads(3,168),diatom_bands(3,100),                                 &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                                   &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                              &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                                       &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,           &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      integer charge_diatom,g_diatom,lo_state,s_diatom,up_state,          &               
     & g_atom1,g_atom2,gneq_diatom,check,ncentr(301)                                      
      integer vu,vl,spinu, spinl,sisi                                                     
      common/comi/nwave                                                                   
      common/comadiatom/ae_diatom(46,mdiatoms),                           &               
     & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms),    &               
     & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms),             &               
     & atomwt2(mdiatoms),be_diatom(46,mdiatoms),                          &               
     & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms),       &               
     & betae_diatom(46,mdiatoms),                                         &               
     & cross_diatom(11,121,21,mdiatoms),                                  &               
     & cross_imp_diatom(11,11,11,mdiatoms),                               &               
     & de_diatom(46,mdiatoms),diatom_mass(mdiatoms),                      &               
     & diatomwt(mdiatoms),                                                &               
     & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms),                    &               
     & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms),                 &               
     & FC_imp_diatom(0:11,0:11,11,11,mdiatoms),                           &               
     & e_elec_imp_diatom(11,11,11,mdiatoms),                              &               
     & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms),                     &               
     & lam2_diatom(46,mdiatoms),                                          &               
     & n_himp_bb_diatom(11,11,11,mdiatoms),                               &               
     & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms),    &               
     & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms),            &               
     & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms),          &               
     & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms),                    &               
     & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms),    &               
     & td_himp_bb_diatom(11,11,11,mdiatoms),                              &               
     & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms),         &               
     & wavel_cont_diatom(121,0:21,mdiatoms),                              &               
     & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms),                   &               
     & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms)                                  
      common/comidiatom/charge_diatom(mdiatoms),contnm_diatom             &               
     & (2,5,mdiatoms),g_diatom(46,mdiatoms),g_atom1(11,mdiatoms),         &               
     & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms),                   &               
     & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms),        &               
     & maxvl_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxvu_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxv_up_diatom(45,mdiatoms),                                       &               
     & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms),          &               
     & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms),           &               
     & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms),        &               
     & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms),                     &               
     & nup_diatom(45,mdiatoms),                                           &               
     & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms)                                 
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/comhund/hund_diatom(35,mdiatoms)                                             
      common/spect/calpha,slope_ratio,wavmin,wavmax,rangex                                             
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      real*8 minwavel,maxwavel                                                            
      common/scratch/y(nw)                                                                
      dimension emisj(nw),tlog(15),wavelx(501),cross(501)                                 
!                                                                                         
! echo status                                                                             
      write(6,10) diatomnm(isp),dens_diatom(isp)                                          
 10   format(' in diatom_bf. species = ',a4,1pe10.3,' cm-3')                              
! cycle over transitions    
      do itr=1,ncont_diatom(isp)                                                          
        write(6,40) (contnm_diatom(i,itr,isp),i=1,2)                                      
40      format(' calculate ', 2a4)                                                        
                                                                                          
        nwavex = ncont_wavel_diatom(itr,isp)                                              
        minwavel = wavel_cont_diatom(1,itr,isp)                                           
        maxwavel = wavel_cont_diatom(nwavex,itr,isp)                                      
!        ncentr=nwave*((wavel_atom(k,isp)-wavmin)/(wavmax-wavmin))**(1./calpha)
        nstrt = nwave*((minwavel-wavmin)/(wavmax-wavmin))**(1./calpha)
!        nstrt = (1.0/dsqrt(wavmin) - 1./dsqrt(minwavel))/estep + 1
        if(nstrt.lt.1) nstrt = 1
        nend = nwave
        ntemp = ncont_temp_diatom(itr,isp)  
        if(nstrt.lt.1) nstrt = 1                                                          
        if(nend.gt.nwave) nend = nwave                                                    
!                                                                                         
! interpolate absorption cross sections for given electron temperature                    
        do it = 1,ntemp                                                                   
          tlog(it) = dlog(temp_cont_diatom(it,itr,isp))                                   
        end do                                                                            
        tlogx = dlog(temp)                                                                
        mon = 0                                                                           
        do iwave = 1, nwavex                                                              
          wavelx(iwave) = wavel_cont_diatom(iwave,itr,isp)                                
          do it = 1, ntemp                                                                
            if(cross_diatom(it,iwave,itr,isp).gt.1.e-20)                  &               
     &      y(it) = dlog(cross_diatom(it,iwave,itr,isp))                                  
            if(cross_diatom(it,iwave,itr,isp).le.1.e-20)                  &               
     &      y(it) = dlog(1.d-20)                                                          
          end do                                                                          
          if(temp.lt.temp_cont_diatom(ntemp,itr,isp))                     &               
     &      call taint(tlog,y,tlogx,crossx,ntemp,2,ner,mon)                               
          if(temp.ge.temp_cont_diatom(ntemp,itr,isp))                     &               
     &      call taint(tlog,y,tlogx,crossx,ntemp,1,ner,mon)                               
          cross(iwave) = crossx                                                           
        end do                                                                            
!                                                                                         
! interpolate to find cross section crosx                                                 
        mon = 0                                                                           
        do m = nend,nstrt,-1                                                              
          if((wavel(m).gt.minwavel).and.(wavel(m).lt.maxwavel)) then                                                   
            call taint(wavelx,cross,wavel(m),crosx,nwavex,1,ner,mon)                      
            absorption = dexp(crosx) * dens_diatom(isp)                                   
            ax = dexp(-1.43877*1.0d8/(wavel(m)*temp))                                       
            blam = 1.1904d-16 * ax/((1.0d-8*wavel(m))**5*(1.0 - ax))                        
            emission = absorption * blam                                                    
            absb(m) = absb(m) + absorption                                                  
          end if
        enddo                                                                             
!        end if                                                                           
!20      continue                                                                         
      end do                                                                              
      return                                                                              
      end                                                                                 
!*****************************************************************************            
      subroutine diatom_read(ndiatoms)                   
! read diatomic data from diatom.dat                                                      
! input parameters:                                                                       
!   ndiatoms=number of diatomic molecules                                                 
!   diatomnm1(mdiatoms)=name of diatoms                                                    
!   diatom_bands(3,100)=diatomic radiation mechanisms to be calculated
! output parameters:
!   diatomnm(mdiatoms)=name of diatoms                                    
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60)                                                    
      implicit real*8(a-h,o-z)                                                            
      real*8 lam2_diatom,n_himp_diatom,n_himp_bb_diatom                                   
      character*1 dum(90)                                                                 
      character*5 hund_diatom                                                             
      character*4 asterik,atomnm2(matoms),bandnm_diatom,                                &               
     & minus1,unknown                                                                
      character*4 atom_rads(3,168),diatom_bands(3,100),contnm_diatom,                   &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                                   &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                              &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                                       &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,           &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      integer charge_diatom,g_diatom,lo,s_diatom,g_atom1,g_atom2,         &               
     & gneq_diatom,check,up_state                                                         
      common/comadiatom/ae_diatom(46,mdiatoms),                           &               
     & a_eimp_diatom(0:21,mdiatoms),a_himp_diatom(0:11,0:11,mdiatoms),    &               
     & a_himp_bb_diatom(11,11,11,mdiatoms),atomwt1(mdiatoms),             &               
     & atomwt2(mdiatoms),be_diatom(46,mdiatoms),                          &               
     & an_eimp_diatom(0:21,mdiatoms),barrier_diatom(0:21,mdiatoms),       &               
     & betae_diatom(46,mdiatoms),                                         &               
     & cross_diatom(11,121,21,mdiatoms),                                  &               
     & cross_imp_diatom(11,11,11,mdiatoms),                               &               
     & de_diatom(46,mdiatoms),diatom_mass(mdiatoms),                      &               
     & diatomwt(mdiatoms),                                                &               
     & dissoc_eny(mdiatoms),dzero_diatom(46,mdiatoms),                    &               
     & Ecm_atom1(0:21,mdiatoms),Ecm_atom2(0:21,mdiatoms),                 &               
     & FC_imp_diatom(0:11,0:11,11,11,mdiatoms),                           &               
     & e_elec_imp_diatom(11,11,11,mdiatoms),                              &               
     & homo_fac(mdiatoms),lambda_diatom(46,mdiatoms),                     &               
     & lam2_diatom(46,mdiatoms),                                          &               
     & n_himp_bb_diatom(11,11,11,mdiatoms),                               &               
     & n_himp_diatom(15,15,mdiatoms),prob_diatom(0:11,11,11,mdiatoms),    &               
     & ratep_diatom(11,11,11,mdiatoms),re_diatom(46,mdiatoms),            &               
     & re1_diatom(0:15,0:15,45,mdiatoms),reduced_mass(mdiatoms),          &               
     & spin_nuc(mdiatoms),spinorb_diatom(46,mdiatoms),                    &               
     & td_eimp_diatom(21,mdiatoms),td_himp_diatom(0:11,0:11,mdiatoms),    &               
     & td_himp_bb_diatom(11,11,11,mdiatoms),                              &               
     & te_diatom(46,mdiatoms),temp_cont_diatom(11,0:21,mdiatoms),         &               
     & wavel_cont_diatom(121,0:21,mdiatoms),                              &               
     & we_diatom(46,mdiatoms),wexe_diatom(46,mdiatoms),                   &               
     & weye_diatom(46,mdiatoms),weze_diatom(46,mdiatoms)                                  
      common/comidiatom/charge_diatom(mdiatoms),contnm_diatom             &               
     & (2,5,mdiatoms),g_diatom(46,mdiatoms),g_atom1(11,mdiatoms),         &               
     & g_atom2(11,mdiatoms),gneq_diatom(0:21,mdiatoms),                   &               
     & jim_v_diatom(0:21,46,mdiatoms),maxv_lo_diatom(45,mdiatoms),        &               
     & maxvl_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxvu_FC_diatom(0:11,0:11,mdiatoms),                               &               
     & maxv_up_diatom(45,mdiatoms),                                       &               
     & meth_imp_diatom(0:11,0:11,mdiatoms),nbb_diatom(mdiatoms),          &               
     & ncont_diatom(mdiatoms),ncont_temp_diatom(0:21,mdiatoms),           &               
     & ncont_wavel_diatom(0:21,mdiatoms),neq_lev_diatom(mdiatoms),        &               
     & nlev_diatom(mdiatoms),nlo_diatom(45,mdiatoms),                     &               
     & nup_diatom(45,mdiatoms),                                           &               
     & s_diatom(46,mdiatoms),bandnm_diatom(2,45,mdiatoms)                                 
      common/comhund/hund_diatom(35,mdiatoms)                                             
!                                                                                         
      data asterik/'****'/,minus1/'-1  '/                                                 
!                                                                                         
      write(2,900)                                                                        
900   format(' in diatom_read')                                                           
!                                                                                         
! start counting chemical species number                                                  
      isp=0                                                                               
! read asterik line                                                                       
      read(8,10) (dum(i),i=1,90)                                                          
      write(2,10) (dum(i),i=1,90)                                                         
10    format(90a1)                                                                        
10000 continue                                                                            
      read(8,20) unknown,(dum(i),i=1,90)                                                  
      write(2,20) unknown,(dum(i),i=1,90)                                                 
20    format(a4,90a1)                                                                     
      if(unknown.eq.minus1) then                                                          
        write(2,160) (diatomnm(isp),isp=1,ndiatoms)                                       
160     format(' diatomic data finished reading for ',10a4)                               
        return                                                                            
      end if                                                                              
!                                                                                         
! check if this species is required                                                       
      check = 0                                                                           
      do i=1,mdiatoms                                                                     
        if(unknown.eq.diatomnm1(i)) then                                                  
          do j=1,173                                                                      
            if(unknown.eq.diatom_bands(1,j)) check=1                                      
          end do                                                                          
        end if                                                                            
      end do                                                                              
                                                                                          
      if(check.eq.1) then                                                                 
        isp=isp+1                                                                         
        go to 130                                                                         
      endif                                                                               
! this species is not needed and skipped                                                  
      write(2,140)                                                                        
140   format(' this species is skipped')                                                  
150   read(8,20) unknown,(dum(i),i=1,70)                                                  
      if(unknown.ne.asterik) go to 150                                                    
      go to 10000                                                                         
130   continue                                                                            
                                                                                          
! set species name                                                                        
      diatomnm(isp) = trim(adjustl(unknown))                                              
!                                                                                         
! prepare to read diatomic level data                                                     
      read(8,30) diatom_mass(isp), (dum(i),i=1,50)                                        
      write(2,30) diatom_mass(isp), (dum(i),i=1,50)                                       
 30   format(e11.3,70a1)                                                                  
      read(8,30) diatomwt(isp), (dum(i),i=1,50)                                           
      write(2,30) diatomwt(isp), (dum(i),i=1,50)                                          
      read(8,30) reduced_mass(isp), (dum(i),i=1,50)                                       
      write(2,30) reduced_mass(isp), (dum(i),i=1,50)                                      
      read(8,30) dissoc_eny(isp), (dum(i),i=1,50)                                         
      write(2,30) dissoc_eny(isp), (dum(i),i=1,50)                                        
      read(8,30) spin_nuc(isp), (dum(i),i=1,50)                                           
      write(2,30) spin_nuc(isp), (dum(i),i=1,50)                                          
      read(8,30) homo_fac(isp), (dum(i),i=1,50)                                           
      write(2,30) homo_fac(isp), (dum(i),i=1,50)                                          
      read(8,40) charge_diatom(isp), (dum(i),i=1,50)                                      
      write(2,40) charge_diatom(isp), (dum(i),i=1,50)                                     
      read(8,40) nlev_diatom(isp), (dum(i),i=1,50)                                        
      write(2,40) nlev_diatom(isp), (dum(i),i=1,50)                                       
 40   format(i11,70a1)                                                                    
!                                                                                         
      do i1=1,3                                                                           
        read(8,10) (dum(i),i=1,90)                                                        
        write(2,10) (dum(i),i=1,90)                                                       
      enddo                                                                               
!                                                                                         
! read diatomic level data                                                                
      do lev=1,nlev_diatom(isp)                                                           
        read(8,50) (dum(i),i=1,13),                                       &               
     &    te_diatom(lev,isp),re_diatom(lev,isp),g_diatom(lev,isp),        &               
     &    dzero_diatom(lev,isp),we_diatom(lev,isp),wexe_diatom(lev,isp),  &               
     &    weye_diatom(lev,isp),weze_diatom(lev,isp),be_diatom(lev,isp),   &               
     &    ae_diatom(lev,isp),de_diatom(lev,isp),betae_diatom(lev,isp),    &               
     &    spinorb_diatom(lev,isp),lambda_diatom(lev,isp),                 &               
     &    s_diatom(lev,isp),lam2_diatom(lev,isp)                                          
        write(2,50) (dum(i),i=1,13),                                      &               
     &    te_diatom(lev,isp),re_diatom(lev,isp),g_diatom(lev,isp),        &               
     &    dzero_diatom(lev,isp),we_diatom(lev,isp),wexe_diatom(lev,isp),  &               
     &    weye_diatom(lev,isp),weze_diatom(lev,isp),be_diatom(lev,isp),   &               
     &    ae_diatom(lev,isp),de_diatom(lev,isp),betae_diatom(lev,isp),    &               
     &    spinorb_diatom(lev,isp),lambda_diatom(lev,isp),                 &               
     &    s_diatom(lev,isp),lam2_diatom(lev,isp)                                          
50      format(13a1,f10.2,f8.4,i3,f10.2,f10.3,f9.4,e11.3,e11.3,f9.5,      &               
     &    e11.3,e11.3,e11.3,e11.3,2i3,e11.3)                                              
      enddo                                                                               
!                                                                                         
! prepare to read max rotational quantum numbers                                          
      do j=1,5                                                                            
        read(8,10) (dum(i),i=1,90)                                                        
        write(2,10) (dum(i),i=1,90)                                                       
      enddo                                                                               
! read max rotational quantum numbers                                                     
      do ilev=1,nlev_diatom(isp)                                                          
        read(8,60) jlev,(jim_v_diatom(iv,ilev,isp),iv=0,21)                               
        write(2,60) jlev,(jim_v_diatom(iv,ilev,isp),iv=0,21)                              
 60     format(i6,23i6)                                                                   
      enddo                                                                               
!                                                                                         
! number of radiative transitions                                                         
      read(8,10) (dum(i),i=1,90)                                                          
      write(2,10) (dum(i),i=1,90)                                                         
      read(8,70) nbb_diatom(isp), (dum(i),i=1,70)                                         
      write(2,70) nbb_diatom(isp),(dum(i),i=1,70)                                         
      read(8,70) ncont_diatom(isp),(dum(i),i=1,70)                                        
      write(2,70) ncont_diatom(isp),(dum(i),i=1,70)                                       
 70   format(i10,90a1)                                                                    
      read(8,10) (dum(i),i=1,90)                                                          
      write(2,10) (dum(i),i=1,90)                                                         
!                                                                                         
! read bound-bound radiation data                                                         
      do iband=1,nbb_diatom(isp)                                                          
        read(8,80) (bandnm_diatom(i,iband,isp),i=1,2),(dum(i),i=1,60)                     
        write(2,80) (bandnm_diatom(i,iband,isp),i=1,2),(dum(i),i=1,60)                    
 80     format(2a4,70a1)                                                                  
        read(8,90)                                                        &               
     &    nup_diatom(iband,isp),(dum(i),i= 1,17),                         &               
     &    nlo_diatom(iband,isp),(dum(i),i=18,34),                         &               
     &    hund_diatom(iband,isp),(dum(i),i=35,50)                                         
        write(2,90)                                                       &               
     &    nup_diatom(iband,isp),(dum(i),i= 1,17),                         &               
     &    nlo_diatom(iband,isp),(dum(i),i=18,34),                         &               
     &    hund_diatom(iband,isp),(dum(i),i=35,50)                                         
 90     format(i5,17a1,i3,17a1,a5,16a1)                                                   
                                                                                          
        do i1=1,5                                                                         
          read(8,10) (dum(i),i=1,90)                                                      
          write(2,10) (dum(i),i=1,90)                                                     
        enddo                                                                             
        read(8,91)                                                        &               
     &    maxv_up_diatom(iband,isp),(dum(i),i=1,17),                      &               
     &    maxv_lo_diatom(iband,isp),(dum(i),i=18,40)                                      
        write(2,91)                                                       &               
     &    maxv_up_diatom(iband,isp),(dum(i),i=1,17),                      &               
     &    maxv_lo_diatom(iband,isp),(dum(i),i=18,40)                                      
 91     format(i5,17a1,i3,50a1)                                                           
        do j=1,3                                                                          
          read(8,10) (dum(i),i=1,90)                                                      
          write(2,10) (dum(i),i=1,90)                                                     
        enddo                                                                             
!                                                                                         
        do ivu=0, maxv_up_diatom(iband,isp)                                               
          read(8,100) (dum(i),i=1,3),                                     &               
     &      (re1_diatom(ivl,ivu,iband,isp),ivl=0,                         &               
     &      maxv_lo_diatom(iband,isp))                                                    
          write(2,110) (dum(i),i=1,3),                                    &               
     &      (re1_diatom(ivl,ivu,iband,isp),ivl=0,                         &               
     &      maxv_lo_diatom(iband,isp))                                                    
100       format(3a1,22e8.1)                                                              
110       format(3a1,1p22es8.2e1)                                                         
        enddo                                                                             
        read(8,10) (dum(i),i=1,90)                                                        
        write(2,10) (dum(i),i=1,90)                                                       
      end do                                                                              
!-------------------------------------------------------------------                      
! prepare to read molecular continuum data                                                
      if(ncont_diatom(isp).eq. 0) go to 120                                               
      do 125 iband=1,ncont_diatom(isp)     ! cycle over continuum starts                  
        read(8,80) (contnm_diatom(i,iband,isp),i=1,2),(dum(i),i=1,60)                     
        write(2,80) (contnm_diatom(i,iband,isp),i=1,2),(dum(i),i=1,60)                    
        do i1=1,2                                                                         
          read(8,10) (dum(i),i=1,79)                                                      
          write(2,10) (dum(i),i=1,79)                                                     
        end do                                                                            
        read(8,70) ncont_temp_diatom(iband,isp),(dum(i),i=1,60)                           
        write(2,70) ncont_temp_diatom(iband,isp),(dum(i),i=1,60)                          
        read(8,70) ncont_wavel_diatom(iband,isp),(dum(i),i=1,60)                          
        write(2,70) ncont_wavel_diatom(iband,isp),(dum(i),i=1,60)                         
        read(8,10) (dum(i),i=1,79)                                                        
        write(2,10) (dum(i),i=1,79)                                                       
!                                                                                         
        nvuvtemp = ncont_temp_diatom(iband,isp)                                           
        nvuvwave = ncont_wavel_diatom(iband,isp)                                          
!                                                                                         
        read(8,200) (dum(i),i=1,11),(temp_cont_diatom(it,iband,isp),      &               
     &   it=1,nvuvtemp)                                                                   
        write(2,200) (dum(i),i=1,11),(temp_cont_diatom(it,iband,isp),     &               
     &    it=1,nvuvtemp)                                                                  
200     format(11a1,7f10.1)                                                               
        read(8,10) (dum(i),i=1,90)                                                        
        write(2,10) (dum(i),i=1,90)                                                       
!                                                                                         
! read molecular continuum data                                                           
        do iwav=1, nvuvwave                                                               
          read(8,210) wavel_cont_diatom(iwav,iband,isp),                  &               
     &      (cross_diatom(it,iwav,iband,isp),it=1,nvuvtemp)                               
          write(2,210) wavel_cont_diatom(iwav,iband,isp),                 &               
     &      (cross_diatom(it,iwav,iband,isp),it=1,nvuvtemp)                               
210       format(f10.2,7e10.3)                                                            
        enddo                                                                             
        read(8,10) (dum(i),i=1,90)                                                        
        write(2,10) (dum(i),i=1,90)                                                       
125   continue                                                                            
!                                                                                         
!------------------------------------------------------------------------------------     
! prepare to read collisional excitation parameters                                       
120   continue                                                                            
      read(8,270) (dum(i),i=1,12),atomnm1(isp),(dum(i),i=13,14),          &               
     &  atomnm2(isp),(dum(i),i=15,90)                                                     
      write(2,270) (dum(i),i=1,12),atomnm1(isp),(dum(i),i=13,14),         &               
     &  atomnm2(isp),(dum(i),i=15,90)                                                     
270   format(12a1,a3,2a1,a3,90a1)                                                         
      read(8,170) neq_lev_diatom(isp),(dum(i),i=1,70)                                     
      write(2,170) neq_lev_diatom(isp),(dum(i),i=1,70)                                    
170   format(i5,90a1)                                                                     
!                                                                                         
      if(neq_lev_diatom(isp).eq. 0) go to 180      ! no data, skip                        
!                                                                                         
! read dissociated atoms parameters                                                       
      read(8,10) (dum(i),i=1,90)                                                          
      write(2,10) (dum(i),i=1,90)                                                         
      read(8,290) atomwt1(isp),(dum(i),i=1,50)                                            
      write(2,290) atomwt1(isp),(dum(i),i=1,50)                                           
290   format(f10.2,50a1)                                                                  
      do i=1,4                                                                            
        read(8,300) Ecm_atom1(i,isp),g_atom1(i,isp),(dum(j),j=1,39)                       
        write(2,300) Ecm_atom1(i,isp),g_atom1(i,isp),(dum(j),j=1,39)                      
300     format(f10.2,i10,40a1)                                                            
      end do                                                                              
      read(8,10) (dum(i),i=1,90)                                                          
      write(2,10) (dum(i),i=1,90)                                                         
      read(8,290) atomwt2(isp),(dum(i),i=1,50)                                            
      write(2,290) atomwt2(isp),(dum(i),i=1,50)                                           
      do i=1,4                                                                            
        read(8,300) Ecm_atom2(i,isp),g_atom2(i,isp),(dum(j),j=1,39)                       
        write(2,300) Ecm_atom2(i,isp),g_atom2(i,isp),(dum(j),j=1,39)                      
      end do                                                                              
      read(8,10) (dum(i),i=1,90)                                                          
      write(2,10) (dum(i),i=1,90)                                                         
!                                                                                         
! read collisional excitation data                                                        
!                                                                                         
! collisional bound-free transition data                                                  
!                                                                                         
      read(8,10) (dum(i),i=1,90)                                                          
      write(2,10) (dum(i),i=1,90)                                                         
      do ilev=1,neq_lev_diatom(isp)                                                       
! electron-impact bf data                                                                 
        read(8,220) (dum(i),i=1,24),gneq_diatom(ilev,isp),                &               
     &   barrier_diatom(ilev,isp),a_eimp_diatom(ilev,isp),                &               
     &   an_eimp_diatom(ilev,isp),td_eimp_diatom(ilev,isp)                                
        write(2,220) (dum(i),i=1,24),gneq_diatom(ilev,isp),               &               
     &   barrier_diatom(ilev,isp),a_eimp_diatom(ilev,isp),                &               
     &   an_eimp_diatom(ilev,isp),td_eimp_diatom(ilev,isp)                                
220     format(24a1,i3,f9.2,e10.3,f8.4,f10.2)                                             
                                                                                          
! heavy-particle-impact bf data                                                           
        do im=1,6                                                                         
          read(8,222) (dum(i),i=1,36),a_himp_diatom(ilev,im,isp),         &               
     &      n_himp_diatom(ilev,im,isp),td_himp_diatom(ilev,im,isp)                        
222       format(36a1,e10.3,f8.4,e10.3)                                                   
          write(2,222) (dum(i),i=1,36),a_himp_diatom(ilev,im,isp),        &               
     &      n_himp_diatom(ilev,im,isp),td_himp_diatom(ilev,im,isp)                        
        end do                                                                            
      end do                                                                              
      read(8,10) (dum(i),i=1,90)                                                          
      write(2,10) (dum(i),i=1,90)                                                         
260   continue                                                                            
!                                                                                         
! prepare to read bound-bound electron-impact transition rate data                        
!                                                                                         
! specify lower and upper states                                                          
      read(8,10) (dum(i),i=1,90)                                                          
      write(2,10) (dum(i),i=1,90)                                                         
      read(8,90) lo_state,(dum(i),i=1,17),up_state,(dum(i),i=18,40)                       
      write(2,90) lo_state,(dum(i),i=1,17),up_state,(dum(i),i=18,40)                      
!                                                                                         
! read radiative transition probability between lower and upper states                    
      read(8,240)                                                         &               
     &  (prob_diatom(im,lo_state,up_state,isp),im=0,7),(dum(i),i=1,10)                    
      write(2,240)                                                        &               
     &  (prob_diatom(im,lo_state,up_state,isp),im=0,7),(dum(i),i=1,10)                    
240   format(8e10.3,10a1)                                                                 
!                                                                                         
! prepare to read Franck-Condon factors                                                   
      read(8,10) (dum(i),i=1,90)                                                          
      write(2,10) (dum(i),i=1,90)                                                         
      read(8,10) (dum(i),i=1,90)                                                          
      write(2,10) (dum(i),i=1,90)                                                         
      read(8,90)                                                          &               
     & maxvu_FC_diatom(lo_state,up_state,isp),(dum(i),i=1,17),            &               
     & maxvl_FC_diatom(lo_state,up_state,isp),(dum(i),i=18,40)                            
      write(2,90)                                                         &               
     & maxvu_FC_diatom(lo_state,up_state,isp),(dum(i),i=1,17),            &               
     & maxvl_FC_diatom(lo_state,up_state,isp),(dum(i),i=18,40)                            
      do i1=1,3                                                                           
        read(8,10) (dum(i),i=1,90)                                                        
        write(2,10) (dum(i),i=1,90)                                                       
      enddo                                                                               
!                                                                                         
      max_vu = maxvu_FC_diatom(lo_state,up_state,isp)                                     
      max_vl = maxvl_FC_diatom(lo_state,up_state,isp)                                     
!                                                                                         
! read franck-condon factors                                                              
      do ivu=0, max_vu                                                                    
        read(8,250) i,                                                    &               
     &   (FC_imp_diatom(ivl,ivu,lo_state,up_state,isp),ivl=0,max_vl)                      
        write(2,251) i,                                                   &               
     &   (FC_imp_diatom(ivl,ivu,lo_state,up_state,isp),ivl=0,max_vl)                      
250     format(i3,14e8.1)                                                                 
251     format(i3,1p14e8.1)                                                               
      enddo                                                                               
!                                                                                         
! read banner for electron-impact excitation data                                         
      read(8,10) (dum(i),i=1,90)                                                          
      write(2,10) (dum(i),i=1,90)                                                         
!                                                                                         
! set meth (method of specifying electron-impact excitation value)                        
! meth=1 if cross section specified. meth=2 if rate parameter specified                   
      if((dum(1).eq.'E').or.(dum(1).eq.'e'))                              &               
     &  meth_imp_diatom(lo_state,up_state,isp)=1                                          
      if((dum(1).eq.'R').or.(dum(1).eq.'r'))                              &               
     &  meth_imp_diatom(lo_state,up_state,isp)=2                                          
!                                                                                         
! meth=1                                                                                  
      if(meth_imp_diatom(lo_state,up_state,isp).eq.1) then                                
!      electron energy, ev                                                                
        read(8,225) (dum(i),i=1,21),                                      &               
     &    (e_elec_imp_diatom(iev,lo_state,up_state,isp),iev=1,8)                          
        write(2,226) (dum(i),i=1,21),                                     &               
     &    (e_elec_imp_diatom(iev,lo_state,up_state,isp),iev=1,8)                          
225     format(21a1,8e10.3)                                                               
226     format(21a1,1p8e10.3)                                                             
!   excitation cross section, cm2                                                         
        read(8,225) (dum(i),i=1,21),                                      &               
     &    (cross_imp_diatom(iev,lo_state,up_state,isp),iev=1,8)                           
        write(2,226) (dum(i),i=1,21),                                     &               
     &    (cross_imp_diatom(iev,lo_state,up_state,isp),iev=1,8)                           
!                                                                                         
! default values of electron energy                                                       
        if(e_elec_imp_diatom(1,lo_state,up_state,isp).lt.0.001) then                      
          do iev = 1,8                                                                    
            e_elec_imp_diatom(iev,lo_state,up_state,isp) =                &               
     &        ((te_diatom(up_state,isp)-te_diatom(lo_state,isp))/         &               
     &        8067.5) *1.3**(ilev-1)                                                      
          end do                                                                          
          do iev = 1,8                                                                    
            x=e_elec_imp_diatom(iev,lo_state,up_state,isp)/               &               
     &        e_elec_imp_diatom(1,lo_state,up_state,isp)                                  
            if((charge_diatom(isp).eq.0).and.                             &               
     &        (s_diatom(lo_state,isp).eq.s_diatom(up_state,isp))) then                    
              cross_diatom(iev,lo_state,up_state,isp)=                    &               
     &        3.14159 * (0.5292*1.0e-8)**2 * log(x)/x                                     
            end if                                                                        
! default values of cross section                                                         
            if((charge_diatom(isp).eq.0).and.                             &               
     &        (s_diatom(lo_state,isp).ne.s_diatom(up_state,isp))) then                    
                cross_diatom(iev,lo_state,up_state,isp)=3.14159           &               
     &          *(0.5292*1.0e-8)**2*0.65*(x-1.0)/(1.0+(x-1.0)**2)                         
            end if                                                                        
            if(charge_diatom(isp).eq.1) then                                              
              cross_diatom(iev,lo_state,up_state,isp)=                    &               
     &         3.14159*(0.5292*1.0e-8)**2*3.4*(2.+x)/(2.+x**2)                            
            end if                                                                        
          end do                                                                          
          write(2,280)                                                    &               
     &      (e_elec_imp_diatom(iev,lo_state,up_state,isp),iev=1,8),       &               
     &       (cross_diatom(iev,lo_state,up_state,isp),iev=1,8)                            
280       format(' default elect energy:',8f10.4/'default cros section:'  &               
     &      ,1p8e10.3)                                                                    
        end if                                                                            
      end if                                                                              
!                                                                                         
! meth=2                                                                                  
      if(meth_imp_diatom(lo_state,up_state,isp).eq.2) then                                
        read(8,225) (dum(i),i=1,21),                                      &               
     &    (ratep_diatom(iev,lo_state,up_state,isp),iev=1,3)                               
        write(2,225) (dum(i),i=1,21),                                     &               
     &    (ratep_diatom(iev,lo_state,up_state,isp),iev=1,3)                               
      end if                                                                              
!                                                                                         
! read heavy particle-impact bound-bound transition rate parameters                       
      read(8,10) (dum(i),i=1,90)                                                          
      write(2,10) (dum(i),i=1,90)                                                         
      read(8,10) (dum(i),i=1,89)                                                          
      write(2,10) (dum(i),i=1,90)                                                         
      read(8,10) (dum(i),i=1,89)                                                          
      write(2,10) (dum(i),i=1,90)                                                         
      do im=1,6                                                                           
        read(8,310) (dum(i),i=1,15),                                      &               
     &    a_himp_bb_diatom(im,lo_state,up_state,isp),                     &               
     &    n_himp_bb_diatom(im,lo_state,up_state,isp),                     &               
     &    td_himp_bb_diatom(im,lo_state,up_state,isp)                                     
 310    format(15a1,3e10.3)                                                               
 311    format(15a1,1p3e10.3)                                                             
        write(2,311) (dum(i),i=1,15),                                     &               
     &    a_himp_bb_diatom(im,lo_state,up_state,isp),                     &               
     &    n_himp_bb_diatom(im,lo_state,up_state,isp),                     &               
     &    td_himp_bb_diatom(im,lo_state,up_state,isp)                                     
      end do                                                                              
!                                                                                         
! default values of a, n, and td                                                          
      read(8,20) unknown,(dum(i),i=1,70)                                                  
      write(2,20) unknown,(dum(i),i=1,70)                                                 
      if(unknown.eq.asterik) go to 10000                                                  
      go to 260                                                                           
!                                                                                         
! this species has ended                                                                  
180   continue                                                                            
      read(8,20) unknown,(dum(i),i=1,70)                                                  
      write(2,20) unknown,(dum(i),i=1,70)                                                 
      if(unknown.ne.asterik)go to 180                                                     
      go to 10000                                                                         
!                                                                                         
      end                                                                                 
!**************************************************************************               
      subroutine eintf(pft,pfti,tmax,tmin)                                                
! calculates coefficients for expressions for internal energy and                         
!    electronic energy                                                                    
! inputs:                                                                                 
!   pft(5,20,3)=total partition functions at 5 temperatures                               
!   pfti(5,20,3)=internal partition functions at 5 temperatures                           
!   tmax=maximum temperature, K                                                           
!   tmin=minimum temeprature, K                                                           
      parameter(msp=60)                                                                   
      implicit real*8(a-h,o-z)                                                            
      common/eqcoma/elemwt(15),                                           &               
     & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp),            &               
     & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp),             &               
     & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp),                     &               
     & akb(5,msp),akd(5,msp),avmw0                                                        
      common/eqcomb/elemnm(12)                                                            
      common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc,  &               
     & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp),   &               
     & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp)                        
      character*4 elemnm,spnm                                                             
      dimension tt(5),tt1(5),xx(5,5),b(5),wkarea(msp),elenf(5),pft        &               
     & (5,msp,3),pfti(5,msp,3)                                                            
!                                                                                         
      tdif=0.25d0*(tmax-tmin)                                                             
      do 330 jt=1,5                                                                       
      tt(jt)=tmin+tdif*(jt-1)                                                             
  330 tt1(jt)=10000.d0/tt(jt)                                                             
!                                                                                         
! internal energy (without translational-rotational energy), J/mol                        
      do 440 jt=1,5                                                                       
        temp=tt(jt)                                                                       
        dtemp=0.002d0*temp                                                                
        do 400 jsp=1,nsp1                                                                 
          akbjt=1.3805d-23*6.025d23*temp**2*dlog(pft(jt,jsp,3)/           &               
     &   pft(jt,jsp,1))/(2.0d0*dtemp)-(12.4716d0+8.3148d0*im(jsp))*temp                   
         akb(jt,jsp)=dmax1(akbjt,1.0d-10)                                                 
  400 continue                                                                            
  440 continue                                                                            
!                                                                                         
! determine 5 coefficients expressing internal energy                                     
! eint=exp[akb(1,j)/z+akb(2,j)+akb(3,j)*ln(z)+akb(4,j)*z+akb(5,j)*z**2]                   
!     where z=10000./temp                                                                 
!                                                                                         
! set independent variables xx(j,i)                                                       
!    j=row number, i=column number                                                        
      do 530 jsp=1,nsp1                                                                   
      do 540 j=1,5                                                                        
      b(j)=dlog(akb(j,jsp))                                                               
      xx(j,1)=1.d0/tt1(j)                                                                 
      xx(j,2)=1.0d0                                                                       
      xx(j,3)=dlog(tt1(j))                                                                
      do 540 i=4,5                                                                        
  540 xx(j,i)=tt1(j)**(i-3)                                                               
      call leqt2f(xx,1,5,5,b,0,wkarea,ier)                                                
      do 541 j=1,5                                                                        
  541 akb(j,jsp)=b(j)                                                                     
  530 continue                                                                            
!-----------------------------------------------------------------------                  
! determine 5 coefficients expressing electronic energy, J/kg                             
! elenf=exp[akd(1,j)/z+akd(2,j)+akd(3,j)*ln(z)+akd(4,j)*z+akd(5,j)*z**2]                  
!     where z=10000./temp                                                                 
!                                                                                         
      do 10 isp=1,nsp                                                                     
        nlev=nelec(isp)                                                                   
        do 30 jt=1,5                                                                      
          te=tt(jt)                                                                       
          q=0.d0                                                                          
          els=0.d0                                                                        
          do 20 ilev=1,nlev                                                               
!                                                                                         
! atom                                                                                    
            if(im(isp).eq.0) then                                                         
              expe=dexp(-1.4388d0*atome(ilev,isp)/te)                                     
              q=q+atomg(ilev,isp)*expe                                                    
              els=els+atome(ilev,isp)*atomg(ilev,isp)*expe                                
            endif                                                                         
!                                                                                         
! molecule                                                                                
            if(im(isp).eq.1) then                                                         
              ge=spect(1,ilev,isp)                                                        
              tex=spect(2,ilev,isp)                                                       
              expe=dexp(-1.4388d0*tex/te)                                                 
              q=q+ge*expe                                                                 
              els=els+tex*ge*expe                                                         
            endif                                                                         
!                                                                                         
   20     continue                                                                        
          elenf(jt)=1.4388d0*1.3806d-23*6.026d23*els/q +1.0D-10                           
   30 continue                                                                            
!                                                                                         
      do 40 j=1,5                                                                         
      b(j)=dlog(elenf(j))                                                                 
      xx(j,1)=1.d0/tt1(j)                                                                 
      xx(j,2)=1.0d0                                                                       
      xx(j,3)=dlog(tt1(j))                                                                
      do 40 i=4,5                                                                         
   40 xx(j,i)=tt1(j)**(i-3)                                                               
      call leqt2f(xx,1,5,5,b,0,wkarea,ier)                                                
      do 50 j=1,5                                                                         
      akd(j,isp)=b(j)                                                                     
   50 continue                                                                            
!                                                                                         
   10 continue                                                                            
!                                                                                         
      return                                                                              
      end                                                                                 
!**********************************************************************                   
      subroutine emis_absb(nprt,natomsx,ndiatomsx,ntriatoms,inode,        &               
     &    tran,trot,tvib,tele,                        &               
     &   concAl,concAlp,concAlpp,concAl3p,            &
     &   concC, concC2,                               &
     &   concCa,concCap,concCl,concC2H,               &
     &   concC3,concCH, concCN,concCO,                &
     &   concCO2,concCp, concCpp,concC3p,             &
     &   concC4p,concCr,concCrp,concCrpp,             &
     &   concFe,concFeO,concFep,concFepp,             &
     &   concFe3p,concFe4p,concFe5p,concH,            &
     &   concH2, concHp,concH2O,concK,                &
     &   concMg, concMgO,concMgp,concMgpp,            &
     &   concMg3p,concMg4p,concN,concNE,              &
     &   concN2,concN2p,concNp,concNpp,               &
     &   concN3p,concN4p,concNa,concNap,              &
     &   concNO,concNi,concNip,concNipp,              &
     &   concNi3p,concO,concO2,concOH,                &
     &   concOp,concOpp,concO3p,concO4p,              &
     &   concS,concSi,concSO,concSiO,                 &
     &   concSip,concSipp,concSi3p,concSi4p,          &
     &   concSp,concSpp,concS3p,concS4p,              &
     &   concSiH,concTi,concTip,concTipp,             &
     &   concTi3p,concTiO,                            &               
     &  avg_molwt)                                                        
! emission and absorption calculation                                                     
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,mnode=1,msp=60)                                
      parameter   (nw=400000)                                                             
      implicit real*8(a-h,o-z)                                                            
      real*8 ion_pot,n_himp_bb_diatom,lam2_diatom,                        &               
     & n_himp_diatom,ix_lev_triatom,iy_lev_triatom,iz_lev_triatom,        &               
     & intens                                                                             
      integer g_atom,gi_atom,gk_atom,g_diatom,g_atom1,g_atom2,            &               
     & gneq_diatom,s_diatom,up,gg_lev_triatom,ge_lev_triatom,             &               
     & spin_lev_triatom,g1_lev_triatom,g2_lev_triatom,g3_lev_triatom,     &               
     & charge_diatom,g_neq_lev_atom,g_ion                                                 
      common/coma1/atomwt(matoms),ion_pot(matoms),                        &               
     &  Ecm_atom(nlev_tot_atom,matoms),Ecm_ion(nlev_tot_atom,matoms),     &               
     &  starkg(line_tot,matoms),                                          &               
     &  starkn(line_tot,matoms),Ecm_neq_lev_atom(23,matoms),              &               
     &  ei_atom(line_tot,matoms),ek_atom(line_tot,matoms),                &               
     &  wavel_atom(line_tot,matoms),aki_atom(line_tot,                    &               
     &  matoms),z(matoms),e_inner(matoms),ephot_gaunt(21,matoms),         &               
     &  e_gaunt(51,matoms),gaunt(9,51,matoms),temp_cross_atom(11,matoms)  &               
     &  ,wavel_cross_atom(101,matoms),cross_atom(101,11,matoms),          &               
     &  ephot_ff(11,matoms),temp_ff(31,matoms),gaunt_ff(7,31,matoms),     &               
     &  eimp_ro(26,26,matoms),eimp_rexp(26,26,matoms)                                     
      common/comb1/ g_atom(nlev_tot_atom,matoms),g_neq_lev_atom(23,       &               
     &  matoms),gi_atom(line_tot,matoms),g_ion(nlev_tot_atom,             &               
     &  matoms),gk_atom(line_tot,matoms),ig_gaunt(99,matoms),             &               
     &  ind_lev_atom(nlev_tot_atom,matoms),ind_lev_ion(nlev_tot_atom,     &               
     &  matoms),ind_line(line_tot,matoms),iz_atom(matoms),                &               
     &  neq_lev_atom(matoms),n_gaunt(99,matoms),ng_atom(nlev_tot_atom,    &               
     &  matoms),ng_gaunt(99,matoms),n_temp_cross_atom(matoms),            &               
     &  ngi_atom(line_tot,matoms),ngk_atom(line_tot,matoms),              &               
     &  nlev_atom(matoms),nlev_atomic_ion(matoms),nline(matoms),          &               
     &  n_temp_ff_atom(matoms),ntot_gaunt(matoms),num_exct(matoms),       &               
     &  n_wavel_cross_atom(matoms)                                                        
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      character*4 atom_rads(3,168),diatom_bands(3,100),                   &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                     &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                         &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,  &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      character*4 contnm_triatom,contnm_diatom                                                          
      character*5 hund_diatom                                                             
      common/comi/nwave                                                                   
      dimension                                                           &               
     & avg_molwt(mnode),diatom_avg_molwt(mdiatoms),diatom_dens_atom       &               
     & (mdiatoms),diatom_dens_mol(mdiatoms),diatom_dens_hvy(mdiatoms),    &               
     & diatom_dens_elec(mdiatoms),didens_atom(mdiatoms),diatom_rho        &               
     & (mdiatoms),diatom_chi(mdiatoms),                                   &               
     & diatom_dens_atom1(mdiatoms),diatom_dens_atom2(mdiatoms),           &               
     & tridens_atom(mtriatoms),                                           &               
     & tran(mnode),trot(mnode),tvib(mnode),tele(mnode)                                    
      dimension                                                           &
     & concAl(mnode),concAlp(mnode),concAlpp(mnode),concAl3p(mnode),      &
     & concC(mnode), concC2(mnode),                                       &
     & concCa(mnode),concCap(mnode),concCl(mnode),concC2H(mnode),         &
     & concC3(mnode),concCH(mnode), concCN(mnode),concCO(mnode),          &
     & concCO2(mnode),concCp(mnode), concCpp(mnode),concC3p(mnode),       &
     & concC4p(mnode),concCr(mnode),concCrp(mnode),concCrpp(mnode),       &
     & concFe(mnode),concFeO(mnode),concFep(mnode),concFepp(mnode),       &
     & concFe3p(mnode),concFe4p(mnode),concFe5p(mnode),concH(mnode),      &
     & concH2(mnode), concHp(mnode),concH2O(mnode),concK(mnode),          &
     & concMg(mnode), concMgO(mnode),concMgp(mnode),concMgpp(mnode),      &
     & concMg3p(mnode),concMg4p(mnode),concN(mnode),concNE(mnode),        &
     & concN2(mnode),concN2p(mnode),concNp(mnode),concNpp(mnode),         &
     & concN3p(mnode),concN4p(mnode),concNa(mnode),concNap(mnode),        &
     & concNO(mnode),concNi(mnode),concNip(mnode),concNipp(mnode),        &
     & concNi3p(mnode),concO(mnode),concO2(mnode),concOH(mnode),          &
     & concOp(mnode),concOpp(mnode),concO3p(mnode),concO4p(mnode),        &
     & concS(mnode),concSi(mnode),concSO(mnode),concSiO(mnode),           &
     & concSip(mnode),concSipp(mnode),concSi3p(mnode),concSi4p(mnode),    &
     & concSp(mnode),concSpp(mnode),concS3p(mnode),concS4p(mnode),        &
     & concSiH(mnode),concTi(mnode),concTip(mnode),concTipp(mnode),       &
     & concTi3p(mnode),concTiO(mnode) 
      save                                                  
      data blank4/'    '/ 
      
      natoms=natomsx                                                                           
      ndiatoms=ndiatomsx                                                                         
      ntriatoms=0                                                                         
      avg_molwt(1)=15.  
!
! atomic species    
      if(natoms.gt.0) then                                                                
        dens_atom_hvy=0.                                                                  
        do isp=1,natoms  
          dens_atom(isp)=0.
          atom_chi(isp) = 1.0                                                             
          atom_avg_molwt = avg_molwt(inode)                                               
          dens_elec = 1.0e-6*concNe(inode)                                                
          if(atomnm(isp).eq.'Al  ') then                                                  
            dens_atom(isp) = 1.0e-6*concAl(inode)                                          
            atom_dens_ion(isp) =1.0e-6*concAlp(inode)                                      
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Al+ ') then                                                  
            dens_atom(isp) = 1.0e-6*concAlp(inode)                                          
            atom_dens_ion(isp) =1.0e-8*concAlp(inode)                                      
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Al++') then                                                  
            dens_atom(isp) = 1.0e-6*concAlpp(inode)                                          
            atom_dens_ion(isp) =1.0e-6*concAl3p(inode)                                      
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Al+3') then                                                  
            dens_atom(isp) = 1.0e-6*concAl3p(inode)                                          
            atom_dens_ion(isp) =1.0e-8*concAl3p(inode)                                      
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'C   ') then                                                  
            dens_atom(isp) = 1.0e-6*concC(inode)                                          
            atom_dens_ion(isp) =1.0e-6*concCp(inode)                                      
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Ca  ') then                                                  
            dens_atom(isp) = 1.0e-6*concCa(inode)                                          
            atom_dens_ion(isp) =1.0e-6*concCap(inode)                                      
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Ca+ ') then                                                  
            dens_atom(isp) = 1.0e-6*concCap(inode)                                          
            atom_dens_ion(isp) =1.0e-8*concCap(inode)                                      
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'C+  ') then                                                  
            dens_atom(isp) = 1.0e-6*concCp(inode)                                         
            atom_dens_ion(isp) =1.0e-6*concCpp(inode)                                     
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'C++ ') then                                                  
            dens_atom(isp) = 1.0e-6*concCpp(inode)                                        
            atom_dens_ion(isp) =1.0e-6*concC3p(inode)                                     
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'C+3 ') then                                                  
            dens_atom(isp) = 1.0e-6*concC3p(inode)                                        
            atom_dens_ion(isp) =1.0e-7*concC3p(inode)                                     
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'C+4 ') then                                                  
            dens_atom(isp) = 1.0e-6*concC4p(inode)                                        
            atom_dens_ion(isp) =1.0e-7*concC4p(inode)                                     
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Cl  ') then                                                  
            dens_atom(isp) = 1.0e-6*concCl(inode)                                         
            atom_dens_ion(isp) =1.0e-7*concCl(inode)                                      
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Cr  ') then                                                  
            dens_atom(isp) = 1.0e-6*concCr(inode)                                         
            atom_dens_ion(isp) =1.0e-6*concCrp(inode)                                      
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Cr+ ') then                                                  
            dens_atom(isp) = 1.0e-6*concCrp(inode)                                         
            atom_dens_ion(isp) =1.0e-6*concCrpp(inode)                                      
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Cr++') then                                                  
            dens_atom(isp) = 1.0e-6*concCrpp(inode)                                         
            atom_dens_ion(isp) =1.0e-7*concCrpp(inode)                                      
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Fe  ') then                                                  
            dens_atom(isp) = 1.0e-6*concFe(inode)                                         
            atom_dens_ion(isp) = 1.0e-6*concFep(inode)                                    
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Fe+ ') then                                                  
            dens_atom(isp) = 1.0e-6*concFep(inode)                                        
            atom_dens_ion(isp) = 1.0e-6*concFepp(inode)                                   
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Fe++') then                                                  
            dens_atom(isp) = 1.0e-6*concFepp(inode)                                       
            atom_dens_ion(isp) = 1.0e-6*concFe3p(inode)                                   
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Fe+3') then                                                  
            dens_atom(isp) = 1.0e-6*concFe3p(inode)                                       
            atom_dens_ion(isp) = 1.0e-6*concFe4p(inode)                                   
          end if                                                                          
          if(atomnm(isp).eq.'Fe+4') then                                                  
            dens_atom(isp) = 1.0e-6*concFe4p(inode)                                       
            atom_dens_ion(isp) = 1.0e-6*concFe5p(inode)                                   
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Fe+5') then                                                  
            dens_atom(isp) = 1.0e-6*concFe5p(inode)                                       
            atom_dens_ion(isp) = 1.0e-7*concFe5p(inode)                                   
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'H   ') then                                                  
            dens_atom(isp) = 1.0e-6*concH(inode)                                          
            atom_dens_ion(isp) = 1.0e-6*concHp(inode)                                     
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'H+  ') then                                                  
            dens_atom(isp) = 1.0e-6*concHp(inode)                                         
            atom_dens_ion(isp) = 1.0e-7*concHp(inode)                                     
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'K   ') then                                                  
            dens_atom(isp) = 1.0e-6*concK(inode)                                          
            atom_dens_ion(isp) = 1.0e-7*concK(inode)                                      
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Mg  ') then                                                  
            dens_atom(isp) = 1.0e-6*concMg(inode)                                         
            atom_dens_ion(isp) = 1.0e-6*concMgp(inode)                                    
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Mg+ ') then                                                  
            dens_atom(isp) = 1.0e-6*concMgp(inode)                                        
            atom_dens_ion(isp) = 1.0e-6*concMgpp(inode)                                   
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Mg++') then                                                  
            dens_atom(isp) = 1.0e-6*concMgpp(inode)                                       
            atom_dens_ion(isp) = 1.0e-6*concMg3p(inode)                                   
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Mg+3') then                                                  
            dens_atom(isp) = 1.0e-6*concMg3p(inode)                                       
            atom_dens_ion(isp) = 1.0e-6*concMg4p(inode)                                   
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Mg+4') then                                                  
            dens_atom(isp) = 1.0e-6*concMg4p(inode)                                       
            atom_dens_ion(isp) = 1.0e-7*concMg4p(inode)                                   
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'N   ') then                                                  
            dens_atom(isp) = 1.0e-6*concN(inode)     
            atom_dens_ion(isp) = 1.0e-6*concNp(inode)                                     
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)  
          end if                                                                          
          if(atomnm(isp).eq.'N+  ') then                                                  
            dens_atom(isp) = 1.0e-6*concNp(inode)    
            atom_dens_ion(isp) = 1.0e-6*concNpp(inode)                                    
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'N++ ') then                                                  
            dens_atom(isp) = 1.0e-6*concNpp(inode)                                        
            atom_dens_ion(isp) = 1.0e-6*concN3p(inode)                                    
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'N+3 ') then                                                  
            dens_atom(isp) = 1.0e-6*concN3p(inode)                                        
            atom_dens_ion(isp) = 1.0e-7*concN3p(inode)                                    
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'N+4 ') then                                                  
            dens_atom(isp) = 1.0e-6*concN4p(inode)                                        
            atom_dens_ion(isp) = 1.0e-7*concN4p(inode)                                    
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Na  ') then                                                  
            dens_atom(isp) = 1.0e-6*concNa(inode)                                         
            atom_dens_ion(isp) = 1.0e-6*concNap(inode)                                     
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Na+ ') then                                                  
            dens_atom(isp) = 1.0e-6*concNap(inode)                                         
            atom_dens_ion(isp) = 1.0e-7*concNap(inode)                                     
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Ni  ') then                                                  
            dens_atom(isp) = 1.0e-6*concNi(inode)                                         
            atom_dens_ion(isp) = 1.0e-6*concNip(inode)                                     
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Ni+ ') then                                                  
            dens_atom(isp) = 1.0e-6*concNip(inode)                                         
            atom_dens_ion(isp) = 1.0e-7*concNipp(inode)                                     
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Ni++') then                                                  
            dens_atom(isp) = 1.0e-6*concNipp(inode)                                         
            atom_dens_ion(isp) = 1.0e-7*concNi3p(inode)                                     
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Ni+3') then                                                  
            dens_atom(isp) = 1.0e-6*concNi3p(inode)                                         
            atom_dens_ion(isp) = 1.0e-7*concNi3p(inode)                                     
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'O   ') then                                                  
            dens_atom(isp) = 1.0e-6*concO(inode)      
            atom_dens_ion(isp) = 1.0e-6*concOp(inode)                                     
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'O+  ') then                                                  
            dens_atom(isp) = 1.0e-6*concOp(inode)   
            atom_dens_ion(isp) = 1.0e-6*concOpp(inode)                                    
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'O++ ') then                                                  
            dens_atom(isp) = 1.0e-6*concOpp(inode)                                        
            atom_dens_ion(isp) = 1.0e-6*concO3p(inode)                                    
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'O+3 ') then                                                  
            dens_atom(isp) = 1.0e-6*concO3p(inode)                                        
            atom_dens_ion(isp) = 1.0e-6*concO4p(inode)                                    
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'O+4 ') then                                                  
            dens_atom(isp) = 1.0e-6*concO4p(inode)                                        
            atom_dens_ion(isp) = 1.0e-7*concO4p(inode)                                    
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'S   ') then                                                  
            dens_atom(isp) = 1.0e-6*concS(inode)                                          
            atom_dens_ion(isp) = 1.0e-6*concSp(inode)                                     
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'S+  ') then                                                  
            dens_atom(isp) = 1.0e-6*concSp(inode)                                         
            atom_dens_ion(isp) = 1.0e-6*concSpp(inode)                                    
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'S++ ') then                                                  
            dens_atom(isp) = 1.0e-6*concSpp(inode)                                        
            atom_dens_ion(isp) = 1.0e-6*concS3p(inode)                                    
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'S+3 ') then                                                  
            dens_atom(isp) = 1.0e-6*concS3p(inode)                                        
            atom_dens_ion(isp) = 1.0e-6*concS4p(inode)                                    
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'S+4 ') then                                                  
            dens_atom(isp) = 1.0e-6*concS4p(inode)                                        
            atom_dens_ion(isp) = 1.0e-7*concS4p(inode)                                    
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Si  ') then                                                  
            dens_atom(isp) = 1.0e-6*concSi(inode)                                         
            atom_dens_ion(isp) = 1.0e-6*concSip(inode)                                    
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Si+ ') then                                                  
            dens_atom(isp) = 1.0e-6*concSip(inode)                                        
            atom_dens_ion(isp) = 1.0e-6*concSipp(inode)                                   
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Si++') then                                                  
            dens_atom(isp) = 1.0e-6*concSipp(inode)                                       
            atom_dens_ion(isp) = 1.0e-6*concSipp(inode)                                   
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Si+3') then                                                  
            dens_atom(isp) = 1.0e-6*concSi3p(inode)                                       
            atom_dens_ion(isp) = 1.0e-7*concSi3p(inode)                                   
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Si+4') then                                                  
            dens_atom(isp) = 1.0e-6*concSi4p(inode)                                       
            atom_dens_ion(isp) = 1.0e-7*concSi4p(inode)                                   
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Ti  ') then                                                  
            dens_atom(isp) = 1.0e-6*concTi(inode)                                         
            atom_dens_ion(isp) = 1.0e-6*concTip(inode)                                    
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Ti+ ') then                                                  
            dens_atom(isp) = 1.0e-6*concTip(inode)                                        
            atom_dens_ion(isp) = 1.0e-6*concTipp(inode)                                   
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Ti++') then                                                  
            dens_atom(isp) = 1.0e-6*concTipp(inode)                                       
            atom_dens_ion(isp) = 1.0e-6*concTi3p(inode)                                   
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          
          if(atomnm(isp).eq.'Ti+3') then                                                  
            dens_atom(isp) = 1.0e-6*concTi3p(inode)                                       
            atom_dens_ion(isp) = 1.0e-7*concTi3p(inode)                                   
            dens_atom_hvy=dens_atom_hvy+dens_atom(isp)                                    
          end if                                                                          

! generate default values of atom_rho(i,isp)                                              
          do i=1,neq_lev_atom(isp)                                                        
            atom_rho(i,isp)=1.0                                                           
          end do                                                                          
          atom_chi(isp) = 1.0                                                             
!                                                                                         
! bound-bound radiation  
          do i=1,167  
            ibb=0
            if((atomnm(isp).eq.atom_rads(1,i)).and.                               &
     &        (atom_rads(1,i).eq.atom_rads(3,i)).and.                             &
     &        (atom_rads(2,i).eq.'bb  ')) then                                                
              ibb = 1 
            end if 
            if((ibb.eq.1).and.(dens_atom(isp).gt.1.0e12)) then 
              if(atomnm(isp).ne.'H   ') then   
                write(6,61) atomnm(isp),dens_atom(isp),tran(1)                              
                write(*,61) atomnm(isp),dens_atom(isp),tran(1)                              
  61            format(/' calling atom_bb ',a4,1pe10.3,' temp=',0pf10.1) 
                call atom_bb(isp, tele(inode),power) 
                write(*,62) atomnm(isp)                                                     
                write(6,62) atomnm(isp)                                                     
  62            format(' out of atom_bb ',a4,1pe10.3)   
              end if                                                                        
              if(atomnm(isp).eq.'H   ') then                                                
                write(6,81) atomnm(isp),dens_atom(isp),tran(1)                              
                write(*,81) atomnm(isp),dens_atom(isp),tran(1)                              
  81            format(/' calling H_bb ',a4,1pe10.3,' temp=',0pf10.1)                          
                call H_bb(isp,tele(inode),power)                                    
                write(*,82) atomnm(isp)                                                     
                write(6,82) atomnm(isp)                                                     
  82            format(' out of H_bb ',a4,1pe10.3)                                          
              end if                                                                        
            end if                                                                          
          end do
!                                                                                         
! bound-free radiation                                                                    
          ibf = 0                                                                         
          do i=1,167                                                                      
            if((atomnm(isp).eq.atom_rads(1,i)).and.                                  &
     &        (atom_rads(1,i).eq.atom_rads(3,i)).and.                                &
     &        (atom_rads(2,i).eq.'bG  ')) ibf=1
            if((atomnm(isp).eq.atom_rads(1,i)).and.                                  &
     &        (atom_rads(1,i).eq.atom_rads(3,i)).and.                                &
     &        (atom_rads(2,i).eq.'bc  ')) ibf=2
          end do                                                                          
          if((ibf.eq.1).and.(dens_atom(isp).gt.1.0e12) ) then                                             
            write(6,63) atomnm(isp),dens_atom(isp),tran(1)                                
            write(*,63) atomnm(isp),dens_atom(isp),tran(1)                                
 63         format(/' calling atom_bf_gaunt ',a4,1pe10.3,' temp=',0pf10.1)                   
!            call atom_bf_Gaunt(isp,tele(inode), power)                             
            write(*,76) atomnm(isp)                                                       
            write(6,76) atomnm(isp)                                                       
 76         format(' out of atom_bf_gaunt ',a4,1pe10.3)                                   
          end if                                                                          
          if((ibf.eq.2).and.(dens_atom(isp).gt.1.0e12)) then                                         
            write(*,64) atomnm(isp),dens_atom(isp),tele(inode)                            
            write(6,64) atomnm(isp),dens_atom(isp),tele(inode)                            
 64         format(/' calling atom_bf_cr ',a4,1pe10.3,' temp=',0pf10.1)  
!            call atom_bf_cr(isp,tele(inode), power)                                
            write(*,75) atomnm(isp)                                                       
            write(6,75) atomnm(isp)                                                       
 75         format(' out of atom_bf_cr ',a4,1pe10.3)                                      
          end if                                                                          
!                                                                                         
! free-free radiation                                                                     
          iff = 0                                                                         
          do i=1,167                                                                      
            if((atomnm(isp).eq.atom_rads(1,i)).and.(atom_rads(1,i).eq.atom_rads(3,i))   &               
     &        .and.(atom_rads(2,i).eq.'ff')) iff = 1                                           
          enddo                                                                           
          if((iff.eq.1).and.(dens_atom(isp).gt.1.0e12)) then                              
            write(*,65) atomnm(isp),dens_atom(isp),tran(1)                                
            write(6,65) atomnm(isp),dens_atom(isp),tran(1)                                
  65        format(/' calling atom_ff ',a4,1pe10.3,' t=',0pf10.1)                         
            call atom_ff(isp, tele(inode), power)                                 
            write(*,66) atomnm(isp)                                                       
            write(6,66) atomnm(isp)                                                       
  66        format(' out of atom_ff ',a4,1pe10.3)                                         
            power_tot=power_tot+power                                                     
          end if                                                                          
        end do                                      ! over atomic species                 
      end if                                        ! atoms                               
!                                                                                         
!--------------------------------------------------------------------------------------   
! diatomic radiation                                                                      
      if(ndiatoms.gt.0) then                                                              
        do isp = 1,ndiatoms  
          dens_diatom(isp)=0.                                                             
          diatom_dens_elec(isp) = 1.0e-6*concNe(inode)                                    
          if(diatomnm(isp).eq.'C2  ') then                                                
            dens_diatom(isp) = 1.0e-6 * concC2(inode)                                     
            diatom_dens_atom1(isp) = 1.0e-6 * concC(inode)                                
            diatom_dens_atom2(isp) = 1.0e-6 * concC(inode)                                
          endif                                                                           
          if(diatomnm(isp).eq.'CH  ') then                                                
            dens_diatom(isp) = 1.0e-6 * concCH(inode)                                     
            diatom_dens_atom1(isp) = 1.0e-6 * concC(inode)                                
            diatom_dens_atom2(isp) = 1.0e-6 * concH(inode)                                
          endif                                                                           
          if(diatomnm(isp).eq.'CN  ') then                                                
            dens_diatom(isp) = 1.0e-6 * concCN(inode)                                     
            diatom_dens_atom1(isp) = 1.0e-6 * concC(inode)                                
            diatom_dens_atom2(isp) = 1.0e-6 * concN(inode)                                
          endif                                                                           
          if(diatomnm(isp).eq.'CO  ') then                                                
            dens_diatom(isp) = 1.0e-6 * concCO(inode)                                     
            diatom_dens_atom1(isp) = 1.0e-6 * concC(inode)                                
            diatom_dens_atom2(isp) = 1.0e-6 * concO(inode)                                
          endif                                                                           
          if(diatomnm(isp).eq.'H2  ') then                                                
            dens_diatom(isp) = 1.0e-6 * concH2(inode)                                     
            diatom_dens_atom1(isp) = 1.0e-6 * concH(inode)                                
            diatom_dens_atom2(isp) = 1.0e-6 * concH(inode)                                
          endif                                                                           
          if(diatomnm(isp).eq.'N2  ') then                                                
            dens_diatom(isp) = 1.0e-6 * concN2(inode)                                     
            diatom_dens_atom1(isp) = 1.0e-6 * concN(inode)                                
            diatom_dens_atom2(isp) = 1.0e-6 * concN(inode)                                
          endif                                                                           
          if(diatomnm(isp).eq.'N2+ ') then                                                
            dens_diatom(isp) = 1.0e-6 * concN2p(inode)                                    
            diatom_dens_atom1(isp) = 1.0e-6 * concNp(inode)                               
            diatom_dens_atom2(isp) = 1.0e-6 * concN(inode)                                
          endif                                                                           
          if(diatomnm(isp).eq.'NO  ') then                                                
            dens_diatom(isp) = 1.0e-6 * concNO(inode)                                     
            diatom_dens_atom1(isp) = 1.0e-6 * concN(inode)                                
            diatom_dens_atom2(isp) = 1.0e-6 * concO(inode)                                
          endif                                                                           
          if(diatomnm(isp).eq.'O2  ') then                                                
            dens_diatom(isp) = 1.0e-6 * concO2(inode)                                     
            diatom_dens_atom1(isp) = 1.0e-6 * concO(inode)                                
            diatom_dens_atom2(isp) = 1.0e-6 * concO(inode)                                
          endif                                                                           
          if(diatomnm(isp).eq.'OH  ') then                                                
            dens_diatom(isp) = 1.0e-6 * concOH(inode)                                     
            diatom_dens_atom1(isp) = 1.0e-6 * concO(inode)                                
            diatom_dens_atom2(isp) = 1.0e-6 * concH(inode)                                
          endif                                                                           
          if(diatomnm(isp).eq.'SiH ') then                                                
            dens_diatom(isp) = 1.0e-6 * concSiH(inode)                                    
            diatom_dens_atom1(isp) = 1.0e-6 * concSi(inode)                               
            diatom_dens_atom2(isp) = 1.0e-6 * concH(inode)                                
          end if                                                                          
          if(diatomnm(isp).eq.'SiO ') then                                                
            dens_diatom(isp) = 1.0e-6 * concSiO(inode)                                    
            diatom_dens_atom1(isp) = 1.0e-6 * concSi(inode)                               
            diatom_dens_atom2(isp) = 1.0e-6 * concO(inode)                                
          end if                                                                          
          if(diatomnm(isp).eq.'MgO ') then                                                
            dens_diatom(isp) = 1.0e-6 * concMgO(inode)                                    
            diatom_dens_atom1(isp) = 1.0e-6 * concMg(inode)                               
            diatom_dens_atom2(isp) = 1.0e-6 * concO(inode)                                
          end if                                                                          
          if(diatomnm(isp).eq.'FeO ') then                                                
            dens_diatom(isp) = 1.0e-6 * concFeO(inode)                                    
            diatom_dens_atom1(isp) = 1.0e-6 * concFe(inode)                               
            diatom_dens_atom2(isp) = 1.0e-6 * concO(inode)                                
          end if                                                                          
          if(diatomnm(isp).eq.'SO ') then                                                 
            dens_diatom(isp) = 1.0e-6 * concSO(inode)                                     
            diatom_dens_atom1(isp) = 1.0e-6 * concS(inode)                                
            diatom_dens_atom2(isp) = 1.0e-6 * concO(inode)                                
          end if                                                                          
          if(diatomnm(isp).eq.'TiO') then                                                 
            dens_diatom(isp) = 1.0e-6 * concTiO(inode)                                     
            diatom_dens_atom1(isp) = 1.0e-6 * concTi(inode)                                
            diatom_dens_atom2(isp) = 1.0e-6 * concO(inode)                                
          end if                                                                          
!                                                                                         
!   generate default values of diatom_rho(ie,isp)                                         
          do i=1,ndiatoms                                                                 
            do ie=1,20                                                                    
              diatom_rho(i) = 1.0                                                         
            end do                                                                        
          end do                                                                          
          diatom_chi(isp) = 1.0                                                           
!                                                                                         
! bound-bound radiation                                                                   
          ibb = 0                                                                         
          do i=1,100                                                                      
            if( (diatomnm(isp).eq.diatom_bands(1,i)).and.                      &
     &        (diatom_bands(1,i).eq.diatom_bands(3,i))                         &               
     &       .and. ( (diatom_bands(2,i).ne.'cont') .and.                       &               
     &        (diatom_bands(2,i).ne.'nrct') ) ) then
              ibb = 1 
              is=i
            end if                             
            if((ibb.eq.1).and.(dens_diatom(isp).gt.1.0e12)) then 
              write(*,51) diatomnm(isp),diatom_bands(2,is),dens_diatom(isp),tran(1)                            
              write(6,51) diatomnm(isp),diatom_bands(2,is),dens_diatom(isp),tran(1)                            
  51          format(/' calling diatom_bb ',2a4,1pe10.3,' t=',0pf10.1)                       
              call diatom_bb(isp,diatomnm,tran(inode),                         &               
     &          trot(inode),tvib(inode),tele(inode),diatom_bands)                           
              write(*,73) diatomnm(isp)                                                     
              write(6,73) diatomnm(isp)                                                     
 73           format(' out of diatom_bb ',a4,1pe10.3)                                       
            end if
            ibb=0
          end do                                                                          
!                                                                                         
! bound-free radiation   
          ibf = 0                                                                         
          do i=1,100                                                                      
            if( (diatomnm(isp).eq.diatom_bands(1,i)) .and.                     &
     &        (diatom_bands(1,i).eq.diatom_bands(3,i))                         &               
     &        .and.((diatom_bands(2,i).eq.'cont') .or.                         &               
     &        (diatom_bands(2,i).eq.'nrct') ) ) then
              ibf = 1
              is=i   
            end if                                
            if((ibf.eq.1).and.(dens_diatom(isp).gt.1.0e12)) then   
              write(*,52) diatomnm(isp),diatom_bands(2,is),dens_diatom(isp),tran(1)                            
              write(6,52) diatomnm(isp),diatom_bands(2,is),dens_diatom(isp),tran(1)                            
 52           format(/' calling diatom_bf ',2a4,1pe10.3,' t=',0pf10.1)    
              call diatom_bf(isp,tele(1)) 
              write(*,72) diatomnm(isp)                                                     
              write(6,72) diatomnm(isp)                                                     
 72           format(' out of diatom_bf ',a4,1pe10.3)                                       
            end if                                                                          
            ibf=0
          end do
        end do                                            ! over diatomic species         
      end if                                              ! diatoms                       
!                                                                                         
!-----------------------------------------------------------------------------------------
! triatomic radiation                                                                     
      if(ntriatoms.gt.0) then                                                             
        do isp=1,ntriatoms                                                                
          if(triatomnm(isp).eq.'C3  ') then                                               
            dens_triatom(isp) = 1.0e-6 * concC3(inode)                                    
          end if                                                                          
          if(triatomnm(isp).eq.'C2H ') then                                               
            dens_triatom(isp) = 1.0e-6 * concC2H(inode)                                   
          end if                                                                          
          if(triatomnm(isp).eq.'H2O ') then                                               
            dens_triatom(isp) = 1.0e-6 * concH2O(inode)                                   
          end if                                                                          
          if(triatomnm(isp).eq.'CO2 ') then                                               
            dens_triatom(isp) = 1.0e-6 * concCO2(inode)                                   
          end if                                                                          
!                                                                                         
! continuum radiation only                                                                    
          ibf = 0                                                                         
          do i=1,10                                                                       
            if((triatomnm(isp).eq.triatom_bands(1,i)).and.                        &
    &       (triatom_bands(1,i).eq.triatom_bands(3,i))) then
              ibf = 1   
              is=i
            end if                                  
            if((ibf.eq.1).and.(dens_triatom(isp).gt.1.0e12)) then                                            
              write(*,*) ' calling triatom_bf ',triatomnm(isp),triatom_bands(2,is)                              
              write(6,*) ' calling triatom_bf ',triatomnm(isp),triatom_bands(2,is)                              
              call triatom_bf(isp,tele(1))                                                                    
              write(6,*) ' out of triatom_bf'                                               
              write(*,*) ' out of triatom_bf'                                               
            end if
          end do 
          ibf=0                                                                         
        end do                                                                            
      end if                                                                              
! 
      return                                                                              
      end                                                                                 
!***********************************************************************
      subroutine emis_absb1(itemp,natomsx,ndiatomsx,ntriatoms,      &
  &     nprt,inode,temp,rho,an,avg_molwt)
      parameter(nw=400000)
      parameter(matoms=56,mdiatoms=12,mtriatoms=6,mnode=1,msp=60)                                
      implicit real*8(a-h,o-z)
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,     &
    &   atomnm1,diatomnm,diatomnm1,triatomnm,triatomnm1
      character*4 atom_rads(3,168),diatom_bands(3,100),                   &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                     &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                         &               
     &  triatomnm1(mtriatoms)                                                             
      common/comi/nwave                                                                   
      dimension an(10),avg_molwt(mnode)

! 1 2  3  4  5  6  7  8  9
! O N O2 N2 NO O+ N+ NO+ E-
      
      natoms=natomsx                                                                           
      ndiatoms=ndiatomsx                                                                         
      ntriatoms=0                                                                         
      avg_molwt(1)=15.  

! atoms
      dens_atom_hvy=an(1)+an(2)+an(6)+an(7)
      do isp=1,natoms
        ibb=0    
        if(atomnm(isp).eq.'O   ')  then
          dens_atom(isp) = an(1)                                          
          atom_dens_ion(isp) = an(6)
          ibb=1                                     
        end if
        if(atomnm(isp).eq.'N   ')  then
          dens_atom(isp) = an(2)                                          
          atom_dens_ion(isp) = an(7)                                     
          ibb=1                                     
        end if
        if(atomnm(isp).eq.'O+  ')  then
          dens_atom(isp) = an(6)                                          
          atom_dens_ion(isp) = 1.0e-6* an(6)                                     
          ibb=1                                     
        end if
        if(atomnm(isp).eq.'N+  ')  then
          dens_atom(isp) = an(7)                                          
          atom_dens_ion(isp) = 1.0e-6* an(7)                                     
          ibb=1                                     
        end if

        if((ibb.eq.1).and.(dens_atom(isp).gt.1.0e12)) then 
          write(6,61) atomnm(isp),dens_atom(isp),temp                              
          write(*,61) atomnm(isp),dens_atom(isp),temp                              
  61      format(/' calling atom_bb ',a4,1pe10.3,' temp=',0pf10.1) 
          call atom_bb(isp, temp,power) 
          write(*,62) atomnm(isp)                                                     
          write(6,62) atomnm(isp)                                                     
  62      format(' out of atom_bb ',a4,1pe10.3)   
!
          write(*,64) atomnm(isp),dens_atom(isp),temp                            
          write(6,64) atomnm(isp),dens_atom(isp),temp                            
 64       format(/' calling atom_bf_cr ',a4,1pe10.3,' temp=',0pf10.1)   
          call atom_bf_cr(isp,temp, power)                                
          write(*,75) atomnm(isp)                                                       
          write(6,75) atomnm(isp)                                                       
 75       format(' out of atom_bf_cr ',a4,1pe10.3)                                      

          write(*,65) atomnm(isp),dens_atom(isp),temp                                
          write(6,65) atomnm(isp),dens_atom(isp),temp                                
  65      format(/' calling atom_ff ',a4,1pe10.3,' temp=',0pf10.1)                         
          call atom_ff(isp, temp, power)                                 
          write(*,66) atomnm(isp)                                                       
          write(6,66) atomnm(isp)                                                       
  66      format(' out of atom_ff ',a4,1pe10.3)                                         
        end if                                                                          
!
      end do
!
! diatoms
! 1 2  3  4  5  6  7  8  9
! O N O2 N2 NO O+ N+ NO+ E-
      do isp=1,ndiatoms
        ibb=0
        if(diatomnm(isp).eq.'O2  ') then
          dens_diatom(isp)=an(3)
          ibb=1
        end if
        if(diatomnm(isp).eq.'N2  ') then
          dens_diatom(isp)=an(4)
          ibb=1
        end if
        if(diatomnm(isp).eq.'NO  ') then
          dens_atom(isp)=an(5)
          ibb=1
        end if

        if((ibb.eq.1).and.(dens_diatom(isp).gt.1.0e12)) then 
          write(*,51) diatomnm(isp),diatom_bands(2,is),dens_diatom(isp),temp                            
          write(6,51) diatomnm(isp),diatom_bands(2,is),dens_diatom(isp),temp                            
  51      format(/' calling diatom_bb ',2a4,1pe10.3,' temp=',0pf10.1)                       
!         call diatom_bb(isp,diatomnm,temp,temp,temp,temp,diatom_bands)                           
          write(*,73) diatomnm(isp)                                                     
          write(6,73) diatomnm(isp)                                                     
 73       format(' out of diatom_bb ',a4,1pe10.3)                                       
          write(*,52) diatomnm(isp),diatom_bands(2,is),dens_diatom(isp),temp                            
          write(6,52) diatomnm(isp),diatom_bands(2,is),dens_diatom(isp),temp                            
 52       format(/' calling diatom_bf ',2a4,1pe10.3,' temp=',0pf10.1)                       
          call diatom_bf(isp,temp)                                          
          write(*,72) diatomnm(isp)                                                     
          write(6,72) diatomnm(isp)                                                     
 72       format(' out of diatom_bf ',a4,1pe10.3)                                       
        end if                                                                          
      end do

      return
      end
!**********************************************************************                   
      subroutine eqcal2(rhox,tempx,spnmx,spgamx,nstep,nprt,nprint,        &               
     &  eintx,presx, enthx,zz,avmw,ansp)                                                       
!                                                                                         
! calculate equilibrium composition for given density and temperature                     
! input                                                                                   
!   rhox=density, kg/m3                                                                   
!   tempx=temperature, K 
!   spnmx(msp)=species name                                                                 
!   spgamx(i)=initial estimate of species concentration, mol/kg                           
!   presx=pressure, pascal                                                                
!   nstep=max allowed time step in stiff7 integration                                     
!   nprt=print index                                                                      
!     nprt=0 no print. 3=print                                                            
!   nprint=printing interval                                                              
! output                                                                                  
!   eintx=internal energy per unit volume, J/m3                                           
!   enthx=enthalpy, J/kg                                                                  
!   zz=compressibility                                                                    
!   avmw=average molecular weight,kg/mol                                                  
!                                                                                         
      parameter(msp=60)                                                                   
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      common/eqcoma/elemwt(15),                                           &               
     & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp),            &               
     & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp),             &               
     & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp),                     &               
     & akb(5,msp),akd(5,msp),avmw0                                                        
      common/eqcomb/elemnm(12)                                                            
      common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc,  &               
     & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp),   &               
     & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp)                        
      common/eqcomb/pres,temp,rho,enth,spgam(msp),amdot                                   
      common/eqcomd/gamma,delta,elen,aratx,emfp,epsiln                                    
      dimension y(msp),yy(msp),dy(msp),case(5),spgamx(msp),frac(msp),ansp(msp)                      
      character*4 elemnm,spnm,spnmx(msp) 
      save                                                 
      external der1                                                                       
                                                                                          
      epsiln=1.0d-9*(rhox/1.0e-5)**0.75                                                  
!      epsiln=1.0d-12*(rhox/1.0e-5)**0.75                                                  
      neq=nsp-nelem                                                                       
      temp=tempx                                                                          
      rho=rhox                                                                            
      do isp=1,nsp                                                                        
        dy(isp)=100.                                                                      
        spnm(isp)=spnmx(isp)                                                              
      end do   
       call assign(spgam,nprt)
!                                                                                         
! integration                                                                             
      t=0.                                                                                
      h=1.0d-20                                                                           
      case(1)=0.025d0                                                                      
      case(2)=10.                                                                     
      case(3)=1.0d-7                                                                      
!      case(4)=-1.5d0                                                                     
      case(4)=1.0d0/3.0d0                                                                 
      case(5)=1.0d-7                                                                      
      call conv(spgam,yy,0)                                                               

      istep=1                                                                             
      iprint=0     
      nprt=2  
      go to 80                                                                            
!                                                                                         
   20 continue                                                                            
      if(nprt.gt.2) write(6,130) istep,h,tempx,(yy(i),i=1,neq)                            
  130 format(' in eqcal2. istep=',i7,' h=',1pe9.2,' tempx=',             &               
  &     e10.3,' yy='/(1p7e10.2))                                                           
      call stiff7(neq,t,yy,dy,der1,h,case,istep,nprt)                                     
      istep=istep+1                                                                       
      if(istep.lt.20) go to 20                                                            
      iprint=iprint+1                                                                     

   80 continue                                                                            

      call conv1(yy,y,0)                                                                  

      sumdy=0.                                                                     
      do i=1,neq                                                                          
        sumdy=sumdy+dy(i)**2                                                
      end do                                                                              
      sumdy=dsqrt(sumdy/float(neq))                                         
      if((iprint.eq.nprint).and.(nprt.gt.1)) then                                         
        write(6,30) istep,temp,h,sumdy                                            
   30   format(' in eqcal2. istep=',i7,' temp=',1pe10.3,' h=',1pe9.2,    &               
     &   ' sumdy=',1pe9.2)                                                                
!        write(6,70) (spnm(i),i=1,nsp1)                                                   
   70   format(1x,7(2x,a4,4x))                                                            
!        write(6,50) (y(i),i=1,nsp1)                                                      
        iprint=0                                                                          
      endif                                                                               

! converged if h.gt.case(2)                                                               
      if(h.gt.case(2)) then
        go to 140                                                          
      end if
      if((istep.gt.500000).and.(sumdy.lt.epsiln)) then
        go to 140                           
      end if
      ddy=0.                                                                              
      go to 20                                                                            
!                                                                                         
! write out if wanted                                                                     
   50  format(1x,1p7e10.3)                                                                
      if(sumdy.gt.epsiln) then     
        write(6,170) istep,rhox,tempx,sumdy                                        
  170   format(' in eqcal2. istep,rhox,tempx,sumdy=',i6,1p3e10.3,         &               
     &   ' stop')                                                                         
        stop                                                                              
      end if                                                                              
!                                                                                         
! converged, post-processing begins                                                       
  140 continue    
! audit elemental mass fractions: compare the mass frac with the original values
      call audit(spgam,nprt)

      sumh=0.                                                                             
      spgam(nsp1)=0.                                                                      
      do 90 jsp=1,nsp                                                                     
        spgam(jsp)=y(jsp)                                                                 
        spgam(nsp1)=spgam(nsp1)+spgam(jsp)*ie(jsp)                                        
   90 sumh=sumh+spgam(jsp)                                                                
      sumgam=sumh+spgam(nsp1)                                                             
      avmw=1./sumgam  
      rhox=presx*avmw/(8.3143*tempx)                                                                    
      zz=avmw0/avmw                                                                       
      do 160 jsp=1,nsp1                                                                   
        frac(jsp)=spgam(jsp)/sumgam                                                       
        spgamx(isp)=spgam(isp)                                                            
  160 continue                                                                            
!                                                                                         
! enthalpy enthx, J/kg                                                                    
      enthx=0.                                                                            
      z=10000./temp                                                                       
      alogz=dlog(z)                                                                       
      do jsp=1,nsp1                                                                       
        enthx=enthx+(dexp(akb(1,jsp)/z+akb(2,jsp)+akb(3,jsp)*alogz+       &               
     &   akb(4,jsp)*z+akb(5,jsp)*z**2)+(20.78575+8.3148*im(jsp))          &               
     &   *temp+h0sp(jsp))*spgam(jsp)                                                      
      end do                                                                              
!                                                                                         
! write if wanted                                                                         
!      if(nprt.gt.1) then                                                                  
        write(6,100) istep,sumdy,presx,tempx,enthx,                       &               
     &   rhox,h,(dy(i),i=1,neq)                                                
  100   format(/'in eqcal2. converged. istep=',i8,' sumdy=',              &               
     &   1pe10.3,' presx=',1pe10.3/' tempx=',e10.3,' enth=',e10.3,        &               
     &   ' rhox=',e10.3,' h=',e12.3,' dy='/(1p7e10.3))                                   
        write(6,70) (spnm(i),i=1,nsp)                                                     
        write(6,180) (frac(i),i=1,nsp1)                                                   
  180   format(' frac='/(1p7e10.3))                                                       
!      endif                                                                               
!                                                                                         
! write conditions                                                                        
      antot=presx/(1.3806e-23*tempx)                                                      
      write(6,210) rhox,tempx,enthx,antot                                                      
  210 format(/                                                            &               
     & ' density     =',1pe12.5,' kg/m3'/                                 &               
     & ' temperature =',0pf12.2,' K.'/                                    &               
     & ' enthalpy    =',1pe12.5,' J/kg'/                                  & 
     & ' ntot        =',e12.5,' m-3'/                                     &              
     & ' species    mol/kg    mol-frac    n(m-3)')                                        
      do isp=1,nsp1                                                                       
        spnmx(isp)=spnm(isp)                                                              
        spgamx(isp)=spgam(isp)  
        ansp(isp)=antot*frac(isp)                                                          
        write(6,220) spnm(isp),spgamx(isp),frac(isp),ansp(isp)                      
  220   format(1x,a4,2x,1p4e12.5)                                                         
      end do                                                                              
      return                                                                              
      end                                                                                 
!**********************************************************************                   
      subroutine eqcal3(px,tempx,spnmx,spgamx,nstep,nprt,nprint,        &               
     &  eintx, rhox,enthx,zz,avmw,ansp)                                                       
!                                                                                         
! calculate equilibrium composition for given density and temperature                     
! input                                                                                   
!   px=pressure, Pascal                                                                   
!   tempx=temperature, K   
!   spnmx(40)=species name   
!   spgamx(msp)=initial guess of spcies concentration, mol/kg                                                            
!   nstep=max allowed time step in stiff7 integration                                     
!   nprt=print index                                                                      
!     nprt=0 no print. 3=print                                                            
!   nprint=printing interval                                                              
! output                                                                                  
!   spnmx(40)=species name, through common/eqcomi                                                                
!   eintx=internal energy per unit volume, J/m3                                           
!   rhox=density, kg/m3                                                                
!   enthx=enthalpy, J/kg                                                                  
!   zz=compressibility                                                                    
!   avmw=average molecular weight,kg/mol                                                  
!   spgamx(i)=calculated species concentration, mol/kg                           
!                                                                                         
      parameter(msp=60)                                                                   
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      common/eqcoma/elemwt(15),                                           &               
     & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp),            &               
     & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp),             &               
     & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp),                     &               
     & akb(5,msp),akd(5,msp),avmw0                                                        
      common/eqcomb/elemnm(12)                                                            
      common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc,  &               
     & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp),   &               
     & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp)                        
      common/eqcomb/pres,temp,rho,enth,spgam(msp),amdot                                   
      common/eqcomd/gamma,delta,elen,aratx,emfp,epsiln                                    
      dimension y(msp),yy(msp),dy(msp),case(5),spgamx(msp),ansp(msp)                      
      character*4 elemnm,spnm,spnmx(msp) 
      save                                                 
      external der1                                                                       
!
! first approximation of density       
!
      call eqcal2(rhox,tempx,spnmx,spgamx,nstep,nprt,nprint,              &               
  &   eintx, px,enthx,zz,avmw,ansp)                                                       
!
!      do ip=1,2
!        rhox=rhox*px/presx
!        call eqcal2(rhox,tempx,spnmx,spgamx,nstep,nprt,nprint,            &               
!  &       eintx, px,enthx,zz,avmw,ansp) 
!      end do
!
      return
      end
!************************************************************************
      subroutine ffp5(ndm,rhoinf,vinf,rnose,rhorat,amdot,rhos,rhoe, beta,  &
  &     f,fp,betae,fwx)
! vertical velocity function f and tangential velocity function fp for ablation layer
! 5th order polynomial fit
! input parameters:
!   ndm=length of spatial node point array
!   rhoinf=freestrem density, kg/m3
!   vinf=freestream velocity, m/s
!   rhorat(802)=density ratio
!   amdot=ablation rate, kg/(m2-s)
!   rhos=density behind shock, kg/m3
!   rhoe=density of ablation product at interface, kg/m3
!   beta(ndm)=independent coordinate 
!   f(802)=normal velocity function
!   fp(802)=df/deta, tangential velocity function
!   betae=interface value of beta
! output parameters:  
!   fwx=wall value of f
      implicit real*8(a-h,o-z)
      dimension beta(802),f(802),fp(802),rhorat(802)
      common/fprof2/fw,fpw,fppw,rhorw,rhor1,d0,d2,d3,c1,c2,c3,c4,c5
      save
      external funfw2
!
      method=1
      ndm1=ndm/2
      ndm2=ndm1+1
      ndm3=ndm1-1
      duedr=(vinf/rnose)*dsqrt(2.*rhoinf/rhoe)
      fw=-amdot/(2.*duedr*rhos)
      if(fw.gt.0.) then
        write(*,80) amdot,fw
        write(6,80) amdot,fw
  80    format(' in ffp5. amdot=',1pe12.5,' fw=',1pe12.5,' stop')
        stop
      end if

      rhorw=rhorat(1)
      nmid=ndm1/2
      rhor1=rhorat(nmid)
      if(method.eq.1) then
        fpw=0.d0
        fppw=-0.5*rhorw/fw
      end if
      if(method.eq.2) then
        fpw=dsqrt(rhorw)
        fppw=0.d0
      end if
      dbeta=-0.01*fw
      betaef=0.
      itry=0
!
   10 continue
      itry=itry+1
      betaef=betaef+dbeta
      ff=funfw2(betaef)
!      write(6,40) itry,dbeta,betaef,ff
   40 format(' ffp5. itry=',i4,' dbeta=',1pe10.3,' betaef=',e10.3,' ff=',e10.3)
      if(itry.gt.1) then
        if(ff*ffold.lt.0.) go to 20
      end if
      if((itry.gt.1).and.(ff.gt.ffold)) go to 70
      betaef_old=betaef
      ffold=ff
      dbeta=dbeta*1.2
      if(itry.ge.100) then
        write(6,50) betaef
   50   format(' ffp5. no sign change after 500 tries and betaef=',1pe10.3)
        stop
      end if
      go to 10
!
   20 continue
      beta1=betaef_old-(betaef-betaef_old)*0.1
      beta2=betaef+(betaef-betaef_old)*0.1
!      write(6,60) beta1,beta2
   60 format(' ffp5. beta1,beta2=',1p2e11.4)
      betaex=0.5*(beta1+beta2)
      e1=1.0e-6
      e2=1.0e-6
      call root(funfw2,betae,betaex,beta1,beta2,e1,e2,ier)
      if(ier.ne.1) then
        write(6,30) ier
   30   format(' ffp5. ier=',i1,' stop')
        stop
      end if
!
   70 continue
      do inode=1,ndm1
        beta(inode)=float(inode-1)*betae/float(ndm3)
        f(inode)=c1*(beta(inode)-betae)+c2*(beta(inode)-betae)**2+c3*(beta(inode)      &
  &       -betae)**3+c4*(beta(inode)-betae)**4+c5*(beta(inode)-betae)**5
        fp(inode)=c1+2.*c2*(beta(inode)-betae)+3.*c3*(beta(inode)-betae)**2            &
  &       +4.*c4*(beta(inode)-betae)**3+5.*c5*(beta(inode)-betae)**4
      end do
      fwx=fw
      return
      end
!***********************************************************************                  
      function fkmax(k,u,imax1,imax,evib,bv,dv)                                           
      implicit real*8(a-h,o-z)                                                            
      dimension k(500),u(500)                                                             
      do 260 i=imax1,imax                                                                 
      kk1=k(i)*(k(i)+1)                                                                   
      e2=evib+bv*kk1-dv*kk1**2                                                            
      kmax=k(i)                                                                           
      if (e2.le.u(i)) goto 270                                                            
      kmax=k(i)                                                                           
 260  continue                                                                            
!                                                                                         
 270  fkmax=kmax                                                                          
      imax1=i+1                                                                           
      return                                                                              
      end                                                                                 

!************************************************************************************
      subroutine flux_inner(nwave,ndm,im,nim,y,beta,tx,dtdy,sigma,  &
  &     int_old,dqdy)
! radiative flux calculation for inner layer
! input parameters:
!   nwave=length of wavelength array
!   ndm=length of spatial node point array
!   im=current number of iteration
!   nim=number of allowed iteration of inner layer
!   y(ndm)=node coordinates
!   beta(ndm)=normalized node coordinates
!   tx(ndm)=temperature, K
!   dtdy(ndm)=temperature slope, K/m
!   sigma=emissivity of wall
!   int_old(10,nw)=intensity toward wall, W/(cm2-mic-sr)
! output parameters:
!   int_e(10,nw)=outward intensity at edge, through common spectb
      parameter(nw=400000)
      implicit real*8(a-h,o-z)
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e,int_old,int_new,int_s,int_cam,int_abl
      common/qpqm/qp(802),qm(802),int_s(10,nw),ang(11),sin2(11),             &
  &     int_cam(nw)
      dimension y(802),beta(802),tx(802),dtdy(802),dqdy(802),                &
  &    dqpdy(802),dqmdy(802),dqpdy1(802),dqmdy1(802)
! qp=flux from wall to shock; qm=flux from shock to wall
      common/scratch/int_new(10,nw)
      dimension int_old(10,nw)
      dimension cos1(11),bint(11)
      save
      data itime/0/,pi/3.1415926/,ITM/0/
!
        ndm1=ndm/2
        ndm2=ndm1+1
        ndm3=ndm1-1
!        nwave=nw
        do iang=1,10
          ang(iang)=(iang-1)*0.5*pi/10.
          cos1(iang)=1./dcos(ang(iang))
          sin2(iang)=dsin(2.*ang(iang))
        end do
        ang(11)=0.5*pi
        bint(1)=0.; bint(11)=0.
        itime=itime+1
!
! radiative transfer from interface to wall (flux taken to be positive)--------------------
!
      do iw=1,nw
        do iang=1,10
          int_old(iang,iw)=0.
        end do
      end do
      qm(ndm1)=qm(ndm2)
      mon=0
      do idm=ndm1-1,1,-1
        tinv=10000./tx(idm)
        qm(idm)=0.
        do iw=1,nwave
          mon=0
          call taint(tcho,absb_cho(1,iw),tinv,absbx,11,2,ier,mon)
!          call intpl1(tcho,absb_cho(1,iw),tinv,absbx,11)
          absba=dexp(absbx)
          dely=(y(idm+1)-y(idm))*100.                               ! cm
          ax=dexp(-1.43877d0*1.0d8/(wavel(iw)*tx(idm)))
          blam=1.1904d-16*ax/((1.0d-8*wavel(iw))**5*(1.d0-ax))      ! W/(cm2-mic-sr)
!          dbdt=1.1904e-16*1.43877*ax/((1.0d-8*wavel(iw))**6*tx(idm)**2*(1.-ax)**2)
!  intensity
          do iang=1,10
            tau=absba*dely*cos1(iang)
            expx=dexp(-tau)
            int_new(iang,iw)=blam*(1.0-expx)+int_old(iang,iw)*expx
            bint(iang)=pi*sin2(iang)*int_new(iang,iw)
          end do
          call simp(qlam,ang,bint,11,ier)
! memorize intensity to wall
          if(idm.eq.1) then
            do iang=1,10
              intw(iang,iw)=int_new(iang,iw)
            end do
          end if
!  flux
          if(iw.eq.1) delw=wavel(2)-wavel(1)
          if((iw.gt.1).and.(iw.lt.nwave)) delw=0.5*(wavel(iw+1)-wavel(iw-1))
          if(iw.eq.nwave) delw=wavel(nwave)-wavel(nwave-1)
          qm(idm)=qm(idm)+qlam*delw*1.0e-4                                  ! W/cm2
          do iang=1,10
            int_old(iang,iw)=int_new(iang,iw)
          end do
        end do
        qm(idm)=qm(idm)*1.e4                                        ! W/m2
      end do
      write(6,60) qm(1)
   60 format(/' to-wall radiative flux=',1pe10.3,' W/m2'/)
!
! radiative transfer from wall to edge(interface)-----------------------------
!
! absorption coefficient at wall and intensity from wall
      twall=10000./tx(1)
      qp(1)=0.
      do iw=1,nwave
        ax=dexp(-1.43877d0*1.0d8/(wavel(iw)*tx(1)))
        do iang=1,10
          intw(iang,iw)=sigma*1.1904d-16*ax/((1.0d-8*wavel(iw))**5*(1.d0-ax))   &
  &          + (1.-sigma)*intw(iang,iw)                             ! W/(cm2-mic-sr)
          bint(iang)=pi*sin2(iang)*intw(iang,iw)
        end do
        call simp(qlam,ang,bint,11,ier)
        if(iw.eq.1) delw=wavel(2)-wavel(1)
        if((iw.gt.1).and.(iw.lt.nwave)) delw=0.5*(wavel(iw+1)-wavel(iw-1))
        if(iw.eq.nwave) delw=wavel(nwave)-wavel(nwave-1)
        qp(1)=qp(1)+qlam*delw*1.0e-4  

        call intpl1(tcho,absb_cho(1,iw),twall,absbx,11)
 
       end do
      qp(1)=qp(1)*1.0e4                                             ! W/m2
! radiative transfer from wall to edge
      do iw=1,nwave
        do iang=1,10
          int_old(iang,iw)=intw(iang,iw)
        end do
      end do
      do idm=2,ndm1
        tinv=10000./tx(idm)
        qp(idm)=0.
        do iw=1,nwave
          mon=0
          call taint(tcho,absb_cho(1,iw),tinv,absbx,11,2,ier,mon)
!          call intpl1(tcho,absb_cho(1,iw),tinv,absbx,11)
          absba=dexp(absbx)
          dely=(y(idm)-y(idm-1))*100.                               ! cm
          ax=dexp(-1.43877d0*1.0d8/(wavel(iw)*tx(idm)))
          blam=1.1904d-16*ax/((1.0d-8*wavel(iw))**5*(1.d0-ax))      ! W/(cm2-mic-sr)
!          dbdt=1.1904e-16*1.43877*ax/((1.0d-8*wavel(iw))**6*tx(idm)**2*(1.-ax)**2)
!  intensity
          do iang=1,10
            tau=absba*dely*cos1(iang)
            expx=dexp(-tau)
            int_new(iang,iw)=blam*(1.0-expx)+int_old(iang,iw)*expx
            bint(iang)=pi*sin2(iang)*int_new(iang,iw)
          end do
          call simp(qlam,ang,bint,11,ier)
          if(iw.eq.nwave) then
            do iang=1,10
              int_new(iang,iw)=int_new(iang,iw-1)
            end do
          end if
!  flux  
          if(iw.eq.1) delw=wavel(2)-wavel(1)
          if((iw.gt.1).and.(iw.lt.nwave)) delw=0.5*(wavel(iw+1)-wavel(iw-1))
          if(iw.eq.nwave) delw=wavel(nwave)-wavel(nwave-1)
          qp(idm)=qp(idm)+qlam*delw*1.0e-4                          ! W/cm2
          do iang=1,10
            int_old(iang,iw)=int_new(iang,iw)
          end do
        end do
        if(idm.eq.ndm1) then
          do iw=1,nwave
            do iang=1,10
              int_e(iang,iw)=int_new(iang,iw)
            end do
          end do
        end if
        qp(idm)=qp(idm)*1.e4                                        ! W/m2
      end do
!
! divergence of heat flux
!     
      do inode=1,ndm3                                               ! at inode + 1/2 point
        dqpdy1(inode)=(qp(inode+1)-qp(inode))/(y(inode+1)-y(inode))
        dqmdy1(inode)=(qm(inode+1)-qm(inode))/(y(inode+1)-y(inode))
      end do
! interpolate to obtain the values at inode
      mon=0
      do inode=1,ndm1
        if(inode.eq.1) y1=-0.5*(y(2)-y(1))
        if(inode.gt.1) y1=y(inode)-0.5*(y(inode+1)-y(inode))
        call taint(y,dqpdy1,y1,dqpdy(inode),ndm3,1,ier,mon)
      end do
      mon=0
      do inode=1,ndm1
        if(inode.eq.1) y1=-0.5*(y(2)-y(1))
        if(inode.gt.1) y1=y(inode)-0.5*(y(inode+1)-y(inode))
        call taint(y,dqmdy1,y1,dqmdy(inode),ndm3,1,ier,mon)
      end do
!
! impose zero at interface
      do inode=1,ndm1
        rat=(float(inode-1)/float(ndm1-1))**4
        dqpdy(inode)=(1.-rat)*dqpdy(inode)+rat*dqmdy(inode)
      end do
! divergence: dqdy>0 means flow gaining energy
      do inode=1,ndm1
        dqdy(inode)=-dqpdy(inode)+dqmdy(inode)
      end do
!
      return
      end
!***********************************************************************************
      subroutine flux_outer(nwave,ndm,iout,nout,rhoinf,rnose,vinf,y,beta,tx,dtdy,     &
  &      int_old, dqdy, qpshock)
! radiative flux calculation for outer layer
! input parameters:
!   nwave=length of wavelength array
!   ndm=length of spatial node point array
!   nout=number of allowed iteration of outer layer calculation
!   rhoinf=freestream density, kg/m3
!   rnose=nose radius, m
!   vinf=freestream velocity, m/s
!   y(ndm)=node coordinates
!   beta(ndm)=normalized node coordinates
!   tx(ndm)=temperature, K
!   dtdy(ndm)=temperature slope, K/m
!   int_old(10,nw)=intensity in the last iteration, W/(cm2-mic-sr)
! output parameters:
!   qp(ndm)=shockward radiative flux, W/cm2
!   qm(ndm)=wallward radiation flux, W/cm2
!   dqdy(ndm)=divergence of radiative flux, W/m3
!   qpshock=outward radiation flux from shock, W/m2
!
      parameter(nw=400000)
      implicit real*8(a-h,o-z)
! iny_e(10,nw)=intensity of ablation product at edge (interface)
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e,int_s,int_sav,int_prec,int_old,int_new,            &
  &     int_cam,int_abl
      common/qpqm/qp(802),qm(802),int_s(10,nw),ang(11),sin2(11),                 &
  &     int_cam(nw)
      dimension y(802),beta(802),tx(802),dtdy(802),dqdy(802),                    &
  &    dqpdy(802),dqmdy(802),dqpdy1(802),dqmdy1(802)
! qp=flux from wall to shock; qm=flux from shock to wall
      common/scratch/int_new(10,nw),int_sav(nw)
! flx(nw)=radiative flux at shock; flx_prec(nw)=radiative flux at end of precursor
      dimension int_old(10,nw),flx(nw),flx_prec(nw),flx_grd(nw),                 &
  &     int_prec(nw),qplam(nw)
! wav_tran(101) and air(tran(101) are atmospheric absorption
      dimension cos1(11),bint(11)
!      dimension wav_tran(154),air_tran(154)
      save
      data itime/0/,pi/3.1415926/,cutlo/4000./,cuthi/8000./,iwrite/0/
! 
      ndm1=ndm/2
      ndm2=ndm1+1
      ndm3=ndm1-1
      do iang=1,10
        ang(iang)=(iang-1)*0.5*pi/10.
        cos1(iang)=1./dcos(ang(iang))
        sin2(iang)=dsin(2.*ang(iang))
      end do
      ang(11)=0.5*pi
      bint(1)=0.; bint(11)=0.
      itime=itime+1
!
! radiative transfer from interface to shock --------------------
!
      do idm=ndm2+1,ndm
        if(idm.eq.ndm2+1) then
          do iw=1,nwave
            do iang=1,10
              if(itime.le.nout) int_old(iang,iw)=intw(iang,iw)
              if(itime.gt.nout) int_old(iang,iw)=int_e(iang,iw)
            end do
          end do
        end if

        qps=0.
        tinv=10000./tx(idm)
        qp(idm)=0.
        do iw=1,nwave
          mon=0
          call taint(tair(1),absb_air(1,iw),tinv,absbx,5,2,ier,mon)
          absba=dexp(absbx)                                  ! cm-1
          dely=(y(idm)-y(idm-1))*100.                               ! cm
          ax=dexp(-1.43877d0*1.0d8/(wavel(iw)*tx(idm)))
          blam=1.1904d-16*ax/((1.0d-8*wavel(iw))**5*(1.d0-ax))      ! W/(cm2-mic-sr)
          dbdt=1.1904e-16*1.43877*ax/((1.0d-8*wavel(iw))**6*tx(idm)**2*(1.-ax)**2)
          do iang=1,10
            tau=absba*dely*cos1(iang)
            if(tau.gt.500.) then
              int_new(iang,iw)=blam
            end if
            if(tau.le.500.) then
              expx=dexp(-tau)
              int_new(iang,iw)=blam*(1.0-expx)+int_old(iang,iw)*expx  ! W/(cm2-mic-sr)
            end if
            bint(iang)=pi*sin2(iang)*int_new(iang,iw)
          end do
          call simp(qlam,ang,bint,11,ier)                             ! qlam W/(cm2-mic)
!  memorize spectrum at shock for later use
          if(idm.eq.ndm) then
            do iang=1,10
              int_s(iang,iw)=int_new(iang,iw)                         ! W/(cm2-mic-sr)
            end do
          end if
!  flux
          if(iw.eq.1) delw=wavel(2)-wavel(1)
          if((iw.gt.1).and.(iw.lt.nwave)) delw=0.5*(wavel(iw+1)-wavel(iw-1))
          if(iw.eq.nwave) delw=wavel(nwave)-wavel(nwave-1)
          qp(idm)=qp(idm)+qlam*delw*1.0e-4                            ! W/cm2
          if((wavel(iw).gt.cutlo).and.(wavel(iw).lt.cuthi))                             &
   &      qps=qps+qlam*delw*1.0e-4                                    ! W/cm2
          do iang=1,10
            int_old(iang,iw)=int_new(iang,iw)                         ! W/(cm2-mic-sr)
          end do
          qplam(iw)=qp(idm)*1.e4                                      ! W/m2
        end do
        qp(idm)=qp(idm)*1.e4                                          ! W/m2
        qps=qps*1.e4                                                  ! W/m2
      end do
      qpshock=qp(ndm)
!
! radiative transfer from shock to interface (flux taken to be positive)--------------------
! 
      do iw=1,nwave
        do iang=1,10
          int_old(iang,iw)=0.
        end do
      end do
      qm(ndm)=0.
      do idm=ndm-1,ndm2,-1
        tinv=10000./tx(idm)
        qm(idm)=0.
        do iw=1,nwave
          mon=0
          call taint(tair,absb_air(1,iw),tinv,absbx,5,2,ier,mon)
          absba=dexp(absbx)
          dely=(y(idm+1)-y(idm))*100.                               ! cm
          ax=dexp(-1.43877d0*1.0d8/(wavel(iw)*tx(idm)))
          blam=1.1904d-16*ax/((1.0d-8*wavel(iw))**5*(1.d0-ax))      ! W/(cm2-mic-sr)
!          dbdt=1.1904e-16*1.43877*ax/((1.0d-8*wavel(iw))**6*tx(idm)**2*(1.-ax)**2)
!  intensity
          do iang=1,10
            tau=absba*dely*cos1(iang)
            if(tau.gt.700.) tau=700.
            expx=dexp(-tau)
            int_new(iang,iw)=blam*(1.0-expx)+int_old(iang,iw)*expx
            bint(iang)=pi*sin2(iang)*int_new(iang,iw)
          end do
          call simp(qlam,ang,bint,11,ier)
          if(iw.eq.nwave) then
            do iang=1,10
            int_new(iang,iw)=int_new(iang,iw-1)
            end do
          end if
!  flux
          if(iw.eq.1) delw=wavel(2)-wavel(1)
          if((iw.gt.1).and.(iw.lt.nwave)) delw=0.5*(wavel(iw+1)-wavel(iw-1))
          if(iw.eq.nwave) delw=wavel(nwave)-wavel(nwave-1)
          qm(idm)=qm(idm)+qlam*delw*1.0e-4                          ! W/(cm2-mic)
          do iang=1,10
            int_old(iang,iw)=int_new(iang,iw)
          end do
        end do
        qm(idm)=1.e4*qm(idm)                                        ! W/m2
      end do
!
! divergence of heat flux
!
      do inode=ndm2,ndm-1                                           ! at inode + 1/2 point
        dqpdy1(inode)=(qp(inode+1)-qp(inode))/(y(inode+1)-y(inode))
        dqmdy1(inode)=(qm(inode+1)-qm(inode))/(y(inode+1)-y(inode))
      end do
! interpolate to obtain the values at inode
      mon=0
      do inode=ndm2,ndm-1
        if(inode.eq.ndm2) y1=-0.5*(y(ndm2+1)-y(ndm2))
        if(inode.gt.ndm2) y1=y(inode)-0.5*(y(inode+1)-y(inode))
        call taint(y(ndm2),dqpdy1(ndm2),y1,dqpdy(inode),ndm3,2,ier,mon)
      end do
      mon=0
      do inode=ndm2,ndm-1
        if(inode.eq.ndm2) y1=-0.5*(y(ndm2+1)-y(ndm2))
        if(inode.gt.ndm2) y1=y(inode)-0.5*(y(inode+1)-y(inode))
        call taint(y(ndm2),dqmdy1(ndm2),y1,dqmdy(inode),ndm3,2,ier,mon)
      end do
!
! impose zero at interface
      do inode=ndm2,ndm
        rat=(float(inode-ndm2)/float(ndm1-1))**4
        dqpdy(inode)=rat*dqpdy(inode)+(1.-rat)*dqmdy(inode)
      end do
! divergence: dqdy>0 means flow gaining energy
      do inode=ndm2,ndm
        dqdy(inode)=-dqpdy(inode)+dqmdy(inode)
      end do
!
      return
      end
!***********************************************************************
      function funfw2(betae)
! function subroutine for determining edge value of beta
! input parameter:
!   betae=edge value of beta
      implicit real*8(a-h,o-z)
      common/fprof2/fw,fpw,fppw,rhorw,rhor1,d0,d2,d3,c1,c2,c3,c4,c5
      dimension a(2,2),b(2),x(2)
! determine curve fit coefficient d2 and d3 to fit the given density ratio function
      a(1,1)=betae**2
      a(1,2)=-betae**3
      b(1)=rhorw-1.d0
      a(2,1)=0.25d0*betae**2
      a(2,2)=-0.125d0*betae**3
      b(2)=rhor1-1.d0
      call lin2(a,b,x)
      d0=1.0d0
      d2=x(1); d3=x(2)
      c1=1.0d0
      c2=(fw+betae-0.05d0*fppw*betae**2-(7.d0/60.d0)*d2*betae**3+d3*betae**4/40.d0)    &
  &     /(0.9d0*betae**2+d2*betae**4/60.d0)
      c3=-d2/(6.d0*c1)
      c4=-d3/(16.d0*c1)+d2*c2/24.d0
      c5=(2.d0*c2-6.d0*c3*betae+12.d0*c4*betae**2-fppw)/(20.d0*betae**3)
      funfw2=5.d0*c5*betae**4 -4.d0*c4*betae**3 + 3.d0*c3*betae**2                     &
  &      - 2.d0*c2*betae + 1.d0 -fpw    
!      write(6,40) fw,betae,fppw,c1,c2,c3,c4,c5,funfw2
  40  format(' in funfw2'/                                                             &
  &     ' fw=',1pe10.3,' betae=',e10.3,' fppw=',e10.3/                                 &
  &     ' c1-c5=',5e10.3,' funfw2=',1pe10.3)
      return
      end
!***********************************************************************
      subroutine gausst(nwave,hwhh,wav1,wav2,wavel,nskip,ainp,aout)
! Gaussian slit processing
! input parameters:
!   nwave=number of wavelength points
!   hwhh=half width in A at half height 
!   wav1=low wavelength limit of plot, A
!   wav2=high wavelength limit of plot, A
!   wavel(nw)=wavelengths
!   ainp(nw)=original signal
! output parameter
!   aout(nw)=slit-processed signal
      parameter (nw=400000)
      implicit real*8(a-h,o-z)
      common/scratch/wavel1(nw),aout1(nw)                                                           
      dimension wavel(nw),ainp(nw),aout(nw)
      common/scratch/gaussx(-101:101),gaussy(-101:101),fx(-101:101)
!
! generate Gaussian function
      xhalf=(-dlog(0.5d0))
      xstep=hwhh/20.
      sum=0.
      do i=0,101
        gaussx(i)=xstep*i
        gaussx(-i)=-gaussx(i)
        gaussy(i)=dexp(-xhalf*(gaussx(i)/hwhh)**2)
        gaussy(-i)=gaussy(i)
        if(i.gt.0) then
          sum=sum+0.5*(gaussy(i-1)+gaussy(i))*xstep
        end if
      end do      
      sum=sum*2.
!      write(*,*) ' sum=',sum
      do i=-101,101
        gaussy(i)=gaussy(i)/sum
      end do
      do i=-101,101
!        write(6,10) i,gaussx(i),gaussy(i)
  10    format(i5,1p2e12.5)
      end do
!
!
      iw=1
  50  continue
      iw=iw+1
      if(wavel(iw).lt.wav1) go to 50
      nw1=iw-101
  60  continue
      iw=iw+1
      if(wavel(iw).lt.wav2) go to 60
      nw2=iw+101
      do iw=1,nwave
        aout(iw)=0.
      end do
      if(nw1.lt.1) nw1=1
      if(nw2.gt.nwave) nw2=nwave
      nw1a=nw1-100; if(nw1a.lt.1) nw1a=1
      nw2a=nw2+100; if(nw2a.gt.nwave) nw2a=nwave
      nscan=nw2a-nw1a
!
      mon=0
! Gaus operation every 5th points
      j=0
      do iw=nw1,nw2,nskip
        sum=0.
        do iwx=-101,101
          wavelx=wavel(iw)+gaussx(iwx)
          call taint(wavel(nw1a),ainp(nw1a),wavelx,fx(iwx),nscan,1,ier,mon)
          sum=sum+fx(iwx)*gaussy(iwx)*xstep
        end do
        aout(iw)=sum
        j=j+1
        wavel1(j)=wavel(iw)
        aout1(j)=aout(iw)
        jmax=j
      end do
! interpolate between the 5th values
      mon=0
      do iw=nw1,nw2
        if(wavel(iw).lt.wavel1(jmax))                                          &
  &      call taint(wavel1(1),aout1(1),wavel(iw),aout(iw),jmax,1,ier,mon)
      end do
!
! Boltzmann plot
      call boltzf(wavel,aout)
      call boltzf1(wavel,aout)
      return
      end
!******************************************************************************           
      subroutine H_bb(isp, temp, power)                                           
! calculates emission and absorption coefficients by atomic lines of H                    
! input parameters:  
!   isp=species index
!   temp=temperature, K
! output parameter:
!   power=emission power, W/cm3                                                                     
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,mdiatoms=12,mtriatoms=6,msp=60)                                                     
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      real*8 ion_pot,nk,ni,neq_factor_k,neq_factor_i                                      
      character*4 asterik,atomnm2(matoms),bandnm_diatom,                  &
     &    minus1,unknown                              
      character*4 atom_rads(3,168),diatom_bands(3,100),                   &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                     &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                         &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      common/comi/nwave                                                                   
      integer g_atom,g_ion,gi_atom,gk_atom,g_neq_lev_atom                                 
      common/coma1/atomwt(matoms),ion_pot(matoms),                        &               
     &  Ecm_atom(nlev_tot_atom,matoms),Ecm_ion(nlev_tot_atom,matoms),     &               
     &  starkg(line_tot,matoms),                                          &               
     &  starkn(line_tot,matoms),Ecm_neq_lev_atom(23,matoms),              &               
     &  ei_atom(line_tot,matoms),ek_atom(line_tot,matoms),                &               
     &  wavel_atom(line_tot,matoms),aki_atom(line_tot,                    &               
     &  matoms),z(matoms),e_inner(matoms),ephot_gaunt(21,matoms),         &               
     &  e_gaunt(51,matoms),gaunt(9,51,matoms),temp_cross_atom(11,matoms)  &               
     &  ,wavel_cross_atom(101,matoms),cross_atom(101,11,matoms),          &               
     &  ephot_ff(11,matoms),temp_ff(31,matoms),gaunt_ff(7,31,matoms),     &               
     &  eimp_ro(26,26,matoms),eimp_rexp(26,26,matoms)                                     
      common/comb1/ g_atom(nlev_tot_atom,matoms),g_neq_lev_atom(23,       &               
     &  matoms),gi_atom(line_tot,matoms),g_ion(nlev_tot_atom,             &               
     &  matoms),gk_atom(line_tot,matoms),ig_gaunt(99,matoms),             &               
     &  ind_lev_atom(nlev_tot_atom,matoms),ind_lev_ion(nlev_tot_atom,     &               
     &  matoms),ind_line(line_tot,matoms),iz_atom(matoms),                &               
     &  neq_lev_atom(matoms),n_gaunt(99,matoms),ng_atom(nlev_tot_atom,    &               
     &  matoms),ng_gaunt(99,matoms),n_temp_cross_atom(matoms),            &               
     &  ngi_atom(line_tot,matoms),ngk_atom(line_tot,matoms),              &               
     &  nlev_atom(matoms),nlev_atomic_ion(matoms),nline(matoms),          &               
     &  n_temp_ff_atom(matoms),ntot_gaunt(matoms),num_exct(matoms),       &               
     &  n_wavel_cross_atom(matoms)                                                        
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/spect/calpha,slope_ratio,wavmin,wavmax,range1                                             
      common/scratch/emisr(nw)                                                            
      dimension alph(20,6),spro(20,6),dell(20),y(20)                                      
      integer npro(6)                                                                     
      integer isp,wave_num1,i,j,k,ncentr,m,nl,nu,mon,ner,lin,nlim                         
!                                                                                         
! The following hydrogen line Stark broadening parameters are from Griem, Plasma          
!   Spectroscopy                                                                          
!                                                                                         
! number of data points                                                                   
      data npro/                                                          &               
     &    17,                                                             &    ! L-alpha  
     &    16,                                                             &    ! L-beta   
     &    14,                                                             &    ! B-alpha  
     &    19,                                                             &    ! B-beta   
     &    13,                                                             &    ! B-gamma  
     &    10       /                                                           ! B-delta  
!                                                                                         
! wavelength deviation coordinates                                                        
      data alph/                                                          &               
     & 0.,    0.0001,0.0002,0.0003,0.0004,0.0005,0.0006,0.0008,0.001,     &    ! L-alpha  
     & 0.0013,0.0016,0.002, 0.0025,0.003, 0.0035,0.004, 0.0045,0.,        &    !    "     
     & 0.,   0.,                                                          &    !    "     
     &  0.,    0.0002,0.0004,0.0006,0.0008,0.001, 0.0013,0.0016,0.002,    &    ! L-beta   
     & 0.0025, 0.003, 0.0035,0.004, 0.005, 0.007, 0.01,  0.,    0.,       &    !    "     
     & 0.,   0.,                                                          &    !    "     
     &   0.,    0.005, 0.01,  0.015, 0.02,  0.025, 0.03,  0.04,  0.05,    &    ! B-alpha  
     & 0.07,   0.09,  0.12,  0.15,  0.2,   0.,    0.,    0.,    0.,       &    !    "     
     & 0.,   0.,                                                          &    !    "     
     &   0.,    0.01,  0.02,  0.03,  0.04,  0.05,  0.06,  0.07,  0.08,    &    ! B-beta   
     &  0.09,  0.1,   0.12,  0.14,  0.16,  0.18,  0.2,   0.25,  0.3,      &    !    "     
     &  0.35, 0.,                                                         &    !    "     
     &   0.,    0.01,  0.02,  0.04,  0.06,  0.08,  0.1,   0.12,  0.15,    &    ! B-gamma  
     &  0.2,    0.3,   0.4,   0.5,   0.,    0.,    0.,    0.,    0.,      &    !    "     
     &   0.,   0.,                                                        &    !    "     
     &   0.,    0.02,  0.04,  0.07,  0.1,   0.15,  0.2,   0.3,   0.42,    &    ! B-delta  
     &   0.6,   0.,    0.,    0.,    0.,    0.,    0.,    0.,    0.,      &    !    "     
     &   0.,   0.   /                                                          !    "     
!                                                                                         
! intensity coordinates                                                                   
      data spro/                                                          &               
     &   2304., 1153., 522.,  291.,  208.,  169.,  145.,  104.,  78.2,    &    ! L-alpha  
     &   54.2,  39.9,  28.1,  17.9,  11.9,  7.8,   5.2,   3.4,   0.,      &    !    "     
     &   0.,   0.,                                                        &    !    "     
     &  98.1,  117.9, 163.6, 177.,  176.7, 166.5, 146.3, 122.0, 97.,      &    ! L-beta   
     &  71.5,  52.9,  40.1,  29.9,  19.0,  9.4,   4.0,   0.,    0.,       &    !    "     
     &   0.,   0.,                                                        &    !    "     
     &  15.7,  14.0,  11.2,  8.63,  6.79,  5.55,  4.63,  3.35,  2.52,     &    ! B-alpha  
     &  1.55,  1.03,  0.6,   0.375, 0.2,   0.,    0.,    0.,    0.,       &    !    "     
     &   0.,   0.,                                                        &    !    "     
     &  3.36,  3.62,  3.91,  4.01,  3.85,  3.53,  3.16,  2.74,  2.34,     &    ! B-beta   
     &   2.,   1.73,  1.31,  0.999, 0.787, 0.622, 0.502, 0.313, 0.218,    &    !    "     
     &  0.164, 0.,                                                        &    !    "     
     &  3.43,  3.28,  2.99,  2.53,  2.23,  1.94,  1.65,  1.38,  1.06,     &    ! B-gamma  
     &  0.684, 0.326, 0.182, 0.113, 0.,    0.,    0.,    0.,    0.,       &    !    "     
     &   0.,    0.,                                                       &    !    "     
     &  1.63,  1.69,  1.71,  1.58,  1.37,  1.04,  0.772, 0.43,  0.229,    &    ! B-delta  
     &  0.106, 0.,    0.,    0.,    0.,    0.,    0.,    0.,    0.,       &    !    "     
     &   0.,    0.   /                                                         !    "     
!                                                                                         
      write(6,10) atomnm(isp),dens_atom(isp)                                              
 10   format(' in H_bb. species = ', a4,1pe10.3,' cm-3')                                  
!                                                                                         
! neutral partition function                                                              
      partn=0.                                                                            
      do i=1,nlev_atom(isp)                                                               
        partn=partn+g_atom(i,isp)*dexp(-1.43877d0*Ecm_atom(i,isp)/temp)                   
      end do                                                                              
! cycle over lines                                                                        
!                                                                                         
      do k = 1,nline(isp)                                                                 
!                                                                                         
! number density of upper state                                                           
        nk=(dens_atom(isp)*gk_atom(k,isp) * dexp(-1.43877d0               &               
     &    *ek_atom(k,isp)/temp)/partn)                                                    
!                                                                                         
! number density of lower state                                                           
        ni=(dens_atom(isp)* gi_atom(k,isp)* dexp(-1.43877d0               &               
     &    *ei_atom(k,isp)/temp)/partn)                                                    
!                                                                                         
! seek line profile data from Griem's table                                               
        nl = ngi_atom(k,isp)                                                              
        nu = ngk_atom(k,isp)                                                              
        lin=0                                                                             
        if((nl.eq.1).and.(nu.eq.2)) lin=1                                                 
        if((nl.eq.1).and.(nu.ge.3)) lin=2                                                 
        if((nl.eq.1).and.(nu.ge.4)) lin=2                                                 
        if((nl.eq.1).and.(nu.ge.5)) lin=2                                                 
        if((nl.eq.1).and.(nu.ge.6)) lin=2                                                 
        if((nl.eq.2).and.(nu.eq.3)) lin=3                                                 
        if((nl.eq.2).and.(nu.eq.4)) lin=4                                                 
        if((nl.eq.2).and.(nu.eq.5)) lin=5                                                 
        if((nl.eq.2).and.(nu.eq.6)) lin=6                                                 
        if((nl.gt.2).and.(nu.eq.4)) lin=4                                                 
        if((nl.gt.2).and.(nu.eq.5)) lin=5                                                 
        if((nl.gt.2).and.(nu.ge.6)) lin=6                                                 
        nlim=npro(lin)                                                                    
        f0=1.253e-9*(dens_elec**0.666667)                                                 
        f1=1./f0                                                                          
        do j=1,npro(lin)                                                                  
          y(j)=spro(j,lin)                                                                
          dell(j)=f0*alph(j,lin)                                                          
        enddo                                                                             
!                                                                                         
! determine the wavelength node m for line center                                         
! determine the wavelength node m for line center                                         
        ncentr=nwave*((wavel_atom(k,isp)-wavmin)/(wavmax-wavmin))**(1./calpha)
!        ncentr=(1.0d0/dsqrt(wavmin) - 1.0d0/dsqrt(wavel_atom(k,isp)))/estep + 1                         
                                                                                          
! determine wavelength interval at line center in angstrom                                
        witv=((wavmax-wavmin)/float(nwave)**calpha)*calpha*float(nwave)**(calpha-1.)
!        witv=wavmin**2*estep/((1.0d0-wavmin*estep*ncentr)                 &               
!     &    *(1.0d0-wavmin*estep*(ncentr-1)))                                               
!        witv=1./(1./dsqrt(wavmin)-estep*(ncentr-1))**2                       &
!   &      -1./(1./dsqrt(wavmin)-estep*ncentr)**2
!        witv=dabs(witv)
!                                                                                         
        ax=(real(gi_atom(k,isp))/real(gk_atom(k,isp)))*(nk/ni)                            
        blam=1.1904d-16*ax/((1.0d-8*wavel_atom(k,isp))**5*(1.0d0-ax))                     
! line emissiion power in w/(cm3-sr)                                                      
        e=1.580d-16*aki_atom(k,isp)*nk/wavel_atom(k,isp)                                  
        const=spro(npro(lin),lin)*(dell(nlim)**2.5)                                       
        mtot=0                                                                            
        mon=0                                                                             
        do m=1,nwave                                                                      
!          del=1.0d0/(1.0d0/wavmin-estep*(ncentr-1))-1.0d0/(1.0d0/         &               
!     &      wavmin-estep*(m-1))   
! determine wavelength interval at line center in angstrom                                
          witv=((wavmax-wavmin)/float(nwave)**calpha)*calpha*float(nwave)**(calpha-1.)
!        witv=wavmin**2*estep/((1.0d0-wavmin*estep*ncentr)                 &               
!     &    *(1.0d0-wavmin*estep*(ncentr-1)))                                               
!          del=1./(1./dsqrt(wavmin)-estep*(ncentr-1))**2                       &
!   &      -1./(1./dsqrt(wavmin)-estep*ncentr)**2
!          del=dabs(witv)
!                                                                                         
! skip if wavelength is more than 10000 Angstrom away from the center of the line         
          if(del.gt.wavel_atom(k,isp)*0.1) go to 20                                       
!          if(del.gt.1000.) go to 20                                                      
! within Griem's profile limit                                                            
          if(del.lt.dell(nlim)) go to 30                                                  
!                                                                                         
! extrapolate beyond Griem's profile limit                                                
          prof=const/(del**2.5)                                                           
          go to 40                                                                        
!                                                                                         
! Griem's profile by interpolation                                                        
   30     continue                                                                        
          call taint(dell,y,del,prof,nlim,2,ner,mon)                                      
!                                                                                         
! construct profile                                                                       
   40     continue                                                                        
          mtot=mtot+1                                                                     
          emisr(m)=prof                                                                   
          if(mtot.eq.1) m1=m                                                              
          m2=m                                                                            
   20     continue                                                                        
        end do                                                                            
        call trapez(ans,wavel(m1),emisr(m1),mtot,ier)                                     
        ratio=ans*f1                                                                      
!        do m=nstart,nend 
        do m=m1,m2                                                                 
          emisr(m)=emisr(m)/ratio                                                         
        end do                                                                            
        do m=m1,m2                                                                        
          emission=e*emisr(m)*1.0e4*f1                                                    
          absorption = emission/blam                                                      
          cross=absorption/dens_atom(isp)                                                 
          absb(m) = absb(m) + absorption                                                  
        end do                                                                            
      end do                                                                              
!                                                                                         
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine interp(nsp,natoms,ndiatoms,ntriatoms,&
     &   rho,temp,spnmx,spgam,pres,enth,avmw,ansp,    &               
     &   concAl,concAlp,concAlpp,concAl3p,            &
     &   concC, concC2,                               &
     &   concCa,concCap,concCl,concC2H,               &
     &   concC3,concCH, concCN,concCO,                &
     &   concCO2,concCp, concCpp,concC3p,             &
     &   concC4p,concCr,concCrp,concCrpp,             &
     &   concFe,concFeO,concFep,concFepp,             &
     &   concFe3p,concFe4p,concFe5p,concH,            &
     &   concH2, concHp,concH2O,concK,                &
     &   concMg, concMgO,concMgp,concMgpp,            &
     &   concMg3p,concMg4p,concN,concNE,              &
     &   concN2,concN2p,concNp,concNpp,               &
     &   concN3p,concN4p,concNa,concNap,              &
     &   concNO,concNi,concNip,concNipp,              &
     &   concNi3p,concO,concO2,concOH,                &
     &   concOp,concOpp,concO3p,concO4p,              &
     &   concS,concSi,concSO,concSiO,                 &
     &   concSip,concSipp,concSi3p,concSi4p,          &
     &   concSp,concSpp,concS3p,concS4p,              &
     &   concSiH,concTi,concTip,concTipp,             &
     &   concTi3p,concTiO)                                           

! picks needed radiation mechanisms by matching the species number density
!   and given command
! input parameters:                                                                       
!   nsp= number of species                                                                                   
!   rho=density, kg/m3                                                                             
!   temp=temperature, K                                                                                  
!   spnm(msp)=species name                                                                                  
!   spgam(msp)=species concentration, mol/kg                                                                          
!   pres=pressure, Pascal                                                                 
!   enth=enthalpy, J/kg                                                                   
!   avmw=average molecular weight kg/mol                                                  
!   atomnm(matoms)=name of atoms                                                                                
!   diatomnm(mdiatoms)=name of diatoms                                                                              
!   triatomnm(mtriatoms)=name of triatoms
!   atom_rads(3,168)=list of atomic radiation mechanisms to be calculated
!   diatom_bands(3,100)=list of diatomic radiation mechanisms to be calculated
!   triatom_bands(3,10)=list of triatomic radiation mechanisms to be calculated
!   concAl, etc= concentration of Al, etc, m-3                                                                            
!                                                                                         
      parameter(matoms=56,mdiatoms=12,mtriatoms=6,msp=60)                                 
      implicit real*8(a-h,o-z)                                                            
      character*4 asterik,atomnm2(matoms),bandnm_diatom,spnmx(msp),                     &
     &    minus1,unknown
      character*4 atom_rads(3,168),diatom_bands(3,100),                                 &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                                   &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                              &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                                       &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,            &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      dimension spgam(msp),ansp(msp)                                                     

      nsp1=nsp+1                                                                          
      
      do isp=1,nsp1                                                                       
        if(spnm(isp).eq.'Al  ') then
          concAl=ansp(isp)
        end if
        if(spnm(isp).eq.'C   ') then                                                      
          concC=ansp(isp)                                                                 
        end if                                                                            
        if(spnm(isp).eq.'C2  ') then                                                      
          concC2=ansp(isp)                                                                
        end if                                                                            
!        if(spnm(isp).eq.'Cl  ') then                                                      
!          concCl=ansp(isp)                                                                
!        end if                                                                            
        if(spnm(isp).eq.'Cr  ') then                                                      
          concCr=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'C2H ') then                                                      
          concC2H=ansp(isp)                                                               
        end if                                                                            
        if(spnm(isp).eq.'Ca  ') then                                                      
          concCa=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'C3  ') then                                                      
          concC3=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'CH  ') then                                                      
          concCH=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'CN  ') then                                                      
          concCN=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'CO  ') then                                                      
          concCO=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'CO2 ') then                                                      
          concCO2=ansp(isp)                                                               
        end if                                                                            
        if(spnm(isp).eq.'Al+ ') then
          concAlp=ansp(isp)
        end if
        if(spnm(isp).eq.'Al++') then
          concAlpp=ansp(isp)
        end if
        if(spnm(isp).eq.'Al+3') then
          concAl3p=ansp(isp)
        end if
        if(spnm(isp).eq.'C+  ') then                                                      
          concCp=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'Ca+ ') then                                                      
          concCap=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'Cr+ ') then                                                      
          concCrp=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'C++ ') then                                                      
          concCpp=ansp(isp)                                                               
        end if                                                                            
        if(spnm(isp).eq.'C+3 ') then                                                      
          concC3p=ansp(isp)                                                               
        end if                                                                            
!        if(spnm(isp).eq.'Cr++') then                                                      
!          concCrpp=ansp(isp)                                                                
!        end if                                                                            
        if(spnm(isp).eq.'Fe  ') then                                                      
          concFe=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'FeO ') then                                                      
          concFeO=ansp(isp)                                                                 
        end if                                                                            
        if(spnm(isp).eq.'Fe+ ') then                                                      
          concFep=ansp(isp)                                                               
        end if                                                                            
        if(spnm(isp).eq.'Fe++') then                                                      
          concFepp=ansp(isp)                                                              
        end if                                                                            
        if(spnm(isp).eq.'Fe+3') then                                                      
          concFe3p=ansp(isp)                                                              
        end if                                                                            
        if(spnm(isp).eq.'Fe+4') then                                                      
          concFe4p=ansp(isp)                                                              
        end if                                                                            
        if(spnm(isp).eq.'Fe+5') then                                                      
          concFe5p=ansp(isp)                                                              
        end if                                                                            
        if(spnm(isp).eq.'H   ') then                                                      
          concH=ansp(isp)                                                                 
        end if                                                                            
        if(spnm(isp).eq.'H2  ') then                                                      
          concH2=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'H+  ') then                                                      
          concHp=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'H2O ') then                                                      
          concH2O=ansp(isp)                                                               
        end if                                                                            
!        if(spnm(isp).eq.'K   ') then                                                      
!          concK=ansp(isp)                                                                 
!        end if                                                                            
        if(spnm(isp).eq.'Mg  ') then                                                      
          concMg=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'MgO ') then                                                      
          concMgO=ansp(isp)                                                               
        end if                                                                            
        if(spnm(isp).eq.'Mg+ ') then                                                      
          concMgp=ansp(isp)                                                               
        end if                                                                            
        if(spnm(isp).eq.'Mg++') then                                                      
          concMgpp=ansp(isp)                                                              
        end if                                                                            
        if(spnm(isp).eq.'Mg+3') then                                                      
          concMg3p=ansp(isp)                                                              
        end if                                                                            
        if(spnm(isp).eq.'Mg+4') then                                                      
          concMg3p=ansp(isp)                                                              
        end if                                                                            
        if(spnm(isp).eq.'N   ') then                                                      
          concN=ansp(isp)                                                                 
        end if                                                                            
        if(spnm(isp).eq.'N2  ') then                                                      
          concN2=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'N2+ ') then                                                      
          concN2p=ansp(isp)                                                               
        end if                                                                            
        if(spnm(isp).eq.'N+  ') then                                                      
          concNp=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'N++ ') then                                                      
          concNpp=ansp(isp)                                                               
        end if                                                                            
        if(spnm(isp).eq.'N+3 ') then                                                      
          concN3p=ansp(isp)                                                               
        end if                                                                            
        if(spnm(isp).eq.'N+4 ') then                                                      
          concN3p=ansp(isp)                                                               
        end if                                                                            
        if(spnm(isp).eq.'Na  ') then                                                      
          concNa=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'Na+ ') then                                                      
          concNap=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'Ni  ') then                                                      
          concNi=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'Ni+ ') then                                                      
          concNip=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'Ni++') then                                                      
          concNipp=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'Ni+3') then                                                      
          concNi3p=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'NO  ') then                                                      
          concNO=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'O   ') then                                                      
          concO=ansp(isp)                                                                 
        end if                                                                            
        if(spnm(isp).eq.'O2  ') then                                                      
          concO2=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'OH  ') then                                                      
          concOH=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'O+  ') then                                                      
          concOp=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'O++ ') then                                                      
          concOpp=ansp(isp)                                                               
        end if                                                                            
        if(spnm(isp).eq.'O+3 ') then                                                      
          concO3p=ansp(isp)                                                               
        end if                                                                            
        if(spnm(isp).eq.'O+4 ') then                                                      
          concO3p=ansp(isp)                                                               
        end if                                                                            
        if(spnm(isp).eq.'S   ') then                                                      
          concS=ansp(isp)                                                                 
        end if                                                                            
        if(spnm(isp).eq.'Si  ') then                                                      
          concSi=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'SO  ') then                                                      
          concSO=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'Si+ ') then                                                      
          concSip=ansp(isp)                                                               
        end if                                                                            
        if(spnm(isp).eq.'Si++') then                                                      
          concSipp=ansp(isp)                                                              
        end if                                                                            
        if(spnm(isp).eq.'Si+3') then                                                      
          concSi3p=ansp(isp)                                                              
        end if                                                                            
        if(spnm(isp).eq.'Si+4') then                                                      
          concSi4p=ansp(isp)                                                              
        end if                                                                            
        if(spnm(isp).eq.'S+  ') then                                                      
          concSp=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'S++ ') then                                                      
          concSpp=ansp(isp)                                                               
        end if                                                                            
        if(spnm(isp).eq.'S+3 ') then                                                      
          concS3p=ansp(isp)                                                               
        end if                                                                            
        if(spnm(isp).eq.'SiH ') then                                                      
          concSiH=ansp(isp)                                                               
        end if                                                                            
        if(spnm(isp).eq.'SiO ') then                                                      
          concSiO=ansp(isp)                                                               
        end if                                                                            
        if(spnm(isp).eq.'Ti  ') then                                                      
          concTi=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'Ti+ ') then                                                      
          concTip=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'Ti++') then                                                      
          concTipp=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'Ti+3') then                                                      
          concTip3=ansp(isp)                                                                
        end if                                                                            
         if(spnm(isp).eq.'TiO ') then                                                      
          concTiO=ansp(isp)                                                                
        end if                                                                            
        if(spnm(isp).eq.'E-  ') concNE=ansp(isp)                                          
      end do                                                                              
! 
      return                                                                              
      end                                                                                 
!*************************************************************************                
      subroutine intpl1(xtab,ftab,x,f,n)                                                  
! three-point interpolation, for equally-spaced xtab values                               
! linear extrapolation beyond limits                                                      
! inputs:                                                                                 
!   xtab(n)=tabulated x values                                                            
!   ftab(n)=tabulated function values                                                     
!   x=x value where interpolation is wanted                                               
!   n=number of data points                                                               
! output:                                                                                 
!   f=function value at x                                                                 
!                                                                                         
      implicit real*8(a-h,o-z)                                                            
      dimension xtab(n), ftab(n)                                                          
!                                                                                         
      a=(x-xtab(1))/(xtab(n)-xtab(1))                                                     
!                                                                                         
! x is within limits                                                                      
      if((a.gt.0.).and.(a.lt.1.)) then                                                    
        i=int(float(n-1)*(x-xtab(1))/(xtab(n)-xtab(1)))+1                                 
        if(i.eq.1) then                                                                   
          p=(x-xtab(2))/(xtab(2)-xtab(1))                                                 
          f=0.5*p*(p-1.)*ftab(1)+(1.-p*p)*ftab(2)+0.5*p*(p+1.)*ftab(3)                    
        endif                                                                             
        if(i.gt.1) then                                                                   
          p=(x-xtab(i))/(xtab(2)-xtab(1))                                                 
          f=0.5*p*(p-1.)*ftab(i-1)+(1.-p*p)*ftab(i)+0.5*p*(p+1.)          &               
     &      *ftab(i+1)                                                                    
        endif                                                                             
      endif                                                                               
! x is below lower limit, linear extrapolation                                            
      if(a.le.0.) then                                                                    
        f=ftab(1)+(ftab(2)-ftab(1))*(x-xtab(1))/(xtab(2)-xtab(1))                         
      endif                                                                               
! x is over upper limit, linear extrapolation                                             
      if(a.ge.1.) then                                                                    
        f=ftab(n)+(ftab(n)-ftab(n-1))*(x-xtab(n))/(xtab(n)-xtab(n-1))                     
      endif                                                                               
!                                                                                         
      return                                                                              
      end                                                                                 
!***********************************************************************
      subroutine ivuna_wall(pab, twa,delHa)
! determines wall conditions for Ivuna-Orgueil meteoroid 
! input parameter
!   pab=pressure, Pa
! outputparameters
!   twa=wall temperature, K
!   delHa=ablation energy, J/kg
      implicit real*8(a-h,o-z)
! feo_L_K is for liquid FeO
! fes_c_K is for solid FeS
      real*8 mg_K,mgo_c_K,mgo_K,mgo_L_K,na2o_L_K,nao_K,na_K,ni_L_K,nig_K
      dimension tw(9),tw1(9),twx(9),plogx(9),psum(9),psumlog(9),         &
     & p(9,14),delK(10,14),delHz(4),coeft(4),coefH(4),                   &
     & o_K(9),o2_K(9),ca_K(9),cao_L_K(9),cao_K(9),                       &

     & sio2_c_K(6),sio2_L_K(9),al2o3_c_K(9),al2o_K(9),alo2_K(9),         &
     & alo_K(9),sio2_K(9),sio_K(9),fe2o3_c_K(6),fe2o3_L_K(9),            &
     & feo_L_K(9),feo_K(9),fe_L_K(9),fe_K(9),mg_K(9),mgo_c_K(9),         &
     & mgo_L_K(9),mgo_K(9),na2O_L_K(9),nao_K(9),na_K(9),h2o_L_K(9),      &
     & h2o_K(9),oh_K(9),h2_K(9),h_K(9),fes_c_K(6),                       &
     & fes_L_K(9),fes_K(9),ni_L_K(9),nig_K(9),tio2_L_K(9),tiog_K(9),     &
     & c_c_K(9),c3_K(9),s_K(9),                                          &

     & sens_O(9),sens_O2(9),sens_SiO(9),sens_Si(9),sens_SiO2(9),         &
     & sens_TiO(9),sens_TiO2(9),sens_Ti(9),sens_Fe(9),                   &
     & sens_AlO(9),sens_Al2O(9),sens_Al(9),sens_CrO(9),                  &
     & sens_FeO(9),sens_CaO(9),sens_Ca(9),sens_FeS(9),sens_S(9),         &
     & sens_H(9),sens_OH(9),sens_H2O(9),sens_MgO(9),sens_Mg(9),sens_NaO(9),    &
     & sens_Na(9),sens_Ni(9),sens_C(9),sens_C3(9)  
      dimension ploglog(51)
      character*6 compnm
! compef=mol fraction of compounds
      common/compi/compnm(14)
      common/compe/compef(14),solid_dens(14),solid_dens_av,wtmolc
      dimension aa(4,4),bb(4,2),cc(4,2)
      dimension twz(51),ppb(51),delH_wt(51),pln(51)
!
      data tw/500.,1000.,1500.,2000.,2500.,3000.,3500.,4000.,4500./
      data twx/500.,1000.,1500.,2000.,2500.,3000.,3500.,4000.,4500./
      data itime/0/
!
! equilibrium constants---------------------------------------------------------- 
!
! O2 --> 2 O
      data o2_K/    0.,     0.,    0.,    0.,    0.,   0., 0., 0., 0./ 

! 1. SiO2(L) --> SiO2(g)
      data sio2_c_K/85.444,38.137,22.443,14.388,9.463,6.197/
      data sio2_L_K/85.617,38.145,22.415,14.388,9.528,6.322,4.056,1.665,-0.186/      ! OK
      data sio2_K/32.142,16.114,10.743,7.796,5.902,4.631,3.717,2.318,1.222/
      data sio_K/15.168,9.790,7.926,6.706,5.836,5.240,4.802,3.757,2.934/
!
! 2. TiO2 --> TiO + 0.5*O2
      data tio2_L_K/84.880,38.329,22.853,15.188,10.576,7.526,5.365,3.214,1.063/
      data tiog_K/-0.497,2.173,2.925,3.219,3.269,3.255,3.211,2.615,1.965/            ! OK
!
! 3. Al2O3 -->Al2O + O2
      data al2o3_c_K/158.659,71.114,41.067,27.008,18.433,12.325,7.157,3.365,-0.427/
      data al2o_K/19.968,12.014,8.868,7.196,6.139,4.633,2.639,1.143,-0.020/
      data alo2_K/9.949,5.350,3.593,2.685,2.120,1.346,0.336,-0.421,-1.008/
      data alo_K/-2.470,0.800,1.614,1.981,2.186,1.933,1.301,0.832,0.470/              ! ok
      data o_K/-22.936,-9.803,-5.392,-3.175,-1.839,-0.946,-0.307,0.173,0.547/

! 5. Fe2O3(L) --> 2FeO + 0.5 O2
      data fe2o3_c_K/71.972,29.349,15.265,8.185,3.837,-0.511/
      data feo_L_K/23.271,10.355,6.033,3.877,2.766,1.661,0.428,-0.673,-1.517/
!      data feo_K/-20.427,-7.561,-3.492,-1.588,-0.565,0.071,-0.112,-0.451,-0.721/     ! corrected
      data feo_K/-20.427,-7.561,-3.492,-1.588,-0.565,0.071,-0.112,-0.451,-0.721/

! 6. FeO(L) --> FeO(g)
      data feo_L_K/23.271,10.355,6.033,3.877,2.544,1.661,0.428,0.673,-1.517/
!      data feo_K/-20.427,-7.561,-3.492,-1.588,-0.565,0.071,-0.112,-0.451,-0.721/     ! corrected
      data feo_K/-20.427,-7.561,-3.492,-1.588,-0.565,0.071,-0.112,-0.451,-0.721/
!
! 7. MgO(L) --> Mg + 0.5 O2
      data mgo_c_K/57.153,25.749,14.722,8.358,4.582,2.095,0.341,-0.957,-0.957/
      data mgo_L_K/57.153,25.749,14.722,8.358,4.582,2.095,0.491,-0.654,-1.527/         ! corrected
      data mgo_K/-2.040,0.894,1.327,0.679,0.305,0.059,-0.115,-0.246,-0.350/
      data mg_K/ -9.338,-1.828,0.,   0.,   0.,   0.,   0.,   0.,   0./
!
! 8. CaO --> Ca + 0.5 O2
      data cao_L_K/53.971,24.918,15.121,9.720,6.044,3.630,1.930,0.778,-0.310/
      data cao_K/  -0.690,1.185,1.817,1.461,0.783,0.359,0.080,-0.116,-0.364/            ! corrected
      data ca_K/   -12.090,-3.393,-0.812, 0.,  0.,  0.,  0.,  0.,  0./
!
! 9. Na2O --> NaO + Na
      data Na2O_L_K/36.652,14.634,5.836,1.292,-1.317,-2.981,-4.145,-5.018,-5.697/
      data NaO_K   /-4.968,-0.920,-0.586,-0.794,-0.920,-1.06,-1.069,-1.118,-1.159/       ! OK
      data Na_K    /    0.,   0.,    0.,    0.,     0.,   0.,   0.,    0.,    0./

! 10. H2O(L) --> OH + 0.5H2
      data h2o_L_K/20.534,6.458,1.934, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/
      data oh_K/ -3.246, -1.222, -0.563, -0.240, -0.050,0.074,0.160, 0.223,0.270/        ! OK
      data h2_K/0.,0.,0.,0.,0.,0.,0.,0.,0./
!      data h_K/-20.158,-8.644,-4.754,-2.788,-1.599,-0.801,-0.228,0.203,0.539/
!      data h2o_K/22.884,10.060,5.724,3.540,2.223,1.344,0.713,0.239,-0.131/
!
! 11. Fe(L) --> Fe(g)
      data fe_L_K/ 0.,   0.,   0.,   0.,   0.,   0.,   -0.605,-1.236,-1.867/
      data fe_K/-35.408,-13.824,-6.816,-3.429,-1.505,-0.260,0.,    0.,    0./            ! OK
!
! 12. Ni(L) --> Ni(g)
      data ni_L_K/ 0.,   0.,   0.,   0.,   0.,   0.,   -0.609, -1.524,2.286/
      data nig_K/-37.000,-14.659,-7.282,-3.717, -1.666,-0.327,  0.,    0.,   0./         ! OK

! 13. FeS(c) --> Fe + S
      data fes_c_K/10.707,5.102,2.401,1.297,0.577,0.091/
      data fes_L_K/10.707,5.102,2.401,1.297,0.577,0.091,-0.867,-1.806,-2.544/
      data fes_K/-28.832,-10.510,-5.481,-3.099,-1.791,-0.967,-1.017,-1.256,-1.448/       ! corrected
      data s_K/   -21.932,-8.154,-4.286,2.494,-1.356,-0.595,-0.050,0.360,0.680/

! 14. C(c) --> (1/3) C3
      data c_c_K/0.,0.,0.,0.,0.,0.,0.,0.,0./
      data c3_K/-74.143,-31.400,-17.322,-10.384,-6.285,-3.596,-1.708,-0.317,0.745/        ! OK
!
      if(itime.eq.1) go to 1000
!
!-------------------------------------------------------------------
! initialization
!
! generate 1000/T array
      do it=1,9
        tw1(it)=1000./tw(it)
      end do
!-------------------------------------------------------------------
! mol fractions brought from compos
!         1        2        3        4        5
!  &     'SiO2  ','TiO2  ','Al2O3 ','CrO2  ','Fe2O3 ',                              &
!         6        7        8        9       10
!  &     'FeO   ','MgO   ','CaO   ','Na2O  ','H2O   ',                              &
!        11       12       13       14
!  &     'Fe    ','Ni    ','FeS   ','C     '/
! vapor pressure
!
! 1. SiO2(L) --> SiO2(g)
      do it=1,9
        delK(it,1)=sio2_K(it)-sio2_L_K(it)
        p(it,1)=10.**delK(it,1)
      end do
! 2. TiO2 --> TiO + 0.5O2
      do it=1,9
        delK(it,2)=tiog_K(it) - tio2_L_K(it)  
        p(it,2)=10.**delK(it,2)
      end do
! 3. Al2O3--> Al2O + O2
      do it=1,9
        delK(it,3)=al2o_K(it)-al2o3_c_K(it)
        p(it,3)=10.**delK(it,3)
      end do
! 5. Fe2O3(L) --> 2 FeO + 0.5O2
      do it=1,9
        if(it.le.6) fe2o3ck=fe2o3_c_K(it)
        if(it.gt.6) then
          mon=0
          call taint(tw1(1),fe2o3_c_K(1),tw1(it),fe2o3ck,6,1,ier,mon)
        end if
        delK(it,5)=feo_K(it) + 0.5*o2_K(it) - fe2o3ck
        p(it,5)=10.**delK(it,5)
      end do
! 6. FeO(L) --> FeO(g)
      do it=1,9
        delK(it,6)=feo_K(it) - feo_L_K(it)
        p(it,6)=10.**delK(it,3)
      end do
! 7. MgO(c) --> MgO(g)
      do it=1,9
        delK(it,7)=mgo_K(it)-mgo_c_K(it)
        p(it,7)=10.**delK(it,7)
      end do
! 8. CaO(c) --> CaO(g)
      do it=1,9
        delK(it,8)=cao_K(it)-cao_L_K(it)
        p(it,8)=10.**delK(it,9)
      end do
! 9. Na2O --> NaO + Na
      do it=1,9
        delK(it,9)=NaO_K(it)+Na_K(it)-Na2O_L_K(it)
        p(it,9)=10.**delK(it,9)
      end do
! 10. H2O(L) --> OH + 0.5H2
      do it=1,9
        delK(it,10)=oh_K(it)+0.5*h2_K(it)-h2O_L_K(it)
!        delK(it,10)=h2o_K(it)-h2o_L_K(it)
        p(it,10)=10.**delK(it,10)
      end do
! 11. Fe(L) --> Fe(g)
      do it=1,9
        delK(it,11)=fe_K(it)-fe_L_K(it)
        p(it,11)=10.**delK(it,11)
      end do
! 12. Ti(L) --> Ti    
      do it=1,9
        delK(it,12)=nig_K(it)-ni_L_K(it)
        p(it,11)=10.**delK(it,12)
      end do
! 13. FeS(L) --> FeS(g) 
      do it=1,9
        delK(it,13)=feS_K(it) - fes_L_K(it)
!        delK(it,13)=fes_K(it) - fes_L_K(it)
        p(it,13)=10.**delK(it,6)
      end do
! 14. C(c) --> C3/3
      do it=1,9
        delK(it,14)=0.33333*c3_K(it) - c_c_K(it)
        p(it,14)=10.**delK(it,7)
      end do
! mol fractions brought from compos
!         1        2        3        4        5
!  &     'SiO2  ','TiO2  ','Al2O3 ','CrO2  ','Fe2O3 ',                              &
!         6        7        8        9       10
!  &     'FeO   ','MgO   ','CaO   ','Na2O  ','H2O   ',                              &
!        11       12       13       14
!  &     'Fe    ','Ni    ','FeS   ','C     '/
! 
      compef_sum=0.
      do i=1,14
        compef_sum=compef_sum+compef(i)
      end do      
! individual partial pressures
      do it=1,9
        p(it,1)=p(it,1)*compef(1)     ! SiO2
        p(it,2)=p(it,2)*compef(2)     ! TiO2
        p(it,3)=p(it,3)*compef(3)     ! Al2O3
        p(it,4)=0.                    ! CrO2
        p(it,5)=p(it,5)*compef(5)     ! Fe2O3
        p(it,6)=p(it,6)*compef(6)     ! FeO
        p(it,7)=p(it,7)*compef(7)     ! MgO
        p(it,8)=p(it,8)*compef(8)     ! CaO
        p(it,9)=p(it,9)*compef(9)     ! Na2O
        p(it,10)=p(it,10)*compef(10)  ! H2O
        p(it,11)=p(it,11)*compef(11)  ! Fe
        p(it,12)=p(it,12)*compef(12)  ! Ni
        p(it,13)=p(it,13)*compef(13)  ! FeS
        p(it,14)=p(it,14)*compef(14)  ! C
      end do
!
! write vapor pressures
      write(6,*) ' '
      write(6,20) 
   20 format(47h 1=SiO2->SiO+O, 2=TiO2->TiO+O, 3=Al2O3->2AlO+O      ,             &
 &     69h 4=CrO2->CrO+O, 5=Fe2O3->2FeO+O, 6=FeO(L)->FeO, 7=MgO(L)->MgO        /  &                    
 &     69h 8=CaO(L)->CaO(g), 9=Na2O->NaO+Na, 10=H2O->OH+H, 11=Fe(L)->Fe(g)        &
 &     47h 12=Ni(L)->Ni(g),13=FeS(L)->FeS 14=C(c)->C3/3                           &
 &      /'Partial pressures (atm)'/                                               &
 &     69h   Tw   1000/Tw    SiO2    TiO2    Al2O3     CrO2    Fe2O3      FeO     &   
 &     69h  MgO       CaO     Na2O      Fe       Ni       FeS      C      psum  )
     do it=1,9
        psum(it)=p(it,1)+0.*p(it,2)+p(it,3)+p(it,4)+p(it,5)+p(it,6)+0.*p(it,7)     &
 &        +p(it,8)+p(it,9)+p(it,10)+p(it,11)+p(it,12)+p(it,13)+p(it,14)
        psumlog(it)=dlog10(psum(it))
        write(6,10) tw(it),1000./tw(it),(p(it,k),k=1,3),(p(it,k),k=5,14),psum(it)       
   10   format(f7.0,f8.5,1p20e9.2)
      end do
!
! write temperature-pressure relationship
      write(6,120)
  120 format(/'   p1(atm)      Tw')
      do itx=1,51
        twz(itx)=1850.+2000.*0.035*(itx-1)
        mon=0.
        call taint(tw,psumlog,twz(itx),pslx,9,2,ier,mon)
        ppb(itx)=10.**pslx
        pln(itx)=dlog(ppb(itx))
        write(6,110) ppb(itx),twz(itx)        
  110   format(1pe11.3,0pf10.1)
      end do
!
!---------------------------------------------------------------------
! ablation energy
!         1        2        3        4        5
!  &     'SiO2  ','TiO2  ','Al2O3 ','CrO2  ','Fe2O3 ',                              &
!         6        7        8        9       10
!  &     'FeO   ','MgO   ','CaO   ','Na2O  ','H2O   ',                              &
!        11       12       13       14
!  &     'Fe    ','Ni    ','FeS   ','C     '/
!
! formation energy, condensate
      data delHc_SiO2/-908.346/,delHc_TiO2/-893.055/,delHc_Al2O3/-1620.567/,  &
   &    delHc_Fe2O3/-819.03/,delHc_FeO/-247.532/,delHc_MgO/-601.241/,         &
   &    delHc_CaO/-557.335/,delHc_Na2O/-413.15/,delHc_H2O/-285.830/,          &
   &    delHc_Fe/0./,delHc_FeS/-101.67/,delHc_C/0./
!
! total formation energy of condensate
      Hc_av =                                                                 &
        delHc_SiO2*compef(1) + delHc_TiO2*compef(2) + delHc_Al2O3*compef(3)   &
   & +  delHc_Fe2O3*compef(5) + delHc_FeO*compef(6) + delHc_MgO*compef(7)     &
   & +  delHc_CaO*compef(8)  + delHc_Na2O*compef(9) + delHc_H2O*compef(10)    &
   & +  delHc_Fe*compef(11)  + delHc_FeS*compef(13) + delHc_C*compef(14)    ! kJ/mol
      Hc_av = Hc_av*1.0e3                                                   ! J/mol
!      
! formation energy, ablation product
    data delHg_Si/446.00/, delHg_SiO/-101.57/,                                 &
   &    delHg_TiO2/-303.28/, delHg_TiO/53.93/,delHg_Ti/470.92/,                &
   &    delHg_AlO/67.0/, delHg_Al/327.3/,delHg_FeO/251.05/,                    &
   &    delHg_MgO/58.16/, delHg_CaO/45.1/, delHg_Na/107.5/,                    &
   &    delHg_NaO/85.04/, delHg_O/246.79/, delHg_O2/0./,delHg_Fe/413.1/,       &
   &    delHg_FeS/370.77/, delHg_CaO/45.1/, delHg_H2O/-241.826/,               &
   &    delHg_C/273.3/, delHg_C3/811./, delHg_Na2O/85.48/,delHg_S/274.71/
!         1        2        3        4        5
!  &     'SiO2  ','TiO2  ','Al2O3 ','CrO2  ','Fe2O3 ',                              &
!         6        7        8        9       10
!  &     'FeO   ','MgO   ','CaO   ','Na2O  ','H2O   ',                              &
!        11       12       13       14
!  &     'Fe    ','Ni    ','FeS   ','C     '/
!
! sensible energies of ablation product
! SiO2     
      data sens_SiO2/9.655,37.405,67.179,97.614,128.337,159.210,            &
    & 190.168,221.181,252.231/
! SiO
      data sens_SiO/6.282,23.472,41.645,60.179,78.897,97.735,116.672,       &
    &   135.710,154.884/
! Si
      data sens_Si/4.374,14.903,25.447,36.236,47.326,58.649,70.116,         &
    &    81.651,93.206/
! TiO
      data sens_TiO/6.855,25.283,44.324,63.568,83.040,102.932,123.455,      &
    &   144.751,166.861/
! TiO2
      data sens_TiO2/9.606,36.491,64.750,93.417,122.266,151.256,180.438,    &
    &   209.914,239.789/
! O
      data sens_O/4.343,14.860,25.296,35.713,46.130,56.574,67.079,77.675,   &
    &   88.386/
! O2
      data sens_O2/6.084,22.703,40.599,59.175,78.328,98.013,118.165,138.705,&
    &   159.572/
! Al2O
      data sens_Al2O/11.067,40.732,71.341,102.227,133.229,164.293,195.405,  &
    &   226.567,357.814/
! AlO
      data sens_AlO/6.544,24.362,43.930,65.606,88.743,112.374,135.896,      &
    &   159.094,181.978/
! Al 
      data sens_Al/4.268,14.712,25.112,35.523,45.921,56.318,66.722,77.150,  &
    &   87.642/
! CrO
      data sens_CrO/6.640,24.526,43.103,61.952,80.979,100.179,119.586,      &
    &    139.243,159.188/
! FeO
      data sens_FeO/6.556,24.545,43.095,61.963,81.189,100.865,121.034,      &
    &  141.676,162.732/
! Fe
      data sens_Fe/5.138,16.874,27.984,39.312,51.274,63.994,77.507,         &
    &   91.872,107.200/
! MgO      
      data sens_MgO/7.053,31.379,57.820,81.353,103.117,124.081,144.717,     &
    &  165.267,185.871/
! CaO
      data sens_CaO/6.859,25.058,44.255,66.293,93.122,123.790,155.679,      &
    &   186.918,216.877/
! Ca
      data sens_Ca/4.196,14.589,24.982,35.405,46.054,57.105,70.641,86.448,  &
    &   105.568/
! NaO
      data sens_NaO/7.294,26.050,45.189,64.582,84.202,104.040,124.092,      &
    &   144.357,164.833/
! Na
      data sens_Na/4.196,14.589,24.982,35.378,45.803,56.343,67.154,78.457,  &
    &   90.469/
! OH
      data sens_OH/5.992,20.935,36.839,53.762,71.419,89.584,108.119,126.939,&
    &   145.991/
! H2O
      data sens_H2O/6.925,26.000,48.151,72.790,99.108,126.549,154.768,      &
    &  183.552,212.764/
! H
      data sens_H/4.196,14.589,24.982,35.375,45.768,56.161,66.554,76.947,   &
    &   87.370/
! Ni
      data sens_Ni/4.815,17.239,29.461,41.266,52.748,64.031,75.225,86.433,  &
    &   97.760/
! FeS
      data sens_FeS/7.111,25.568,44.396,63.478,82.887,102.761,123.143,      &
    &  144.017,165.329/
! S
      data sens_S/4.689,15.677,26.325,36.917,47.640,58.538,69.634,80.898,   &
    &   92.290/
! C
      data sens_C/2.337,9.492,17.317,25.645,34.294,43.178,52.24,            &
    &  61.446,70.772/      
! C3
      data sens_C3/7.612,28.477,51.951,76.934,100.885,129.534,156.720,      &
    &   184.339,184.339/
!
!         1        2        3        4        5
!  &     'SiO2  ','TiO2  ','Al2O3 ','CrO2  ','Fe2O3 ',                              &
!         6        7        8        9       10
!  &     'FeO   ','MgO   ','CaO   ','Na2O  ','H2O   ',                              &
!        11       12       13       14
!  &     'Fe    ','Ni    ','FeS   ','C     '/
!
! vary pressure
!
      write(6,*) ' '
      write(6,*) '  p(atm)        Tw     delH(J/kg'
      mon=0
      do ip=1,51
        mon=0
! SiO2(L) -> SiO2(g)
        call taint(tw,sens_SiO2,twz(ip),sensx_SiO2,9,2,ier,mon)
!        call taint(tw,sens_O,tww,sensx_O,9.2,ier,mon)
!        call taint(tw,sens_O2,tww,sensx_O2,9,2,ier,mon)
        delHx_SiO2=(delHg_SiO2 + sensx_SiO2-delHc_SiO2)*1000.
! TiO2(L) -> TiO2(g)
        call taint(tw,sens_TiO2,twz(ip),sensx_TiO2,9.2,ier,mon)
        delHx_TiO2=(delHg_TiO2+sensx_TiO2-delHc_TiO2)*1000.
! Al2O3(L) -> Al2O(g) + O2
!        call taint(tw,sens_Al,tww,sensx_Al,9,2,ier,mon)
        call taint(tw,sens_Al2O,twz(ip),sensx_Al2O,9,2,ier,mon)
        delHx_Al2O3=(delHg_Al2O+sensx_Al2O+0.5*delHg_O2           &
    &     +0.5*sensx_O2*(twz(ip)-298.)- delHc_Al2O3)*1000.
! CrO2
!        call taint(tw,sens_CrO,tww,sensx_CrO,ier,mon)
!      end do
! Fe2O3 -> 2FeO + O2
!        call taint(tw,sens_Fe,twz(ip),sensx_Fe,9,2,ier,mon)
        call taint(tw,sens_FeO,tww,sensx_FeO,9,2,ier,mon)
        delHx_Fe2O3=(2*delHg_FeO+2.*sensx_FeO+delHg_O2+sensx_O2      &
    &     -delHc_Fe2O3)*1000.
! FeO(c) -> FeO(g)
        delHx_FeO=(delHg_FeO+sensx_FeO-delHc_FeO)*1000.
! MgO(c) -> MgO(g)
!        call taint(tw,sens_Mg,tww,sensx_Mg,9,2,ier,mon)
        call taint(tw,sens_MgO,twz(ip),sensx_MgO,9,2,ier,mon)
        delHx_MgO=(delHg_MgO+sensx_MgO-delHc_MgO)*1000.
! CaO(c) -> CaO(g)
        call taint(tw,sens_CaO,twz(ip),sensx_CaO,9,2,ier,mon)
        delHx_CaO=(delHg_CaO+sensx_CaO-delHc_CaO)*1000
! H2O(c) -> H2O(g)       
!        call taint(tw,sens_H,twz(ip),sensx_H,9,2,ier,mon)
        call taint(tw,sens_H2O,twz(ip),sensx_H2O,9,2,ier,mon)
        delHx_H2O=(delHg_H2O+2*sensx_H2O-delHc_H2O)*1000.
! Na2O -> NaO + 0.5O2
        call taint(tw,sens_NaO,twz(ip),sensx_NaO,9,2,ier,mon)
        delHx_Na2O=(delHg_NaO+sensx_NaO-delHc_Na2O)*1000.
! FeS
        call taint(tw,sens_FeS,twz(ip),sensx_FeS,9,2,ier,mon)
        delHx_FeS=(delHg_FeS+sensx_FeS-delHc_FeS)*1000.
! Fe
        call taint(tw,sens_Fe,twz(ip),sensx_Fe,9,2,ier,mon)
        delHx_Fe=(delHg_Fe+sensx_Fe-delHc_Fe)*1000.  
! C
        call taint(tw,sens_C3,twz(ip),sensx_C3,9,2,ier,mon)
        delHx_C=(delHg_C3+sensx_C3-delHc_C)*1000.

        delH_wt(ip) =                                                         &
     &  (delHx_SiO2*compef(1) + delHx_TiO2*compef(2) + delHx_Al2O3*compef(3)  &
     & + delHx_Fe2O3*compef(5)+ delHx_FeO*compef(6)  + delHx_MgO*compef(7)    &
     & + delHx_CaO*compef(8)  + delHx_Na2O*compef(9) + delHx_H2O*compef(10)   &
     & + delHx_Fe*compef(11)  + delHx_FeS*compef(13)   &
     & + delHx_C*compef(14))/wtmolc
       write(6,135) ppb(ip),twz(ip),delH_wt(ip)
       pln(ip)=dlog(ppb(ip))
 135   format(1pe11.4,0pf11.1,1pe11.4)
!
!         1        2        3        4        5
!  &     'SiO2  ','TiO2  ','Al2O3 ','CrO2  ','Fe2O3 ',                              &
!         6        7        8        9       10
!  &     'FeO   ','MgO   ','CaO   ','Na2O  ','H2O   ',                              &
!        11       12       13       14
!  &     'Fe    ','Ni    ','FeS   ','C     '/
!
      end do
!-------------------------------------------------------------
! run
 1000 continue
      pll=dlog(pab/1.0133e5)
      mon=0
      call taint(pln,twz,pll,twa,51,2,ier,mon)
      call taint(pln,delH_wt,pll,delHa,51,2,ier,mon)

      return
      end
!*********************************************************************                    
      subroutine jmax(m)                                                                  
!  set up arrays k(i) and u(i) to                                                         
!  find kmax - the maximum rotational quantum number.                                     
!                                                                                         
!  note that kmax values can not be calculated unless                                     
!  dissociation energies are input.                                                       
!                                                                                         
      parameter(msp=60)                                                                   
      implicit real*8(a-h,o-z)                                                            
      common/eqcoma/elemwt(15),                                           &               
     & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp),            &               
     & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp),             &               
     & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp),                     &               
     & akb(5,msp),akd(5,msp),avmw0                                                        
      common/eqcomb/elemnm(12)                                                            
      common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc,  &               
     & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp),   &               
     & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp)                        
      common/eqcome/kmaxvV(msp,25,100),maxv(msp,25),vV(msp,25,100)                        
      dimension k(500),u(500)                                                             
      character*4 elemnm,spnm                                                             
      real*8 mu                                                                           
!                                                                                         
      rmax=1.0e-7                                                                         
      mu=rmass(m)                                                                         
      c3=1.686e-15/mu                                                                     
      n=nelec(m)                                                                          
!                                                                                         
      do 25 i=1,n                                                                         
25    maxv(m,i)=0                                                                         
!                                                                                         
      do 2 ie1=1,n                                                                        
!                                                                                         
      we=spect(3,ie1,m)                                                                   
      wexe=spect(4,ie1,m)                                                                 
      weye=spect(5,ie1,m)                                                                 
      requil=spect(6,ie1,m)*1.0d-8                                                        
      dzero=spect(7,ie1,m)                                                                
      be=spect(8,ie1,m)                                                                   
      alpha=spect(9,ie1,m)                                                                
      de=spect(10,ie1,m)                                                                  
      beta=spect(11,ie1,m)                                                                
!                                                                                         
      imax=0                                                                              
      imax1=1                                                                             
      do 20 i=1,500                                                                       
        k(i)=0                                                                            
20    u(i)=0.                                                                             
                                                                                          
      rstep=1.0d-9                                                                        
      dequil=dzero+.5d0*we-.25d0*wexe+.125d0*weye                                         
      c1=1.2177d+7*we*dsqrt(mu/dequil)                                                    
      r=requil                                                                            
      fr2=0.0d0                                                                           
80    fr1=fr2                                                                             
85    r=r+rstep                                                                           
      if (r.gt.rmax) go to 90                                                             
      c2=dexp(-c1*(r-requil))                                                             
      fr2=(r*1.0d+8)**3*c2*(1.0d0-c2)                                                     
      if (fr2.gt.fr1) go to 80                                                            
      if(dabs(fr2-fr1).le.1.0d-10) goto 90                                                
      r=r-rstep                                                                           
      rstep=rstep/10.                                                                     
      goto 85                                                                             
!                                                                                         
90    continue                                                                            
      fk=fr2*1.0e-24*c1*dequil/c3                                                         
      rk=-.5d0+.5d0*dsqrt(1.0d0+4.0d0*fk)                                                 
      k(1)=rk                                                                             
      u(1)=dequil*(1.0d0-dexp(-c1*(r-requil)))**2+c3*rk*(rk+1.)/r**2                      
      rstep=1.0d-10                                                                       
      do 120 i=2,500                                                                      
        kjh=0                                                                             
100     r=r+rstep                                                                         
        c2=dexp(-c1*(r-requil))                                                           
        fr2=(r*1.0e+8)**3*c2*(1.0-c2)                                                     
        fk=fr2*1.0e-24*c1*dequil/c3                                                       
        rk=-.5d0+.5d0*sqrt(1.0d0+4.0d0*fk)                                                
        k(i)=rk                                                                           
        if(k(i).lt.3) goto 130                                                            
        delk=k(i-1)-k(i)                                                                  
        if(delk.lt.1.5d0.and.delk.gt.0.5d0) goto 110                                      
        r=r-rstep                                                                         
        if(delk.le.0.5) rstep=rstep*2.0                                                   
        if(delk.ge.1.5) rstep=rstep/10.0                                                  
        kjh=kjh+1                                                                         
        if(kjh.lt.100) goto 100                                                           
                                                                                          
        write(6,700) m,i                                                                  
700     format(' infinite loop in jmax at 700; m=',i3,' i=',i3)                           
        stop                                                                              
!                                                                                         
110     u(i)=dequil*(1.0d0-exp(-c1*(r-requil)))**2+c3*rk*(rk+1.)/r**2                     
        imax=i                                                                            
120   continue                                                                            
130   continue                                                                            
!                                                                                         
! cycle over vibrational levels                                                           
!                                                                                         
! the energies of the first 16 levels, or less if evib=>dequil, are                       
! calculated from we,wexe and weye. the energies of the remaining                         
! levels are calculated by added on the evib increment from a morse pot.                  
!                                                                                         
      nvib=32                                                                             
 140  nvib=nvib/2                                                                         
      if(nvib.gt.0) goto 150                                                              
!                                                                                         
      write(6,710) m,ie                                                                   
 710  format(' error!! no vibrational levels for m=',i3,                  &               
     & '  state=',i3)                                                                     
      stop                                                                                
 150  evib=0.                                                                             
      do 1 jvib=1,nvib                                                                    
      v=jvib-1                                                                            
      evib2=evib                                                                          
      bv=be-alpha*(v+0.5d0)                                                               
      dv=de+beta*(v+0.5d0)                                                                
      evib=we*(v+.5d0)-wexe*(v+.5d0)**2+weye*(v+.5d0)**3                                  
      vv(m,ie1,jvib)=evib                                                                 
      delev=evib-evib2                                                                    
      if(evib.le.evib2) goto 140                                                          
      kmax=fkmax(k,u,imax1,imax,evib,bv,dv)                                               
      kmaxvv(m,ie1,jvib)=kmax                                                             
      if (evib.ge.dequil/2.) goto 4                                                       
      if(kmax.le.2) goto 3                                                                
    1 continue                                                                            
      jvib1=nvib+1                                                                        
      goto 5                                                                              
    4 jvib1=jvib+1                                                                        
    5 nvib=2.*dequil/we                                                                   
      if(nvib.gt.100) nvib=100                                                            
      do 6 jvib=jvib1,nvib                                                                
        v=jvib-1                                                                          
        bv=be-alpha*(v+0.5)                                                               
        dv=de+beta*(v+0.5)                                                                
        delev=delev-we**2/(2.*dequil)                                                     
        evib=evib+delev                                                                   
        vv(m,ie1,jvib)=evib                                                               
        if(evib.gt.dequil) goto 3                                                         
        kmax=fkmax(k,u,imax1,imax,evib,bv,dv)                                             
        kmaxvv(m,ie1,jvib+1)=kmax                                                         
        if(kmax.le.2) goto 3                                                              
    6 continue                                                                            
      jvib=nvib                                                                           
      goto 7                                                                              
    3 jvib=jvib-1                                                                         
    7 maxv(m,ie1)=jvib                                                                    
    2 continue                                                                            
      iv(m)=1                                                                             
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine kmeqm(p1,t1,ethm1,iprb,elmsf1,spmlf1,brm1,rho1)                          
!                                                                                         
!.....iprb(t,p)=1; iprb(h,p)=2.........................................                   
!     subroutine for computing chemical equilibrium in flow fields. the                   
!     method is essentially that given in nasa sp-273 by mcbride and gordon               
!                                                                                         
! inputs:                                                                                 
!   p1=pressure, atm                                                                      
!   T1=temperature, K                                                                     
!   ethm1=enthalpy, J/kg                                                                  
! outputs:                                                                                
!   brm1=average molecular weight, g/mol                                                  
!   rho1=density, kg/m3                                                                   
      implicit real*8(a-h,o-z)                                                            
      common /spcdat/ eltbl(8,2),    sptbl(9,32),   fln(8,32),            &               
     &                tdc(8,32,4),   spm(32),                             &               
     &                        ne,            ns,                          &               
     &                itchm,         ioutch,        elms(8)                               
!                                                                                         
      common /node  / spv(32),       t,             p,                    &               
     &                brm,           speth(32),     spgfz(32),            &               
     &                spcsp(32),     bzro(8),       ethm                                  
!                                                                                         
      dimension       amtrx(16,16),  bvtr(16),      work(16),             &               
     &          ipvt(16),elmsf1(8),spmlf1(32)                                             
      data itime/0/                                                                       
      do 70 i=1,32                                                                        
   70 spmlf1(i)=0.1                                                                       
                                                                            
  300 format(1x,80a1)                                                                     
!.....p=pressure in atm                                                                   
!.....t=temperature in k                                                                  
!.....ethm=enthalpy in j/kg                                                               
      p=p1                                                                                
      t=t1                                                                                
      if(iprb.eq.2) ethm=ethm1                                                            
!.....set elemental mass fractions to input values                                        
      do 10 i=1,ne                                                                        
        bzro(i)=elmsf1(i)/elms(i)
   10 continue                                                          
!..... normalize initial guess of species mole fractions and calculate brm                
      sum=0.                                                                              
      do 50 i=1,ns                                                                        
   50 sum=sum+spmlf1(i)
      brm=0.                                                                              
      do 60 i=1,ns                                                                        
        spmlf1(i)=spmlf1(i)/sum                                                             
        brm=brm+spm(i)*spmlf1(i) 
   60 continue
!.....set initial guess for species mole fractions to input values                        
      do 40 i=1,ns                                                                        
   40 spv(i)=spmlf1(i)                                                                    
!                                                                                         
      ndim = 16                                                                           
      nrnk=ne+1                                                                           
!.....if h,p problem, increase rank of a matrix by 1........................              
      if(iprb.eq.2)nrnk=nrnk+1                                                            
!                                                                                         
!.....set species thermo functions........................................ 
      call spthf                                                                          
!                                                                                         
!     iteration loop                                                                                                                                                               
      itcmax = 30000                                                                       
      do 20 itc = 1, itcmax                                                               
!                                                                                         
!.....reset species thermo functions if h,p problem.......................  
      if(iprb.eq.2)call spthf                                                             
!                                                                                         
!     fill matrix resulting from lagrangian multiplier method                               
        call chmtx(amtrx, bvtr, iprb)                                                     
!                                                                                         
!     solve linear system for species changes                                               
        call decomp(ndim,nrnk, amtrx, cndno, ipvt, work)                                  
        call solve(ndim,nrnk, amtrx, bvtr, ipvt)                                          
!                                                                                         
!     apply species update corrections                                                    
! 
        call spudt(bvtr, lcnv, iprb)                                                      
!      write(6,201) (spv(i),i=1,10),t,brm                                            
  201 format(1x,' SPV='/1p10e10.3/' T,BRM=',3E10.3)                                                                
        if(lcnv .ne. 0) go to 30                                                          
   20 continue                                                                            
!                                                                                         
!     solution failed to converge                                                         
!                                                                                         
      write(6,100)  itcmax, t, p, (spv(ii),ii=1,ns)                                      
  100 format(//5x,26heqm. chm. did not converge,3h in,                    &               
     &  i7,12h iterations.,/,5x,37hstate conditions for this case are :   &               
     &  7htemp.= ,1pe11.4,18h kelvin ; press.= ,1pe11.4,5h atm. /         &               
     &  ' spmlfo='/ (1p5e11.3))                                                             
      stop                                                                                
!                                                                                         
!     solution converged                                                                  
   30 continue                                                                            
!                                                                                         
!      write (6,200) itc                                                             
200   format (/' no. of iteration steps : ',i2)                                           
!                                                                                         
      do 2 i=1,ns                                                                         
    2 spmlf1(i)=spv(i)                                                                    
      if(iprb.eq.2) t1=t                                                                  
      brm1=brm                                                                            
      if(iprb.eq.2) go to 99                                                              
      ethm1=0.                                                                            
      do 1 i=1,ns                                                                         
    1 ethm1=ethm1+spv(i)*speth(i)                                                         
      ethm1=ethm1*8.31434e3*t/brm1                                                        
!                                                                                         
  99  continue                                                                            
      antot=p1*1.0133e5/(1.3805e-23*t1)                                                   
      awt=1.0e-3*brm1/6.025e23                                                            
      rho1=antot*awt  
      return                                                                              
      end                                                                                 
!****************************************************************                         
       subroutine leqt2f(a,m,n,ia,b,idgt,wkarea,ier)                                      
! matrix inversion with accompanying solution of linear equations                         
!   of the form ax=b                                                                      
! inputs:                                                                                 
! a(n,n)=left-hand-side matrix, first index=row, second index=column                      
! m=column dimension of b                                                                 
! n=row dimensions of a and b                                                             
! ia=dimensions of a and b                                                                
! b(n,m)=right-hand-side vector                                                           
! idgt=input option                                                                       
! wkarea=work area                                                                        
! outputs:                                                                                
! b(n,m) contains the solution vector                                                     
! ier=errror message                                                                      
      implicit real*8(a-h,o-z)                                                            
      dimension ipivot(70),pivot(70),index(70,2)                                          
      dimension a(ia,ia),b(ia,m),wkarea(1)                                                
      equivalence (irow,jrow),(icolum,jcolum),(amax,t,swap)                               
!                                                                                         
! initialization                                                                          
   10 determ=1.0                                                                          
   15 do 20 j=1,n                                                                         
   20 ipivot(j)=0                                                                         
   30 do 550 i=1,n                                                                        
   40 amax=0.0d0                                                                          
!                                                                                         
! search for pivot element                                                                
   45 do 105 j=1,n                                                                        
   50 if(ipivot(j)-1)  60,105,60                                                          
   60 do 100 k=1,n                                                                        
   70 if(ipivot(k)-1)  80,100,740                                                         
   80 if(abs(amax)-abs(a(j,k)))   85,100,100                                              
   85 irow=j                                                                              
   90 icolum=k                                                                            
   95 amax=a(j,k)                                                                         
  100 continue                                                                            
  105 continue                                                                            
  110 ipivot(icolum)=ipivot(icolum)+1                                                     
!                                                                                         
! interchange rows to put pivot element on diagonal                                       
  130 if(irow-icolum) 140,260,140                                                         
  140 determ=-determ                                                                      
  150 do 200 l=1,n                                                                        
  160 swap=a(irow,l)                                                                      
  170 a(irow,l)=a(icolum,l)                                                               
  200 a(icolum,l)=swap                                                                    
  205 if(m) 260,260,210                                                                   
  210 do 250 l=1,m                                                                        
  220 swap=b(irow,l)                                                                      
  230 b(irow,l)=b(icolum,l)                                                               
  250 b(icolum,l)=swap                                                                    
  260 index(i,1)=irow                                                                     
  270 index(i,2)=icolum                                                                   
  310 pivot(i)=a(icolum,icolum)                                                           
  320 determ=determ*pivot(i)                                                              
!                                                                                         
! divide pivot row by pivot element                                                       
  330 a(icolum,icolum)=1.0                                                                
  340 do 350 l=1,n                                                                        
  350 a(icolum,l)=a(icolum,l)/pivot(i)                                                    
  355 if(m) 380,380,360                                                                   
  360 do 370 l=1,m                                                                        
  370 b(icolum,l)=b(icolum,l)/pivot(i)                                                    
!                                                                                         
! reduce non-pivot rows                                                                   
  380 do 550 l1=1,n                                                                       
  390 if(l1-icolum)  400,550,400                                                          
  400 t=a(l1,icolum)                                                                      
  420 a(l1,icolum)=0.0                                                                    
  430 do 450 l=1,n                                                                        
  450 a(l1,l)=a(l1,l)-a(icolum,l)*t                                                       
  455 if(m)550,550,460                                                                    
  460 do 500 l=1,m                                                                        
  500 b(l1,l)=b(l1,l)-b(icolum,l)*t                                                       
  550 continue                                                                            
!                                                                                         
! interchange columns                                                                     
  600 do 710 i=1,n                                                                        
  610 l=n+1-i                                                                             
  620 if(index(l,1)-index(l,2))  630,710,630                                              
  630 jrow=index(l,1)                                                                     
  640 jcolum=index(l,2)                                                                   
  650 do 705  k=1,n                                                                       
  660 swap=a(k,jrow)                                                                      
  670 a(k,jrow)=a(k,jcolum)                                                               
  700 a(k,jcolum)= swap                                                                   
  705 continue                                                                            
  710 continue                                                                            
  740 return                                                                              
      end                                                                                 
!***********************************************************************
      subroutine lin2(a,r, x)
! solve two simultaneous linear equations
! input parameters:
!   a(2,2)=left hand side matrix
!   r(2)=right hand side vector
! output parameters:
!   x(2)=solution vector
      implicit real*8(a-h,o-z)
      dimension a(2,2),r(2),x(2)
      x(1)=(-r(1)/a(1,2)+r(2)/a(2,2))/(a(2,1)/a(2,2)-a(1,1)/a(1,2))
      x(2)=r(1)/a(1,2)-(a(1,1)/a(1,2))*x(1)
      return
      end
!*************************************************************************
      subroutine lsqpol(x,y,w,resid,n,sum,l,a,b,m)  
! x(n) is the abscissa of data points
! y(n) is the ordinate of data points
! w(n) is the weighting factor
! n is the number of data points
! l is the number of sets                            
! m is the number of terms in polynomial   
! a(m,m) is the working space                                     
! b(m,l) is the coefficient array in ascending degree            
      implicit real*8(a-h,o-z)                    
      dimension x(n),y(n,l),resid(n,l),w(n),a(2,2),b(2,1),sum(l),          &      
 &      c(27,27),ipvt(27),work(27)                                                                 
   10 do 20 i=1,n                                                               
   20 c(i,1)=1.0                                                                
   30 do 50 j=2,m                                                               
   40 do 50 i=1,n                                                               
   50 c(i,j)=c(i,j-1)*x(i)                                                      
   60 do 100 i=1,m                                                              
   70 do 100 j=1,m                                                              
   80 a(i,j)=0.0                                                                
   90 do 100 k=1,n                                                              
  100 a(i,j)=a(i,j)+c(k,i)*c(k,j)*w(k)                                          
  105 do 150 j=1,l                                                              
  110 do 150 i=1,m                                                              
  120 b(i,j)=0.0                                                                
  130 do 150 k=1,n                                                              
  150 b(i,j)=b(i,j)+c(k,i)*y(k,j)*w(k)                                          
  170 call decomp(2,2,a,cond,ipvt,work)
      call solve(2,2,a,b,ipvt)
!      call decomp(4,4,ax,cond,ipvt,work)                                       
!      call solve(4,4,ax,rhs,ipvt)                                                 
!  170 call minv(a,n,n,b,l,determ)                                                 
  180 do 205 j=1,l                                                              
  185 sum(j)=0.                                                                 
  192 do 195 k=1,m                                                              
  195 c(k,1)=b(k,j)                                                             
  198 continue                                                                  
! 198 do 205 i=1,n                                                              
! 200 resid(i,j)=polye1(x(i),m,c(1,1)) - y(0,j)                                 
! 205 sum(j)=sum(j)+resid(i,j)**2*w(i)                                          
  205 continue                                                                  
  210 return                                                                    
      end                                                                       
!***********************************************************************
      subroutine magnitf(nwave,rnose,flux_s,flux_prec,flux_grd,       &
  &     alt,elev_ang, magnit)
! calculates brightness magnitude of the meteor
! input parameters:
!   nwave
!   rnose
!   flux_grd=radiation flux received at ground, W/m2
!   wavel(nw)
!   int_prec(nw)=intensity at the end of absorption, W/(m2-sr)
!   alt=altitude, m
!   
      parameter(nw=400000)
      implicit real*8(a-h,o-z)
      real*8 int_prec,magnit
      dimension wavel(nw),int_prec(nw)
      data unit_mag/2.511886/,sun_mag/-26.74/

! sun's brightness at Earth = 1364.9 
      qsun=1364.9                                      ! W/m2
! meteor's total radiation flux at edge of precursor region
      qsurf=flux_prec*1.0e-4* 3.1416*rnose**2 *1.0e4   ! W
! distance from meteor to the observer
      dist=alt                                         ! m
! area of the imaginary half-sphere of radius = dist
      area=2.*3.1416*dist**2                           ! m2
! brightness
      q=qsurf/area                                     ! W/m2
! compare with sun
      qratio=qsun/q
! unit_mag**x=qratio --> x log(unit_mag) = log(qratio)
      x = dlog(qratio)/dlog(unit_mag)
! magnitude of the meteor
      magnit = sun_mag + x
! write 
      write(6,10) magnit
   10 format(/' brightness magnitude =',f10.2)

      return
      end
!***********************************************************************
!     minv          1/29/71
        subroutine minv(a,ndim,n,b,m,determ)
! matrix inversion with accompanying solution of linear equations
!   of the form ax=b
! input parameters:
!   a(ndim,ndim)=left-hand-side matrix, first index=row, second index=column
!   ndim=dimension of a and b
!   n=actual size of a and b
!   b(ndim,2)=right-hand-side vector
!   m=1 or 2, depending on the dimension of b
! output parameters:
!   b(n,2) contains the solution vector
!   determ contains the determinant of a-matrix
!   note: the matrix a and vector b must be solidly loaded
      implicit real*8(a-h,o-z)
      dimension ipivot(70),pivot(70),index(70,2)
      dimension a(ndim,ndim),b(ndim,2)
      equivalence (irow,jrow),(icolum,jcolum),(amax,t,swap)
!
! initialization
   10 determ=1.0
   15 do 20 j=1,n
   20 ipivot(j)=0
   30 do 550 i=1,n
   40 amax=0.0
!
! search for pivot element
   45 do 105 j=1,n
   50 if(ipivot(j)-1)  60,105,60
   60 do 100 k=1,n
   70 if(ipivot(k)-1)  80,100,740
   80 if(abs(amax)-abs(a(j,k)))   85,100,100
   85 irow=j
   90 icolum=k
   95 amax=a(j,k)
  100 continue
  105 continue
  110 ipivot(icolum)=ipivot(icolum)+1
!
! interchange rows to put pivot element on diagonal
  130 if(irow-icolum) 140,260,140
  140 determ=-determ
  150 do 200 l=1,n
  160 swap=a(irow,l)
  170 a(irow,l)=a(icolum,l)
  200 a(icolum,l)=swap
  205 if(m) 260,260,210
  210 do 250 l=1,m
  220 swap=b(irow,l)
  230 b(irow,l)=b(icolum,l)
  250 b(icolum,l)=swap
  260 index(i,1)=irow
  270 index(i,2)=icolum
  310 pivot(i)=a(icolum,icolum)
  320 determ=determ*pivot(i)
!
! divide pivot row by pivot element
  330 a(icolum,icolum)=1.0
  340 do 350 l=1,n
  350 a(icolum,l)=a(icolum,l)/pivot(i)
  355 if(m) 380,380,360
  360 do 370 l=1,m
  370 b(icolum,l)=b(icolum,l)/pivot(i)
!
! reduce non-pivot rows
  380 do 550 l1=1,n
  390 if(l1-icolum)  400,550,400
  400 t=a(l1,icolum)
  420 a(l1,icolum)=0.0
  430 do 450 l=1,n
  450 a(l1,l)=a(l1,l)-a(icolum,l)*t
  455 if(m)550,550,460
  460 do 500 l=1,m
  500 b(l1,l)=b(l1,l)-b(icolum,l)*t
  550 continue
!
! interchange columns
  600 do 710 i=1,n
  610 l=n+1-i
  620 if(index(l,1)-index(l,2))  630,710,630
  630 jrow=index(l,1)
  640 jcolum=index(l,2)
  650 do 705  k=1,n
  660 swap=a(k,jrow)
  670 a(k,jrow)=a(k,jcolum)
  700 a(k,jcolum)= swap
  705 continue
  710 continue
  740 return
      end
!***********************************************************************                  
      subroutine partfx(m,specie,amass,t,tv,te,nprt,partf,parti)                          
! evaluates partition function                                                            
! input parameters:                                                                       
!   m=species index:                                                                      
!   specie=specie                                                                         
!   amass=atomic or molecular weight, gram/mol                                            
!   spect(i,j,m)=spectral constants                                                       
!     i: 1=degen,2=term,3=we,4=wexe,5=weye,6=re,7=dzero                                   
!        8=be,9=alphae,10=de,11=betae                                                     
!     j: max number of electronic levels is 12                                            
!   t=heavy particle translational and rotational temperature, k                          
!   tv=vibrational temperature, k                                                         
!   te=electron temperature, k                                                            
!   nprt=print index. print if nprt.ge.2                                                  
! calculated parameter:                                                                   
!   factr=sysmmetry factor; 0.5 for homo diatomics, 1.0 otherwise                         
! output parameter:                                                                       
!   partf=partition function, including translational component                           
!   parti=internal partition function, excluding translational component                  
!                                                                                         
      parameter(msp=60)                                                                   
      implicit real*8(a-h,o-z)                                                            
      common/eqcoma/elemwt(15),                                           &               
     & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp),            &               
     & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp),             &               
     & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp),                     &               
     & akb(5,msp),akd(5,msp),avmw0                                                        
      common/eqcomb/elemnm(12)                                                            
      common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc,  &               
     & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp),   &               
     & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp)                        
      dimension specie(msp)                                                               
      character*4 elemnm,spnm,specie                                                      
!                                                                                         
! electron                                                                                
      if(m.eq.nsp1) then                                                                  
      parti=2.0                                                                           
      partf=1.878e20*sqrt(amass*te)*amass*te                                              
      return                                                                              
      endif                                                                               
!                                                                                         
! translational component                                                                 
      qt=1.878e20*sqrt(amass*t)*amass*t                                                   
!                                                                                         
! atom                                                                                    
      if(im(m).eq.0) then                                                                 
      q=0.                                                                                
      t1=1./te                                                                            
      nlev=nelec(m)                                                                       
      do 4 j=1,nlev                                                                       
   4  q=q+atomg(j,m)*dexp(-1.43877*atome(j,m)*t1)                                         
      endif                                                                               
!                                                                                         
! diatomic molecule                                                                       
      if((im(m).eq.1).and.(ih(m).eq.2)) then                                              
        q=qevr(m,t,tv,te,nprt)*factr(m)                                                   
      end if                                                                              
!                                                                                         
! triatomic molecule                                                                      
      if((im(m).eq.1).and.(ih(m).eq.3)) then                                              
        q=pftri(m,t,tv,nprt)*factr(m)                                                     
      end if                                                                              
      parti=q                                                                             
      partf=q*qt                                                                          
      return                                                                              
      end                                                                                 
!**********************************************************************                   
      subroutine pH_air(iuse,presx,enthx, rhox,tempx)                                     
! from ebyrho and rho, determine pres, temp, and enth for air                             
! input parameters:                                                                       
!   iuse=0, initialization; =1, normal use;                                               
!     =2, for fixed pressure(iuse=1 must preceed)                                         
!   presx=pressure, Pascal                                                                
!   enthx=enthalpy, J/kg                                                                  
! output parameters:                                                                      
!   rhox=density, kg/m3                                                                   
!   tempx=temperature, K                                                                  
      implicit real*8(a-h,o-z)                                                            
      character*4 dum(25)                                                                 
      dimension pres(33),enth(29),rho(33,29),temp(33,29),                 &               
     &  rhoz(29),tempz(29)                                                                
      save                                                                                
!                                                                                         
! read data file if presx.eq.0                                                            
      if(iuse.eq.0) then                                                                  
        read(4,10) (dum(i),i=1,25)                                                        
        read(4,10) (dum(i),i=1,25)                                                        
  10    format(25a4)                                                                      
        do ip=1,33                                                                        
          do ih=1,29                                                                      
            read(4,20) pres(ip),enth(ih),rho(ip,ih),temp(ip,ih)                           
  20        format(10x,4e12.4)                                                            
            rho(ip,ih)=dlog(rho(ip,ih))                                                   
            temp(ip,ih)=dlog(temp(ip,ih))                                                 
          end do                                                                          
        end do                                                                            
        do ip=1,33                                                                        
          pres(ip)=dlog(pres(ip))                                                         
        end do                                                                            
        do ih=1,29                                                                        
          enth(ih)=dlog(enth(ih))                                                         
        end do                                                                            
        return                                                                            
      end if                                                                              
 !                                                                                        
      presy=dlog(presx)                                                                   
      enthy=dlog(enthx)                                                                   
      if(iuse.eq.1) then                                                                  
        mon=0                                                                             
        do ih=1,29                                                                        
          call taint(pres(1),rho(1,ih),presy,rhoz(ih),33,2,ier,mon)                       
          call taint(pres(1),temp(1,ih),presy,tempz(ih),33,2,ier,mon)                     
        end do                                                                            
      end if                                                                              
      mon=0                                                                               
      call taint(enth(1),rhoz(1),enthy,rhox,29,2,ier,mon)                                 
      rhox=exp(rhox)                                                                      
      call taint(enth(1),tempz(1),enthy,tempx,29,2,ier,mon)                               
      tempx=exp(tempx)                                                                    
      return                                                                              
      end                                                                                 
!***********************************************************************
      subroutine pH_ivu(iuse,presx,enthx, rhox,tempx)
! from p and H, determine rho and T for H-chondrite
! input parameters:
!   iuse=0, initialization; =1, normal use; 
!   presx=pressure, Pascal
!   enthx=enthalpy, J/kg
! output parameters:
!   rhox=density, kg/m3
!   tempx=temperature, K
      implicit real*8(a-h,o-z)
      common/eqivu/rho_ivu(11),t_ivu(11),h_ivu(11)     
      dimension temp(11),enth(11),rho(11)                                      
      save
      if(iuse.eq.0) then
        do itemp=1,11
          enth(itemp)=dlog(h_ivu(itemp))
          rho(itemp)=dlog(rho_ivu(itemp))
        end do
      end if
!
      enthy=dlog(enthx)
      mon=0
      call taint(enth(1),rho(1),enthy,rhox,11,2,ier,mon)
      rhox=dexp(rhox)
      call taint(enth(1),t_ivu(1),enthy,tempx,11,2,ier,mon)
      return
      end
!***********************************************************************
      subroutine precurs(mwave,nwave,int_s,qps, rhoinf,vinf,rnose,             &
  &     flux_s,flux_prec,int_prec)
! input parameters:
!   nwave
!   rhoinf
!   vinf
!   rnose
!   int_s(10,nw)=angle_specific intensity, W/(cm2-mic-sr)
!   qps=radiation flux emanating from shock wave, W/m2
! output parameters
!   mwave=wavelength index for 1750 A
!   flux_s=radiative flux at shock calculated in this subroutine, W/m2
!   flux_prec=radiative flux at end of precursor region, W/m2
!   int_prec(nw)=normal intensity at the end of precursor region, W/(cm2-mic-sr)
!
      parameter(nw=400000)
      implicit real*8(a-h,o-z)
      dimension ang(11),flux(1091),r(1091),q(1091),h(1091),temp(1091)
      dimension int_s(10,nw),int_prec(nw)         
      real*8 int_s,int_new,int_old,intw,int_e,int_prec
      dimension wavprec(171),croslog(171)
      common /spcdat/ eltbl(8,2),    sptbl(9,32),   fln(8,32),            &               
     &                tdc(8,32,4),   spm(32),                             &               
     &                        ne,            ns,                          &               
     &                itchm,         ioutch,        elms(8)        
      dimension elmsf(8),spmlf(32),ansp(32)
      common/scratch/int_new(nw),int_old(nw)
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      character*4 spnm(9)                       
      common/lowdens/ntlow
      common/lowdens1/templ(11),enthl(11)
      dimension cos1(11),sin2(11),bint(11)
      data pi/3.141592/,itime/0/
      data spnm/'O   ','N   ','O2  ','N2  ','NO  ','O+  ','N+  ','NO+ ','E-  '/  
!
! wavelength of absorption cross section for air at room temperature
      data wavprec/                                                    &
  &       50.0,    60.0,    70.0,    80.0,    90.0,   100.0,   110.0,  &
  &      120.0,   130.0,   140.0,   150.0,   160.0,   170.0,   180.0,  &
  &      190.0,   200.0,   210.0,   220.0,   230.0,   240.0,   250.0,  &
  &      260.0,   270.0,   280.0,   290.0,   300.0,   310.0,   320.0,  &
  &      330.0,   340.0,   350.0,   360.0,   370.0,   380.0,   390.0,  &
  &      400.0,   410.0,   420.0,   430.0,   440.0,   450.0,   460.0,  &
  &      470.0,   480.0,   490.0,   500.0,   510.0,   520.0,   530.0,  &
  &      540.0,   550.0,   560.0,   570.0,   580.0,   590.0,   600.0,  &
  &      610.0,   620.0,   630.0,   640.0,   650.0,   660.0,   670.0,  &
  &      680.0,   690.0,   700.0,   710.0,   720.0,   730.0,   740.0,  &
  &      750.0,   760.0,   770.0,   780.0,   790.0,   800.0,   810.0,  &
  &      820.0,   830.0,   840.0,   850.0,   860.0,   870.0,   880.0,  &
  &      890.0,   900.0,   910.0,   920.0,   930.0,   940.0,   950.0,  &
  &      960.0,   970.0,   980.0,   990.0,  1000.0,  1010.0,  1020.0,  &
  &     1030.0,  1040.0,  1050.0,  1060.0,  1070.0,  1080.0,  1090.0,  &
  &     1100.0,  1110.0,  1120.0,  1130.0,  1140.0,  1150.0,  1160.0,  &
  &     1170.0,  1180.0,  1190.0,  1200.0,  1210.0,  1220.0,  1230.0,  &
  &     1240.0,  1250.0,  1260.0,  1270.0,  1280.0,  1290.0,  1300.0,  &
  &     1310.0,  1320.0,  1330.0,  1340.0,  1350.0,  1360.0,  1370.0,  &
  &     1380.0,  1390.0,  1400.0,  1410.0,  1420.0,  1430.0,  1440.0,  &
  &     1450.0,  1460.0,  1470.0,  1480.0,  1490.0,  1500.0,  1510.0,  &
  &     1520.0,  1530.0,  1540.0,  1550.0,  1560.0,  1570.0,  1580.0,  &
  &     1590.0,  1600.0,  1610.0,  1620.0,  1630.0,  1640.0,  1650.0,  &
  &     1660.0,  1670.0,  1680.0,  1690.0,  1700.0,  1710.0,  1720.0,  &
  &     1730.0,  1740.0,  1750.0/
!
! log10 of absorption cross section of air at room temperature
      data croslog/                                                    &
  &   -18.5627,-18.4086,-18.2624,-18.1245,-17.9951,-17.8741,-17.7896,  &
  &   -17.7059,-17.6228,-17.5400,-17.4572,-17.3989,-17.3424,-17.2877,  &
  &   -17.2347,-17.1835,-17.1456,-17.1087,-17.0730,-17.0384,-17.0050,  &
  &   -16.9765,-16.9490,-16.9227,-16.8976,-16.8737,-16.8568,-16.8402,  &
  &   -16.8239,-16.8079,-16.7922,-16.7764,-16.7609,-16.7457,-16.7308,  &
  &   -16.7163,-16.6990,-16.6828,-16.6675,-16.6533,-16.6401,-16.6279,  &
  &   -16.6168,-16.6067,-16.5976,-16.5896,-16.5857,-16.5820,-16.5787,  &
  &   -16.5757,-16.5730,-16.5736,-16.5745,-16.5758,-16.5774,-16.5793,  &
  &   -16.5727,-16.5690,-16.5688,-16.5726,-16.5809,-16.5840,-16.5920,  &
  &   -16.6048,-16.6220,-16.6432,-16.6570,-16.6700,-16.6804,-16.7915,  &
  &   -16.8218,-16.8498,-16.8740,-16.9150,-16.9546,-16.9921,-17.3619,  &
  &   -17.5158,-17.6697,-17.7215,-17.7732,-17.8249,-17.8767,-17.9284,  &
  &   -17.9802,-18.0319,-18.0772,-18.1224,-18.1677,-18.2130,-18.2583,  &
  &   -18.3035,-18.3488,-18.3941,-18.4394,-18.4846,-18.5661,-18.6476,  &
  &   -18.7291,-18.8106,-18.8921,-18.8993,-18.9066,-18.9138,-18.9210,  &
  &   -18.9283,-18.9364,-18.9446,-18.9527,-18.9609,-18.9690,-18.9772,  &
  &   -18.9853,-18.9935,-19.0016,-19.0098,-19.0234,-19.0369,-19.0505,  &
  &   -19.0641,-19.0777,-19.0913,-19.1048,-19.1184,-18.9977,-18.9192,  &
  &   -18.7418,-18.5643,-18.3868,-18.2094,-18.0319,-17.9196,-17.8074,  &
  &   -17.6951,-17.5828,-17.4705,-17.4597,-17.4488,-17.4379,-17.4271,  &
  &   -17.4162,-17.4488,-17.4814,-17.5140,-17.5466,-17.5792,-17.6118,  &
  &   -17.6444,-17.6770,-17.7096,-17.7422,-17.8001,-17.8581,-17.9160,  &
  &   -17.9740,-18.0319,-18.0953,-18.1587,-18.2220,-18.2854,-18.3488,  &
  &   -18.4122,-18.4756,-18.5389,-18.6023,-18.6657,-18.9699,-19.2742,  &
  &   -19.5784,-19.8826,-20.1868/
!
      WRITE(*,*) ' '
      WRITE(*,*) ' IN PRECURS'
!
! write out int_s
      write(6,*) ' '
      write(6,67) qps
   67 format(' qps(radiative flux at shock wave) = ',1pe10.3,' W/m2') 
      write(6,*) ' normal intensity entering precursor region'
      write(6,62)
   62 format('       iw      wavel     int_s   cros_sec')
      iprint=101
      mon=0
      do iw=1,nwave
        cros=0.
        if(wavel(iw).lt.1750) then
          call taint(wavprec,croslog,wavel(iw),crosl,171,2,ier,mon)
          cros=10.**crosl                    ! absorption cross section, cm2
        end if
        iprint=iprint+1
        if(iprint.ge.100) then
          write(6,61) iw,wavel(iw),int_s(1,iw),cros
   61     format(i10,f10.2,1p3e11.3)
          iprint=0
        end if
      end do
!
! number density of freestream
      aninf=rhoinf*(6.0223e23/0.028855)*1.0e-6              ! cm-3
!
! freestream pressure
      pinf=(8.3144/0.028854)*rhoinf*298.                    ! Pa
      patm=pinf/1.0133e5                                    ! atm
!
! freestream enthalpy
      hinf=3.0053e5                                         ! J/kg
!
! rnose in cm
      rnose1=rnose*100.
!
! find iw for 1750 A
      do iw=1,nwave
        if(wavel(iw).gt.1750.) go to 10
      end do
   10 mwave=iw-1
      write(6,20) mwave
   20 format(' mwave=',i6)
!
! flux contained below 1750 A in int_s(10,iw)
      do iang=1,11
        ang(iang)=(iang-1)*0.5*pi/10.
        cos1(iang)=1./dcos(ang(iang))
        sin2(iang)=dsin(2.*ang(iang))
      end do
      bint(1)=0.; bint(11)=0.
!
! flux below 1750 A in int_s
      flux0=0.                    ! flux in int_s below 1750 A, W/m2
      do iw=2,mwave
        delw=wavel(iw)-wavel(iw-1)
        do iang=1,10
          bint(iang)=pi*sin2(iang)*int_s(iang,iw)
        end do
        call simp(qlam,ang,bint,11,ier)
        flux0=flux0+qlam*delw   ! flux in int_s below 1750 A, W/m2
      end do
      write(6,50) flux0
   50 format(' flux0(flux below 1750 A)=',1pe10.3,' W/m2')
!
! flux below 1750 A in int_s normal assuming solid angle of pi
      flux1=0.
      do iw=2,mwave
        delw=wavel(iw)-wavel(iw-1)
        flux1=flux1+pi*int_s(1,iw)*delw
      end do
      s_ratio=flux0/flux1
      write(6,60) flux1,s_ratio
   60 format(                                                               &
  &     ' flux1(calculated from normal with solid angle of pi)=',1pe11.4/   &
  &     ' flux0/flux1                                         =',e11.4)
!
! carry out radiative transfer calc until flux drops to 1% of flux0
!
! number of grids
      ngrid=1000
! 
! prepare grid in a radial direction in half-space
      dr1=0.5e17/aninf                                ! step size, cm
      dr=0.01*dr1                                     ! step size, m
      do igrid=1,ngrid
        r(igrid)=dr*(igrid-1)
      end do
!
! outward irradiation
! 
! set initial value for int_old and flux
      flux(1)=0.
      do iw=1,nwave
        int_old(iw)=int_s(1,iw)
      end do
!
! radiative transfer below 1750 A
      write(6,*) ' '
      write(6,*) ' radiative transfer below 1750 A.'
      write(6,*) ' igrid      r(m)   flux(w/m2)'
      igrid=1
      r0=0.
      temp0=298.
      write(6,44) igrid,r0,flux0
      mon=0
      do igrid=2,ngrid
        flux(igrid)=0.
        do iw=2,mwave
          delw=wavel(iw)-wavel(iw-1)
          call taint(wavprec,croslog,wavel(iw),crosl,171,2,ier,mon)
          cros=10.**crosl                                ! absorption cross section, cm2
          absb=cros*aninf
          tau=absb*dr1
          expx=dexp(-tau)
          ax=dexp(-1.43877d0*1.0d8/(wavel(iw)*temp0))
          blam=1.1904d-16*ax/((1.0d-8*wavel(iw))**5*(1.d0-ax))          ! W/(cm2-mic-sr)
!            int_new(iw)=blam*(1.0-expx)+int_old(iw)*expx               ! W/(cm2-mic-sr)
!
! expanding flow
          tau1=((2./(100.*rnose))*dsqrt(int_old(iw)/int_s(1,iw))           &
  &         + absba)*dr*100.                                            ! cm-1
          exp1=dexp(-tau1)
          int_new(iw)=absba*blam*(1./tau1-exp1/tau1) + int_old(iw)*exp1 
!
          flux(igrid)=flux(igrid)+s_ratio*pi*int_new(iw)*delw    ! W/m2                
          int_old(iw)=int_new(iw)
        end do
        write(6,44) igrid,r(igrid),flux(igrid)
   44   format(i7,f11.5,1pe11.3)
!
! find the end point of nearly-total absorption(5%) below 1750 A
        flux_rat=flux(igrid)/flux0
        if(flux_rat.lt.0.10) go to 30
      end do
   30 continue
! the r-value is the precursor thickness
      prec_th=r(igrid)                               ! precursor region thickness, m
      write(6,*) ' precursor thickness=',prec_th
      mgrid=igrid                                    ! precursor edge node
!
! energy source
      q(1)=0.; q(2)=0.
      do igrid=3,mgrid-1
        q(igrid)=(flux(igrid+1)-flux(igrid-1))/(2.*dr)          ! rad source, W/m3
      end do  
      q(2)=2.*q(3) - q(4)                           ! correct first and last values
      q(1)=q(2) - (q(3)-q(2))  
      q(mgrid)=2.*q(mgrid-1) - q(mgrid-2)   
! 
! enthalpy increase due to rad source q
      h(mgrid)=hinf
      write(6,*) ' '
      write(6,*) ' enthalpy in precursor region raised by absorption'
      write(6,*) ' igrid     r(m)     q(J/m3)  enth(J/kg)'
      write(6,40) igrid,r(mgrid),q(mgrid),h(mgrid)
      do igrid=mgrid-1,1,-1
        dh=(q(igrid+1)/(rhoinf*vinf))*dr                          ! J/kg
        h(igrid)=h(igrid+1)+dabs(dh)
        write(6,40) igrid,r(igrid),q(igrid),h(igrid)
   40   format(i7,f11.5,1pe11.3,1p3e11.4)
      end do
!
! radiative transfer of wavelengths above 1750 A
!
! starting flux above 1750 A
      flux_a=0.
      do iw=mwave,nwave
        delw=wavel(iw)-wavel(iw-1)
        flux_a=flux_a+1.5*pi*int_s(1,iw)*delw
      end do
      write(6,80) flux_a
   80 format(/' at shock, flux above 1750 A =',1pe11.4,' W/m2')
!
! radiative transfer
      iprb=2
      elmsf(1)=0.233; elmsf(2)=0.767
      do iw=mwave,nwave
        int_new(iw)=int_s(1,iw)
        int_old(iw)=int_new(iw)
      end do

      do iw=mwave,nwave
        int_old(iw)=int_s(1,iw)
      end do
      flux(1)=flux_a
      write(6,70)
   70 format(/' flux in precursor region above 1750 A'/                 &
  &     ' igrid    r(m)       temp   flux(W/m2)')
      zero=0.; ione=1; temp(1)=6000.
      call kmeqm(patm,temp(1),h(1),iprb,elmsf,spmlf,brm,rho)
      write(6,71) temp(1),(spmlf(k),k=1,16)
   71 format(' first kmeqm finished. temp(1)=',f10.2/                   &
  &   ' spmlf='/(1p5e10.3))
      patm=patm*rhoinf/rho                                ! correction
      call kmeqm(patm,temp(1),h(1),iprb,elmsf,spmlf,brm,rho)
      write(*,*) ' correction kmeqm finished, temp(1)=',temp(1)
      write(6,90) ione,zero,temp(1),flux(1)
   90 format(i5,f11.5,f11.1,1pe11.4)
      do igrid=2,mgrid
        temp(igrid)=h(igrid)/1008.5                       ! temporary temperature
        if(temp(igrid).gt.800.) then
          call kmeqm(patm,temp(igrid),h(igrid),iprb,elmsf,spmlf,brm,rho)
          patm=patm*rhoinf/rho                            ! correction
          call kmeqm(patm,temp(igrid),h(igrid),iprb,elmsf,spmlf,brm,rho)
        end if        
        tinv=10000./temp(igrid)
        flux(igrid)=0.
! expanding flow
        mon=0
        do iw=mwave,nwave
          delw=wavel(iw)-wavel(iw-1)
! expanding flow
          if(temp(igrid).le.1500.) then
            int_new(iw)=int_old(iw)
            flux(igrid)=flux(igrid-1)
            int_old(iw)=int_new(iw)
          end if
          if(temp(igrid).gt.1500.) then
            call taint(txlow(1),absb_low(1,iw),tinv,absbx,ntlow,2,ier,mon)
            absba=dexp(absbx)                                  ! cm-1
            delr=(r(igrid)-r(igrid-1))*100.                               ! cm
            ax=dexp(-1.43877d0*1.0d8/(wavel(iw)*temp(igrid)))
            blam=1.1904d-16*ax/((1.0d-8*wavel(iw))**5*(1.d0-ax))          ! W/(cm2-mic-sr)
            tau=absba*delr*100.
            expx=dexp(-tau)
!            int_new(iw)=blam*(1.0-expx)+int_old(iw)*expx                  ! W/(cm2-mic-sr)
!
! expanding flow
            tau1=((2./(100.*rnose))*dsqrt(int_old(iw)/int_s(1,iw))           &
  &           + absba)*dr*100.                                            ! cm-1
            exp1=dexp(-tau1)
            int_new(iw)=absba*blam*(1./tau1-exp1/tau1) + int_old(iw)*exp1 
!
            flux(igrid)=flux(igrid)+2.0*pi*int_new(iw)*delw               ! W/m2
            int_old(iw)=int_new(iw)
          end if
        end do
        write(6,90) igrid,r(igrid),temp(igrid),flux(igrid)
      end do
      do iw=1,nwave
        if(iw.le.mwave) int_prec(iw)=0.
        if(iw.gt.mwave) int_prec(iw)=int_new(iw)
      end do
      flux_s=flux(1); flux_prec=flux(mgrid)     

      WRITE(*,*) ' GETTING OUT OF PRECURS'
      
      return
      end
!******************************************************************                   
      subroutine pT_air(iuse,presx,tempx, rhox,enthx,cp)                                  
! from p and T, determine rho and H for air                                               
! input parameters:                                                                       
!   iuse=0, initialization; =1, normal use;                                               
!     =2, for fixed pressure(iuse=1 must preceed)                                         
!   presx=pressure, Pascal                                                                
!   tempx=temperature, K                                                                  
! output parameters:                                                                      
!   rhox=density, kg/m3                                                                   
!   enthx=enthalpy, J/kg                                                                  
!   cp=dH/dT, J/(kg-K)                                                                    
      implicit real*8(a-h,o-z)                                                            
      character*4 dum(25)                                                                 
      dimension pres(29),temp(50),rho(29,50),enth(29,50),enthz(50),       &               
     &  rhoz(50),tempz(50)                                                                
      save                                                                                
!                                                                                         
! read data file if presx.eq.0                                                            
      if(iuse.eq.0) then                                                                  
        read(4,10) (dum(i),i=1,25)                                                        
        read(4,10) (dum(i),i=1,25)                                                        
  10    format(25a4)                                                                      
        do ip=1,29                                                                        
          do it=1,50                                                                      
            read(4,20) pres(ip),temp(it),rho(ip,it),enth(ip,it)                           
  20        format(10x,4e12.4)                                                            
            rho(ip,it)=dlog(rho(ip,it))                                                   
            enth(ip,it)=dlog(enth(ip,it))                                                 
          end do                                                                          
        end do                                                                            
        do ip=1,29                                                                        
          pres(ip)=dlog(pres(ip))                                                         
        end do                                                                            
        do it=1,50                                                                        
          temp(it)=dlog(temp(it))                                                         
        end do                                                                            
        return                                                                            
      end if                                                                              
 !                                                                                        
      presy=dlog(presx)                                                                   
      tempy=dlog(tempx)                                                                   
      if(iuse.eq.1) then                                                                  
        mon=0                                                                             
        do it=1,50                                                                        
          call taint(pres(1),rho(1,it),presy,rhoz(it),29,2,ier,mon)                       
          call taint(pres(1),enth(1,it),presy,enthz(it),29,2,ier,mon)                     
        end do                                                                            
      end if                                                                              
      mon=0                                                                               
      call taint(temp(1),rhoz(1),tempy,rhox,50,2,ier,mon)                                 
      rhox=exp(rhox)                                                                      
      call taint(temp(1),enthz(1),tempy,enthx,50,2,ier,mon)                               
      enthx=exp(enthx)                                                                    
      dtemp=0.02*tempx                                                                    
      temp1=dlog(tempx+dtemp)                                                             
      call taint(temp(1),enthz(1),temp1,enth1,50,2,ier,mon)                               
      enth1=exp(enth1)                                                                    
      temp2=dlog(tempx-dtemp)                                                             
      call taint(temp(1),enthz(1),temp2,enth2,50,2,ier,mon)                               
      enth2=exp(enth2)                                                                    
      cp=(enth1-enth2)/(2.*dtemp)                                                         
      return                                                                              
      end                                                                                 
!**********************************************************************
      subroutine pT_ivu(iuse,presx,tempx, rhox,enthx,cp)
! from p and T, determine rho, and enth for ablation product
! input parameters:
!   iuse=0, initialization; =1, normal use; 
!     =2, for fixed pressure(iuse=1 must preceed)
!   presx=pressure, Pascal
!   tempx=temperature, K
! output parameters:
!   rhox=density, kg/m3
!   enthx=enthalpy, J/kg
!   cp=dH/dT, J/(kg-K)
      implicit real*8(a-h,o-z)
      character*4 dum(25)
      common/eqivu/rho_ivu(11),t_ivu(11),h_ivu(11)                                           
      dimension temp(11),rho(11),enth(11)                              
      save
!
! read data file if presx.eq.0
      if(iuse.eq.0) then
        do itemp=1,11
          temp(itemp)=dlog(t_ivu(itemp))
          enth(itemp)=dlog(h_ivu(itemp))
          rho(itemp)=dlog(rho_ivu(itemp))
        end do
      end if
!
      tempy=dlog(tempx)
      mon=0
      call taint(temp(1),rho(1),tempy,rhox,11,2,ier,mon)
      rhox=dexp(rhox)
      mon=0
      call taint(temp(1),enth(1),tempy,enthx,11,2,ier,mon)
      enthx=dexp(enthx)
      dtemp=0.02*tempx
      temp1=dlog(tempx+dtemp)
      mon=0
      call taint(temp(1),enth(1),temp1,enth1,11,2,ier,mon)
      enth1=dexp(enth1)
      temp2=dlog(tempx-dtemp)
      call taint(temp(1),enth(1),temp2,enth2,11,2,ier,mon)
      enth2=dexp(enth2)
      cp=(enth1-enth2)/(2.*dtemp)
      return
      end
!**********************************************************************
      subroutine pT_vis_air(presx,tempx, viscx)
! from p and T, determine viscosity for air
! input parameters:
!   iuse=0, initialization; =1, normal use; 
!     =2, for fixed pressure(iuse=1 must preceed)
!   presx=pressure, Pascal
!   tempx=temperature, K
! output parameters:
!   viscx=density, MKS units
      implicit real*8(a-h,o-z)
      character*4 dum(25)
      dimension pres(25),temp(57),visc(25,57),viscz(57),tempz(57)
      save
!
! read data file if presx.eq.0
      if((presx.lt.1.).and.(tempx.lt.1.)) then
        read(4,10) (dum(i),i=1,25)
!        write(*,10) (dum(i),i=1,25)
  10    format(25a4)
        do ip=1,25
          do it=1,57
            read(4,20) pres(ip),temp(it),visc(ip,it)
!            write(*,20) pres(ip),temp(it),visc(ip,it)
  20        format(10x,4e12.4)
            visc(ip,it)=dlog(visc(ip,it))
          end do
        end do
        do ip=1,25
          pres(ip)=dlog(pres(ip))
        end do
        do it=1,57
          temp(it)=dlog(temp(it))
        end do
      end if
 !
      presy=dlog(presx)
      tempy=dlog(tempx)
      mon=0
      do it=1,57
        call taint(pres(1),visc(1,it),presy,viscz(it),25,2,ier,mon)
      end do
      mon=0
      call taint(temp(1),viscz(1),tempy,viscx,57,2,ier,mon)
      viscx=dexp(viscx)
      return
      end
!**********************************************************************                   
      function pftri(m,t,tv,nprt)                                                         
! partition function for triatomic molecule                                               
! inputs:                                                                                 
!   m=species index                                                                       
!   t=translational-rotational temperature                                                
!   tv=vibrational temperature                                                            
!   nprt=printing index                                                                   
      parameter(msp=60)                                                                   
      implicit real*8(a-h,o-z)                                                            
      common/eqcoma/elemwt(15),                                           &               
     & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp),            &               
     & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp),             &               
     & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp),                     &               
     & akb(5,msp),akd(5,msp),avmw0                                                        
      common/eqcomb/elemnm(12)                                                            
      common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc,  &               
     & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp),   &               
     & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp)                        
      character*4 elemnm,spnm                                                             
!      factr(i)=rotational factor (1 for hetero, 0.5 for homo)                            
!      spect(1,1,jsp)=1st vibrational multiplicity                                        
!      spect(1,2,jsp)=1st vibrational constant, cm-1                                      
!      spect(2,1,jsp)=2nd vibrational multiplicity                                        
!      spect(2,2,jsp)=2nd vibrational constant, cm-1                                      
!      spect(3,1,jsp)=3rd vibrational multiplicty                                         
!      spect(3,2,jsp)=3rd vibrational constant, cm-1                                      
!      spect(4,1,jsp)=ground state electronic multiplicity                                
!      spect(5,1,jsp)=1st bond distance, angstrom                                         
!      spect(5,2,jsp)=2nd bond distance, angstrom                                         
!      spect(6,1,jsp)=bond angle, degrees                                                 
!      spect(7,1,jsp)=moment of inertia, g3-cm6                                           
!      spect(7,2,jsp)=B, cm-1                                                             
      g1=spect(1,1,m)                                                                     
      ev1=spect(1,2,m)                                                                    
      g2=spect(2,1,m)                                                                     
      ev2=spect(2,2,m)                                                                    
      g3=spect(3,1,m)                                                                     
      ev3=spect(3,2,m)                                                                    
      ge=spect(4,1,m)                                                                     
      angle=spect(6,1,m)                                                                  
      ai=spect(7,1,m)                                                                     
      B=spect(7,2,m)                                                                      
!                                                                                         
! vibration                                                                               
      qv1=g1/(1.-exp(-1.4388*ev1/tv))                                                     
      qv2=g2/(1.-exp(-1.4388*ev2/tv))                                                     
      qv3=g3/(1.-exp(-1.4388*ev3/tv))                                                     
      qv=qv1*qv2*qv3                                                                      
!                                                                                         
! rotation                                                                                
      if(angle.gt.179.) qr=t/(1.4388*b)                                                   
!      if(angle.le.179.) qr=t**1.5*sqrt(ai)/((1.4388*2.7994e-39)**1.5)                    
! formula requiring ai*1.e100 in the place of ai, for a machine of low ceiling            
      if(angle.le.179.) qr=t**1.5*sqrt(ai/(1.4388*2.7994e1))/             &               
     & (1.4388*2.7994e-10)                                                                
!                                                                                         
! total                                                                                   
      pftri=ge*qv*qr                                                                      
!      write(6,10) m,t,qv,qr,pftri                                                        
   10 format(' pftri. m,t,qv,qr,pftri=',i2,1p4e10.3)                                      
      return                                                                              
      end                                                                                 
!**********************************************************************                   
      function qevr(m,t,tv,te,nprt)                                                       
      parameter(msp=60)                                                                   
      implicit real*8(a-h,o-z)                                                            
      common/eqcoma/elemwt(15),                                           &               
     & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp),            &               
     & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp),             &               
     & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp),                     &               
     & akb(5,msp),akd(5,msp),avmw0                                                        
      common/eqcomb/elemnm(12)                                                            
      common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc,  &               
     & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp),   &               
     & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp)                        
      common/eqcome/kmaxvV(msp,25,100),maxv(msp,25),vV(msp,25,100)                        
      character*4 elemnm,spnm                                                             
!                                                                                         
      if(iv(m).gt.0) go to 5                                                              
      call jmax(m)                                                                        
      nst1=nelec(m)                                                                       
      do 60 ist1=1,nst1                                                                   
      maxv1=maxv(m,ist1)                                                                  
      if(nprt.gt.2) write(6,90) m,ist1                                                    
   90 format(' m=',i3,' kmax for electronic state ',i2)                                   
      if(nprt.gt.2) write(6,70) (kmaxvv(m,ist1,maxv2),maxv2=1,maxv1)                      
   70 format(16i5)                                                                        
   60 continue                                                                            
!                                                                                         
   5  q=0.                                                                                
      n=nelec(m)                                                                          
      do 30 ie1=1,n                                                                       
      degen=spect(1,ie1,m)                                                                
      term=spect(2,ie1,m)                                                                 
      if(ie1.ne.1) goto 50                                                                
      term1=term                                                                          
      dele1=vv(m,1,1)                                                                     
  50  dele=vv(m,ie1,1)                                                                    
      ee=term+dele-term1-dele1                                                            
      qe=degen*dexp(-1.43877*ee/te)                                                       
      nv=maxv(m,ie1)                                                                      
      if(nv.eq.0) goto 30                                                                 
      qvr=0.                                                                              
      do 20 i=1,nv                                                                        
      v=i-1                                                                               
      ev=vv(m,ie1,i)-dele                                                                 
      qv=dexp(-1.43877*ev/tv)                                                             
      bv=spect(8,ie1,m)-spect(9,ie1,m)*(v+.5)                                             
      dv=spect(10,ie1,m)+spect(11,ie1,m)*(v+.5)                                           
      nr=kmaxvv(m,ie1,i)                                                                  
      qr=0.                                                                               
      do 10 ir=1,nr                                                                       
      k=ir-1                                                                              
      kk1=k*(k+1)                                                                         
      er=bv*kk1-dv*kk1**2                                                                 
      if((er.gt.0.).and.(er.lt.100000))                                   &               
     &  qr=qr+(2*k+1.)*dexp(-1.43877*er/t)                                                
  10  continue                                                                            
      qvr=qvr+qv*qr                                                                       
  20  continue                                                                            
      q=q+qe*qvr                                                                          
  30  continue                                                                            
      qevr=q                                                                              
      return                                                                              
      end                                                                                 
!***********************************************************************************      
      subroutine radipac(nprt,natoms,ndiatoms,method,tblack,    &               
     &  rnose,rangex,nwavex,tran,trot,tvib,tele,      &               
     &   concAl,concAlp,concAlpp,concAl3p,            &
     &   concC, concC2,                               &
     &   concCa,concCap,concCl,concC2H,               &
     &   concC3,concCH, concCN,concCO,                &
     &   concCO2,concCp, concCpp,concC3p,             &
     &   concC4p,concCr,concCrp,concCrpp,             &
     &   concFe,concFeO,concFep,concFepp,             &
     &   concFe3p,concFe4p,concFe5p,concH,            &
     &   concH2, concHp,concH2O,concK,                &
     &   concMg, concMgO,concMgp,concMgpp,            &
     &   concMg3p,concMg4p,concN,concNE,              &
     &   concN2,concN2p,concNp,concNpp,               &
     &   concN3p,concN4p,concNa,concNap,              &
     &   concNO,concNi,concNip,concNipp,              &
     &   concNi3p,concO,concO2,concOH,                &
     &   concOp,concOpp,concO3p,concO4p,              &
     &   concS,concSi,concSO,concSiO,                 &
     &   concSip,concSipp,concSi3p,concSi4p,          &
     &   concSp,concSpp,concS3p,concS4p,              &
     &   concSiH,concTi,concTip,concTipp,             &
     &   concTi3p,concTiO,                            &               
     &   avg_molwt)                                              

! radiation package main program                                                                                      
! input parameters:                                                                       
!   z(mnode) = geometrical distance, m                                                    
!   method=1: Uniform slab (nnode = 1). Emission power and normal intensity               
!             calculated. 1.5 million words typ for spectrum for 0.5 million              
!             wavelength points.  Needs 'depth' in cm, and 'nnode' must be 1.             
!   tblack(2) = temperature of black body incident on gas.                                
!      for method = 4,5, and 6,  (1) is at wall, (2) is at free stream                    
!   atom_rads(3,168) specifies atom radiation calculation                                 
!   diatom_bands(3,100) specifies molecular band calculation                              
!   tran(mnnode) = translational temperature, K                                           
!   trot(mnode) = rotational temperature, K                                               
!   tvib(mnode) = vibrational temperature, K                                              
!   tele(mnode) = electron temperature, K                                                 
!   concC,concC2,concC2H,concC3,concCH,concCN,concCO,concCp,concH,concH2,concHp,          
!     concN,concN2,concN2p,concNE,concNO,concNp,concO,concO2,concOH,concOp                
!     = species concentration in m-3 for C, C2, C2H, --- etc                              
!   avg_molwt(mnode) = average molecular weight, g/mol                                    
!                                                                                         
      parameter (nw=400000)                                                               
      parameter(matoms=56,mdiatoms=12,mtriatoms=6,mnode=1,msp=60)                                
      implicit real*8(a-h,o-z)                                                            
      character*4 blank4,count4,blank2,count2                                             
      character*4 asterik,atomnm2(matoms),bandnm_diatom,                  &
     &    minus1,unknown                              
      character*4 atom_rads(3,168),diatom_bands(3,100),                   &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                     &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                         &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/coma/absb(nw)                                                      
      dimension                                                           &
     & concAl(mnode),concAlp(mnode),concAlpp(mnode),concAl3p(mnode),      &
     &  concC(mnode), concC2(mnode),                                      &
     & concCa(mnode),concCap(mnode),concCl(mnode),concC2H(mnode),         &
     & concC3(mnode),concCH(mnode), concCN(mnode),concCO(mnode),          &
     & concCO2(mnode),concCp(mnode), concCpp(mnode),concC3p(mnode),       &
     & concC4p(mnode),concCr(mnode),concCrp(mnode),concCrpp(mnode),       &
     & concFe(mnode),concFeO(mnode),concFep(mnode),concFepp(mnode),       &
     & concFe3p(mnode),concFe4p(mnode),concFe5p(mnode),concH(mnode),      &
     & concH2(mnode), concHp(mnode),concH2O(mnode),concK(mnode),          &
     & concMg(mnode), concMgO(mnode),concMgp(mnode),concMgpp(mnode),      &
     & concMg3p(mnode),concMg4p(mnode),concN(mnode),concNE(mnode),        &
     & concN2(mnode),concN2p(mnode),concNp(mnode),concNpp(mnode),         &
     & concN3p(mnode),concN4p(mnode),concNa(mnode),concNap(mnode),        &
     & concNO(mnode),concNi(mnode),concNip(mnode),concNipp(mnode),        &
     & concNi3p(mnode),concO(mnode),concO2(mnode),concOH(mnode),          &
     & concOp(mnode),concOpp(mnode),concO3p(mnode),concO4p(mnode),        &
     & concS(mnode),concSi(mnode),concSO(mnode),concSiO(mnode),           &
     & concSip(mnode),concSipp(mnode),concSi3p(mnode),concSi4p(mnode),    &
     & concSp(mnode),concSpp(mnode),concS3p(mnode),concS4p(mnode),        &
     & concSiH(mnode),concTi(mnode),concTip(mnode),concTipp(mnode),       &
     & concTi3p(mnode),concTiO(mnode),                                    &               
     & z(mnode),tran(mnode),trot(mnode),tvib(mnode),tele(mnode),          &               
     & tblack(2),avg_molwt(mnode)                                                         
      common/heavy_imp/collid_dens(6)                                                     
      common/comi/nwave                                                                   
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e
      common/spect/calpha,slope_ratio,wavmin,wavmax,range                                              
!                                                                                         
      data blank2/'    '/,blank4/'    '/,itime/0/                                         
      write(6,*) ' In radipac'                                                            
!                                                                                         
! set common parammeters                                                                  
      nwave=nwavex; range=rangex; method=1; avg_molwt(1)=15.; inode = 1                                                                         
      itime=1                                                                             
!                                                                                         
! initialize wavelength array. square root-spaced energy intervals                            
! wavelength in angstroms                                                                  
      do  m=1,nwave                                                                       
        wavel(m)=wavmin+(wavmax-wavmin)*(float(m)/float(nwave))**calpha
!        wavel(m)=1.0d0/(1.0d0/dsqrt(wavmin)-estep*(m-1))**2                                         
      end do                                                                              
!                                                                                         
! initiate emission coef, absorption coef, and intensity arrays                           
        do m=1,nwave                                                                      
          absb(m) = 1.0d-30                                     ! absorption coef         
        end do                                                                            
!                                                                                         
        write(6,*) ' '                                                                    
!                                                                                         
! emission and absorption coefs                                                           
!
        write(*,*) ' calling emis_absb'
        write(6,*) ' calling emis_absb'
        call emis_absb(nprt,natoms,ndiatoms,ntriatoms, &               
     &    inode,tran,trot,tvib,tele,                   &               
     &   concAl,concAlp,concAlpp,concAl3p,             &
     &   concC, concC2,                                &
     &   concCa,concCap,concCl,concC2H,                &
     &   concC3,concCH, concCN,concCO,                 &
     &   concCO2,concCp, concCpp,concC3p,              &
     &   concC4p,concCr,concCrp,concCrpp,              &
     &   concFe,concFeO,concFep,concFepp,              &
     &   concFe3p,concFe4p,concFe5p,concH,             &
     &   concH2, concHp,concH2O,concK,                 &
     &   concMg, concMgO,concMgp,concMgpp,             &
     &   concMg3p,concMg4p,concN,concNE,               &
     &   concN2,concN2p,concNp,concNpp,                &
     &   concN3p,concN4p,concNa,concNap,               &
     &   concNO,concNi,concNip,concNipp,               &
     &   concNi3p,concO,concO2,concOH,                 &
     &   concOp,concOpp,concO3p,concO4p,               &
     &   concS,concSi,concSO,concSiO,                  &
     &   concSip,concSipp,concSi3p,concSi4p,           &
     &   concSp,concSpp,concS3p,concS4p,               &
     &   concSiH,concTi,concTip,concTipp,              &
     &   concTi3p,concTiO,                             &               
     &   avg_molwt)                                                        

      itime=itime+1
      write(*,*) ' '
      write(*,*) ' out of emis_absb'
      write(6,*) ' '
      write(6,*) ' out of emis_absb'
!  
      return                                                                              
      end                                                                                 
!*************************************************************************
      subroutine root (fun,r,a,bl,bu,ep,e2,i)                                   
!root      sorensen, emc.  modification made feb. 1963 to modify way    root0010
!     second guess at root is made.                                     root0020
!                                                                       root0040
!     argument list-                                                    root0050
!              fun-function subprogram name.                            root0060
!              r  -argument of subprogram and value of root.            root0070
!              a  -initial guess at root                                root0080
!              bl -lower bound on root                                  root0090
!              bu -upper bound on root                                  root0100
!              ep -epsilon test for function - if fun(r) (absolute      root0110
!                      value) is less than or equal to ep, i=1 and      root0120
!                      return.                                          root0130
!              e2 -epsilon test on root approximation. if ratio of diff-root0140
!                      erence of successive approximations to current   root0150
!                      approximation is less than e2 in absolute value, root0160
!                      i=1 and return.                                  root0170
!              i   -error code =1 for normal return                     root0180
!                                                                       root0190
!                                                                       root0200
      implicit real*8(a-h,o-z)
      dimension x(3),fx(3)                                                      
!     dimension x(3),fx(3)                                              root0220
      g=a                                                                       
      isp=0                                                                     
!     test for lower bound on root less than upper bound                root0250
      if (bl-bu) 1,2,2                                                          
!     if not, error code i=3. return.                                   root0270
    2 i=3                                                                       
      return                                                                    
!     test for guess outside bounds.                                    root0300
    1 if (g-bl) 9,7,8                                                           
    8 if (g-bu) 6,7,9                                                           
!     if yes, error code i=2 and return.                                root0330
    9 i=2                                                                       
      return                                                                    
!     if guess=lower bound, compute guess=0.5*(bu+bl)                   root0360
    7 g=(bl+bu)/2.0                                                             
    6 gl=bl+0.1*(g-bl)                                                          
      gu=bu-0.1*(bu-g)                                                          
   80 r=g                                                                       
      fg=fun(g)                                                                 
      if (abs(fg)-ep) 13,13,32                                                  
   10 if (abs(fx(i1))-ep) 13,13,17                                              
   13 i=1                                                                       
      return                                                                    
!
   17 i1=i1                                                                     
      if (fx(i1)) 18,18,19                                                      
   18 if (fx(i2)) 20,20,21                                                      
   20 im=1                                                                      
      go to 23                                                                  
   19 if (fx(i2)) 24,24,22                                                      
   22 im=0                                                                      
      go to 23                                                                  
   21 ip=i2                                                                     
      im=i1                                                                     
      go to 25                                                                  
   24 ip=i1                                                                     
      im=i2                                                                     
      go to 25                                                                  
!
   23 do 26 ic1=1,20                                                            
!     root has not been bracketed. use successive approximations.       root0610
      t=fx(i2)-fx(i1)                                                           
      if (abs(t)-0.01*ep) 27,27,28                                              
   27 if (x(i1)-x(i2)) 14,12,14                                                 
   12 i=4                                                                       
      return                                                                    
!
   14 x(if)=0.5*(x(i1)+x(i2))                                                   
      r=x(if)                                                                   
      go to 33                                                                  
!
   28 x(if)=x(i2)-(x(i2)-x(i1))/t*fx(i2)                                        
      r=x(if)                                                                   
      if (x(if)) 63,64,63                                                       
   63 if (abs((x(if)-x(i2))/x(if))-e2    ) 34,34,65                             
   64 if (abs(x(if)-x(i2))-e2    ) 34,34,65                                     
   34 fx(if)=fun(x(if))  
      i=1
      return                                                       
!
   65 continue                                                                  
   29 if (bl-x(if)) 31,31,32                                                    
   31 if (x(if)-bu) 33,33,32                                                    
   33 fx(if)=fun (x(if))                                                        
      if (abs(fx(if))-ep) 13,13,35                                              
   35 if (fx(if)) 36,13,37                                                      
   36 if (im) 38,38,39                                                          
   38 ip=i2                                                                     
      im=if                                                                     
      if=i1                                                                     
      go to 25                                                                  
   37 if (im) 39,39,40                                                          
   40 ip=if                                                                     
      im=i2                                                                     
      if=i1                                                                     
      go to 25                                                                  
   39 i1=i1+1                                                                   
      i2=i2+1                                                                   
      if=if+1                                                                   
      go to (42,42,43,44),if                                                    
   42 i2=1                                                                      
      go to 26                                                                  
   43 i1=1                                                                      
      go to 26                                                                  
   44 if=1                                                                      
   26 continue                                                                  
!
   32 isp=isp+1                                                                 
      i1=1                                                                      
      i2=2                                                                      
      if=3                                                                      
      x(i2)=g                                                                   
      fx(i2)=fg                                                                 
      go to (47,48,49,50,51,69,70),isp                                          
   47 x(i1)=gl                                                                  
      r=gl                                                                      
      fgl=fun(r)                                                                
      fx(i1)=fgl                                                                
      go to 10                                                                  
   48 x(i1)=gu                                                                  
      r=gu                                                                      
      fgu=fun(r)                                                                
      fx(i1)=fgu                                                                
      go to 10                                                                  
   49 x(i2)=gl                                                                  
      fx(i2)=fgl                                                                
      g2=0.5*(g+bl)                                                             
   71 x(i1)=g2                                                                  
      r=g2                                                                      
      fg2=fun(r)                                                                
      fx(i1)=fg2                                                                
      go to 10                                                                  
   50 x(i1)=g2                                                                  
      fx(i1)=fg2                                                                
      go to 17                                                                  
   51 g2=0.5*(g+bu)                                                             
      go to 71                                                                  
   69 x(i1)=gu                                                                  
      fx(i1)=fgu                                                                
      x(i2)=g2                                                                  
      fx(i2)=fg2                                                                
      go to 17                                                                  
   70 i=5                                                                       
      return                                                                    
!
   25 do 52 ic=1,50                                                             
!     root has been bracketed. use approximations on each side.         root1410
      x(if)=x(ip)-(x(ip)-x(im))/(fx(ip)-fx(im))*fx(ip)                          
      r=x(if)                                                                   
      if (x(if)) 61,62,61                                                       
   61 if (abs((x(if)-x(ip))/x(if))-e2    ) 134,134,67                             
   67 if (abs((x(if)-x(im))/x(if))-e2    ) 134,134,53                             
   62 if (abs(x(if)-x(ip))       -e2    ) 134,134,68                              
   68 if (abs(x(if)-x(im))       -e2    ) 134,134,53  
  134 fx(if)=fun(x(if))  
      i=1
      return                                                       
!                           
   53 continue                                                                  
   54 if (x(if)-bl) 32,56,56                                                    
   56 if (x(if)-bu) 55,55,32                                                    
   55 fx(if)=fun (x(if))                                                        
      if (abs(fx(if))-ep) 13,13,57                                              
   57 if (fx(if)) 58,13,59                                                      
   58 it=im                                                                     
      im=if                                                                     
      go to 60                                                                  
   59 it=ip                                                                     
      ip=if                                                                     
   60 if=it                                                                     
   52 continue                                                                  
      go to 32                                                                  
      end                                                                       
!***********************************************************************                  
      subroutine simp(r,x,y,n,ier)                                                        
      implicit real*8(a-h,o-z)                                                            
      dimension x(n),y(n)                                                                 
      r=0.0                                                                               
      if(n.gt.1) go to 1                                                                  
      ier=2                                                                               
      return                                                                              
    1 if(x(1).eq.x(2)) go to 12                                                           
      nm1=n-1                                                                             
      if(n.eq.2) go to 13                                                                 
      if(x(1).lt.x(2)) go to 3                                                            
!  test for x to be monotonically decreasing                                              
      do 2 i=2,nm1                                                                        
      if(x(i+1).ge.x(i)) go to 12                                                         
    2 continue                                                                            
      go to 5                                                                             
!  test for x to be monotonically increasing                                              
    3 do 4 i=2,nm1                                                                        
      if(x(i+1).le.x(i)) go to 12                                                         
    4 continue                                                                            
    5 nm2=n-2                                                                             
      if(mod(n,2).eq.0) go to 14                                                          
      p=0.0                                                                               
      n1=1                                                                                
    6 s1=x(n1+1)-x(n1)                                                                    
      s2=x(n1+2)-x(n1+1)                                                                  
      s3=x(nm1)-x(nm2)                                                                    
      s4=x(n)-x(nm1)                                                                      
      r=(2.*s1**2+s1*s2-s2**2)/s1*y(n1)+(2.*s4**2+s3*s4-s3**2)/s4*y(n)                    
      n1=n1+1                                                                             
      do 7 i=n1,nm1,2                                                                     
      s1=x(i)-x(i-1)                                                                      
      s2=x(i+1)-x(i)                                                                      
    7 r=r+(s1+s2)**3/(s1*s2)*y(i)                                                         
      if(n.lt.5) go to 9                                                                  
      n1=n1+1                                                                             
      do 8 i=n1,nm2,2                                                                     
      s1=x(i-1)-x(i-2)                                                                    
      s2=x(i)-x(i-1)                                                                      
      s3=x(i+1)-x(i)                                                                      
      s4=x(i+2)-x(i+1)                                                                    
    8 r=r+((2.*s2**2+s1*s2-s1**2)/s2+(2.*s3**2+s3*s4-s4**2)/s3)*y(i)                      
    9 r=r/6.+p                                                                            
   10 continue                                                                            
      ier=1                                                                               
      return                                                                              
   11 ier=3                                                                               
      return                                                                              
   12 ier=4                                                                               
      return                                                                              
!  trapezoidal rule for n=2                                                               
   13 r=(x(2)-x(1))*(y(1)+y(2))/2.0                                                       
      go to 10                                                                            
!  fit polynomial thru first 3 points and integrate from x(1) to x(2).                    
   14 s1=x(2)-x(1)                                                                        
      s2=x(3)-x(1)                                                                        
      s3=y(2)-y(1)                                                                        
      s4=y(3)-y(1)                                                                        
      p=s1/6.*(2.*s3+6.*y(1)+(s2**2*s3-s1**2*s4)/(s2*(s2-s1)))                            
      n1=2                                                                                
      go to 6                                                                             
      end                                                                                 
!***************************************************************************
      subroutine slope(n,xx,yy,dydx)
! derivative subroutine
      implicit real*8(a-h,o-z)
! input parameters:
!   n=number of points
!   xx(n)=independent variables
!   yy(n)=dependent variables
! output parameters
!   dydx(n)=slope at mid point
      dimension xx(802),yy(802),dydx(802)
      dydx(1)=(yy(2)-yy(1))/(xx(2)-xx(1))
      do i=2,n-1
        call slope1(xx(i-1),xx(i),xx(i+1),yy(i-1),yy(i),yy(i+1), dydx(i))
      end do
      dydx(n)=(yy(n)-yy(n-1))/(xx(n)-xx(n-1))
      return
      end
!****************************************************************************
      subroutine slope1(x1,x2,x3,y1,y2,y3, dydx2)
      implicit real*8(a-h,o-z)
      b1=(y3-y1)/(x3-x1); b2=(y2-y1)/(x2-x1)
      a2=(b1-b2)/(x3-x2); a1=b2-a2*(x3-x1)
      dydx2=a1+2.*a2*(x2-x1)
      return
      end
!***********************************************************************
      subroutine smooth(nwave,wavel,sigin, wavsig,sigout)
! shortens the signal by averaging
! input parameters:
!   nwave=length of wavel and sigin
!   wavel(nw)=wavelength, A
!   sigin(nw)=input signal
! output parameters:
!   wavsig(500)=wavelength for sigout
!   sigout(500)=smoothed signal
      parameter(nw=400000)
      implicit real*8(a-h,o-z)
      dimension wavel(nw),sigin(nw),wavsig(1000),sigout(1000)
!
      navge=float(nwave)/1000.
      do i=1,999
        wavsig(i)=wavel(i*navge)
        i1=(i-1)*navge+1; i2=i*navge 
        if(i2.gt.nwave) i2=nwave
        sigout(i)=0.
        an=0
        do j=i1,i2
          sigout(i)=sigout(i)+sigin(j)
          an=an+1.0
        end do
        sigout(i)=sigout(i)/an 
      end do
      return
      end
!***********************************************************************                  
      subroutine solve(ndim,n,a,b,ipvt)                                                   
      implicit real*8(a-h,o-z)                                                                                         
      integer ndim, n, ipvt(n)                                                            
      real*8 a(ndim,n), b(n)                                                                
!                                                                                         
!     solution of linear systems, a*x = b                                                 
!     do not use if decomp has detected singularity                                       
!                                                                                         
!     input...                                                                            
!       ndim = declared row dimension of array containing a                               
!       n = order of matrix                                                               
!       a = triangularized matrix from subroutine decomp                                  
!       b = right hand side vector                                                        
!       ipvt = pivot vector obtained from decomp                                          
!                                                                                         
!     output                                                                              
!                                                                                         
!       b = solution vector, x                                                            
!                                                                                         
      integer kb, km1, nm1, kp1, i, k, m                                                  
      real*8 t                                                                              
!                                                                                         
!     forward elimination                                                                 
!                                                                                         
      if(n .eq. 1) go to 50                                                               
      nm1 = n - 1                                                                         
      do 20 k = 1, nm1                                                                    
        kp1 = k + 1                                                                       
        m = ipvt(k)                                                                       
        t = b(m)                                                                          
        b(m) = b(k)                                                                       
        b(k) = t                                                                          
        do 10 i = kp1, n                                                                  
          b(i) = b(i) + a(i,k)*t                                                          
   10   continue                                                                          
   20 continue                                                                            
!                                                                                         
!     back substitution                                                                   
!                                                                                         
      do 40 kb = 1, nm1                                                                   
        km1 = n - kb                                                                      
        k = km1 + 1                                                                       
      b(k)=b(k)/a(k,k)                                                                    
        t = -b(k)                                                                         
        do 30 i = 1, km1                                                                  
          b(i) = b(i) + a(i,k)*t                                                          
   30   continue                                                                          
   40 continue                                                                            
   50 b(1) = b(1)/a(1,1)                                                                  
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine spdinp                                                                   
!                                                                                         
      implicit real*8(a-h,o-z)                                                            
      common /spcdat/ eltbl(8,2),    sptbl(9,32),   fln(8,32),            &               
     &                tdc(8,32,4),   spm(32),                             &               
     &                        ne,            ns,                          &               
     &                itchm,         ioutch,        elms(8)                               
!                                                                                         
      common /node  / spv(32),       t,             p,                    &               
     &                brm,           speth(32),     spgfz(32),            &               
     &                spcsp(32),     bzro(8),       ethm                                  
!                                                                                         
      dimension       end(3),        tn(9),         tf(3),                &               
     &                tel(2),        rnum(9),       trmax(3),             &               
     &                emtbl(3,16)                                                         
!                                                                                         
      ioutch=0                                                                            
      ncd=0                                                                               
      ne=0                                                                                
      ns=0                                                                                
      nsmax = 32                                                                          
      nemax = 8                                                                           
      do 24 j = 1, nsmax                                                                  
      do 24 i = 1, nemax                                                                  
      fln(i,j)=0.0                                                                        
  24  continue                                                                            
!                                                                                         
  1   continue                                                                            
      ncd=ncd+1                                                                           
!.....read a species data card...........................                                 
      read(19,100)(tn(i),i=1,9),(tf(j),j=1,3),tt,icd                                       
  100 format(9a1,1x,3(e18.5),6x,f5.0,3x,i1)                                               
      write(6,100) (tn(i),i=1,9),(tf(j),j=1,3),tt,icd                                     
!.....determine if this is end of data..................................                  
      data end/1hE,1hN,1hD/                                                               
      do 2 i=1,3                                                                          
      if(tn(i).ne.end(i))go to 3                                                          
  2   continue                                                                            
!                                                                                         
!     chemistry card input has ended                                                      
!                                                                                         
      if(ioutch.eq.0) go to 98                                                            
        write(6,110)                                                                      
  110   format(1h1, 44x, 20hchemistry input data)                                         
        write(6,120)                                                                      
 120  format(/,1x,22hspecies molecular mass,/)                                            
        do 30 j = 1, ns                                                                   
          write(6,130) (sptbl(ic,j), ic = 1, 5), spm(j)                                   
  130     format(3x, 5a1, 6x, f9.5)                                                       
   30   continue                                                                          
!                                                                                         
        write(6,135)                                                                      
  135   format( //, 38x, 40hthermodynamic coefficients - janaf model)                     
        write(6,140)                                                                      
  140   format(/, 1x, 15hspecies     t,k, 12x, 1ha, 14x, 1hb, 14x, 1hc,   &               
     &         14x, 1hd, 14x, 1he, 14x, 1hf, /)                                           
        do 50 j = 1, ns                                                                   
          do 40 itr = 1, 3                                                                
            write(6,150) (sptbl(ic,j), ic = 1, 5), trmax(itr),            &               
     &                   (tdc(icf,j,itr), icf = 1, 6)                                     
  150       format(3x, 5a1, f9.0, 3x, 1p6e15.5)                                           
   40     continue                                                                        
          write(6,155)                                                                    
  155     format(/)                                                                       
   50   continue                                                                          
!                                                                                         
      go to 98                                                                            
  3   continue                                                                            
                                                                                          
      if(ns.eq.0)go to 4                                                                  
      do 5 i=1,ns                                                                         
      isp=i                                                                               
      do 6 j=1,9                                                                          
      if(tn(j).ne.sptbl(j,i))go to 5                                                      
  6   continue                                                                            
      go to 7                                                                             
  5   continue                                                                            
!.....new species found.................................................                  
  4   continue                                                                            
      ns=ns+1                                                                             
      isp=ns                                                                              
!                                                                                         
!.....decompose species name............................................                  
      n=0                                                                                 
  8   continue                                                                            
      n=n+1                                                                               
      tel(1)=tn(n)                                                                        
!.....determine if next character is a formula number...................                  
      data rnum/1h1,1h2,1h3,1h4,1h5,1h6,1h7,1h8,1h9/                                      
      do 9 i=1,9                                                                          
      if(tn(n+1).eq.rnum(i))go to 10                                                      
  9   continue                                                                            
      n=n+1                                                                               
      tel(2)=tn(n)                                                                        
      go to 11                                                                            
  10  continue                                                                            
      data blank/1h /                                                                     
      tel(2)=blank                                                                        
  11  continue                                                                            
      if(ne.eq.0)go to 12                                                                 
!.....test temporary element symbol against element table...............                  
      do 13 i=1,ne                                                                        
      iel=i                                                                               
      do 14 j=1,2                                                                         
      if(tel(j).ne.eltbl(i,j))go to 13                                                    
  14  continue                                                                            
      go to 20                                                                            
  13  continue                                                                            
!.....don't add electron to element list if already there..............                   
      if(tel(1).ne.eltrn.or.tel(2).ne.blank)go to 12                                      
      if(ielt.ne.0)go to 20                                                               
      ielt=ne+1                                                                           
  12  continue                                                                            
      ne=ne+1                                                                             
      iel=ne                                                                              
      eltbl(ne,1)=tel(1)                                                                  
      eltbl(ne,2)=tel(2)                                                                  
!                                                                                         
!.....locate element mass & stow to elms................................                  
      data emtbl/1hE,1h ,5.486e-4,                                        &               
     &           1hH,1h ,1.008,                                           &               
     &           1hB,1h ,4.004,                                           &               
     &           1hC,1h ,12.0112,                                         &               
     &           1hO,1h ,16.0,                                            &               
     &           1hN,1h ,14.008,                                          &               
     &           1hS,1h ,28.06,                                           &               
     &           1hA,1h ,39.948,                                          &               
     &           24*0.0/                                                                  
      do 31 i=1,16                                                                        
      idlc=i                                                                              
      do 28 j=1,2                                                                         
      if(tel(j).ne.emtbl(j,i))go to 31                                                    
  28  continue                                                                            
      go to 29                                                                            
  31  continue                                                                            
      write(6,107)                                                                        
  107 format(//5x,' species data input has encountered an element not',  &               
  &     ' present in element table(emtbl).')                                                    
      stop                                                                                
!                                                                                         
  29  elms(ne)=emtbl(3,idlc)                                                              
!                                                                                         
!.....stow formula number for this element of current species...........                  
  20  continue                                                                            
      n=n+1                                                                               
      do 15 i=1,9                                                                         
      if(tn(n).eq.rnum(i))inum=i                                                          
  15  continue                                                                            
      fln(iel,ns)=float(inum)                                                             
!                                                                                         
!.....is this an ionic species?.........................................                  
      data ielt/0/                                                                        
      data pls/1h+/,rmns/1h-/                                                             
      if(tn(n+1).eq.pls)go to 23                                                          
      if(tn(n+1).eq.rmns)go to 23                                                         
      go to 21                                                                            
  23  continue                                                                            
      n=n+1                                                                               
!.....is this 1st ionic species encountered?............................                  
      if(ielt.ne.0)go to 22                                                               
!.....add electron to element tables....................................                  
      ne=ne+1                                                                             
      ielt=ne                                                                             
      data eltrn/1hE/                                                                     
      eltbl(ne,1)=eltrn                                                                   
      eltbl(ne,2)=blank                                                                   
      elms(ielt)=emtbl(3,1)                                                               
!                                                                                         
!.....stow formula number for electron in this species.................                   
  22  continue                                                                            
      if(tn(n).eq.pls)fln(ielt,ns)=-1.                                                    
      if(tn(n).eq.rmns)fln(ielt,ns)=1.                                                    
!                                                                                         
  21  continue                                                                            
      if(tn(n+1).eq.blank)go to 16                                                        
      go to 8                                                                             
!.....blank in species name indicates end of name, so stow name to sptbl                  
  16  continue                                                                            
      do 17 i=1,9                                                                         
      sptbl(i,ns)=tn(i)                                                                   
  17  continue                                                                            
!                                                                                         
!.....stow thermodynamic & transport data...............................                  
!                                                                                         
  7   continue                                                                            
!.....is this card thermo data?.........................................                  
      if(tt.ne.0.0)go to 18                                                               
!.....stow species mass in spm(i)                                                         
      go to(25,1,1),icd                                                                   
  25  spm(isp)=tf(1)                                                                      
      go to 1                                                                             
!                                                                                         
!.....stow thermo data..................................................                  
  18  continue                                                                            
!.....determine temperature range index.................................                  
      itr=1                                                                               
      if(tt.eq.3000.)itr=2                                                                
      if(tt.eq.6000.)itr=3                                                                
      trmax(itr) = tt                                                                     
!.....detemine which half of thermo coefficients........................                  
      ih=0                                                                                
      if(icd.eq.2)ih=3                                                                    
!.....stow data to tcd..................................................                  
      do 19 i=1,3                                                                         
      idx=i+ih                                                                            
      tdc(idx,isp,itr)=tf(i)                                                              
  19  continue                                                                            
      go to 1                                                                             
  98  continue                                                                            
      if(ielt.eq.0)go to 99                                                               
!.....move electron to bottom of element & form. num. tables.............                 
!.....also set ne down by 1 for gas dynamics.............................                 
      do 34 i=1,ne                                                                        
      ielt=i                                                                              
      if(eltbl(i,1).eq.eltrn.and.eltbl(i,2).eq.blank)go to 35                             
  34  continue                                                                            
      go to 99                                                                            
  35  continue                                                                            
      tmp1=eltbl(ielt,1)                                                                  
      tmp2=eltbl(ielt,2)                                                                  
      tmp3=elms(ielt)                                                                     
      nem1=ne-1                                                                           
      do 36 i=ielt,nem1                                                                   
      eltbl(i,1)=eltbl(i+1,1)                                                             
      eltbl(i,2)=eltbl(i+1,2)                                                             
      elms(i)=elms(i+1)                                                                   
  36  continue                                                                            
      eltbl(ne,1)=tmp1                                                                    
      eltbl(ne,2)=tmp2                                                                    
      elms(ne)=tmp3                                                                       
      do 37 j=1,ns                                                                        
      tmp1=fln(ielt,j)                                                                    
      do 38 i=ielt,nem1                                                                   
      fln(i,j)=fln(i+1,j)                                                                 
  38  continue                                                                            
      fln(ne,j)=tmp1                                                                      
  37  continue                                                                            
!                                                                                         
  99  return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine spthf                                                                    
!.....routine for computing the thermodynamic functions for species..                     
!.....using the janaf format fitting functions........................                    
!                                                                                         
!.....nb:- all thermo functions output for this routine are...........                    
!.....normalized:  ie, divided r or r*t...............................                    
!                                                                                         
      implicit real*8(a-h,o-z)                                                            
      common /spcdat/ eltbl(8,2),    sptbl(9,32),   fln(8,32),            &               
     &                tdc(8,32,4),   spm(32),                             &               
     &                        ne,            ns,                          &               
     &                itchm,         ioutch,        elms(8)                               
!                                                                                         
      common /node  / spv(32),       t,             p,                    &               
     &                brm,           speth(32),     spgfz(32),            &               
     &                spcsp(32),     bzro(8),       ethm                                  
!                                                                                         
      dimension f1(32),f2(32),f3(32),f4(32),f5(32),f6(32)                                 
!                                                                                         
      data rgc/0.503205/                                                                  
!                                                                                         
  1   continue                                                                            
!                                                                                         
!.....move appropriate temp. subset of tdc into working arrays fn..                       
      if(t.ge.3000.)go to 2                                                               
      do 3 j=1,ns                                                                         
      f1(j)=tdc(1,j,1)                                                                    
      f2(j)=tdc(2,j,1)                                                                    
      f3(j)=tdc(3,j,1)                                                                    
      f4(j)=tdc(4,j,1)                                                                    
      f5(j)=tdc(5,j,1)                                                                    
      f6(j)=tdc(6,j,1)                                                                    
  3   continue                                                                            
      go to 7                                                                             
!                                                                                         
  2   continue                                                                            
      if(t.ge.6000)go to 4                                                                
      do 5 j=1,ns                                                                         
      f1(j)=tdc(1,j,2)                                                                    
      f2(j)=tdc(2,j,2)                                                                    
      f3(j)=tdc(3,j,2)                                                                    
      f4(j)=tdc(4,j,2)                                                                    
      f5(j)=tdc(5,j,2)                                                                    
      f6(j)=tdc(6,j,2)                                                                    
  5   continue                                                                            
      go to 7                                                                             
!                                                                                         
  4   continue                                                                            
      do 6 j=1,ns                                                                         
      f1(j)=tdc(1,j,3)                                                                    
      f2(j)=tdc(2,j,3)                                                                    
      f3(j)=tdc(3,j,3)                                                                    
      f4(j)=tdc(4,j,3)                                                                    
      f5(j)=tdc(5,j,3)                                                                    
      f6(j)=tdc(6,j,3)                                                                    
  6   continue                                                                            
!                                                                                         
  7   continue                                                                            
!                                                                                         
!.....set temperature functions........................................                   
      data tc1,tc2,tc3,tc4/3.e3,9.e6,3.333333e-4,1.111111e-7/                             
      rt=1./t                                                                             
      tf1=t-tc1                                                                           
      tf2=0.5*(t*t-tc2)                                                                   
      tf3=-(rt-tc3)                                                                       
      tf4=tf1-t*dlog(t*tc3)                                                               
      tf5=tf2-t*tf1                                                                       
      tf6=tf3+0.5*t*(rt*rt-tc4)                                                           
      rgct=rgc*rt                                                                         
!                                                                                         
!.....compute thermo-functions for the species set...................                     
      do 8 j=1,ns                                                                         
      spcsp(j)=f3(j)+f4(j)*t+f5(j)*rt*rt                                                  
      c1p2=f1(j)+f2(j)                                                                    
      speth(j)=c1p2+f3(j)*tf1+f4(j)*tf2+f5(j)*tf3                                         
      spgfz(j)=c1p2+f3(j)*tf4+f4(j)*tf5+f5(j)*tf6-f6(j)*t                                 
  8   continue                                                                            
!                                                                                         
!.....norminalization by gas constant & temperature................                       
      do 9 j=1,ns                                                                         
      spcsp(j)=spcsp(j)*rgc                                                               
      speth(j)=speth(j)*rgct                                                              
      spgfz(j)=spgfz(j)*rgct                                                              
  9   continue                                                                            
!                                                                                         
!                                                                                         
  99  return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine spudt(svtr,lcnv,iprb)                                                    
!     routine for updating solution vector, namely, species mole                          
!     fractions and mixture molar mass                                                    
!                                                                                         
      implicit real*8(a-h,o-z)                                                            
      common /spcdat/ eltbl(8,2),    sptbl(9,32),   fln(8,32),            &               
     &                tdc(8,32,4),   spm(32),                             &               
     &                        ne,            ns,                          &               
     &                itchm,         ioutch,        elms(8)                               
!                                                                                         
      common /node  / spv(32),       t,             p,                    &               
     &                brm,           speth(32),     spgfz(32),            &               
     &                spcsp(32),     bzro(8),       ethm                                  
!                                                                                         
      dimension       svtr(16),      dlns(32),      spl(32)                               
!                                                                                         
      data tln/9.21034/                                                                   
      nep1=ne+1                                                                           
      nep2=ne+2                                                                           
      pln=dlog(p)                                                                         
!                                                                                         
!     compute changes in the log of the species mole fractions                            
!                                                                                         
      do 1 j=1,ns                                                                         
      spl(j)=dlog(spv(j))                                                                 
      dlns(j)=-(spgfz(j)+pln+spl(j))                                                      
      if(iprb.eq.2)dlns(j)=dlns(j)+speth(j)*svtr(nep2)                                    
      do 1 i=1,ne                                                                         
      dlns(j)=dlns(j)+fln(i,j)*svtr(i)                                                    
  1   continue                                                                            
!                                                                                         
!     select weighting factor                                                             
!                                                                                         
      wf1=dabs(dlns(1))                                                                   
      do 2 j=2,ns                                                                         
        wf1 = dmax1(wf1, dabs(dlns(j)))                                                   
  2   continue                                                                            
      wf1=dmax1(wf1,dabs(svtr(nep1)))                                                     
      if(wf1 .lt. 1.0e-25) wf1 = 1.0                                                      
      wf1=2./wf1                                                                          
!                                                                                         
      wf2=1.0                                                                             
      do 3 j=1,ns                                                                         
      if(spl(j).gt.-18.42.and.dlns(j).le.0.)go to 3                                       
      if(dlns(j).eq.0.0.or.(spl(j)+tln).lt.1.e-9)go to 3                                  
      wf2=dmin1(wf2,dabs(-(spl(j)+tln)/(dlns(j))))                                        
  3   continue                                                                            
      wf=dmin1(1.,wf1,wf2)                                                                
!                                                                                         
!     apply corrections to solution vector                                                
!                                                                                         
      spcm=0.                                                                             
      lcnv=0                                                                              
!                                                                                         
!     update molecular mass                                                               
!                                                                                         
      dlnm=wf*svtr(nep1)                                                                  
      brm=dexp(dlog(brm)+dlnm)                                                            
!                                                                                         
!.....for the h,p problem, update temperature.........................                    
      if(iprb.ne.2)go to 5                                                                
      tmpln=dlog(t)+wf*svtr(nep2)                                                         
      t=dexp(tmpln)                                                                       
!                                                                                         
  5   continue                                                                            
!                                                                                         
!     update species mole fractions                                                       
!                                                                                         
      do 4 j=1,ns                                                                         
      spl(j)=spl(j)+wf*dlns(j)                                                            
      spv(j)=dexp(spl(j))                                                                 
      spcp=spv(j)*dabs(dlns(j))                                                           
      spcm=dmax1(spcm,spcp)                                                               
  4   continue                                                                            
!                                                                                         
!     check convergence of mole fractions & molar mass............                        
!                                                                                         
      data tol /1.0e-1/                                                                   
      if(spcm.lt.tol.and.dlnm.lt.tol) lcnv = 1                                            
!                                                                                         
  99  return                                                                              
      end                                                                                 
!**************************************************************************               
      subroutine stiff7(n,t,y,r,der,h,case,istep,nprt)                                    
! stiff equation integrator                                                               
! input specifications                                                                    
!   n=order of differential equation                                                      
!   t=independent variable                                                                
!   y(n)=dependent variable                                                               
!   der=name of the subroutine specifying derivative.                                     
!       must be stated in external in the calling program.                                
!       the subroutine must be in the form                                                
!           subroutine der(t,y,dy)                                                        
!       where t is the independent variable                                               
!             y(n) is the dependent variable                                              
!             dy(n) is the dy/dt array                                                    
!   h=initial step size of t                                                              
!   case(5):                                                                              
!      case(1)=maximum allowed fractional change in dependent variables                   
!              0.04 recommended                                                           
!      case(2)=maximum allowed stepsize in t                                              
!      case(3)=minimum value of dependent variable for which the                          
!              automatic fractional differentiation is done.                              
!      case(4)=stability parameter. 0.33333 is most accurate                              
!              -1.5 is most stable. 0.33333 recommended                                   
!      case(5)=delta y for absolute differentiation when y is less than                   
!              case(3)                                                                    
!   istep=number of steps                                                                 
!   nprt=print index.                                                                     
! output specifications                                                                   
!   t=updated independent variable                                                        
!   y(n)=updated dependent variables                                                      
!   r(n)=increment                                                                        
!                                                                                         
      parameter(msp=60)                                                                   
      implicit real*8(a-h,o-z)                                                            
      dimension case(5),y(msp),dy(msp),ysi(msp),dysi(msp),r(msp)                          
      dimension pw(msp,msp),pwsq(msp,msp),qmat(msp,msp),rmat(msp,msp),    &               
     &  ip(msp)                                                                           
      external der                                                                        
      data itime/0/                                                                       
      ymin=case(3)                                                                        
      dely=case(5)                                                                        
      eps=case(1)                                                                         
      c1=case(4)-1.d0                                                                     
      c2=.5e0-case(4)                                                                     
      call der(n,t,y,dy,istep,nprt)                                                       
!   save initial y in ysi, initial dy in dysi                                             
      do 10 ic=1,n                                                                        
        ysi(ic)=y(ic)                                                                     
   10 dysi(ic)=dy(ic)                                                                     
!   calculate jacobian matrix, store in pw                                                
      do 40 ic=1,n                                                                        
        delyj=.005d0*ysi(ic)                                                              
        if(abs(ysi(ic)).lt.ymin) delyj=dely                                               
        yd=.5e0/delyj                                                                     
        y(ic)=ysi(ic)+delyj                                                               
        call der(n,t,y,dy,istep,nprt)                                                     
        do 20 ir=1,n                                                                      
   20   r(ir)=dy(ir)                                                                      
        y(ic)=ysi(ic)-delyj                                                               
        call der(n,t,y,dy,istep,nprt)                                                     
        do 30 ir=1,n                                                                      
          pw(ir,ic)=(r(ir)-dy(ir))*yd                                                     
   30   continue                                                                          
   40 y(ic)=ysi(ic)                                                                       
!   calculate square of jacobian, store in pwsq                                           
      do 55 ic=1,n                                                                        
      do 55 ir=1,n                                                                        
      s=0.e0                                                                              
      do 50 is=1,n                                                                        
   50 s=s+pw(ir,is)*pw(is,ic)                                                             
   55 pwsq(ir,ic)=s                                                                       
      jmat=1                                                                              
!                                                                                         
!   set up left hand side matrix in qmat                                                  
   60 continue                                                                            
      c3=h*c1                                                                             
      c4=h*h*c2                                                                           
      c5=-h*c2                                                                            
      do 70 ic=1,n                                                                        
        do 71 ir=1,n                                                                      
        qmat(ir,ic)=c3*pw(ir,ic)+c4*pwsq(ir,ic)                                           
        if(ir.eq.ic) qmat(ir,ic)=qmat(ir,ic)+1.d0                                         
   71 continue                                                                            
   70 continue                                                                            
!                                                                                         
      ip(n) = 1                                                                           
      do 86 k = 1,n                                                                       
        if(k.eq.n) go to 85                                                               
        kp1 = k+1                                                                         
        m = k                                                                             
        do 81 i = kp1,n                                                                   
        if(abs(qmat(i,k)).gt.abs(qmat(m,k))) m = i                                        
   81  continue                                                                           
        ip(k) = m                                                                         
        if(m.ne.k) ip(n) = -ip(n)                                                         
        t1 = qmat(m,k)                                                                    
        qmat(m,k) = qmat(k,k)                                                             
        qmat(k,k) = t1                                                                    
        if(t1.eq.0.e0) go to 85                                                           
        do 82 i = kp1,n                                                                   
   82    qmat(i,k) = -qmat(i,k)/t1                                                        
        do 84 j = kp1,n                                                                   
          t1 = qmat(m,j)                                                                  
          qmat(m,j) = qmat(k,j)                                                           
          qmat(k,j) = t1                                                                  
          if(t1.eq.0.e0) go to 84                                                         
          do 83 i = kp1,n                                                                 
   83      qmat(i,j) = qmat(i,j) + qmat(i,k)*t1                                           
   84  continue                                                                           
   85  if(qmat(k,k).eq.0.e0) ip(n) = 0                                                    
   86 continue                                                                            
      qmatmax=0.                                                                          
      do ir=1,n                                                                           
        do ic=1,n                                                                         
          qmatmax=dmax1(qmatmax,dabs(qmat(ir,ic)))                                        
        end do                                                                            
      end do                                                                              
!                                                                                         
      if(ip(n).ne.0) go to 110                                                            
      write(6,88) h                                                                       
   88 format(/' h=',1pe10.3)                                                              
      do ir=1,n                                                                           
        do ic=1,n                                                                         
!          write(6,87) ir,ic,qmat(ir,ic)                                                  
   87     format(' ir,ic=',2i3,' qmat=',1pe10.3)  
        end do                                                                            
      end do                                                                              
      stop                                                                                
!      go to 170                                                                          
  110 continue                                                                            
!                                                                                         
!   calculate right hand side vector r                                                    
      do 120 ic=1,n                                                                       
      do 120 ir=1,n                                                                       
      rmat(ir,ic)=c5*pw(ir,ic)                                                            
      if(ir.eq.ic) rmat(ir,ic)=rmat(ir,ic)+1.e0                                           
  120 continue                                                                            
      do 135 ir=1,n                                                                       
      s=0.e0                                                                              
      do 130 ic=1,n                                                                       
  130 s=s+h*rmat(ir,ic)*dysi(ic)                                                          
  135 r(ir)=s                                                                             
      if(n.eq.1) go to 139                                                                
      nm1 = n-1                                                                           
      do 137 k = 1,nm1                                                                    
        kp1 = k+1                                                                         
        m = ip(k)                                                                         
        t1 = r(m)                                                                         
        r(m) = r(k)                                                                       
        r(k) = t1                                                                         
        do 137 i = kp1,n                                                                  
  137 r(i) = r(i) + qmat(i,k)*t1                                                          
      do 138 kb = 1,nm1                                                                   
        km1 = n-kb                                                                        
        k = km1+1                                                                         
        r(k) = r(k)/qmat(k,k)                                                             
        t1 = -r(k)                                                                        
        do 138 i = 1,km1                                                                  
  138 r(i) = r(i) + qmat(i,k)*t1                                                          
  139 r(1) = r(1)/qmat(1,1)                                                               
!   r contains delta y vector                                                             
!   change step size maximum of 50 times before accepting step                            
      jmat=jmat+1                                                                         
      if(jmat.ge.20) go to 150                                                            
!   find max, abs (delta y)/y                                                             
      am=0.e0                                                                             
      do ir=2,n                                                                           
        am=dmax1(am,abs(r(ir))/(abs(y(ir))+1.0d-80) )                                     
      end do                                                                              
!                                                                                         
!   step size test, reset if necessary                                                    
!      if(am.eq.0.e0) go to 150                                                           
! no change in h necessary                                                                
      if((am.le.eps).and.(am.ge.0.1*eps)) then                                            
        go to 150                                                                         
      end if                                                                              
! h too large                                                                             
      if(am.gt.eps) then                                                                  
        h=.5e0*h                                                                          
        go to 60                                                                          
      end if                                                                              
! h too small                                                                             
      if(am.lt.0.08e0*eps) then                                                            
        h=1.9e0*h                                                                          
        go to 60                                                                          
      end if                                                                              
!      if(h.gt.case(2)) then                                                              
!        go to 150                                                                        
!      endif                                                                              
!      go to 60                                                                           
!                                                                                         
!   increase dependent and independent variables.                                         
  150 continue                                                                            
      do ir=1,n                                                                           
        y(ir)=ysi(ir)+r(ir)                                                               
      end do                                                                              
      t=t+h                                                                               
  170 continue                                                                            
      return                                                                              
      end                                                                                 
!***********************************************************************                                   
      subroutine taint(xtab,ftab,x,fx,n,k,ner, mon)                                       
! interpolation subroutine for unequally-spaced x-values                                  
! input parameters:                                                                       
!   xtab(n)=independent variables in the given table                                      
!   ftab(n)=dependent variables in the given table                                        
!   x=independent variable for which interpolation is wanted                              
!   n=number of points in table                                                           
!   k=order of interpolation. 1=linear (two points), 2=quadratic(three points),etc        
!   mon=must be set initially to zero. the subroutine sets to 1. If set to 1,             
!       the subroutine skips reading xtab. Maximum of 9 allowed                           
! output parameters                                                                       
!   fx=dependetn variable obtained by interpolation                                       
!   ner=error message. 1=successful interpolation. ne.1=error (ner=2: too few             
!       number of given table values. ner=3: xtab values are not monotonic)               
!                                                                                         
      implicit real*8(a-h,o-z)                                                            
      dimension xtab(n),ftab(n),t(10),c(10)                                               
!ps0400  taint subroutine- in fortran ii.                                                 
      if (n - k) 1,1,2                                                                    
    1 ner=2                                                                               
      return                                                                              
    2 if (k-9) 3,3,1                                                                      
    3 if ( mon) 4,4,5                                                                     
    5 if ( mon-2) 6,7,4                                                                   
    4 j=0                                                                                 
      nm1=n-1                                                                             
      do 8 i=1,nm1                                                                        
      if (xtab(i)-xtab(i+1)) 9,11,10                                                      
   11 ner=3                                                                               
      return                                                                              
    9 j=j-1                                                                               
      go to 8                                                                             
   10 j=j+1                                                                               
    8 continue                                                                            
      mon=1                                                                               
      if (j) 12,6,6                                                                       
   12 mon=2                                                                               
    7 do 13 i=1,n                                                                         
      if (x-xtab(i)) 14,14,13                                                             
   14 j=i                                                                                 
      go to 18                                                                            
   13 continue                                                                            
      go to 15                                                                            
    6 do 16 i=1,n                                                                         
      if (x-xtab(i)) 16,17,17                                                             
   17 j=i                                                                                 
      go to 18                                                                            
   16 continue                                                                            
   15 j=n                                                                                 
   18 j=j-(k+1)/2                                                                         
      if (j) 19,19,20                                                                     
   19 j=1                                                                                 
   20 m=j+k                                                                               
      if (m-n) 21,21,22                                                                   
   22 j=j-1                                                                               
      go to 20                                                                            
   21 kp1=k+1                                                                             
      jsave=j                                                                             
   26 do 23 l=1,kp1                                                                       
      c(l)=x-xtab(j)                                                                      
      t(l)=ftab(j)                                                                        
   23 j=j+1                                                                               
      do 24 j=1,k                                                                         
      i=j+1                                                                               
   25 t(i)=(c(j)*t(i)-c(i)*t(j))/(c(j)-c(i))                                              
      i=i+1                                                                               
      if (i-kp1) 25,25 ,24                                                                
   24 continue                                                                            
      fx=t(kp1)                                                                           
      ner=1                                                                               
      return                                                                              
      end                                                                                 
!***************************************************************************              
      subroutine thrcal(tmax,tmin,itemp)                                                   
! thermodynamic calculation                                                               
! input: nprt=print index.                                                                
!   tmax=maximum temperature                                                              
!   tmin=minimum temperature 
!   itemp=temperature index                                                             
      parameter(msp=60)                                                                   
      implicit real*8(a-h,o-z)                                                            
      common/eqcoma/elemwt(15),                                           &               
     & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp),            &               
     & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp),             &               
     & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp),                     &               
     & akb(5,msp),akd(5,msp),avmw0                                                        
      common/eqcomb/elemnm(12)                                                            
      common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc,  &               
     & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp),   &               
     & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp)                        
      dimension tt(5),tt1(5),xx(5,5),b(5),wkarea(msp),pft                 &               
     & (5,msp,3),pfti(5,msp,3)                                                            
      character*4 elemnm,spnm                                                             
!
      nprt=0
      if(itemp.eq.1) nprt=1
!                                                                                         
! prepare for equilibrium constant calculation                                            
      if(n6.ge.1) then                                                                    
      do 310 jr=1,n6                                                                      
      ji1=lid(1,jr)                                                                       
      jf1=lid(3,jr)                                                                       
      jf2=lid(4,jr)                                                                       
      hr(jr)=(h0sp(ji1)-h0sp(jf1)-h0sp(jf2))                                              
  310 continue                                                                            
      endif                                                                               
      if(n10.ge.n7) then                                                                  
      do 320 jr=n7,n10                                                                    
      ji1=lid(1,jr)                                                                       
      ji2=lid(2,jr)                                                                       
      jf1=lid(3,jr)                                                                       
      jf2=lid(4,jr)                                                                       
      hr(jr)=(h0sp(ji1)+h0sp(ji2)-h0sp(jf1)-h0sp(jf2))                                    
  320 continue                                                                            
      endif                                                                               
!                                                                                         
! partition functions                                                                     
      tdif=0.25d0*(tmax-tmin)                                                             
      do 330 jt=1,5                                                                       
        tt(jt)=tmin+tdif*(jt-1)                                                           
        tt1(jt)=10000.d0/tt(jt)                                                           
  330 continue                                                                            
      do 340 jsp=1,nsp1                                                                   
      do 340 jt=1,5                                                                       
      dtemp=0.002d0*tt(jt)                                                                
      do 341 i=1,3                                                                        
        temp=tt(jt)+dtemp*(i-2)                                                           
        spwt1=spwt(jsp)*1.0d3                                                             
        call partfx(jsp,spnm(jsp),spwt1,temp,temp,temp,nprt,partf,        &               
     &   parti)                                                                           
        pfti(jt,jsp,i)=parti                                                              
        pft(jt,jsp,i)=partf/6.025d23                                                      
  341 continue                                                                            
      if(nprt.gt.2) write(6,960) jsp,tt(jt),(pft(jt,jsp,i),i=1,3)                         
  960 format(' jsp=',i2,' temp=',f7.0,' pft=',3e10.3)                                     
  340 continue                                                                            
      call eintf(pft,pfti,tmax,tmin)                                                      
!                                                                                         
! calculate equilibrium constants                                                         
      do 350 jr=1,n6                                                                      
      ji1=lid(1,jr)                                                                       
      jf1=lid(3,jr)                                                                       
      jf2=lid(4,jr)                                                                       
      if(nprt.gt.2) write(6,1000) ji1,jf1,jf2                                             
 1000 format(' ji1,jf1,jf2    =',4i5)                                                     
      do 350 jt=1,5                                                                       
      akax=(pft(jt,jf1,2)/pft(jt,ji1,2))*pft(jt,jf2,2)                                    
      aka(jt,jr)=dlog(akax)+hr(jr)/(6.025d23*1.3805d-23*tt(jt))                           
  350 continue                                                                            
      do 360 jr=n7,n10                                                                    
      ji1=lid(1,jr)                                                                       
      ji2=lid(2,jr)                                                                       
      jf1=lid(3,jr)                                                                       
      jf2=lid(4,jr)                                                                       
      if(nprt.gt.2) write(6,1100) ji1,ji2,jf1,jf2                                         
 1100 format(' ji1,ji2,jf1,jf2=',4i5)                                                     
      do 360 jt=1,5                                                                       
      akax=(pft(jt,jf1,2)/pft(jt,ji1,2))*(pft(jt,jf2,2)/                  &               
     & pft(jt,ji2,2))                                                                     
      aka(jt,jr)=dlog(akax)+hr(jr)/(6.025d23*1.3805d-23*tt(jt))                           
  360 continue                                                                            
      if(nprt.gt.2) write(6,970)                                                          
  970 format(' aka made')                                                                 
!                                                                                         
! determine 5 coefficients expressing equilibrium constant                                
! ke=dexp(aka(1,jr)/z+aka(2,jr)+aka(3,jr)*ln(z)+aka(4,jr)*z                               
!     +aka(5,jr)*z*z), where z=10000/temp                                                 
!                                                                                         
! set independent variables xx(j,i) and rhs b(j)                                          
!   j=row number, i=column number.                                                        
      do 560 jr=1,n10                                                                     
      do 370 j=1,5                                                                        
      b(j)=aka(j,jr)                                                                      
      xx(j,1)=1.0d0/tt1(j)                                                                
      xx(j,2)=1.0d0                                                                       
      xx(j,3)=dlog(tt1(j))                                                                
      do 370 i=4,5                                                                        
  370 xx(j,i)=tt1(j)**(i-3)                                                               
      call leqt2f(xx,1,5,5,aka(1,jr),0,wkarea,ier)                                        
  560 continue                                                                            
!                                                                                         
! write out                                                                               
      if(nprt.gt.0) then                                                                  
        write(6,380)                                                                      
  380   format(/' list of reactions'/' initl species  final species',     &               
     &   ' reaction   equilibrium constant coefficient    rate const',    &               
     &   '    t-pwr','  activn'/29x,'energy',13x,'5-term expansion',13x,  &               
     &   'cm3/mol',13x,'temp' /29x,'kjoul/mol' )                                          
        do 390 jr=1,n10                                                                   
          if(jr.eq.1) write(6,400)                                                        
  400     format(' heavy particle impact dissociation')                                   
          if(jr.eq.n3) write(6,410)                                                       
  410     format(' electron impact dissociations')                                        
          if(jr.eq.n5) write(6,420)                                                       
  420     format(' electron impact ionizations')                                          
          if(jr.eq.n7) write(6,440)                                                       
  440     format(' exchange reactions')                                                   
          if(jr.eq.n9) write(6,450)                                                       
  450     format(' associative ionization reactions')                                     
          l1=lid(1,jr)                                                                    
          l2=lid(2,jr)                                                                    
          l3=lid(3,jr)                                                                    
          l4=lid(4,jr)                                                                    
          if(jr.le.n6) then                                                               
            write(6,470) jr,spnm(l1),spnm(l3),spnm(l4),                   &               
     &        hr(jr)*1.0e-3,(aka(i,jr),i=1,5),(crat(i,jr),i=1,3)                          
  470       format(1x,i2,4x,a4,5x,1h=,a4,1h+,a4,f9.2,1x,5f8.3,            &               
     &        1x,1pe10.3,0pf9.3,f9.0)                                                     
              if(jr.le.n2) then                                                           
                do 490 jsp=1,nsp                                                          
                  write(6,500) spnm(jsp),crat1(jsp,jr),crat(2,jr),        &               
     &              crat(3,jr)                                                            
  500             format(65x,4hm = ,a4,4x,1pe10.3,0pf9.3,f9.0)                            
  490           continue                                                                  
              endif                                                                       
          endif                                                                           
          if(jr.gt.n6) then                                                               
            write(6,480) jr,spnm(l1),spnm(l2),spnm(l3),spnm(l4),          &               
     &        hr(jr)*1.0e-3,(aka(i,jr),i=1,5),(crat(i,jr),i=1,3)                          
  480       format(1x,i2,4x,a4,1h+,a4,1h=,a4,1h+,a4,                      &               
     &        f9.2,1x,5f8.3,1x,1pe10.3,0pf9.3,f9.0)                                       
           endif                                                                          
  390   continue                                                                          
      endif                                                                               
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine thrinp(ncase,nair,nprt, nspx,spnmx, pres,spallf, tw,delH)                                            
! thermodynamic input subroutine                                                          
! input parameters: 
!    ncase=1: air; =2: ablation product                                                              
!    nair=unit containing equilibrium air data                                            
!    nprt=0 no print                                                                      
!        =1 chemical rate formulas only printed                                           
!        =2 inputs and chemical rate formulas printed                                     
!        =3 further details printed  
!    nspx 
!    spnmxx
!    pres=pressure, in Pa                                                    
! output parameters:
!    nspx=number of species
!    spnmx(msp)=species name
!    tw=wall temperature
!    delH=ablation energy. J/kg
      parameter(msp=60)                                                                   
      implicit real*8(a-h,o-z)                                                            
      common/eqcoma/elemwt(15),                                           &               
     & felem(15),spwt(msp),cpsp(msp),h0sp(msp),atomg(500,msp),            &               
     & atome(500,msp),spect(15,45,msp),rmass(msp),factr(msp),             &               
     & hr(msp),crat(3,msp),crat1(msp,msp),aka(5,msp),                     &               
     & akb(5,msp),akd(5,msp),avmw0                                                        
      common/eqcomb/elemnm(12)                                                            
      common/eqcomi/nelem,nsp,nsp1,nsp2,nsp3,nhdiss,nediss,nexch,nassoc,  &               
     & neimp,n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,nded(16),spnm(msp),ie(msp),   &               
     & im(msp),ih(msp),nelec(msp),ielem(msp,15),lid(5,msp),iv(msp)                        
      common/node/spv(msp),t,p,brm,speth(msp),spgfz(msp),spcsp(msp),      &               
     & bzro(9),ethm,h298(msp)                                                             
      dimension dum(40)                                                                   
      character*4 elemnm,dum,spnm,spnmx(msp) 
!                                                                                         
! read in elemental and species indices                                                   
! definition:                                                                             
!   nelem=total number of elements                                                        
!   nsp=total number of species                                                           
!   elemnm(i)=element name(a4)                                                            
!   elemwt(i)=molecular weight of element                                                 
!   felem(i)=mass fraction of element                                                     
!   nded(i)=species to be deduced from others      

      read(5,11) (dum(i),i=1,31)
   11 format(40a4)
      write(6,11) (dum(i),i=1,31)                                       
      read(5,10) (dum(i),i=1,19),nelem,nsp                                                
   10 format(19a4/8i10)                                                                   
      if(nprt.gt.0) write(6,10) (dum(i),i=1,19),nelem,nsp                                 
!
! for air
      if(ncase.eq.1) then                                      
        read(5,80) (dum(i),i=1,19)                                                          
        if(nprt.gt.0) write(6,80) (dum(i),i=1,19)     
        sumel=0.                                                                            
        do 20 jelem=1,nelem                                                                 
          read(5,30) elemnm(jelem),elemwt(jelem),felem(jelem)                               
   30     format(a4,6x,f10.6,e10.3,2i5)                                                     
          if(nprt.gt.0) write(6,30) elemnm(jelem),elemwt(jelem),            &               
     &     felem(jelem)                                                                     
          sumel=sumel+felem(jelem)                                                          
   20   continue                                                                            
        do 21 jelem=1,nelem                                                                 
   21   felem(jelem)=felem(jelem)/sumel                                                     
      end if
!
!  for ablation product
      if(ncase.eq.2) then
        call compos(elemnm,elemwt,felem)
!        call ivuna_wall(pres, tw,delH) 
        if(spallf.gt.1.0e-6) peff=pres/spallf
        if(spallf.le.1.0e-6) peff=pres
        call ivuna_wall(peff, tw,delH1) 
        if(spallf.gt.1.0e-6) delH=delH1/spallf
        if(spallf.le.1.0e-6) delH=delH1
      end if                                                                                       
! read in species data                                                                    
! definition:                                                                             
!   spnm(i)=species name(a4)                                                              
!   spwt(i)=species molecular weight                                                      
!   cpsp(i)=cp of species (j/mol)                                                         
!   h0sp(i)=formation energy, j/mol                                                       
!   ie(i)=electric charge; 0=neutral,1=positive,-1=negative                               
!   im(i)=molecule index; 0=atom, 1=molecle                                               
!   ih(i)=number of atoms in the species                                                  
!   nelec(i)=number of electronic states                                                  
!   ielem(jsp,i)=number of elements i in species jsp                                      
      iveq=0         
      do 50 jsp=1,nsp  
        read(5,61) (dum(k),k=1,19)    
   61   format(21a4)          
        if(nprt.gt.0) write(6,61) (dum(i),i=1,19)    
        read(5,60) spnm(jsp),spwt(jsp),cpsp(jsp),h0sp(jsp),ie(jsp),       &               
     &    im(jsp),ih(jsp),nelec(jsp),(ielem(jsp,i),i=1,nelem)                             
   60   format(a4,6x,f10.6,e10.3,e10.3,4i5,15i2)                                              
          write(6,120) spnm(jsp),spwt(jsp),cpsp(jsp),h0sp(jsp),ie(jsp),   &               
     &      im(jsp),ih(jsp),nelec(jsp),(ielem(jsp,i),i=1,nelem)                           
  120     format(a4,6x,f10.7,1pe10.3,e10.3,4i5,15i2)                                          
!                                                                                         
! spectral data                                                                           
! atom                                                                                    
! definition:                                                                             
!   atomg(ilev,jsp)=g of state ilev of species jsp                                        
!   atome(ilev,jsp)=e of state ilev of species jsp, cm-1                                  
        if(im(jsp).eq.0) then                  
          nlev=nelec(jsp)                                                                 
          read(5,80) (dum(i),i=1,19)                                                      
          if(nprt.gt.1) write(6,80) (dum(i),i=1,19)                                       
   80     format(19a4)                                                                    
          do 70 ilev=1,nlev                                                               
            read(5,90) atomg(ilev,jsp),atome(ilev,jsp)                                    
   90       format(8e10.3)                                                                
            if(nprt.gt.1) write(6,110) atomg(ilev,jsp),atome(ilev,jsp)                    
  110       format(f10.0,f10.2)                                                           
   70     continue                                                                        
        endif                                                                             
!                                                                                         
! diatomic molecule                                                                       
! definition:                                                                             
!   rmass(i)=reduced mass                                                                 
!   factr(i)=rotational factor (1 for hetero, 0.5 for homo)                               
!   spect(i,j,jsp), i=1-11 =spectral constants for species jsp,                           
!      for jth electronic state                                                           
        if((im(jsp).eq.1).and.(ih(jsp).eq.2)) then  
          read(5,80) (dum(i),i=1,19)                                                      
          if(nprt.gt.1) write(6,80) (dum(i),i=1,19)                                       
          read(5,90) rmass(jsp),factr(jsp)                                                
          if(nprt.gt.1) write(6,90) rmass(jsp),factr(jsp)                                 
          read(5,80) (dum(i),i=1,19)                                                      
          if(nprt.gt.1) write(6,80) (dum(i),i=1,19)                                       
          read(5,80) (dum(i),i=1,19)                                                      
          if(nprt.gt.1) write(6,80) (dum(i),i=1,19)                                       
          read(5,80) (dum(i),i=1,19)                                                      
          if(nprt.gt.1) write(6,80) (dum(i),i=1,19)                                       
          nlev=nelec(jsp)                                                                 
          do 160 j=1,nlev                                                                 
            read(5,80) (dum(i),i=1,19)                                                    
            if(nprt.gt.1) write(6,80) (dum(i),i=1,19)                                     
            read(5,130) (spect(i,j,jsp),i=1,7)                                            
  130       format(f10.0,f10.2,f10.4,f10.5,f10.7,f10.5,f10.0)                             
            if(nprt.gt.1) write(6,130) (spect(i,j,jsp),i=1,7)                             
            read(5,140) (spect(i,j,jsp),i=8,11)                                           
  140       format(10x,f10.3,f10.6,e10.3,e10.3)                                           
            if(nprt.gt.1) write(6,150) (spect(i,j,jsp),i=8,11)                            
  150       format(10x,f10.3,f10.6,1pe10.3,e10.3)                                         
  160     continue                                                                        
!                                                                                         
        endif                                                                             
!                                                                                         
! triatomic molecule                                                                      
! definition:                                                                             
!      factr(i)=rotational factor (1 for hetero, 0.5 for homo)                            
!      spect(1,1,jsp)=1st vibrational multiplicity                                        
!      spect(1,2,jsp)=1st vibrational constant, cm-1                                      
!      spect(2,1,jsp)=2nd vibrational multiplicity                                        
!      spect(2,2,jsp)=2nd vibrational constant, cm-1                                      
!      spect(3,1,jsp)=3rd vibrational multiplicty                                         
!      spect(3,2,jsp)=3rd vibrational constant, cm-1                                      
!      spect(4,1,jsp)=ground state electronic multiplicity                                
!      spect(5,1,jsp)=1st bond distance, angstrom                                         
!      spect(5,2,jsp)=2nd bond distance, angstrom                                         
!      spect(6,1,jsp)=bond angle, degrees                                                 
!      spect(7,1,jsp)=moment of inertia, g3-cm6                                           
!      spect(7,2,jsp)=b, cm-1                                                             
!   assumes single electronic state, harmonic oscillator, rigid rotator                   
!                                                                                         
        if((im(jsp).eq.1).and.(ih(jsp).eq.3)) then   
          read(5,80) (dum(i),i=1,19)                                                      
          if(nprt.gt.1) write(6,80) (dum(i),i=1,19)                                       
          read(5,90) rmass(jsp),factr(jsp)                                                
          if(nprt.gt.1) write(6,90) rmass(jsp),factr(jsp)                                 
          read(5,80) (dum(i),i=1,19)                                                      
          if(nprt.gt.1) write(6,80) (dum(i),i=1,19)                                       
          read(5,80) (dum(i),i=1,19)                                                      
          if(nprt.gt.1) write(6,80) (dum(i),i=1,19)                                       
          read(5,730)                                                     &               
     &     spect(1,1,jsp),spect(1,2,jsp),spect(2,1,jsp),spect(2,2,jsp),   &               
     &     spect(3,1,jsp),spect(3,2,jsp),spect(4,1,jsp),                  &               
     &     spect(5,1,jsp),spect(5,2,jsp),spect(6,1,jsp),spect(6,2,jsp),   &               
     &    spect(7,1,jsp),spect(7,2,jsp)                                                   
  730     format(f10.1,f10.2,f10.1,f10.2,f10.1,f10.2,f10.1/               &               
     &      2f10.3,2f10.2,2e10.3)                                                         
          if(nprt.gt.1) write(6,740)                                      &               
     &      spect(1,1,jsp),spect(1,2,jsp),spect(2,1,jsp),spect(2,2,jsp),  &               
     &      spect(3,1,jsp),spect(3,2,jsp),spect(4,1,jsp),                 &               
     &      spect(5,1,jsp),spect(5,2,jsp),spect(6,1,jsp),spect(6,2,jsp),  &               
     &      spect(7,1,jsp),spect(7,2,jsp)                                                 
  740       format(f10.1,f10.2,f10.1,f10.2,f10.1,f10.2,f10.1/             &               
     &       2f10.3,2f10.2,1p2e10.3)                                                      
          endif                                                                           
!                                                                                         
  310 continue                                                                            
   50 continue                                                                            
! reading of heavy-particle species ended                                                 
! electron                                                                                
! definition:                                                                             
      nsp1=nsp+1                                                                          
      nsp2=nsp+2                                                                          
      nsp3=nsp-nelem                                                                      
      jsp=nsp1                                                                            
      read(5,61) (dum(i),i=1,19)                                                          
      if(nprt.gt.1) write(6,61) (dum(i),i=1,19)                                           
      read(5,60) spnm(jsp),spwt(jsp),cpsp(jsp),                           &               
     & h0sp(jsp),ie(jsp),im(jsp),nelec(jsp),(ielem(jsp,i),i=1,            &               
     & nelem)                                                                             
      if(nprt.gt.1) write(6,120) spnm(jsp),spwt(jsp),                     &               
     & cpsp(jsp),h0sp(jsp),ie(jsp),im(jsp),nelec(jsp),(ielem(jsp,i),      &               
     & i=1,nelem)                                                                         
!                                                                                         
! read in reaction data                                                                   
! definition:                                                                             
!   nhdiss=number of dissoc reactions by heavy-particle impact                            
!   nediss=number of dissoc reactions by electron impact                                  
!   neimp=number of ionization reactions by electron impact                               
!   nexch=number of exchange reactions                                                    
!   nassoc=number of associative ionization reactions                                     
      read(5,170) (dum(i),i=1,19),nhdiss,nediss,neimp,nexch,              &               
     & nassoc                                                                             
  170 format(19a4/8i10)                                                                   
      if(nprt.gt.1) write(6,170) (dum(i),i=1,19),nhdiss,nediss,neimp,     &               
     & nexch,nassoc                                                                       
      n1=1                                                                                
      n2=nhdiss                                                                           
      n3=n2+1                                                                             
      n4=n2+nediss                                                                        
      n5=n4+1                                                                             
      n6=n4+neimp                                                                         
      n7=n6+1                                                                             
      n8=n6+nexch                                                                         
      n9=n8+1                                                                             
      n10=n8+nassoc                                                                       
! heavy particle-impact dissociation                                                      
      if(nhdiss.gt.0) then                                                                
      do 230 jr=n1,n2                                                                     
      read(5,180) dum(1),dum(2),dum(3),dum(4),dum(5)                                      
  180 format(10x,a4,8x,a4,10x,a4,8x,a4,8x,a4)                                             
      if(nprt.gt.1) write(6,180) dum(1),dum(2),dum(3),dum(4),dum(5)                       
      do 190 i=1,5                                                                        
      lid(i,jr)=0                                                                         
      do 190 jsp=1,nsp                                                                    
      if(dum(i).eq.spnm(jsp)) lid(i,jr)=jsp                                               
  190 continue                                                                            

      read(5,200) crat(2,jr),crat(3,jr)                                                   
  200 format(10x,f10.3,f10.0)                                                             
      if(nprt.gt.1) write(6,200) crat(2,jr),crat(3,jr)                                    
      do 260  ithird=1,nsp                                                                
      read(5,210) dum(6),crat1(ithird,jr)                                                 
  210 format(a4,6x,e10.3)                                                                 
      if(nprt.gt.1) write(6,210) dum(6),crat1(ithird,jr)                                  
  260 continue                                                                            
  230 continue                                                                            
      endif                                                                               
! electron-impact dissociation + electron-impact ionization                               
      if(n6.ge.n3) then                                                                   
      do 240 jr=n3,n6                                                                     
        read(5,180) dum(1),dum(2),dum(3),dum(4),dum(5)                                    
        if(nprt.gt.1) write(6,180) dum(1),dum(2),dum(3),dum(4),dum(5)                     
        do 220 i=1,5                                                                      
          lid(i,jr)=0                                                                     
          do 220 jsp=1,nsp1                                                               
            if(dum(i).eq.spnm(jsp)) lid(i,jr)=jsp                                         
  220   continue                                                                          
        read(5,510) crat(1,jr),crat(2,jr),crat(3,jr)                                      
  510   format(e10.3,f10.3,f10.0)                                                         
        if(nprt.gt.1) write(6,510) crat(1,jr),crat(2,jr),crat(3,jr)                       
  240 continue                                                                            
      endif                                                                               
! exchange + associative ionization                                                       
      if(n10.ge.n7) then                                                                  
      do 290 jr=n7,n10                                                                    
      read(5,180) dum(1),dum(2),dum(3),dum(4)                                             
      if(nprt.gt.1) write(6,180) dum(1),dum(2),dum(3),dum(4)                              
      do 280 i=1,4                                                                        
      lid(i,jr)=0                                                                         
      do 280 jsp=1,nsp2                                                                   
      if(dum(i).eq.spnm(jsp)) lid(i,jr)=jsp                                               
  280 continue                                                                            
      read(5,510) crat(1,jr),crat(2,jr),crat(3,jr)                                        
      if(nprt.gt.1) write(6,510) crat(1,jr),crat(2,jr),crat(3,jr)                         
  290 continue                                                                            
      endif                                                                               
!                                                                                         
! write lid array, if wanted                                                              
      do 900 jr=n1,n10                                                                    
      if(nprt.gt.2) write(6,910) (lid(i,jr),i=1,5)                                        
  910 format(5i5)                                                                         
  900 continue                                                                            
!                                                                                         
! calculate enthalpy (minus formation energy) at 298 K in J/mol                           
      do isp=1,nsp1                                                                       
      h298(isp)=h0sp(isp)                                                                 
      enddo                                                                               
!                                                                                         
! average molecular weight at low temperature                                             
      avmw0=0.05459068                                                                    
      do iel=1,nelem                                                                      
        nded(iel)=iel                                                                     
      end do                                                                              
      do isp=1,nsp1                                                                       
        spnmx(isp)=spnm(isp)                                                              
      end do                                                                              
      nspx=nsp     
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine trapez(ans,x,y,n,ier)                                                    
! integrates with trapezoidal rule                                                        
      implicit real*8(a-h,o-z)                                                            
      dimension x(n),y(n)                                                                 
      sum=0.                                                                              
      do i=2,n                                                                            
        sum=sum+(x(i)-x(i-1))*0.5*(y(i-1)+y(i))                                           
      enddo                                                                               
      ans=sum                                                                             
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine triatom_bf(isp,temp)                             
! triatomic continuum                                                                     
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60)                                        
      parameter (nw=400000)                                                               
      implicit real*8(a-h,o-z)                                                            
      character*1 dum(140),id_lev_triatom(8,15,mtriatoms)                                 
      character*4 contnm_triatom,unknown,asterik,minus1                                        
      character*4 atomnm2(matoms),bandnm_diatom,                          &
     &  contnm_diatom(2,21,mdiatoms)                             
      character*4 atom_rads(3,168),diatom_bands(3,100),                       &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                         &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                    &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                             &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1, &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      character*8 sym_lev_triatom(10,15,mtriatoms)                                        
      integer check,gg_lev_triatom,ge_lev_triatom,spin_lev_triatom,       &               
     & g1_lev_triatom,g2_lev_triatom,g3_lev_triatom                                       
      real*8 ix_lev_triatom,iy_lev_triatom,iz_lev_triatom                                 
      common/comi/nwave                                                                   
      common/comtriatom/a0_lev_triatom(15,mtriatoms),                     &               
     & ang_lev_triatom(15,mtriatoms),                                     &               
     & b0_lev_triatom(15,mtriatoms),c0_lev_triatom(15,mtriatoms),         &               
     & cross_cont_triatom(302,10,5,mtriatoms),                            &               
     & ix_lev_triatom(15,mtriatoms),iy_lev_triatom(15,mtriatoms),         &               
     & iz_lev_triatom(15,mtriatoms),r1_lev_triatom(15,mtriatoms),         &               
     & r2_lev_triatom(15,mtriatoms),te_lev_triatom(15,mtriatoms),         &               
     & temp_cont_triatom(10,15,mtriatoms),                                &               
     & tv_lev_triatom(15,mtriatoms),triatom_dis_eny(10),                  &               
     & triatom_ion_eny(10),triatom_mass(10),triatomwt(10),                &               
     & wavel_cont_triatom(302,5,mtriatoms),                               &               
     & we_lev_triatom(15,15,mtriatoms),wexe_lev_triatom(15,15,mtriatoms)  &               
     & ,we1_lev_triatom(15,mtriatoms),we2_lev_triatom(15,mtriatoms),      &               
     & we3_lev_triatom(15,mtriatoms),wexe1_lev_triatom(15,mtriatoms),     &               
     & wexe2_lev_triatom(15,mtriatoms),wexe3_lev_triatom(15,mtriatoms)                    
      common/comitriatom/contnm_triatom(2,5,mtriatoms),                   &               
     & g_lev_triatom(5,15,mtriatoms),g1_lev_triatom(15,mtriatoms),        &               
     & g2_lev_triatom(15,mtriatoms),g3_lev_triatom(15,mtriatoms),         &               
     & gg_lev_triatom(15,mtriatoms),ge_lev_triatom(15,mtriatoms),         &               
     & ind_lev_triatom(15,mtriatoms),lam_lev_triatom(15,mtriatoms),       &               
     & nlev_triatom(10),ntemp_cont_triatom(5,mtriatoms),                  &               
     & num_cont_triatom(mtriatoms),nwave_cont_triatom(15,mtriatoms),      &               
     & spin_lev_triatom(15,mtriatoms)                                                     
      common/coma2/dens_atom(matoms),dens_atom_hvy,dens_elec,             &               
     & dens_atom_ion,atom_rho(26,matoms),atom_chi(matoms),                &               
     & atom_avg_molwt,atom_dens_ion(matoms),dens_diatom(mdiatoms),        &               
     & dens_eq_diatom(10,mdiatoms),dens_triatom(mtriatoms)                &               
     & ,rho_diatom(10,mdiatoms)                                                           
      common/spect/calpha,slope_ratio,wavmin,wavmax,rangex                                             
      common/coma/absb(nw)                                                      
      common/spectb/ wavel(nw),absb_air(5,nw),absb_cho(11,nw),absb_low(11,nw),  &
   &    intw(10,nw),int_e(10,nw),tair(5),tcho(11),txlow(11)

      real*8 intw,int_e,minwavel,maxwavel
      dimension tlog(15),y(15),wavelx(151),cross(151)                      
!                                                                                         
      WRITE(*,*) ' IN TRIATOM_BB. ',TRIATOMNM(ISP)                                        
      write(6,15) triatomnm(isp),dens_triatom(isp)                                        
  15  format(' In triatom_bb. species = ',a4,1pe10.3,' cm-3')                             
!                                                                                         
! cycle over continua                                                                     
      k=0                                                                                 
      do icont=1,num_cont_triatom(isp)                                                    
        k=k+1                                                                             
        if(contnm_triatom(2,icont,isp).eq.triatom_bands(2,k)) then                        
        nwavex = nwave_cont_triatom(icont,isp)                                            
        minwavel = wavel_cont_triatom(1,icont,isp)                                        
        maxwavel = wavel_cont_triatom(nwavex,icont,isp)                                   
        nstrt = nwave*((minwavel-wavmin)/(wavmax-wavmin))**(1./calpha)+2
!        nstrt = (1.0/wavmin**2 - 1.0/minwavel**2)/estep + 2                                     
        nend = nwave*((maxwavel-wavmin)/(wavmax-wavmin))**(1./calpha)
!        nend = (1.0/wavmin**2 - 1.0/maxwavel**2)/estep                                          
        ntemp = ntemp_cont_triatom(icont,isp)                                             
        if(nstrt.lt.1) nstrt = 1                                                          
        if(nend.gt.nwave) nend = nwave                                                    
!                                                                                         
! interpolate absorption cross sections for given electron temperature                    
        do it = 1,ntemp                                                                   
          tlog(it) = dlog(temp_cont_triatom(it,icont,isp))                                
        end do                                                                            
        tlogx = dlog(temp)                                                                
        mon = 0                                                                           
        do iwave = 1, nwavex                                                              
          wavelx(iwave) = wavel_cont_triatom(iwave,icont,isp)                             
          do it = 1,ntemp                                                                 
            y(it) = dlog(cross_cont_triatom(iwave,it,icont,isp)+1.0e-22)                  
          end do                                                                          
          call taint(tlog,y,tlogx,crossx,ntemp,2,ner,mon)                                 
          cross(iwave) = crossx                                                           
        end do                                                                            
!                                                                                         
! interpolate to find cross section crosx                                                 
        mon = 0                                                                           
        do m = nstrt,nend                                                                 
          call taint(wavelx,cross,wavel(m),crosx,nwavex,1,ner,mon)                        
          absorption = dexp(crosx) * dens_triatom(isp)                                    
          ax = dexp(-1.43877*1.0e8/(wavel(m)*temp))                                       
          blam = 1.1904e-16 * ax/((1.0e-8*wavel(m))**5*(1.0 - ax))                        
          emission = absorption * blam                                                    
          absb(m) = absb(m) + absorption                                                  
        end do                                                                            
        end if                                                                            
      end do                                                                              
!                                                                                         
      return                                                                              
      end                                                                                 
!***********************************************************************                  
      subroutine triatom_read(ntriatom1)                                                                        
! reads triatom data   
! input parameters:
!   triatom_bands(3,10)=list of triatomic radiation mechanisms to be calculated
!   triatomnm(mtriatoms)=triatom name
! output parameters:
!   ntriatom1=number of triatoms
!   triatomnm1(mtriatoms)=name of triatoms                                                                   
      parameter(matoms=56,nlev_tot_atom=999,                              &               
     & line_tot=2830,ncross_tot=51,mdiatoms=12,mtriatoms=6,msp=60)                                        
      implicit real*8(a-h,o-z)                                                            
      character*1 dum(140),id_lev_triatom(8,15,mtriatoms)                                 
      character*4 contnm_triatom,unknown,asterik,minus1                 
      character*4 atomnm2(matoms),bandnm_diatom,                          &
     &  contnm_diatom(2,21,mdiatoms)                              
      character*4 atom_rads(3,168),diatom_bands(3,100),                                 &               
     &  triatom_bands(3,10),spnm(msp),aster,dum1(60),                                   &               
     &  atomnm(matoms),atomnm1(matoms),diatomnm(mdiatoms),                              &               
     &  diatomnm1(mdiatoms),triatomnm(mtriatoms),                                       &               
     &  triatomnm1(mtriatoms)                                                             
      common/basdat/atom_rads,diatom_bands,triatom_bands,spnm,atomnm,atomnm1,            &
    &   diatomnm,diatomnm1,triatomnm,triatomnm1
      character*8 sym_lev_triatom(10,15,mtriatoms)                                        
      integer check,gg_lev_triatom,ge_lev_triatom,spin_lev_triatom,       &               
     & g1_lev_triatom,g2_lev_triatom,g3_lev_triatom                                       
      real*8 ix_lev_triatom,iy_lev_triatom,iz_lev_triatom                                 
      common/comtriatom/a0_lev_triatom(15,mtriatoms),                     &               
     & ang_lev_triatom(15,mtriatoms),                                     &               
     & b0_lev_triatom(15,mtriatoms),c0_lev_triatom(15,mtriatoms),         &               
     & cross_cont_triatom(302,10,5,mtriatoms),                            &               
     & ix_lev_triatom(15,mtriatoms),iy_lev_triatom(15,mtriatoms),         &               
     & iz_lev_triatom(15,mtriatoms),r1_lev_triatom(15,mtriatoms),         &               
     & r2_lev_triatom(15,mtriatoms),te_lev_triatom(15,mtriatoms),         &               
     & temp_cont_triatom(10,15,mtriatoms),                                &               
     & tv_lev_triatom(15,mtriatoms),triatom_dis_eny(10),                  &               
     & triatom_ion_eny(10),triatom_mass(10),triatomwt(10),                &               
     & wavel_cont_triatom(302,5,mtriatoms),                               &               
     & we_lev_triatom(15,15,mtriatoms),wexe_lev_triatom(15,15,mtriatoms)  &               
     & ,we1_lev_triatom(15,mtriatoms),we2_lev_triatom(15,mtriatoms),      &               
     & we3_lev_triatom(15,mtriatoms),wexe1_lev_triatom(15,mtriatoms),     &               
     & wexe2_lev_triatom(15,mtriatoms),wexe3_lev_triatom(15,mtriatoms)                    
      common/comitriatom/contnm_triatom(2,5,mtriatoms),                   &               
     & g_lev_triatom(5,15,mtriatoms),g1_lev_triatom(15,mtriatoms),        &               
     & g2_lev_triatom(15,mtriatoms),g3_lev_triatom(15,mtriatoms),         &               
     & gg_lev_triatom(15,mtriatoms),ge_lev_triatom(15,mtriatoms),         &               
     & ind_lev_triatom(15,mtriatoms),lam_lev_triatom(15,mtriatoms),       &               
     & nlev_triatom(10),ntemp_cont_triatom(5,mtriatoms),                  &               
     & num_cont_triatom(mtriatoms),nwave_cont_triatom(15,mtriatoms),      &               
     & spin_lev_triatom(15,mtriatoms)                                                     
      data asterik/'****'/,minus1/'-1  '/                                                 
!                                                                                         
      ntriatoms=0                                                                         
      isp=0                                                                               
! read asterik line                                                                       
      read(9,10) (dum(i),i=1,120)                                                         
      write(3,10) (dum(i),i=1,120)                                                        
10    format(130a1)                                                                       
                                                                                          
10000 continue                                                                            
      read(9,20) unknown,(dum(i),i=1,120)                                                 
      write(3,20) unknown,(dum(i),i=1,120)                                                
   20 format(a4,130a1)                                                                    
      if(unknown.eq.minus1) then                                                          
        write(3,160) (triatomnm(i),i=1,ntriatoms)                                         
  160   format(' triatomic data finished reading for ',10a4)                              
        return                                                                            
      end if                                                                              
!                                                                                         
! check if this species is required                                                       
      check = 0                                                                           
      do i=1,mtriatoms                                                                    
        if(unknown.eq.triatomnm1(i)) check=1                                              
      end do                                                                              
      if(check.eq.1) then                                                                 
        isp=isp+1                                                                         
        go to 130                                                                         
      endif                                                                               
! this species is not needed and skipped                                                  
      write(3,140)                                                                        
  140 format(' this species is skipped')                                                  
  150 read(9,20) unknown,(dum(i),i=1,70)                                                  
      write(3,20) unknown,(dum(i),i=1,70)                                                 
      if(unknown.ne.asterik) go to 150                                                    
      go to 10000                                                                         
  130 continue                                                                            
! set species name                                                                        
      triatomnm(isp) = unknown                                                            
!                                                                                         
! prepare to read triatomic level data                                                    
      read(9,30) triatom_mass(isp), (dum(i),i=1,50)                                       
      write(3,30) triatom_mass(isp), (dum(i),i=1,50)                                      
   30 format(e11.4,70a1)                                                                  
      read(9,30) triatomwt(isp), (dum(i),i=1,50)                                          
      write(3,30) triatomwt(isp), (dum(i),i=1,50)                                         
      read(9,10) (dum(i),i=1,70)                                                          
      write(3,10) (dum(i),i=1,70)                                                         
      read(9,30) triatom_dis_eny(isp), (dum(i),i=1,50)                                    
      write(3,30) triatom_dis_eny(isp), (dum(i),i=1,50)                                   
      read(9,30) triatom_ion_eny(isp), (dum(i),i=1,50)                                    
      write(3,30) triatom_ion_eny(isp), (dum(i),i=1,50)                                   
      read(9,40) nlev_triatom(isp), (dum(i),i=1,50)                                       
      write(3,40) nlev_triatom(isp), (dum(i),i=1,50)                                      
   40 format(i11,70a1)                                                                    
!                                                                                         
      do j=1,4                                                                            
        read(9,10) (dum(i),i=1,90)                                                        
        write(3,10) (dum(i),i=1,90)                                                       
      enddo                                                                               
!                                                                                         
! read triatomic level data                                                               
      do lev=1,nlev_triatom(isp)                                                          
        read(9,50) ind_lev_triatom(lev,isp),                              &               
     &   (id_lev_triatom(j,lev,isp),j=1,8),                               &               
     &   gg_lev_triatom(lev,isp),                                         &               
     &   tv_lev_triatom(lev,isp),te_lev_triatom(lev,isp),                 &               
     &   a0_lev_triatom(lev,isp),b0_lev_triatom(lev,isp),                 &               
     &   c0_lev_triatom(lev,isp),ix_lev_triatom(lev,isp),                 &               
     &   iy_lev_triatom(lev,isp),iz_lev_triatom(lev,isp)                                  
 50     format(i3,1x,8a1,i3,8f10.2)                                                       
        write(3,50) ind_lev_triatom(lev,isp),                             &               
     &   (id_lev_triatom(j,lev,isp),j=1,8),                               &               
     &   gg_lev_triatom(lev,isp),                                         &               
     &   tv_lev_triatom(lev,isp),te_lev_triatom(lev,isp),                 &               
     &   a0_lev_triatom(lev,isp),b0_lev_triatom(lev,isp),                 &               
     &   c0_lev_triatom(lev,isp),ix_lev_triatom(lev,isp),                 &               
     &   iy_lev_triatom(lev,isp),iz_lev_triatom(lev,isp)                                  
      read(9,51) lam_lev_triatom(lev,isp),                                &               
     &  spin_lev_triatom(lev,isp),r1_lev_triatom(lev,isp),                &               
     &  r2_lev_triatom(lev,isp),ang_lev_triatom(lev,isp),                 &               
     &  we1_lev_triatom(lev,isp),wexe1_lev_triatom(lev,isp),              &               
     &  g1_lev_triatom(lev,isp),                                          &               
     &  we2_lev_triatom(lev,isp),wexe2_lev_triatom(lev,isp),              &               
     &  g2_lev_triatom(lev,isp),                                          &               
     &  we3_lev_triatom(lev,isp),wexe3_lev_triatom(lev,isp),              &               
     &  g3_lev_triatom(lev,isp)                                                           
   51 format(i7,i5,f9.4,f8.4,f7.1,f8.2,f8.3,i3,f9.2,f8.2,i3,              &               
     &  f8.2,f8.2,i3)                                                                     
      write(3,51) lam_lev_triatom(lev,isp),                               &               
     &  spin_lev_triatom(lev,isp),r1_lev_triatom(lev,isp),                &               
     &  r2_lev_triatom(lev,isp),ang_lev_triatom(lev,isp),                 &               
     &  we1_lev_triatom(lev,isp),wexe1_lev_triatom(lev,isp),              &               
     &  g1_lev_triatom(lev,isp),                                          &               
     &  we2_lev_triatom(lev,isp),wexe2_lev_triatom(lev,isp),              &               
     &  g2_lev_triatom(lev,isp),                                          &               
     &  we3_lev_triatom(lev,isp),wexe3_lev_triatom(lev,isp),              &               
     &  g3_lev_triatom(lev,isp)                                                           
      end do                                                                              
!                                                                                         
! number of radiative transitions                                                         
      read(9,10) (dum(i),i=1,90)                                                          
      write(3,10) (dum(i),i=1,90)                                                         
      read(9,70) num_cont_triatom(isp), (dum(i),i=1,70)                                   
      write(3,70) num_cont_triatom(isp), (dum(i),i=1,70)                                  
   70 format(i10,90a1)                                                                    
      read(9,10) (dum(i),i=1,90)                                                          
      write(3,10) (dum(i),i=1,90)                                                         
!                                                                                         
! prepare to read triatomic continuum data                                                
      if(num_cont_triatom(isp).eq.0) go to 120                                            
!                                                                                         
      do icont=1,num_cont_triatom(isp)                                                    
        read(9,75) (contnm_triatom(i,icont,isp),i=1,2),(dum(i),i=1,60)                    
        write(3,75) (contnm_triatom(i,icont,isp),i=1,2),(dum(i),i=1,60)                   
 75     format(2a4,70a1)                                                                  
        do j=1,2                                                                          
          read(9,10) (dum(i),i=1,79)                                                      
          write(3,10) (dum(i),i=1,79)                                                     
        enddo                                                                             
        read(9,70) ntemp_cont_triatom(icont,isp),(dum(i),i=1,60)                          
        write(3,70) ntemp_cont_triatom(icont,isp),(dum(i),i=1,60)                         
        read(9,70) nwave_cont_triatom(icont,isp),(dum(i),i=1,60)                          
        write(3,70)nwave_cont_triatom(icont,isp),(dum(i),i=1,60)                          
        read(9,10) (dum(i),i=1,79)                                                        
        write(3,10) (dum(i),i=1,79)                                                       
!                                                                                         
        read(9,200) (dum(i),i=1,11),(temp_cont_triatom(it,icont,isp),     &               
     &    it=1,ntemp_cont_triatom(icont,isp))                                             
        write(3,200) (dum(i),i=1,11),(temp_cont_triatom(it,icont,isp),    &               
     &    it=1,ntemp_cont_triatom(icont,isp))                                             
  200   format(11a1,11f10.1)                                                              
        read(9,10) (dum(i),i=1,90)                                                        
        write(3,10) (dum(i),i=1,90)                                                       
!                                                                                         
! read molecular vuv continuum data                                                       
        do iwav=1, nwave_cont_triatom(icont,isp)                                          
          read(9,210) wavel_cont_triatom(iwav,icont,isp),                 &               
     &      (cross_cont_triatom(iwav,it,icont,isp),it=1,                  &               
     &      ntemp_cont_triatom(icont,isp))                                                
          write(3,210) wavel_cont_triatom(iwav,icont,isp),                &               
     &      (cross_cont_triatom(iwav,it,icont,isp),it=1,                  &               
     &      ntemp_cont_triatom(icont,isp))                                                
  210     format(f10.2,11e10.3)                                                           
        enddo                                                                             
        read(9,10) (dum(i),i=1,90)                                                        
        write(3,10) (dum(i),i=1,90)                                                       
      end do                                                                              
  120 continue                                                                            
!                                                                                         
! this species has ended                                                                  
  180 continue                                                                            
      go to 10000                                                                         
!                                                                                         
      end                                                                                 
