program xstar1
c
c
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /mtpass/ tgran
      common /linsel/ nlsv(nnnl),nlsvn
      common /prs   / p,p0
      common /temp  / t,to
      common /sigh  / zeta
      common /nmrc  / numrec,npass
      common /tlim  / tinf
      common /phrate/ pirt(nni)
      common /cdpth / dpthc(ncn)
      common /bdpth / dpthb(ncn)
      common /dpttau/ tauth
      common /tau0ln/ tau0(nnnl)
      common /xcol  / xcc(183)
      common /icc   / lichk(nni),lipin
      common /prtop / elnprnt(400),elimdb(2),nstpt,nlnprnt,lstpt(20)
      common /enerc / epi(ncn),dele(ncn),numcon
      common /spectc/ bremsa(ncn),brems(ncn),zrems(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /radius/ delr,r,rl,rmax,rdel,radexp,rscale,rsave
      common /heato / httoto,cltoto,hmctoto
      common /epden / xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /abel  / xel(nl),xeln(nni),xelln(nnnl)
      common /avquant/ tinner,taverage,tavhp,tavhpsq,rh2sv,corfac
      common /itdat / enfmxs,ensfrc,critd,crittd,epss,crits,
     $             kmaxs,lppris,nlimd,lpprid,nnmax
      common /comptn/ de(61,61),e(61),sx(61),dez(61),ez(61)
      common /rrrthh/ rrrth(11,11)
      common /spctcb/ zremsb(ncn),zrmsbo(ncn),bremsb(ncn),
     &                brmsab(ncn)
      common /numit / lnerrs,lnerrd,ntmpit,nelit,ntotit,
     &                npttit,nstpnm
      common /ffesc / fesc(nnnl)
      common /ffescb/ fescb(nnnl)
      common /lindat/ elin(nnnl),blin(nnnl), 
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &      flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
      common /pheat / htt(nni),htcmp
      common /pcool / cll(nni),clbr,clcmp
      common /ceemis/ ceem(nnnl)
      common /rcemis/ rcem(nnnl)
      common /heat  / httot,cltot,hmctot
c
      character*72 ktitle
c
      open(unit=9,file='sigtmp.dat',form='unformatted')
      open (unit=55,file='rskirs.dat',status='unknown')
c      open(unit=11,file='../atdat/MANSIG')
c
c      lpri=4
c
c     opening message
      write (6,*) 'xstar version 1.46'
      call pprint(13)
      write (6,*) 'doing initial setup...'
c
c
c     default parameter values
      radexp=0.
      ilstpt = 0
      elimdb(1) = 1.e-5
      elimdb(2) = 1.e+5
      ilndpt = 0
      nlimd = 300
      lffst=0
      nel = nl
      na = 15
      nnnl2 = nnnl
      nni2 = nni
      lthin = 0
      lpri = 0
      lwri = 0
      lfix = 0
      npass = 0
      lbcase = 0
      lnoinwd=0
      nstpt = 1
      lstpt(1) = 9
      t = 1.
      r = 0.
      xpxcol = 1.e+21
      xpx = 1.
      rmax = xpxcol
c      rmax=xpxcol/xpx
      lcdd = 1
      zeta = 0.
      xi = 10.**zeta
      xlum = 1.
      r19 = sqrt(xlum/amax1(1.e-34,xi*xpx))
      r = r19*1.e+19
c      rmax=xpxcol/(amax1(xpx,1.e-34))
      rmax = xpxcol
      lfast = 0
      numrec = 2
      xee = 1.099
c
      call ener
      xlumo = xlum
      xlum = 1.e-30
      tp = 10.
      call ispec
      xlum = xlumo
      tgran=0.1
c
c     main event loop
      lrfrst=1
 200    continue
c
c       read in
        call pprint(13)
        call rread1(lrfrst)
c
c       set up for iterative calculation if necessary
        numreco = numrec
        npass = max0(npass,1)
        rsave = r
        colsave=rmax
        xpxsave=xpx
        if (npass.gt.1) rewind(27)
        if (npass.gt.1) rewind(28)
        nptmp = 0
 500    nptmp = nptmp + 1
        numrectmp = numrec
        numrec = numreco-1
        if ( nptmp.gt.1 ) call shuffl
        if ( nptmp.gt.1 ) call rfnd0
        numrec = numrectmp
c
c       do set-ups
        call pprint(13)
        write (6,*) 'doing model setup, pass=',nptmp,'  out of ',
     &            npass
        call init2
        lmin = 0
c
c
        rdel = 0.
        r = rsave
        xpx=xpxsave
c
        delr = 0.
        lipin = 1
        call ichk
        call lescpe
        dilfac = 0.
        call diden
        n50kev = nbinc(6.e+4)
        ldon=0
c
c       correct rmax if lfix=2
        rmaxo=rmax
        if ( lfix.eq.2 ) 
     $   rmax=xpx*((1.+rmax/xpx/r)**(1./float(max0(1,numrec)))-1.)
     $         *float(numrec)
        rmaxt = rmax/xpx
c
        xpx0 = xpx
        r0 = r
c
c       setup for special quantities
        sumt=0.
        sumhpt=0.
        sumhp=0.
        sumhpsqt=0.
        sumhpsq=0.
        sumhesh=0.
        sumv=0.
        lh2fnd=0
c
c       step thru radius zones
        tinf = 0.31
        write (6,*) 'running ...'
        numrec2=numrec
c        if ((lfix.eq.1).and.(lcdd.ne.1)) numrec2=numrec*2
        if (lfix.eq.1) numrec2=numrec+1
        do 700 jk = 1,numrec2
c
c
          write (6,99001) jk
          if ( jk.eq.1 ) lipin = 1
          lipin = 1
          call ichk
c          lipin = 0
          call moveo
          ectt = 13.6
          emult = 0.1
c         the order of these statements matters!
          if (lfix.ge.1) emult=1.
          if (ldon.ge.1) emult=1.e-10
          if ((numrec.ge.10).and.(jk.le.5).and.(lfix.lt.1)) 
     $         emult=2.5e-5
          if (jk.eq.1) emult = 1.e-20
          call step(ectt,emult)
          if ( lfix.ge.1 ) 
     $        delr = (emult)*rmaxt/float(max0(1,numrec-1))
          rl = r
          r = r + delr
          if ( lfix.eq.2 ) r = r*(1.+delr*emult)
          delr2 = delr
          if ( lfix.eq.2 ) delr2 = r*delr
          rdel = rdel + delr2
          delr = delr2
          r19 = r/1.e+19
c          if ( lmin.eq.1 ) t = min(t,tinf)
          numrectmp = numrec
          numrec = numreco
          if ( nptmp.gt.1 ) call rfnd
          numrec = numrectmp
c
          if (abs(radexp).le.1.e-34) go to 9822
             if (lcdd.eq.1) xpx=xpx*((r+rscale)/(rl+rscale))**radexp
             if (lcdd.eq.0)  p0=p0*((r+rscale)/(rl+rscale))**radexp
 9822        continue
c
c
          call solve(jk)
c
c
c         assign special quantities
          vol=12.56*r19*r19*delr
          sumv=sumv+vol
          if (jk.eq.1) tinner=t
          sumt=sumt+vol*t
          volhp=vol*xii(2)*xel(1)
          sumhpt=sumhpt+volhp*t
          sumhp=sumhp+volhp
          volhpsq=volhp*xnx
          sumhpsqt=sumhpsqt+volhpsq*t
          sumhpsq=sumhpsq+volhpsq
          sumhesh=sumhesh+vol*xii(4)*xel(2)/(xii(2)+1.e-34)/xel(1)
          if ((xii(1).gt.0.999).and.(lh2fnd.eq.0)) rh2sv=xcc(183)
          if ((xii(1).gt.0.999).and.(lh2fnd.eq.0)) lh2fnd=1
c         write (6,*)r,delr,vol,lh2fnd,tinner,volhp,sumhpt,sumhp,
c     $      volhpsq,sumhpsqt,sumhpsq,sumhesh,rh2sv
          sumhrec=0.
          do 3011 ll=2,7
            sumhrec=sumhrec+rrrth(7,ll)
 3011       continue
          sumhrec=sumhrec*(13.6+(0.8617)*t)*(1.602197e-12)*xii(2)
     $            *xpx*xnx
c         write (6,*)'h cooling:',sumhrec,cll(1)
 3093     continue
c
c
c          call ispec9(tauth)
c
          call stpcut
c
          do 650 ll = 1,nstpt
            call pprint(lstpt(ll))
 650        continue
c          write (10,*)zeta,(pirt(mm),mm=115,140)
c
c         write(6,9696)httoto,cltoto
9696      format (1h ,'httot=',1pe10.2,' cltot=',
     $     1pe10.2,'(electron point of view)')
c
          if (npass.gt.1) call savo(28)
          if (lwri.eq.1) call savo(30)
          if ( t.le.(1.1*tinf) ) lmin = lmin+1
          if ( t.le.(1.1*tinf) ) t=3*tinf
          if (lmin.ne.0) lh2fnd=1
c
          if ( jk.eq.numrec ) ldon=ldon+1
          if ( (xcc(183).gt.rmax) .and. (lfix.ne.2) ) ldon=ldon+1
          if (ldon.ge.3) goto 800
          if ( lh2fnd.eq.1) ldon=ldon+1
c
c
c
 700      continue
 800    numreco = jk
c
        write (6,*) 'done'
        call pprint(13)
c
c       compute average quantities
        taverage=sumt/(1.e-34+sumv)
        tavhp=sumhpt/(1.e-34+sumhp)
        tavhpsq=sumhpsqt/(1.e-34+sumhpsq)
        corfac=sumhesh/(1.e-34+sumv)
c

        if ( nptmp.lt.npass ) goto 500
c
        if (lwri.eq.2) call savo(30)
c
        numrec=numreco-1
        if (lfix.eq.1) numrec=numrec-1
        if (lnoinwd.ne.1) go to 901
          do 900 ll = 1,numcon
            tmpe=expo(-dpthc(ll))
            if (lthin.eq.2) tmpe=1.
            zremsz(ll) = zremsz(ll)*tmpe
c     $           +zrems(ll)
 900        continue
 901      continue
c
c
        goto 200
c
99001 format (' ',' step number = ',i4)
c
      end
      function abswis(e)
c
      real abswis,e
      integer i
c
c   returns the photo-electric cross section at energy e (in kev)
c    in units of per 10**21 hydrogen atoms
c    as formulated in morrison and mccammon
c                                      a.e.szymkowiak jan 83
      real ery(14),c0(14),c1(14),c2(14)
      data ery/0.100,0.284,0.400,0.532,0.707,0.867,1.303,
     &     1.840,2.471,3.210,4.038,7.111,8.331,10.000/
      data c0/17.3,34.6,78.1,71.4,95.5,308.9,120.6,141.3,
     &     202.7,342.7,352.2,433.9,629.0,701.2/
      data c1/608.1,267.9,18.8,66.8,145.8,-380.6,169.3,
     &     146.8,104.7,18.7,18.7,-2.4,30.9,25.2/
      data c2/ - 2150.,-476.1,4.3,-51.4,-61.1,294.0,-47.7,
     &     -31.5,-17.0,0.0,0.0,0.75,0.0,0.0/
      if ( e.ge.10.000 ) then
         abswis = 0.001*(c0(14)+c1(14)*10.0)/(e*e*e)
      else
         do 50 i = 1,14
            if ( e.lt.ery(i) ) goto 100
 50      continue
 100     abswis = 0.001*(c0(i)+c1(i)*e+c2(i)*e*e)/(e*e*e)
      endif
      return
      end
      function alphdi(n,j,l,ln,t)
c
      real a,alphdi,b,blin,cslin,delt,dl,ebar,eex,
     &     elin,expo,sxlin,t,twork,x,z12,zf
      integer j,l,ln,n,nblin,nilin,nl,nlin,nni,nnnl
c
c
c  dielectronic recombination : burgess and tworkowski for h-like
c
      parameter (nnnl=3900,nni=168,nl=13)
c
      common /lindat/ elin(nnnl),blin(nnnl),
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &    flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
c
c  burgess and tworkowski
      z12 = j - 12.
      twork = .84 + .5/j**2 + .03*z12/(1.+4.5e-5*z12**3)
      if ( n.ne.j ) twork = 1.
      alphdi = 0.
      dl = delt(n,j,l)
      if ( dl.le.0. ) return
      zf = j - 1.
      b = sqrt(zf)*(zf+1.)**2.5/sqrt(zf*zf+13.4)
      x = eex(ln)/((zf+1.)*13.6)
      a = sqrt(x)/(1.+.105*x+.015*x*x)
      ebar = eex(ln)/(1.+.015*zf**3/(zf+1.)**2)
c
      alphdi = .0030*t**(-1.5)*a*b*flin1(ln)
     &         *twork*dl*expo(-ebar*11590./t)
      return
      end
      subroutine augcmp
c
c
c
c
c     this routine uses the photoionization rate matrices aumputed in
c     augfil, to compute the effective photoionization rate, as describ
c     in weisheit.
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /aphrte/ aprtc(6,7),aprtn(7,8),aprto(8,9),
     &                aprtne(10,11),aprtsi(14,15),aprts(16,17),
     &                aprtfe(26,27)
      common /dirate/ dirth(1),dirthe(2),dirtc(6),dirtn(7),
     &                dirto(8),dirtne(10),dirtmg(12),dirtsi(14),
     &                dirts(16),dirtar(18),dirtca(20),dirtfe(26),
     &                dirtni(28)
      common /rrrate/ rrrth(1),rrrthe(2),rrrtc(6),rrrtn(7),
     &                rrrto(8),rrrtne(10),rrrtmg(12),rrrtsi(14),
     &                rrrts(16),rrrtar(18),rrrtca(20),rrrtfe(26),
     &                rrrtni(28)
      common /tbrate/ tbrth(1),tbrthe(2),tbrtc(6),tbrtn(7),
     &                tbrto(8),tbrtne(10),tbrtmg(12),tbrtsi(14),
     &                tbrts(16),tbrtar(18),tbrtca(20),tbrtfe(26),
     &                tbrtni(28)
      common /hcxrt / hxrh(2,1),hxrhe(2,2),hxrc(2,6),hxrn(2,7),
     &                hxro(2,8),hxrne(2,10),hxrmg(2,12),
     &                hxrsi(2,14),hxrs(2,16),hxrar(2,18),
     &                hxrca(2,20),hxrfe(2,26),hxrni(2,28),
     &                hexrh(2,1),hexrhe(2,2),hexrc(2,6),hexrn(2,7)
     &               ,hexro(2,8),hexrne(2,10),hexrmg(2,12),
     &                hexrsi(2,14),hexrs(2,16),hexrar(2,18),
     &                hexrca(2,20),hexrfe(2,26),hexrni(2,28)
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /abel  / xel(nl),xeln(nni),xelln(nnnl)
      common /phrate/ pirth(1),pirthe(2),pirtc(6),pirtn(7),
     &                pirto(8),pirtne(10),pirtmg(12),pirtsi(14),
     &                pirts(16),pirtar(18),pirtca(20),pirtfe(26),
     &                pirtni(28)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
      dimension pirt(nni)
c
      equivalence (pirth(1),pirt(1))
c
      if ( nel.ge.3 ) then
c
         xh1 = xel(1)*xii(1)*xpx
         xh2 = xel(1)*xii(2)*xpx
         xhe1 = xel(2)*xii(3)*xpx
         xhe2 = xel(2)*xii(4)*xpx
c
         if ( lpri.gt.2 ) write (6,99001)
c
c     carbon
         pirtc(1) = aprtc(1,2)
         do 50 ik = 2,6
            prod = 1.
            pirtc(ik) = aprtc(ik,ik+1)
            ikm1 = ik - 1
            do 20 jk = 1,ikm1
               kk = ik - jk
               if ( lpri.gt.2 ) write (6,99002) ik,jk,kk,rrrtc(kk)
     &                                ,dirtc(kk),tbrtc(kk),
     &                                 hxrc(1,kk),hexrc(1,kk),
     &                                 pirtc(kk),prod
               temp = ((rrrtc(kk)+dirtc(kk)+tbrtc(kk))*xnx+hxrc(1,kk)
     &                *xh1+hexrc(1,kk)*xhe1)/pirtc(kk)
               if ( prod.lt.1.e+17 ) prod = prod*temp
               pirtc(ik) = pirtc(ik) + aprtc(kk,ik+1)*prod
 20         continue
 50      continue
c
         if ( nel.ge.4 ) then
c
c           nitrogen
            pirtn(1) = aprtn(1,2)
            do 80 ik = 2,7
               prod = 1.
               pirtn(ik) = aprtn(ik,ik+1)
               ikm1 = ik - 1
               do 60 jk = 1,ikm1
                  kk = ik - jk
                  if ( lpri.gt.2 ) write (6,99002) ik,jk,kk,
     &                 rrrtn(kk),dirtn(kk),tbrtn(kk),hxrn(1,kk),
     &                 hexrn(1,kk),pirtn(kk),prod
                  temp = ((rrrtn(kk)+dirtn(kk)+tbrtn(kk))*xnx+hxrn(1,kk)
     &                   *xh1+hexrn(1,kk)*xhe1)/pirtn(kk)
                  if ( prod.lt.1.e+17 ) prod = prod*temp
                  pirtn(ik) = pirtn(ik) + aprtn(kk,ik+1)*prod
 60            continue
 80         continue
c
            if ( nel.ge.5 ) then
c
c              oxygen
c               go to 3009
               pirto(1) = aprto(1,2) + xh2*hxro(2,1)
               do 90 ik = 2,8
                  prod = 1.
                  pirto(ik) = aprto(ik,ik+1)
                  ikm1 = ik - 1
                  do 85 jk = 1,ikm1
                     kk = ik - jk
                     if ( lpri.gt.2 ) write (6,99002) ik,jk,kk,
     &                    rrrto(kk),dirto(kk),tbrto(kk),hxro(1,kk)
     &                   ,hexro(1,kk),pirto(kk),prod
                     temp = ((rrrto(kk)+dirto(kk)+tbrto(kk))
     &                      *xnx+hxro(1,kk)*xh1+hexro(1,kk)*xhe1)
     &                      /pirto(kk)
c                     temp=min(temp,1.e+33/(1.e-34+prod))
                     if ( prod.lt.1.e+12 ) prod = prod*temp
c                     prod=prod*temp
                     pirto(ik) = pirto(ik) + aprto(kk,ik+1)*prod
 85               continue
 90            continue
 3009          continue
c
               if ( nel.ge.6 ) then
c
c     neon
                  pirtne(1) = aprtne(1,2)
                  do 95 ik = 2,10
                     prod = 1.
                     pirtne(ik) = aprtne(ik,ik+1)
                     ikm1 = ik - 1
                     do 92 jk = 1,ikm1
                        kk = ik - jk
                        if ( lpri.gt.2 ) write (6,99002) ik,jk,kk,
     &                       rrrtne(kk),dirtne(kk),tbrtne(kk),
     &                       hxrne(1,kk),hexrne(1,kk),pirtne(kk),
     &                       prod
                        temp = ((rrrtne(kk)+dirtne(kk)+tbrtne(kk))
     &                         *xnx+hxrne(1,kk)*xh1+hexrne(1,kk)*xhe1)
     &                         /pirtne(kk)
                        if ( prod.lt.1.e+17 ) prod = prod*temp
                        pirtne(ik) = pirtne(ik) + aprtne(kk,ik+1)*prod
 92                  continue
 95               continue
c
                  if ( nel.ge.8 ) then
c
c
c     silicon
                     pirtsi(1) = aprtsi(1,2)
                     do 98 ik = 2,14
                        prod = 1.
                        pirtsi(ik) = aprtsi(ik,ik+1)
                        ikm1 = ik - 1
                        do 96 jk = 1,ikm1
                           kk = ik - jk
                           if ( lpri.gt.2 ) write (6,99002) ik,jk,
     &                          kk,rrrtsi(kk),dirtsi(kk),
     &                          tbrtsi(kk),hxrsi(1,kk),hexrsi(1,kk)
     &                         ,pirtsi(kk),prod
                           temp = ((rrrtsi(kk)+dirtsi(kk)+tbrtsi(kk))
     &                            *xnx+hxrsi(1,kk)*xh1+hexrsi(1,kk)
     &                            *xhe1)/pirtsi(kk)
                           if ( prod.lt.1.e+17 ) prod = prod*temp
                           pirtsi(ik) = pirtsi(ik) + aprtsi(kk,ik+1)
     &                                  *prod
 96                     continue
 98                  continue
c
                     if ( nel.ge.9 ) then
c
c
c     sulfur
                        pirts(1) = aprts(1,2)
                        do 102 ik = 2,16
                           prod = 1.
                           pirts(ik) = aprts(ik,ik+1)
                           ikm1 = ik - 1
                           do 100 jk = 1,ikm1
                              kk = ik - jk
                              if ( lpri.gt.2 ) write (6,99002) ik,jk,
     &                             kk,rrrts(kk),dirts(kk),
     &                             tbrts(kk),hxrs(1,kk),hexrs(1,kk)
     &                            ,pirts(kk),prod
                              temp = ((rrrts(kk)+dirts(kk)+tbrts(kk))
     &                               *xnx+hxrs(1,kk)*xh1+hexrs(1,kk)
     &                               *xhe1)/pirts(kk)
                              if ( prod.lt.1.e+17 ) prod = prod*temp
                              pirts(ik) = pirts(ik) + aprts(kk,ik+1)
     &                           *prod
 100                       continue
 102                    continue
c
c
                        if ( nel.ge.12 ) then
c
c                          iron
                           pirtfe(1) = aprtfe(1,2)
                           do 106 ik = 2,26
                              prod = 1.
                              pirtfe(ik) = aprtfe(ik,ik+1)
                              ikm1 = ik - 1
                              do 104 jk = 1,ikm1
                                 kk = ik - jk
                                 if ( lpri.gt.2 ) write (6,99002) ik,
     &                                jk,kk,rrrtfe(kk),dirtfe(kk)
     &                               ,tbrtfe(kk),hxrfe(1,kk),
     &                                hexrfe(1,kk),pirtfe(kk),prod
                                 temp = ((rrrtfe(kk)+dirtfe(kk)+tbrtfe(
     &                                  kk))*xnx+hxrfe(1,kk)
     &                                  *xh1+hexrfe(1,kk)*xhe1)
     &                                  /pirtfe(kk)
                                 if ( prod.lt.1.e+17 ) prod = prod*temp
                                 pirtfe(ik) = pirtfe(ik)
     &                              + aprtfe(kk,ik+1)*prod
 104                          continue
 106                       continue
                        endif
                     endif
                  endif
               endif
            endif
         endif
      endif
c
c
c
c
      return
99001 format (' ',' in augcmp ')
99002 format (' ',3i4,7e12.4)
      end
      subroutine augfil
c
c
c
c
 
c     this routine fills the photoinization rates matrices, in aphrate.
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /phheat/ pihth(1),pihthe(2),pihtc(6),pihtn(7),
     &                pihto(8),pihtne(10),pihtmg(12),pihtsi(14),
     &                pihts(16),pihtar(18),pihtca(20),pihtfe(26),
     &                pihtni(28)
      common /phrate/ pirth(1),pirthe(2),pirtc(6),pirtn(7),
     &                pirto(8),pirtne(10),pirtmg(12),pirtsi(14),
     &                pirts(16),pirtar(18),pirtca(20),pirtfe(26),
     &                pirtni(28)
      common /abion / xii(nnip),xih(1),xihe(2),xic(6),xin(7),
     &                xio(8),xine(10),ximg(12),xisi(14),xis(16)
     &               ,xiar(18),xica(20),xife(26),xini(28),
     &                xiip(nni),xiln(nnnl),xilp(nnnl),xiio(nnip)
      common /pqrate/ piqth(1),piqthe(2),piqtc(6),piqtn(7),
     &                piqto(8),piqtne(10),piqtmg(12),piqtsi(14),
     &                piqts(16),piqtar(18),piqtca(20),piqtfe(26),
     &                piqtni(28)
      common /pphht / phkh(1),phkhe(2),phkc(6),phlsc(4),phlpc(2)
     &               ,phkn(7),phlsn(5),phlpn(3),phko(8),
     &                phlso(6),phlpo(4),phkne(10),phlsne(8),
     &                phlpne(6),phkmg(12),phlsmg(10),phlpmg(8),
     &                phmsmg(2),phksi(14),phlssi(12),phlpsi(10),
     &                phmssi(4),phmpsi(2),phks(16),phlss(14),
     &                phlps(12),phmss(6),phmps(4),phkar(18),
     &                phlsar(16),phlpar(14),phmsar(8),phmpar(6),
     &                phkca(20),phlsca(18),phlpca(16),phmsca(10),
     &                phmpca(8),phmdca(2),phkfe(26),phlsfe(24),
     &                phlpfe(22),phmsfe(16),phmpfe(14),phmdfe(8),
     &                phnfe(2),phkni(28),phlsni(26),phlpni(24),
     &                phmsni(18),phmpni(16),phmdni(10),phnni(4)
      common /ppqrt / pqkh(1),pqkhe(2),pqkc(6),pqlsc(4),pqlpc(2)
     &               ,pqkn(7),pqlsn(5),pqlpn(3),pqko(8),
     &                pqlso(6),pqlpo(4),pqkne(10),pqlsne(8),
     &                pqlpne(6),pqkmg(12),pqlsmg(10),pqlpmg(8),
     &                pqmsmg(2),pqksi(14),pqlssi(12),pqlpsi(10),
     &                pqmssi(4),pqmpsi(2),pqks(16),pqlss(14),
     &                pqlps(12),pqmss(6),pqmps(4),pqkar(18),
     &                pqlsar(16),pqlpar(14),pqmsar(8),pqmpar(6),
     &                pqkca(20),pqlsca(18),pqlpca(16),pqmsca(10),
     &                pqmpca(8),pqmdca(2),pqkfe(26),pqlsfe(24),
     &                pqlpfe(22),pqmsfe(16),pqmpfe(14),pqmdfe(8),
     &                pqnfe(2),pqkni(28),pqlsni(26),pqlpni(24),
     &                pqmsni(18),pqmpni(16),pqmdni(10),pqnni(4)
      common /ppirt / prkh(1),prkhe(2),prkc(6),prlsc(4),prlpc(2)
     &               ,prkn(7),prlsn(5),prlpn(3),prko(8),
     &                prlso(6),prlpo(4),prkne(10),prlsne(8),
     &                prlpne(6),prkmg(12),prlsmg(10),prlpmg(8),
     &                prmsmg(2),prksi(14),prlssi(12),prlpsi(10),
     &                prmssi(4),prmpsi(2),prks(16),prlss(14),
     &                prlps(12),prmss(6),prmps(4),prkar(18),
     &                prlsar(16),prlpar(14),prmsar(8),prmpar(6),
     &                prkca(20),prlsca(18),prlpca(16),prmsca(10),
     &                prmpca(8),prmdca(2),prkfe(26),prlsfe(24),
     &                prlpfe(22),prmsfe(16),prmpfe(14),prmdfe(8),
     &                prnfe(2),prkni(28),prlsni(26),prlpni(24),
     &                prmsni(18),prmpni(16),prmdni(10),prnni(4)
      common /ethph / etkh(1),etkhe(2),etkc(6),etlsc(4),etlpc(2)
     &               ,etkn(7),etlsn(5),etlpn(3),etko(8),
     &                etlso(6),etlpo(4),etkne(10),etlsne(8),
     &                etlpne(6),etkmg(12),etlsmg(10),etlpmg(8),
     &                etmsmg(2),etksi(14),etlssi(12),etlpsi(10),
     &                etmssi(4),etmpsi(2),etks(16),etlss(14),
     &                etlps(12),etmss(6),etmps(4),etkar(18),
     &                etlsar(16),etlpar(14),etmsar(8),etmpar(6),
     &                etkca(20),etlsca(18),etlpca(16),etmsca(10),
     &                etmpca(8),etmdca(2),etkfe(26),etlsfe(24),
     &                etlpfe(22),etmsfe(16),etmpfe(14),etmdfe(8),
     &                etnfe(2),etkni(28),etlsni(26),etlpni(24),
     &                etmsni(18),etmpni(16),etmdni(10),etnni(4)
      common /spectc/ bremsa(ncn),brems(ncn),zrems(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /aphrte/ aprtc(6,7),aprtn(7,8),aprto(8,9),
     &                aprtne(10,11),aprtsi(14,15),aprts(16,17),
     &                aprtfe(26,27)
      common /agdata/ amkc(6,6),amkn(7,7),amko(8,8),amkne(10,10),
     &                amkmg(12,12),amlsmg(10,10),amlpmg(8,8),
     &                amksi(14,14),amlssi(12,12),amlpsi(10,10),
     &                amks(16,16),amlss(14,14),amlps(12,12),
     &                amkfe(26,26),amlsfe(24,24),amlpfe(22,22)
      common /flpass/ fflmh(15,1),fflmhe(15,2),fflmc(15,6),
     &                fflmn(15,7),fflmo(15,8),fflmne(15,10),
     &                fflmmg(15,12),fflmsi(15,14),fflms(15,16),
     &                fflmfe(15,26)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
      dimension agzro(1464)
      dimension flmzro(102)
      dimension flemh(1),flemc(6),flemn(7),flemo(8),flemne(10),
     &          flemsi(14),flems(16),flemfe(26)
      dimension aheat(26),aion(26)
      dimension nflnk(26),nflnls(26),nflnlp(26),nflnms(26),
     &          nflnmp(26),nflnmd(26)
      dimension piht(nni),piqt(nni)
      dimension esumhe(2),esumc(6),esumn(7),esumo(8),esumne(10)
     &         ,esumsi(14),esums(16),esumfe(26)
c
      equivalence (piht(1),pihth(1)),(piqt(1),piqth(1)),
     &             (agzro(1),aprtc(1,1)),(flmzro(1),flemh(1))
c
c
c
      data ergsev/1.602192e-12/
      data nflnk/3, 2*1,7,7,5*6,2*12,10,5*12,6*8,2*7/
      data nflnls/3*0,1,1,5*5,2*10,9,5*11,6*7,2*6/
      data nflnlp/10*0,2*11,11,5*10,6*6,2*5/
      data nflnms/12*0,1,5*9,6*5,2*4/
      data nflnmp/18*0,6*4,2*3/
      data nflnmd/24*0,2*2/
c     energy sumdata
      data esumhe/79.,54.6/
      data esumc/1030.,1019.,994.4,946.5,882.,490./
      data esumn/1486.,1472.,1442.,1394.,1317.,1219.,667./
      data esumo/2044.,2030.,1995.,1940.,1863.,1749.,1611.,
     &     871.4/
      data esumne/3512.,3490.,3449.,3386.,3289.,3162.,
     &     3004.,2797.,2558.,1362./
      data esumsi/7888.,7880.,7863.,7830.,7785.,7618.,
     &     7413.,7166.,6863.,6512.,6110.,5634.,5111.,
     &     2673./
      data esums/10858.,10848.,10824.,10789.,10742.,10670.,
     &     10581.,10300.,9972.,9593.,9146.,8641.,8077.,
     &     7425.,6718.,3494./
      data esumfe/34628.,34620.,34604.,34573.,34518.,34443.,
     &     34344.,34219.,34068.,33833.,33571.,33281.,
     &     32950.,32589.,32197.,31740.,31250.,29985.,
     &     28627.,27171.,25589.,23900.,22101.,20151.,
     &     18106.,9278./
c
c
c     zero the photoionization rate matrices.
      do 100 jk = 1,1464
         agzro(jk) = 0.
 100  continue
      do 200 jk = 1,102
         flmzro(jk) = 0.
 200  continue
c
      if ( lpri.gt.2 ) write (6,99001)
c
      if ( nel.ge.3 ) then
c
c     carbon
         call aughlp(aprtc,amkc,aheat,aion,prkc,esumc,etkc,flemc,1,6,6)
         do 250 ik = 1,4
            nfl = nflnk(6-ik)
            if ( lpri.gt.2 ) write (6,99002) ik,nfl,flemc(ik)
            if ( (nfl.ne.0) .and. (ik.ne.6) ) fflmc(nfl,ik+1)
     &           = flemc(ik)
            piqtc(ik) = pqkc(ik) + aion(ik)
            pihtc(ik) = phkc(ik) + aheat(ik)
 250     continue
c     l shell
         do 300 ik = 1,4
            nfl = nflnls(6-ik)
            if ( (nfl.ne.0) .and. (ik.ne.6) ) fflmc(nfl,ik+1)
     &           = prlsc(ik)
            aprtc(ik,ik+1) = aprtc(ik,ik+1) + prlsc(ik)
            piqtc(ik) = piqtc(ik) + pqlsc(ik)
            pihtc(ik) = pihtc(ik) + phlsc(ik)
 300     continue
         do 350 ik = 1,2
            nfl = nflnlp(6-ik)
            if ( (nfl.ne.0) .and. (ik.ne.6) ) fflmc(nfl,ik+1)
     &           = aprtc(ik,ik+1) + prlpc(2)
            aprtc(ik,ik+1) = aprtc(ik,ik+1) + prlpc(ik)
            piqtc(ik) = piqtc(ik) + pqlpc(ik)
            pihtc(ik) = pihtc(ik) + phlpc(ik)
 350     continue
c
c
         if ( nel.ge.4 ) then
c
c     nitrogen
c     k shell
            call aughlp(aprtn,amkn,aheat,aion,prkn,esumn,etkn,flemn,1,7,
     &                  7)
            do 360 ik = 1,5
               nfl = nflnk(7-ik)
               if ( (nfl.ne.0) .and. (ik.ne.7) ) fflmn(nfl,ik+1)
     &              = flemn(ik)
               piqtn(ik) = pqkn(ik) + aion(ik)
               pihtn(ik) = phkn(ik) + aheat(ik)
 360        continue
c     l shell
            do 380 ik = 1,5
               nfl = nflnls(7-ik)
               if ( (nfl.ne.0) .and. (ik.ne.7) ) fflmn(nfl,ik+1)
     &              = prlsn(ik)
               aprtn(ik,ik+1) = aprtn(ik,ik+1) + prlsn(ik)
               piqtn(ik) = piqtn(ik) + pqlsn(ik)
               pihtn(ik) = pihtn(ik) + phlsn(ik)
 380        continue
            do 400 ik = 1,3
               nfl = nflnlp(7-ik)
               if ( (nfl.ne.0) .and. (ik.ne.7) ) fflmn(nfl,ik+1)
     &              = prlpn(ik)
               aprtn(ik,ik+1) = aprtn(ik,ik+1) + prlpn(ik)
               piqtn(ik) = piqtn(ik) + pqlpn(ik)
               pihtn(ik) = pihtn(ik) + phlpn(ik)
 400        continue
c
            if ( nel.ge.5 ) then
c
c     oxygen
c     k shell
               call aughlp(aprto,amko,aheat,aion,prko,esumo,etko,flemo,
     &                     1,8,8)
               do 410 ik = 1,6
                  nfl = nflnk(8-ik)
                  if ( (nfl.ne.0) .and. (ik.ne.8) ) fflmo(nfl,ik+1)
     &                 = flemo(ik)
                  piqto(ik) = pqko(ik) + aion(ik)
                  pihto(ik) = phko(ik) + aheat(ik)
 410           continue
c     l shell
               do 420 ik = 1,6
                  nfl = nflnls(8-ik)
                  if ( (nfl.ne.0) .and. (ik.ne.8) ) fflmo(nfl,ik+1)
     &                 = prlso(ik)
                  aprto(ik,ik+1) = aprto(ik,ik+1) + prlso(ik)
                  piqto(ik) = piqto(ik) + pqlso(ik)
                  pihto(ik) = pihto(ik) + phlso(ik)
 420           continue
               do 430 ik = 1,4
                  nfl = nflnlp(8-ik)
                  if ( (nfl.ne.0) .and. (ik.ne.8) ) fflmo(nfl,ik+1)
     &                 = prlpo(ik)
                  aprto(ik,ik+1) = aprto(ik,ik+1) + prlpo(ik)
                  piqto(ik) = piqto(ik) + pqlpo(ik)
                  pihto(ik) = pihto(ik) + phlpo(ik)
 430           continue
c
c
               if ( nel.ge.6 ) then
c     neon
c     k shell
                  call aughlp(aprtne,amkne,aheat,aion,prkne,esumne,
     &                        etkne,flemne,1,10,10)
                  do 435 ik = 1,8
                     nfl = nflnk(10-ik)
                     if ( (nfl.ne.0) .and. (ik.ne.10) ) fflmne(nfl,ik+1)
     &                    = flemne(ik)
                     piqtne(ik) = pqkne(ik) + aion(ik)
                     pihtne(ik) = phkne(ik) + aheat(ik)
 435              continue
c     l shell
                  do 440 ik = 1,8
                     nfl = nflnls(10-ik)
                     if ( (nfl.ne.0) .and. (ik.ne.10) ) fflmne(nfl,ik+1)
     &                    = prlsne(ik)
                     aprtne(ik,ik+1) = aprtne(ik,ik+1) + prlsne(ik)
                     piqtne(ik) = piqtne(ik) + pqlsne(ik)
                     pihtne(ik) = pihtne(ik) + phlsne(ik)
 440              continue
                  do 445 ik = 1,6
                     nfl = nflnlp(10-ik)
                     if ( (nfl.ne.0) .and. (ik.ne.10) ) fflmne(nfl,ik+1)
     &                    = prlpne(ik)
                     aprtne(ik,ik+1) = aprtne(ik,ik+1) + prlpne(ik)
                     piqtne(ik) = piqtne(ik) + pqlpne(ik)
                     pihtne(ik) = pihtne(ik) + phlpne(ik)
 445              continue
c
                  if ( nel.ge.7 ) then
c     silicon
c     k shell
                     call aughlp(aprtsi,amksi,aheat,aion,prksi,esumsi,
     &                           etksi,flemsi,1,14,14)
c                     write (6,*)'si k shell rates:'
                     do 446 ik = 1,12
                        nfl = nflnk(14-ik)
                        if ( (nfl.ne.0) .and. (ik.ne.14) )
     &                       fflmsi(nfl,ik+1) = flemsi(ik)
c                        write (6,*)ik,nfl,flemsi(ik)
                        piqtsi(ik) = pqksi(ik) + aion(ik)
                        pihtsi(ik) = phksi(ik) + aheat(ik)
 446                 continue
c     ls shell
                     call aughlp(aprtsi,amlssi,aheat,aion,prlssi,esumsi,
     &                           etlssi,flemsi,1,12,14)
                     do 448 ik = 1,10
                        nfl = nflnls(14-ik)
                        if ( (nfl.ne.0) .and. (ik.ne.14) )
     &                       fflmsi(nfl,ik+1) = flemsi(ik)
                        pihtsi(ik) = pihtsi(ik) + phlssi(ik) + aheat(ik)
                        piqtsi(ik) = piqtsi(ik) + pqlssi(ik) + aion(ik)
 448                 continue
c     lp shell
                     call aughlp(aprtsi,amlpsi,aheat,aion,prlpsi,esumsi,
     &                           etlpsi,flemsi,1,10,14)
                     do 450 ik = 1,4
                        nfl = nflnlp(14-ik)
                        if ( (nfl.ne.0) .and. (ik.ne.14) )
     &                       fflmsi(nfl,ik+1) = flemsi(ik)
                        pihtsi(ik) = pihtsi(ik) + phlpsi(ik) + aheat(ik)
                        piqtsi(ik) = piqtsi(ik) + pqlpsi(ik) + aion(ik)
 450                 continue
c     ms shell
                     do 452 ik = 1,4
                        nfl = nflnms(14-ik)
                        if ( (nfl.ne.0) .and. (ik.ne.14) )
     &                       fflmsi(nfl,ik+1) = prmssi(ik)
                        aprtsi(ik,ik+1) = aprtsi(ik,ik+1) + prmssi(ik)
 452                 continue
                     do 454 ik = 1,4
                        piqtsi(ik) = piqtsi(ik) + pqmssi(ik)
                        pihtsi(ik) = pihtsi(ik) + phmssi(ik)
 454                 continue
c     mp shell
                     do 456 ik = 1,2
                        nfl = nflnmp(14-ik)
                        if ( (nfl.ne.0) .and. (ik.ne.14) )
     &                       fflmsi(nfl,ik+1) = prmpsi(ik)
                        aprtsi(ik,ik+1) = aprtsi(ik,ik+1) + prmpsi(ik)
 456                 continue
                     do 458 ik = 1,2
                        pihtsi(ik) = pihtsi(ik) + phmpsi(ik)
                        piqtsi(ik) = piqtsi(ik) + pqmpsi(ik)
 458                 continue
c
                     if ( nel.ge.8 ) then
c
c     sulfur
c     k shell
                        call aughlp(aprts,amks,aheat,aion,prks,esums,
     &                              etks,flems,1,16,16)
                        do 460 ik = 1,14
                           nfl = nflnk(16-ik)
                           if ( (nfl.ne.0) .and. (ik.ne.16) )
     &                          fflms(nfl,ik+1) = flems(ik)
                           piqts(ik) = pqks(ik) + aion(ik)
                           pihts(ik) = phks(ik) + aheat(ik)
 460                    continue
c     ls shell
                        call aughlp(aprts,amlss,aheat,aion,prlss,esums,
     &                              etlss,flems,1,14,16)
                        do 462 ik = 1,12
                           nfl = nflnls(16-ik)
                           if ( (nfl.ne.0) .and. (ik.ne.16) )
     &                          fflms(nfl,ik+1) = flems(ik)
                           piqts(ik) = piqts(ik) + pqlss(ik) + aion(ik)
                           pihts(ik) = pihts(ik) + phlss(ik) + aheat(ik)
 462                    continue
c     lp shell
                        call aughlp(aprts,amlps,aheat,aion,prlps,esums,
     &                              etlps,flems,1,12,16)
                        do 464 ik = 1,6
                           nfl = nflnlp(16-ik)
                           if ( (nfl.ne.0) .and. (ik.ne.16) )
     &                          fflms(nfl,ik+1) = flems(ik)
                           piqts(ik) = piqts(ik) + pqlps(ik) + aion(ik)
                           pihts(ik) = pihts(ik) + phlps(ik) + aheat(ik)
 464                    continue
c     ms shell
                        do 466 ik = 1,6
                           nfl = nflnms(16-ik)
                           if ( (nfl.ne.0) .and. (ik.ne.16) )
     &                          fflms(nfl,ik+1) = prmss(ik)
                           aprts(ik,ik+1) = aprts(ik,ik+1) + prmss(ik)
 466                    continue
                        do 468 ik = 1,6
                           piqts(ik) = piqts(ik) + pqmss(ik)
                           pihts(ik) = pihts(ik) + phmss(ik)
 468                    continue
c     mp shell
                        do 470 ik = 1,4
                           nfl = nflnmp(16-ik)
                           if ( (nfl.ne.0) .and. (ik.ne.16) )
     &                          fflms(nfl,ik+1) = prmps(ik)
                           aprts(ik,ik+1) = aprts(ik,ik+1) + prmps(ik)
 470                    continue
                        do 472 ik = 1,4
                           piqts(ik) = piqts(ik) + pqmps(ik)
                           pihts(ik) = pihts(ik) + phmps(ik)
 472                    continue
c
c
                        if ( nel.ge.12) then
c
c                          iron
c                          k shell
                           call aughlp(aprtfe,amkfe,aheat,aion,prkfe,
     &                                 esumfe,etkfe,flemfe,1,26,26)
                           do 474 ik = 1,25
                              nfl = nflnk(26-ik)
                              if ( (nfl.ne.0) .and. (ik.ne.26) )
     &                             fflmfe(nfl,ik+1) = flemfe(ik)
                              nfl2 = nflnls(26-ik)
c                             here's the l shell fluorescence fake
                              if ( (nfl2.ne.0) .and. (ik.le.14) )
     &                             fflmfe(nfl2,ik+1) = flemfe(ik)
     &                             *amlsfe(ik,ik)
                              nfl2 = nflnlp(26-ik)
c                             here's the l shell fluorescence fake
                              if ( (nfl2.ne.0) .and. (ik.le.15) )
     &                             fflmfe(nfl2,ik+1) = flemfe(ik)
     &                             *amlpfe(ik,ik)
                              if ( lpri.gt.2 ) write (6,99003) ik,
     &                             nfl,prkfe(ik),flemfe(ik)
                              piqtfe(ik) = pqkfe(ik) + aion(ik)
                              pihtfe(ik) = phkfe(ik) + aheat(ik)
 474                       continue
c                          ls shell
                           call aughlp(aprtfe,amlsfe,aheat,aion,prlsfe,
     &                                 esumfe,etlsfe,flemfe,1,24,26)
                           do 476 ik = 1,22
                              nfl = nflnls(26-ik)
                              if ( (nfl.ne.0) .and. (ik.ne.26) )
     &                             fflmfe(nfl,ik+1) = flemfe(ik)
                              pihtfe(ik) = pihtfe(ik) + phlsfe(ik)
     &                           + aheat(ik)
                              piqtfe(ik) = piqtfe(ik) + pqlsfe(ik)
     &                           + aion(ik)
 476                       continue
c                          lp shell
                           call aughlp(aprtfe,amlpfe,aheat,aion,prlpfe,
     &                                 esumfe,etlpfe,flemfe,1,22,26)
                           do 478 ik = 1,22
                              nfl = nflnlp(26-ik)
                              if ( (nfl.ne.0) .and. (ik.ne.26) )
     &                             fflmfe(nfl,ik+1) = flemfe(ik)
                              piqtfe(ik) = piqtfe(ik) + pqlpfe(ik)
     &                           + aion(ik)
                              pihtfe(ik) = pihtfe(ik) + phlpfe(ik)
     &                           + aheat(ik)
 478                       continue
c                          ms shell
                           do 480 ik = 1,16
                              nfl = nflnms(26-ik)
                              if ( (nfl.ne.0) .and. (ik.ne.26) )
     &                             fflmfe(nfl,ik+1) = prmsfe(ik)
                              aprtfe(ik,ik+1) = aprtfe(ik,ik+1)
     &                           + prmsfe(ik)
 480                       continue
                           do 482 ik = 1,16
                              piqtfe(ik) = piqtfe(ik) + pqmsfe(ik)
                              pihtfe(ik) = pihtfe(ik) + phmsfe(ik)
 482                       continue
c                          mp shell
                           do 484 ik = 1,14
                              nfl = nflnmp(26-ik)
                              if ( (nfl.ne.0) .and. (ik.ne.26) )
     &                             fflmfe(nfl,ik+1) = prmpfe(ik)
                              aprtfe(ik,ik+1) = aprtfe(ik,ik+1)
     &                           + prmpfe(ik)
 484                       continue
                           do 486 ik = 1,14
                              piqtfe(ik) = piqtfe(ik) + pqmpfe(ik)
                              pihtfe(ik) = pihtfe(ik) + phmpfe(ik)
 486                       continue
c     md shell
                           do 488 ik = 1,8
                              nfl = nflnmd(26-ik)
                              if ( (nfl.ne.0) .and. (ik.ne.26) )
     &                             fflmfe(nfl,ik+1) = prmdfe(ik)
                              aprtfe(ik,ik+1) = aprtfe(ik,ik+1)
     &                           + prmdfe(ik)
 488                       continue
                           do 490 ik = 1,8
                              piqtfe(ik) = piqtfe(ik) + pqmdfe(ik)
                              pihtfe(ik) = pihtfe(ik) + phmdfe(ik)
 490                       continue
c     n shell
                           do 492 ik = 1,2
                              aprtfe(ik,ik+1) = aprtfe(ik,ik+1)
     &                           + prnfe(ik)
 492                       continue
                           do 494 ik = 1,2
                              piqtfe(ik) = piqtfe(ik) + pqnfe(ik)
                              pihtfe(ik) = pihtfe(ik) + phnfe(ik)
 494                       continue
                        endif
                     endif
                  endif
               endif
            endif
         endif
      endif
c
c
      return
99001 format (' ',' in augfil ')
99002 format (' ',2i4,e12.4)
99003 format (' ',2i4,2e12.4)
      end
      subroutine aughlp(apirt,am,aheat,aion,pirt,esum,et,flem,nzmin,
     &                  nzmax,nzmaxo)
c
c
c
c     this routine does the work in computing auger rates
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
c
      dimension apirt(nzmaxo,100),aheat(28),aion(28),esum(28),
     &          et(28),am(nzmax,100),pirt(28),flem(28)
c
       character*72 ktitle
c
      data ergsev/1.602197e-12/
      data eps/1./
c
      if ( lpri.gt.2 ) write (6,*) 'in aughlp',nzmin,nzmax,nzmaxo
      do 100 ik = nzmin,nzmax
         nzmm1 = nzmax + 1
         ikp1 = ik + 1
         do 50 jk = ikp1,nzmm1
            apirt(ik,jk) = apirt(ik,jk) + am(jk-1,ik)*pirt(ik)
            if ( lpri.gt.2 ) write (6,*) ik,jk,am(jk-1,ik),
     &                              pirt(ik),apirt(ik,jk)
 50      continue
         if ( ik.ne.nzmax ) then
            sum = 0.
            svm = 0.
            etmp = -esum(ik) + et(ik)
            flem(ik) = 0.
            etst=etmp+esum(ik+1)
c            if (etst.gt.eps ) 
            flem(ik) = am(max0(1,ik-1),ik)
     &           *pirt(ik)
            if (lpri.gt.2) write (6,*)ik,esum(ik+1),etmp,etst,am(ik,ik),
     $          flem(ik)
            ikp2 = ik + 2
            do 60 jk = ikp2,nzmm1
               ak = float(jk-ik) - 1.
               empt = (etmp+esum(jk-1))/ak
               empt = amax1(empt,1.e-4)
               svm = svm + am(jk-1,ik)*ak*phi(empt)
               sum = sum + am(jk-1,ik)*ak*eheat(empt)
 60         continue
            aheat(ik) = sum*pirt(ik)*ergsev
            aion(ik) = svm*pirt(ik)
         endif
 100  continue
c
      return
      end
      subroutine autoi
c
c
c
c
c     this routine computes autoionization
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /airate/ airt(nni)
      common /aidata/ cai(nni),eai(nni)
      common /temp  / t,to
      common /ethrsh/ eth(nni)
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
      data ergsev/1.602197e-12/
c
      if (lpri.gt.2) write (6,*)'in autoi:',t
c
      tsq = sqrt(t)
      ekt = t*(0.861707)
c
      do 100 j = 1,nni
         airt(j) = 0.
         if ( lichk(j).eq.1 ) then
            airt(j) = cai(j)*expo(-eai(j)/ekt)/tsq
            if (lpri.gt.2) write (6,*)j,cai(j),eai(j),airt(j)
         endif
 100  continue
c
      if (lpri.gt.2) write (6,*)'finishing autoi'
c
      return
      end
      subroutine benchmrk(nbmk)
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /linsel/ nlsv(nnnl),nlsvn
      common /etot  / etotc,etotco,etotl,etotlo
     $               ,etotc1,etotc2,etotc3,etotl1,etotl2
      common /prs   / p,p0
      common /temp  / t,to
      common /sigh  / zeta
      common /nmrc  / numrec,npass
      common /tlim  / tinf
      common /cdpth / dpthc(ncn)
      common /bdpth / dpthb(ncn)
      common /dpttau/ tauth
      common /tau0ln/ tau0(nnnl)
      common /xcol  / xcc(183)
      common /icc   / lichk(nni),lipin
      common /prtop / elnprnt(400),elimdb(2),nstpt,nlnprnt,lstpt(20)
      common /enerc / epi(ncn),dele(ncn),numcon
      common /spectc/ bremsa(ncn),brems(ncn),zrems(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /radius/delr,r,rl,rmax,rdel,radexp,rscale,rsave
      common /heato / httoto,cltoto,hmctoto
      common /pcool / cll(nni),clbr,clcmp
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /abel  / xel(nl),xeln(nni),xelln(nnnl)
      common /itdat / enfmxs,ensfrc,critd,crittd,epss,crits,
     $             kmaxs,lppris,nlimd,lpprid,nnmax
      common /llumin/ elum(nnnl),oelum(nnnl)
      common /llumnb/ elumb(nnnl),oelmb(nnnl)
      common /lindat/ elin(nnnl),blin(nnnl), 
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &      flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
      common /spctcb/ zremsb(ncn),zrmsbo(ncn),bremsb(ncn),
     &                brmsab(ncn)
c
      character*72 ktitle
c
      dimension bmdat(15,50,10),elnsv(2,50,10),eldat(50,10),
     $   nbmdat(10),fbsv(50),sig(50),err(50),sigsm(50),nsm(50),
     $   nlnsv(10),nbmpt(50,10),nlnsv2(10),fluxrl(50),lllsv(50)
c
      character*8 kinam(169)
      character*8 klbm(50,10)
c
c     'Table3MeudonHIIRegion,
c     ',,Meu,Lex,1,2,3,4,5,6,8,9,10,11
       data nlnsv2(1)/13/
c     Table 2: Cool H II region:  Mean,1,2,3,5,6,8,9,10,11,0.,0./
       data nbmdat(1)/10/
       data klbm(14,1),eldat(14,1),bmdat(1,14,1),bmdat(2,14,1),
     $ bmdat(3,14,1),bmdat(4,14,1),bmdat(5,14,1),bmdat(6,14,1),
     $ bmdat(7,14,1),bmdat(8,14,1),bmdat(9,14,1),bmdat(10,14,1),
     $ bmdat(11,14,1),bmdat(12,14,1)
     $ /'L(Hp)',0.,4.93,4.99,4.98,4.93,4.85,
     $  4.83,4.93,4.94,5.01,4.91,0.,0./
       data klbm(2,1),eldat(2,1),bmdat(1,2,1),bmdat(2,2,1),
     $ bmdat(3,2,1),bmdat(4,2,1),bmdat(5,2,1),bmdat(6,2,1),
     $ bmdat(7,2,1),bmdat(8,2,1),bmdat(9,2,1),bmdat(10,2,1),
     $ bmdat(11,2,1),bmdat(12,2,1)
     $ /'[N II]',6584,0.85,0.82,0.91,0.82,0.97,0.82,
     $  0.84,0.84,0.83,0.83,0.,0./
       data klbm(3,1),eldat(3,1),bmdat(1,3,1),bmdat(2,3,1),
     $ bmdat(3,3,1),bmdat(4,3,1),bmdat(5,3,1),bmdat(6,3,1),
     $ bmdat(7,3,1),bmdat(8,3,1),bmdat(9,3,1),bmdat(10,3,1),
     $ bmdat(11,3,1),bmdat(12,3,1)
     $ /'[O III]',3727,1.18,1.11,1.16,1.22,1.32,1.14,
     $  1.21,1.24,1.14,1.11,0.,0./
       data klbm(4,1),eldat(4,1),bmdat(1,4,1),bmdat(2,4,1),
     $ bmdat(3,4,1),bmdat(4,4,1),bmdat(5,4,1),bmdat(6,4,1),
     $ bmdat(7,4,1),bmdat(8,4,1),bmdat(9,4,1),bmdat(10,4,1),
     $ bmdat(11,4,1),bmdat(12,4,1)
     $ /'[Ne II]',1.28E+05,0.31,0.36,0.35,0.29,0.29,0.29,0.29,
     $  0.35,0.29,0.29,0.,0./
       data klbm(5,1),eldat(5,1),bmdat(1,5,1),bmdat(2,5,1),
     $ bmdat(3,5,1),bmdat(4,5,1),bmdat(5,5,1),bmdat(6,5,1),
     $ bmdat(7,5,1),bmdat(8,5,1),bmdat(9,5,1),bmdat(10,5,1),
     $ bmdat(11,5,1),bmdat(12,5,1)
     $ /'[SII]',6720,0.57,0.69,0.64,0.55,0.61,0.52,0.52,
     $  0.6,0.45,0.58,0.,0./
       data klbm(6,1),eldat(6,1),bmdat(1,6,1),bmdat(2,6,1),
     $ bmdat(3,6,1),bmdat(4,6,1),bmdat(5,6,1),bmdat(6,6,1),
     $ bmdat(7,6,1),bmdat(8,6,1),bmdat(9,6,1),bmdat(10,6,1),
     $ bmdat(11,6,1),bmdat(12,6,1)
     $ /'[S III]',1.87E+05,0.32,0.26,0.27,0.36,0.17,0.37,
     $  0.37,0.33,0.4,0.3,0.,0./
       data klbm(7,1),eldat(7,1),bmdat(1,7,1),bmdat(2,7,1),
     $ bmdat(3,7,1),bmdat(4,7,1),bmdat(5,7,1),bmdat(6,7,1),
     $ bmdat(7,7,1),bmdat(8,7,1),bmdat(9,7,1),bmdat(10,7,1),
     $ bmdat(11,7,1),bmdat(12,7,1)
     $ /'[S III]',3.40E+05,0.52,0.43,0.47,0.6,0.27,0.61,
     $  0.62,0.54,0.67,0.51,0.,0./
       data klbm(8,1),eldat(8,1),bmdat(1,8,1),bmdat(2,8,1),
     $ bmdat(3,8,1),bmdat(4,8,1),bmdat(5,8,1),bmdat(6,8,1),
     $ bmdat(7,8,1),bmdat(8,8,1),bmdat(9,8,1),bmdat(10,8,1),
     $ bmdat(11,8,1),bmdat(12,8,1)
     $ /'[S III]',9532,0.55,0.4,0.48,0.55,0.64,0.6,0.56,
     $  0.49,0.62,0.58,0.,0./
       data klbm(9,1),eldat(9,1),bmdat(1,9,1),bmdat(2,9,1),
     $ bmdat(3,9,1),bmdat(4,9,1),bmdat(5,9,1),bmdat(6,9,1),
     $ bmdat(7,9,1),bmdat(8,9,1),bmdat(9,9,1),bmdat(10,9,1),
     $ bmdat(11,9,1),bmdat(12,9,1)
     $ /'L(total)',0.,21.2,20.3,21.3,21.7,20.7,21,21.8,
     $  21.7,22.1,20.6,0.,0./
       data klbm(10,1),eldat(10,1),bmdat(1,10,1),bmdat(2,10,1),
     $ bmdat(3,10,1),bmdat(4,10,1),bmdat(5,10,1),bmdat(6,10,1),
     $ bmdat(7,10,1),bmdat(8,10,1),bmdat(9,10,1),bmdat(10,10,1),
     $ bmdat(11,10,1),bmdat(12,10,1)
     $ /'T(in)',0.,6793,6860,6952,6749,6980,6870,6747,
     $  6230,6912,6838,0.,0./
       data klbm(11,1),eldat(11,1),bmdat(1,11,1),bmdat(2,11,1),
     $ bmdat(3,11,1),bmdat(4,11,1),bmdat(5,11,1),bmdat(6,11,1),
     $ bmdat(7,11,1),bmdat(8,11,1),bmdat(9,11,1),bmdat(10,11,1),
     $ bmdat(11,11,1),bmdat(12,11,1)
     $ /'T(H+)',0.,6744,6690,6740,6742,6950,6660,6742,
     $  6770,6720,6681,0.,0./
       data klbm(12,1),eldat(12,1),bmdat(1,12,1),bmdat(2,12,1),
     $ bmdat(3,12,1),bmdat(4,12,1),bmdat(5,12,1),bmdat(6,12,1),
     $ bmdat(7,12,1),bmdat(8,12,1),bmdat(9,12,1),bmdat(10,12,1),
     $ bmdat(11,12,1),bmdat(12,12,1)
     $ /'<He+>/<H+>',0.,0.054,0,0.041,0.044,0.068,0.048,
     $  0.034,0.055,0.09,0.,0.,0./
       data klbm(13,1),eldat(13,1),bmdat(1,13,1),bmdat(2,13,1),
     $ bmdat(3,13,1),bmdat(4,13,1),bmdat(5,13,1),bmdat(6,13,1),
     $ bmdat(7,13,1),bmdat(8,13,1),bmdat(9,13,1),bmdat(10,13,1),
     $ bmdat(11,13,1),bmdat(12,13,1)
     $ /'R(out) E18',0.,8.96,9,8.93,8.94,9,8.93,9,8.87,9.02,8.97,0.,0./
c    Table 3 Meudon HII Region, Meu,Lex,1,2,3,4,5,6,8,9,10,11/
       data nbmdat(2)/12/
       data nlnsv2(2)/23/
       data klbm(24,2),eldat(24,2),bmdat(1,24,2),bmdat(2,24,2),     
     $ bmdat(3,24,2),bmdat(4,24,2),bmdat(5,24,2),bmdat(6,24,2),     
     $ bmdat(7,24,2),bmdat(8,24,2),bmdat(9,24,2),bmdat(10,24,2),     
     $ bmdat(11,24,2),bmdat(12,24,2)/     
     $ 'H I',4862.,2.06,2.03,1.96,2.06,2.04,1.86,2.02,2.02,
     $2.05,2.10,2.11,2.09/
       data klbm(1,2),eldat(1,2),bmdat(1,1,2),bmdat(2,1,2),
     $ bmdat(3,1,2),bmdat(4,1,2),bmdat(5,1,2),bmdat(6,1,2),
     $ bmdat(7,1,2),bmdat(8,1,2),bmdat(9,1,2),bmdat(10,1,2),
     $ bmdat(11,1,2),bmdat(12,1,2)
     $ /'He I',5876,0.116,0.116,0.125,0.109,
     $ 0.119,0.11,0.101,0.116,0.,0.125,0.115,0.12/
       data klbm(2,2),eldat(2,2),bmdat(1,2,2),bmdat(2,2,2),
     $ bmdat(3,2,2),bmdat(4,2,2),bmdat(5,2,2),bmdat(6,2,2),
     $ bmdat(7,2,2),bmdat(8,2,2),bmdat(9,2,2),bmdat(10,2,2),
     $ bmdat(11,2,2),bmdat(12,2,2)
     $ /'Cll',2326,0.17,0.16,0.07,0.19,0.17,0.16,0.16,0.14,
     $  0.18,0.28,0.12,0.14/
       data klbm(3,2),eldat(3,2),bmdat(1,3,2),bmdat(2,3,2),
     $ bmdat(3,3,2),bmdat(4,3,2),bmdat(5,3,2),bmdat(6,3,2),
     $ bmdat(7,3,2),bmdat(8,3,2),bmdat(9,3,2),bmdat(10,3,2),
     $ bmdat(11,3,2),bmdat(12,3,2)
     $ /'C',1909,0.051,0.06,0.05,0.059,0.059,
     $0.027,0.078,0.065,0.076,0.082,0.077,0.071/
       data klbm(4,2),eldat(4,2),bmdat(1,4,2),bmdat(2,4,2),
     $ bmdat(3,4,2),bmdat(4,4,2),bmdat(5,4,2),bmdat(6,4,2),
     $ bmdat(7,4,2),bmdat(8,4,2),bmdat(9,4,2),bmdat(10,4,2),
     $ bmdat(11,4,2),bmdat(12,4,2)
     $ /'[N II]',1.22E+06,0.,0.031,0.032,0.033,0.,0.,0.,0.036,
     $  0.031,0.03,0.037,0.034/
       data klbm(5,2),eldat(5,2),bmdat(1,5,2),bmdat(2,5,2),
     $ bmdat(3,5,2),bmdat(4,5,2),bmdat(5,5,2),bmdat(6,5,2),
     $ bmdat(7,5,2),bmdat(8,5,2),bmdat(9,5,2),bmdat(10,5,2),
     $ bmdat(11,5,2),bmdat(12,5,2)
     $ /'[N II]',6584,0.73,0.79,0.61,0.88,0.74,0.94,0.87,0.78,
     $  0.73,0.78,0.81,0.75/
       data klbm(6,2),eldat(6,2),bmdat(1,6,2),bmdat(2,6,2),
     $ bmdat(3,6,2),bmdat(4,6,2),bmdat(5,6,2),bmdat(6,6,2),
     $ bmdat(7,6,2),bmdat(8,6,2),bmdat(9,6,2),bmdat(10,6,2),
     $ bmdat(11,6,2),bmdat(12,6,2)
     $ /'[N III]',5.70E+05,0.3,0.27,0.16,0.27,0.29,0.,0.26,
     $  0.3,0.3,0.17,0.27,0.39/
       data klbm(7,2),eldat(7,2),bmdat(1,7,2),bmdat(2,7,2),
     $ bmdat(3,7,2),bmdat(4,7,2),bmdat(5,7,2),bmdat(6,7,2),
     $ bmdat(7,7,2),bmdat(8,7,2),bmdat(9,7,2),bmdat(10,7,2),
     $ bmdat(11,7,2),bmdat(12,7,2)
     $ /'[0 II]',3727,2.01,2.16,1.5,2.19,2.14,2.56,2.3,2.11,
     $  2.26,2.41,2.2,1.95/
       data klbm(8,2),eldat(8,2),bmdat(1,8,2),bmdat(2,8,2),
     $ bmdat(3,8,2),bmdat(4,8,2),bmdat(5,8,2),bmdat(6,8,2),
     $ bmdat(7,8,2),bmdat(8,8,2),bmdat(9,8,2),bmdat(10,8,2),
     $ bmdat(11,8,2),bmdat(12,8,2)
     $ /'[0 III]',5.18E+05,1.1,1.07,1.1,1.04,1.11,1.04,0.99,
     $  1.08,1.08,1.23,1.04,0.97/
       data klbm(9,2),eldat(9,2),bmdat(1,9,2),bmdat(2,9,2),
     $ bmdat(3,9,2),bmdat(4,9,2),bmdat(5,9,2),bmdat(6,9,2),
     $ bmdat(7,9,2),bmdat(8,9,2),bmdat(9,9,2),bmdat(10,9,2),
     $ bmdat(11,9,2),bmdat(12,9,2)
     $ /'[0 III]',8.84E+05,1.2,1.23,1.3,1.07,1.28,0.,1.16,
     $  1.25,1.26,1.42,1.2,1.14/
       data klbm(10,2),eldat(10,2),bmdat(1,10,2),bmdat(2,10,2),
     $ bmdat(3,10,2),bmdat(4,10,2),bmdat(5,10,2),bmdat(6,10,2),
     $ bmdat(7,10,2),bmdat(8,10,2),bmdat(9,10,2),bmdat(10,10,2),
     $ bmdat(11,10,2),bmdat(12,10,2)
     $ /'[0 III]',5007,2.03,2.06,2.3,1.93,1.96,1.47,2.29,2.17,
     $  2.1,2.23,2.22,1.89/
       data klbm(11,2),eldat(11,2),bmdat(1,11,2),bmdat(2,11,2),
     $ bmdat(3,11,2),bmdat(4,11,2),bmdat(5,11,2),bmdat(6,11,2),
     $ bmdat(7,11,2),bmdat(8,11,2),bmdat(9,11,2),bmdat(10,11,2),
     $ bmdat(11,11,2),bmdat(12,11,2)
     $ /'[N III]',1.28E+05,0.21,0.22,0.26,0.23,0.19,0.23,0.22,
     $  0.2,0.2,0.22,0.22,0.2/
       data klbm(12,2),eldat(12,2),bmdat(1,12,2),bmdat(2,12,2),
     $ bmdat(3,12,2),bmdat(4,12,2),bmdat(5,12,2),bmdat(6,12,2),
     $ bmdat(7,12,2),bmdat(8,12,2),bmdat(9,12,2),bmdat(10,12,2),
     $ bmdat(11,12,2),bmdat(12,12,2)
     $ /'[Ne III]',1.55E+05,0.44,0.38,0.37,0.43,0.43,0.47,0.37,
     $  0.42,0.42,0.22,0.34,0.38/
       data klbm(13,2),eldat(13,2),bmdat(1,13,2),bmdat(2,13,2),
     $ bmdat(3,13,2),bmdat(4,13,2),bmdat(5,13,2),bmdat(6,13,2),
     $ bmdat(7,13,2),bmdat(8,13,2),bmdat(9,13,2),bmdat(10,13,2),
     $ bmdat(11,13,2),bmdat(12,13,2)
     $ /'[Ne III]',3869,0.096,0.086,0.085,0.103,
     $  0.086,0.071,0.1,0.079,0.087,0.081,0.087,0.078/
       data klbm(14,2),eldat(14,2),bmdat(1,14,2),bmdat(2,14,2),
     $ bmdat(3,14,2),bmdat(4,14,2),bmdat(5,14,2),bmdat(6,14,2),
     $ bmdat(7,14,2),bmdat(8,14,2),bmdat(9,14,2),bmdat(10,14,2),
     $ bmdat(11,14,2),bmdat(12,14,2)
     $ /'[S II]',6720,0.14,0.2,0.24,0.23,0.16,0.25,0.22,0.17,
     $  0.13,0.21,0.15,0.21/
       data klbm(15,2),eldat(15,2),bmdat(1,15,2),bmdat(2,15,2),
     $ bmdat(3,15,2),bmdat(4,15,2),bmdat(5,15,2),bmdat(6,15,2),
     $ bmdat(7,15,2),bmdat(8,15,2),bmdat(9,15,2),bmdat(10,15,2),
     $ bmdat(11,15,2),bmdat(12,15,2)
     $ /'[S III]',1.87E+05,0.55,0.55,0.56,0.48,0.56,0.53,0.5,0.55,
     $  0.58,0.58,0.58,0.55/
       data klbm(16,2),eldat(16,2),bmdat(1,16,2),bmdat(2,16,2),
     $ bmdat(3,16,2),bmdat(4,16,2),bmdat(5,16,2),bmdat(6,16,2),
     $ bmdat(7,16,2),bmdat(8,16,2),bmdat(9,16,2),bmdat(10,16,2),
     $ bmdat(11,16,2),bmdat(12,16,2)
     $ /'[S III]',3.40E+05,0.93,0.89,0.91,0.82,0.89,0.,0.81,
     $  0.88,0.94,0.92,0.92,0.91/
       data klbm(17,2),eldat(17,2),bmdat(1,17,2),bmdat(2,17,2),
     $ bmdat(3,17,2),bmdat(4,17,2),bmdat(5,17,2),bmdat(6,17,2),
     $ bmdat(7,17,2),bmdat(8,17,2),bmdat(9,17,2),bmdat(10,17,2),
     $ bmdat(11,17,2),bmdat(12,17,2)
     $ /'[S III]',9532,1.25,1.29,1.16,1.27,1.23,1.15,1.48,1.27,
     $  1.3,1.31,1.32,1.46/
       data klbm(18,2),eldat(18,2),bmdat(1,18,2),bmdat(2,18,2),
     $ bmdat(3,18,2),bmdat(4,18,2),bmdat(5,18,2),bmdat(6,18,2),
     $ bmdat(7,18,2),bmdat(8,18,2),bmdat(9,18,2),bmdat(10,18,2),
     $ bmdat(11,18,2),bmdat(12,18,2)
     $ /'[SIV]',1.05E+05,0.39,0.34,0.22,0.37,0.42,0.35,0.36,
     $  0.41,0.33,0.26,0.38,0.27/
       data klbm(19,2),eldat(19,2),bmdat(1,19,2),bmdat(2,19,2),
     $ bmdat(3,19,2),bmdat(4,19,2),bmdat(5,19,2),bmdat(6,19,2),
     $ bmdat(7,19,2),bmdat(8,19,2),bmdat(9,19,2),bmdat(10,19,2),
     $ bmdat(11,19,2),bmdat(12,19,2)
     $ /'L(total)',0.,24.1,24.2,21.7,24.1,24.1,17.4,24.8,24.3,
     $  24.6,26.4,25.5,24.1/
       data klbm(20,2),eldat(20,2),bmdat(1,20,2),bmdat(2,20,2),
     $ bmdat(3,20,2),bmdat(4,20,2),bmdat(5,20,2),bmdat(6,20,2),
     $ bmdat(7,20,2),bmdat(8,20,2),bmdat(9,20,2),bmdat(10,20,2),
     $ bmdat(11,20,2),bmdat(12,20,2)
     $ /'T(in)',0.,7992,7552,7630,7815,7741,
     $  8057,7670,7650,7399,6530,7582,7445/
       data klbm(21,2),eldat(21,2),bmdat(1,21,2),bmdat(2,21,2),
     $ bmdat(3,21,2),bmdat(4,21,2),bmdat(5,21,2),bmdat(6,21,2),
     $ bmdat(7,21,2),bmdat(8,21,2),bmdat(9,21,2),bmdat(10,21,2),
     $ bmdat(11,21,2),bmdat(12,21,2)
     $ /'T(H+)',0.,7378,8034,7880,8064,8047,
     $  7879,8000,8060,8087,8220,8191,7913/
       data klbm(22,2),eldat(22,2),bmdat(1,22,2),bmdat(2,22,2),
     $ bmdat(3,22,2),bmdat(4,22,2),bmdat(5,22,2),bmdat(6,22,2),
     $ bmdat(7,22,2),bmdat(8,22,2),bmdat(9,22,2),bmdat(10,22,2),
     $ bmdat(11,22,2),bmdat(12,22,2)
     $ /'<He+>/<H+>',0.,0,0.77,0,0.71,0.77,
     $  0.69,0.76,0.75,0.83,0.86,0.79,0.77/
       data klbm(23,2),eldat(23,2),bmdat(1,23,2),bmdat(2,23,2),
     $ bmdat(3,23,2),bmdat(4,23,2),bmdat(5,23,2),bmdat(6,23,2),
     $ bmdat(7,23,2),bmdat(8,23,2),bmdat(9,23,2),bmdat(10,23,2),
     $ bmdat(11,23,2),bmdat(12,23,2)
     $ /'R(out)',0.,1.45,1.48,1.43,1.46,1.46,1.61,1.47,1.46,
     $  1.46,1.46,1.49,1.47/
c     Table 4 Blister HII Region   Mean,1,2,3,4,5,6,8,9,10,11,0./
       data nbmdat(3)/11/
       data nlnsv2(3)/22/
       data klbm(1,3),eldat(1,3),bmdat(1,1,3),bmdat(2,1,3),
     $ bmdat(3,1,3),bmdat(4,1,3),bmdat(5,1,3),bmdat(6,1,3),
     $ bmdat(7,1,3),bmdat(8,1,3),bmdat(9,1,3),bmdat(10,1,3),
     $ bmdat(11,1,3),bmdat(12,1,3)
     $ /' I(Hp)',0.,4.62,4.6,4.59,4.81,3.89,
     $  4.69,4.67,4.7,4.85,4.58,4.78,0./
       data klbm(2,3),eldat(2,3),bmdat(1,2,3),bmdat(2,2,3),
     $ bmdat(3,2,3),bmdat(4,2,3),bmdat(5,2,3),bmdat(6,2,3),
     $ bmdat(7,2,3),bmdat(8,2,3),bmdat(9,2,3),bmdat(10,2,3),
     $ bmdat(11,2,3),bmdat(12,2,3)
     $ /'He I',5876,0.12,0.12,0.13,0.11,0.11,
     $  0.12,0.12,0.,0.12,0.11,0.12,0./
       data klbm(3,3),eldat(3,3),bmdat(1,3,3),bmdat(2,3,3),
     $ bmdat(3,3,3),bmdat(4,3,3),bmdat(5,3,3),bmdat(6,3,3),
     $ bmdat(7,3,3),bmdat(8,3,3),bmdat(9,3,3),bmdat(10,3,3),
     $ bmdat(11,3,3),bmdat(12,3,3)
     $ /'Cll',2326,0.18,0.06,0.14,0.2,0.3,
     $  0.1,0.15,0.23,0.35,0.11,0.16,0./
       data klbm(4,3),eldat(4,3),bmdat(1,4,3),bmdat(2,4,3),
     $ bmdat(3,4,3),bmdat(4,4,3),bmdat(5,4,3),bmdat(6,4,3),
     $ bmdat(7,4,3),bmdat(8,4,3),bmdat(9,4,3),bmdat(10,4,3),
     $ bmdat(11,4,3),bmdat(12,4,3)
     $ /'Cll',1335,0.09,0.002,0.17,0.14,0.02,
     $  0.13,0.16,0.,0.01,0.02,0.13,0./
       data klbm(5,3),eldat(5,3),bmdat(1,5,3),bmdat(2,5,3),
     $ bmdat(3,5,3),bmdat(4,5,3),bmdat(5,5,3),bmdat(6,5,3),
     $ bmdat(7,5,3),bmdat(8,5,3),bmdat(9,5,3),bmdat(10,5,3),
     $ bmdat(11,5,3),bmdat(12,5,3)
     $ /'Clil]',1909,0.17,0.13,0.22,0.17,
     $  0.08,0.18,0.15,0.2,0.25,0.14,0.23,0./
       data klbm(6,3),eldat(6,3),bmdat(1,6,3),bmdat(2,6,3),
     $ bmdat(3,6,3),bmdat(4,6,3),bmdat(5,6,3),bmdat(6,6,3),
     $ bmdat(7,6,3),bmdat(8,6,3),bmdat(9,6,3),bmdat(10,6,3),
     $ bmdat(11,6,3),bmdat(12,6,3)
     $ /'[N II]',6584,0.87,0.67,0.58,0.94,
     $  1.48,0.74,0.9,0.87,0.92,0.82,0.83,0./
       data klbm(7,3),eldat(7,3),bmdat(1,7,3),bmdat(2,7,3),
     $ bmdat(3,7,3),bmdat(4,7,3),bmdat(5,7,3),bmdat(6,7,3),
     $ bmdat(7,7,3),bmdat(8,7,3),bmdat(9,7,3),bmdat(10,7,3),
     $ bmdat(11,7,3),bmdat(12,7,3)
     $ /'[Nlil]',5.70E+04,0.031,0.032,0.035,0.033,0.,
     $  0.033,0.032,0.034,0.014,0.032,0.033,0./
       data klbm(8,3),eldat(8,3),bmdat(1,8,3),bmdat(2,8,3),
     $ bmdat(3,8,3),bmdat(4,8,3),bmdat(5,8,3),bmdat(6,8,3),
     $ bmdat(7,8,3),bmdat(8,8,3),bmdat(9,8,3),bmdat(10,8,3),
     $ bmdat(11,8,3),bmdat(12,8,3)
     $ /'[O III]',7330,0.12,0.06,0.1,0.13,0.19,
     $  0.09,0.12,0.14,0.15,0.08,0.1,0./
       data klbm(9,3),eldat(9,3),bmdat(1,9,3),bmdat(2,9,3),
     $ bmdat(3,9,3),bmdat(4,9,3),bmdat(5,9,3),bmdat(6,9,3),
     $ bmdat(7,9,3),bmdat(8,9,3),bmdat(9,9,3),bmdat(10,9,3),
     $ bmdat(11,9,3),bmdat(12,9,3)
     $ /'[O III]',3727,0.88,0.53,0.73,0.98,
     $  1.39,0.69,0.86,1.04,1.04,0.73,0.86,0./
       data klbm(10,3),eldat(10,3),bmdat(1,10,3),bmdat(2,10,3),
     $ bmdat(3,10,3),bmdat(4,10,3),bmdat(5,10,3),bmdat(6,10,3),
     $ bmdat(7,10,3),bmdat(8,10,3),bmdat(9,10,3),bmdat(10,10,3),
     $ bmdat(11,10,3),bmdat(12,10,3)
     $ /'[Olil]',5.18E+04,0.29,0.29,0.31,
     $  0.29,0.26,0.28,0.28,0.28,0.32,0.28,0.27,0./
       data klbm(11,3),eldat(11,3),bmdat(1,11,3),bmdat(2,11,3),
     $ bmdat(3,11,3),bmdat(4,11,3),bmdat(5,11,3),bmdat(6,11,3),
     $ bmdat(7,11,3),bmdat(8,11,3),bmdat(9,11,3),bmdat(10,11,3),
     $ bmdat(11,11,3),bmdat(12,11,3)
     $ /'[Olil]',5007,4.13,4.5,4.74,3.9,
     $  3.28,4.4,3.9,3.96,4.51,4.16,3.98,0./
       data klbm(12,3),eldat(12,3),bmdat(1,12,3),bmdat(2,12,3),
     $ bmdat(3,12,3),bmdat(4,12,3),bmdat(5,12,3),bmdat(6,12,3),
     $ bmdat(7,12,3),bmdat(8,12,3),bmdat(9,12,3),bmdat(10,12,3),
     $ bmdat(11,12,3),bmdat(12,12,3)
     $ /'[N III]',1.28E+04,0.36,0.45,
     $  0.32,0.33,0.44,0.35,0.33,0.35,0.36,0.37,0.35,0./
       data klbm(13,3),eldat(13,3),bmdat(1,13,3),bmdat(2,13,3),
     $ bmdat(3,13,3),bmdat(4,13,3),bmdat(5,13,3),bmdat(6,13,3),
     $ bmdat(7,13,3),bmdat(8,13,3),bmdat(9,13,3),bmdat(10,13,3),
     $ bmdat(11,13,3),bmdat(12,13,3)
     $ /'[Nelil]',1.55E+04,0.98,0.93,
     $  1.24,1.07,1.09,0.96,1.04,1,0.59,0.92,0.97,0./
       data klbm(14,3),eldat(14,3),bmdat(1,14,3),bmdat(2,14,3),
     $ bmdat(3,14,3),bmdat(4,14,3),bmdat(5,14,3),bmdat(6,14,3),
     $ bmdat(7,14,3),bmdat(8,14,3),bmdat(9,14,3),bmdat(10,14,3),
     $ bmdat(11,14,3),bmdat(12,14,3)
     $ /'[Nelil]',3869,0.33,0.33,0.48,0.32,
     $  0.31,0.35,0.26,0.29,35,0.31,0.31,0./
       data klbm(15,3),eldat(15,3),bmdat(1,15,3),bmdat(2,15,3),
     $ bmdat(3,15,3),bmdat(4,15,3),bmdat(5,15,3),bmdat(6,15,3),
     $ bmdat(7,15,3),bmdat(8,15,3),bmdat(9,15,3),bmdat(10,15,3),
     $ bmdat(11,15,3),bmdat(12,15,3)
     $ /'[S III]',1.87E+04,0.35,0.37,0.31,
     $  0.34,0.37,0.31,0.33,0.35,0.37,0.34,0.39,0./
       data klbm(16,3),eldat(16,3),bmdat(1,16,3),bmdat(2,16,3),
     $ bmdat(3,16,3),bmdat(4,16,3),bmdat(5,16,3),bmdat(6,16,3),
     $ bmdat(7,16,3),bmdat(8,16,3),bmdat(9,16,3),bmdat(10,16,3),
     $ bmdat(11,16,3),bmdat(12,16,3)
     $ /'[S III]',9532,1.53,1.52,1.41,1.46,
     $  1.62,1.51,1.42,1.53,1.61,1.42,1.82,0./
       data klbm(17,3),eldat(17,3),bmdat(1,17,3),bmdat(2,17,3),
     $ bmdat(3,17,3),bmdat(4,17,3),bmdat(5,17,3),bmdat(6,17,3),
     $ bmdat(7,17,3),bmdat(8,17,3),bmdat(9,17,3),bmdat(10,17,3),
     $ bmdat(11,17,3),bmdat(12,17,3)
     $ /'[SIV1',1.05E+04,0.46,0.26,0.54,
     $  0.52,0.42,0.51,0.53,0.43,0.36,0.5,0.51,0./
       data klbm(18,3),eldat(18,3),bmdat(1,18,3),bmdat(2,18,3),
     $ bmdat(3,18,3),bmdat(4,18,3),bmdat(5,18,3),bmdat(6,18,3),
     $ bmdat(7,18,3),bmdat(8,18,3),bmdat(9,18,3),bmdat(10,18,3),
     $ bmdat(11,18,3),bmdat(12,18,3)
     $ /'I(total)',0.,50.3,47.1,52.6,52.4,
     $  44.2,50.4,49.4,50.3,54.9,47.4,52.9,0./
       data klbm(19,3),eldat(19,3),bmdat(1,19,3),bmdat(2,19,3),
     $ bmdat(3,19,3),bmdat(4,19,3),bmdat(5,19,3),bmdat(6,19,3),
     $ bmdat(7,19,3),bmdat(8,19,3),bmdat(9,19,3),bmdat(10,19,3),
     $ bmdat(11,19,3),bmdat(12,19,3)
     $ /'T(in)',0.,7989,8300,8206,7582,
     $  0.,8200,8200,7366,7740,8122,8189,0./
       data klbm(20,3),eldat(20,3),bmdat(1,20,3),bmdat(2,20,3),
     $ bmdat(3,20,3),bmdat(4,20,3),bmdat(5,20,3),bmdat(6,20,3),
     $ bmdat(7,20,3),bmdat(8,20,3),bmdat(9,20,3),bmdat(10,20,3),
     $ bmdat(11,20,3),bmdat(12,20,3)
     $ /'T(H+)',0.,8263,8170,8324,8351,
     $  0.,8310,8200,8328,8220,8217,8250,0./
       data klbm(21,3),eldat(21,3),bmdat(1,21,3),bmdat(2,21,3),
     $ bmdat(3,21,3),bmdat(4,21,3),bmdat(5,21,3),bmdat(6,21,3),
     $ bmdat(7,21,3),bmdat(8,21,3),bmdat(9,21,3),bmdat(10,21,3),
     $ bmdat(11,21,3),bmdat(12,21,3)
     $ /'<He+>/<H+>',0.,0.85,0.,0.94,0.78,
     $  0.,0.93,0.79,0.84,0.86,0.85,0.84,0./
       data klbm(22,3),eldat(22,3),bmdat(1,22,3),bmdat(2,22,3),
     $ bmdat(3,22,3),bmdat(4,22,3),bmdat(5,22,3),bmdat(6,22,3),
     $ bmdat(7,22,3),bmdat(8,22,3),bmdat(9,22,3),bmdat(10,22,3),
     $ bmdat(11,22,3),bmdat(12,22,3)
     $ /'AR',0.,0.,2.9,2.88,3.08,0.,2.93,
     $           2.98,3.09,3.1,2.67,3.03,0./
c     Table 6 High Ionization PN,  Mean,1,2,3,4,5,6,10,11,0.,0.,0./
       data nbmdat(5)/9/
       data nlnsv2(5)/22/
       data klbm(1,5),eldat(1,5),bmdat(1,1,5),bmdat(2,1,5),
     $ bmdat(3,1,5),bmdat(4,1,5),bmdat(5,1,5),bmdat(6,1,5),
     $ bmdat(7,1,5),bmdat(8,1,5),bmdat(9,1,5),bmdat(10,1,5),
     $ bmdat(11,1,5),bmdat(12,1,5)
     $ /' L(H:)',0.,5.85,5.67,6.05,5.96,6.02,
     $      5.65,5.74,5.72,6.02,0.,0.,0./
       data klbm(2,5),eldat(2,5),bmdat(1,2,5),bmdat(2,2,5),
     $ bmdat(3,2,5),bmdat(4,2,5),bmdat(5,2,5),bmdat(6,2,5),
     $ bmdat(7,2,5),bmdat(8,2,5),bmdat(9,2,5),bmdat(10,2,5),
     $ bmdat(11,2,5),bmdat(12,2,5)
     $ /'He I',5876,0.12,0.12,0.13,0.13,
     $           0.1,0.12,0.13,0.13,0.13,0.,0.,0./
       data klbm(3,5),eldat(3,5),bmdat(1,3,5),bmdat(2,3,5),
     $ bmdat(3,3,5),bmdat(4,3,5),bmdat(5,3,5),bmdat(6,3,5),
     $ bmdat(7,3,5),bmdat(8,3,5),bmdat(9,3,5),bmdat(10,3,5),
     $ bmdat(11,3,5),bmdat(12,3,5)
     $ /'He II',4686,0.081,0.096,0.08,0.087,
     $  0.039,0.085,0.092,0.09,0.083,0.,0.,0./
       data klbm(4,5),eldat(4,5),bmdat(1,4,5),bmdat(2,4,5),
     $ bmdat(3,4,5),bmdat(4,4,5),bmdat(5,4,5),bmdat(6,4,5),
     $ bmdat(7,4,5),bmdat(8,4,5),bmdat(9,4,5),bmdat(10,4,5),
     $ bmdat(11,4,5),bmdat(12,4,5)
     $ /'C III]',1909,0.83,0.9,0.6,0.6,
     $          0.89,0.99,0.89,1.03,0.74,0.,0.,0./
       data klbm(5,5),eldat(5,5),bmdat(1,5,5),bmdat(2,5,5),
     $ bmdat(3,5,5),bmdat(4,5,5),bmdat(5,5,5),bmdat(6,5,5),
     $ bmdat(7,5,5),bmdat(8,5,5),bmdat(9,5,5),bmdat(10,5,5),
     $ bmdat(11,5,5),bmdat(12,5,5)
     $ /'C IV',1549,0.34,0.24,0.35,0.29,0.45,
     $           0.4,0.37,0.32,0.29,0.,0.,0./
       data klbm(6,5),eldat(6,5),bmdat(1,6,5),bmdat(2,6,5),
     $ bmdat(3,6,5),bmdat(4,6,5),bmdat(5,6,5),bmdat(6,6,5),
     $ bmdat(7,6,5),bmdat(8,6,5),bmdat(9,6,5),bmdat(10,6,5),
     $ bmdat(11,6,5),bmdat(12,6,5)
     $ /'[N II]',6584,0.12,0.12,0.11,0.11,
     $  0.14,0.15,0.12,0.12,0.12,0.,0.,0./
       data klbm(7,5),eldat(7,5),bmdat(1,7,5),bmdat(2,7,5),
     $ bmdat(3,7,5),bmdat(4,7,5),bmdat(5,7,5),bmdat(6,7,5),
     $ bmdat(7,7,5),bmdat(8,7,5),bmdat(9,7,5),bmdat(10,7,5),
     $ bmdat(11,7,5),bmdat(12,7,5)
     $ /'[Nlil]',5.70E+04,0.39,0.27,0.37,
     $            0.,0.,0.4,0.41,0.4,0.48,0.,0.,0./
       data klbm(8,5),eldat(8,5),bmdat(1,8,5),bmdat(2,8,5),
     $ bmdat(3,8,5),bmdat(4,8,5),bmdat(5,8,5),bmdat(6,8,5),
     $ bmdat(7,8,5),bmdat(8,8,5),bmdat(9,8,5),bmdat(10,8,5),
     $ bmdat(11,8,5),bmdat(12,8,5)
     $ /'[O II]',3727,0.29,0.32,0.22,0.24,
     $  0.35,0.35,0.26,0.32,0.27,0.,0.,0./
       data klbm(9,5),eldat(9,5),bmdat(1,9,5),bmdat(2,9,5),
     $ bmdat(3,9,5),bmdat(4,9,5),bmdat(5,9,5),bmdat(6,9,5),
     $ bmdat(7,9,5),bmdat(8,9,5),bmdat(9,9,5),bmdat(10,9,5),
     $ bmdat(11,9,5),bmdat(12,9,5)
     $ /'[O lil]',5007,11.5,12.1,10,
     $  10.1,12.7,12.2,11.7,11.9,11.2,0.,0.,0./
       data klbm(10,5),eldat(10,5),bmdat(1,10,5),bmdat(2,10,5),
     $ bmdat(3,10,5),bmdat(4,10,5),bmdat(5,10,5),bmdat(6,10,5),
     $ bmdat(7,10,5),bmdat(8,10,5),bmdat(9,10,5),bmdat(10,10,5),
     $ bmdat(11,10,5),bmdat(12,10,5)
     $ /'[O lil]',5.20E+04,2.02,2.03,1.88,1.96,2.39,
     $   1.95,2.02,2.02,1.94,0.,0.,0./
       data klbm(11,5),eldat(11,5),bmdat(1,11,5),bmdat(2,11,5),
     $ bmdat(3,11,5),bmdat(4,11,5),bmdat(5,11,5),bmdat(6,11,5),
     $ bmdat(7,11,5),bmdat(8,11,5),bmdat(9,11,5),bmdat(10,11,5),
     $ bmdat(11,11,5),bmdat(12,11,5)
     $ /'[OIV]',2.60E+04,0.79,0.76,0.68,
     $  0.8,1.09,0.71,0.86,0.77,0.67,0.,0.,0./
       data klbm(12,5),eldat(12,5),bmdat(1,12,5),bmdat(2,12,5),
     $ bmdat(3,12,5),bmdat(4,12,5),bmdat(5,12,5),bmdat(6,12,5),
     $ bmdat(7,12,5),bmdat(8,12,5),bmdat(9,12,5),bmdat(10,12,5),
     $ bmdat(11,12,5),bmdat(12,12,5)
     $ /'[Ne lil]',1.55E+04,1.35,1.35,1.3,1.32,
     $  1.55,1.3,1.35,1.34,1.31,0.,0.,0./
       data klbm(13,5),eldat(13,5),bmdat(1,13,5),bmdat(2,13,5),
     $ bmdat(3,13,5),bmdat(4,13,5),bmdat(5,13,5),bmdat(6,13,5),
     $ bmdat(7,13,5),bmdat(8,13,5),bmdat(9,13,5),bmdat(10,13,5),
     $ bmdat(11,13,5),bmdat(12,13,5)
     $ /'[Ne lil]',3869,1.03,1.15,1.02,0.92,
     $      1.02,1.13,0.89,1.11,1,0.,0.,0./
       data klbm(14,5),eldat(14,5),bmdat(1,14,5),bmdat(2,14,5),
     $ bmdat(3,14,5),bmdat(4,14,5),bmdat(5,14,5),bmdat(6,14,5),
     $ bmdat(7,14,5),bmdat(8,14,5),bmdat(9,14,5),bmdat(10,14,5),
     $ bmdat(11,14,5),bmdat(12,14,5)
     $ /'Mg II',2798,0.13,0.34,0.1,0.07,0.14,0.05,0.1,0.1,0.11,0.,0.,0./
       data klbm(15,5),eldat(15,5),bmdat(1,15,5),bmdat(2,15,5),
     $ bmdat(3,15,5),bmdat(4,15,5),bmdat(5,15,5),bmdat(6,15,5),
     $ bmdat(7,15,5),bmdat(8,15,5),bmdat(9,15,5),bmdat(10,15,5),
     $ bmdat(11,15,5),bmdat(12,15,5)
     $ /'Si lil]',1892,0.15,0.1,0.09,
     $        0.1,0.37,0.15,0.13,0.,0.11,0.,0.,0./
       data klbm(16,5),eldat(16,5),bmdat(1,16,5),bmdat(2,16,5),
     $ bmdat(3,16,5),bmdat(4,16,5),bmdat(5,16,5),bmdat(6,16,5),
     $ bmdat(7,16,5),bmdat(8,16,5),bmdat(9,16,5),bmdat(10,16,5),
     $ bmdat(11,16,5),bmdat(12,16,5)
     $ /'[SIII]',1.87E+04,0.34,0.45,
     $  0.24,0.32,0.,0.26,0.28,0.36,0.49,0.,0.,0./
       data klbm(17,5),eldat(17,5),bmdat(1,17,5),bmdat(2,17,5),
     $ bmdat(3,17,5),bmdat(4,17,5),bmdat(5,17,5),bmdat(6,17,5),
     $ bmdat(7,17,5),bmdat(8,17,5),bmdat(9,17,5),bmdat(10,17,5),
     $ bmdat(11,17,5),bmdat(12,17,5)
     $ /'[S lil]',9532,1.13,1.4,0.81,
     $                  0.92,0.,1.02,0.85,1.1,1.77,0.,0.,0./
       data klbm(18,5),eldat(18,5),bmdat(1,18,5),bmdat(2,18,5),
     $ bmdat(3,18,5),bmdat(4,18,5),bmdat(5,18,5),bmdat(6,18,5),
     $ bmdat(7,18,5),bmdat(8,18,5),bmdat(9,18,5),bmdat(10,18,5),
     $ bmdat(11,18,5),bmdat(12,18,5)
     $ /'1S IV1',1.05E+04,2.05,1.66,2.19,
     $  2.21,2.1,2.11,2.35,2.31,1.46,0.,0.,0./
       data klbm(19,5),eldat(19,5),bmdat(1,19,5),bmdat(2,19,5),
     $ bmdat(3,19,5),bmdat(4,19,5),bmdat(5,19,5),bmdat(6,19,5),
     $ bmdat(7,19,5),bmdat(8,19,5),bmdat(9,19,5),bmdat(10,19,5),
     $ bmdat(11,19,5),bmdat(12,19,5)
     $ /'L(total)',0.,133,133,122,120,140,132,131,134,134,0.,0.,0./
       data klbm(20,5),eldat(20,5),bmdat(1,20,5),bmdat(2,20,5),
     $ bmdat(3,20,5),bmdat(4,20,5),bmdat(5,20,5),bmdat(6,20,5),
     $ bmdat(7,20,5),bmdat(8,20,5),bmdat(9,20,5),bmdat(10,20,5),
     $ bmdat(11,20,5),bmdat(12,20,5)
     $ /'T(in)',0.,1.48,1.45,1.48,1.42,1.83,1.4,1.45,1.36,1.44,0.,0.,0./
       data klbm(21,5),eldat(21,5),bmdat(1,21,5),bmdat(2,21,5),
     $ bmdat(3,21,5),bmdat(4,21,5),bmdat(5,21,5),bmdat(6,21,5),
     $ bmdat(7,21,5),bmdat(8,21,5),bmdat(9,21,5),bmdat(10,21,5),
     $ bmdat(11,21,5),bmdat(12,21,5)
     $ /'T(H+)',0.,1.05,1.07,1.01,
     $               1.01,1.03,1.14,1.05,1.06,1.03,0.,0.,0./
       data klbm(22,5),eldat(22,5),bmdat(1,22,5),bmdat(2,22,5),
     $ bmdat(3,22,5),bmdat(4,22,5),bmdat(5,22,5),bmdat(6,22,5),
     $ bmdat(7,22,5),bmdat(8,22,5),bmdat(9,22,5),bmdat(10,22,5),
     $ bmdat(11,22,5),bmdat(12,22,5)
     $ /'<He+>/<H+>',0.,0.92,0.,0.92,0.92,0.,
     $         0.92,0.91,0.92,0.92,0.,0.,0./
c     Table 5 Meudon Planetary Nebula,  
c             Meu,Lex,1,2,3,4,5,6,10,11,0.,0./
       data nbmdat(4)/10/
       data nlnsv2(4)/39/
       data klbm(1,4),eldat(1,4),bmdat(1,1,4),bmdat(2,1,4),
     $ bmdat(3,1,4),bmdat(4,1,4),bmdat(5,1,4),bmdat(6,1,4),
     $ bmdat(7,1,4),bmdat(8,1,4),bmdat(9,1,4),bmdat(10,1,4),
     $ bmdat(11,1,4),bmdat(12,1,4)
     $ /' L(Hp)',0.,2.6,2.53,2.06,2.63,
     $            2.68,2.35,2.73,2.68,2.3,2.8,0.,0./
       data klbm(2,4),eldat(2,4),bmdat(1,2,4),bmdat(2,2,4),
     $ bmdat(3,2,4),bmdat(4,2,4),bmdat(5,2,4),bmdat(6,2,4),
     $ bmdat(7,2,4),bmdat(8,2,4),bmdat(9,2,4),bmdat(10,2,4),
     $ bmdat(11,2,4),bmdat(12,2,4)
     $ /'He I',5876,0.11,0.09,0.09,0.11,
     $  0.1,0.05,0.1,0.11,0.09,0.11,0.,0./
       data klbm(3,4),eldat(3,4),bmdat(1,3,4),bmdat(2,3,4),
     $ bmdat(3,3,4),bmdat(4,3,4),bmdat(5,3,4),bmdat(6,3,4),
     $ bmdat(7,3,4),bmdat(8,3,4),bmdat(9,3,4),bmdat(10,3,4),
     $ bmdat(11,3,4),bmdat(12,3,4)
     $ /'He II',4686,0.33,0.41,0.4,0.32,
     $  0.33,0.81,0.35,0.32,0.43,0.34,0.,0./
       data klbm(4,4),eldat(4,4),bmdat(1,4,4),bmdat(2,4,4),
     $ bmdat(3,4,4),bmdat(4,4,4),bmdat(5,4,4),bmdat(6,4,4),
     $ bmdat(7,4,4),bmdat(8,4,4),bmdat(9,4,4),bmdat(10,4,4),
     $ bmdat(11,4,4),bmdat(12,4,4)
     $ /'C II]',2326,0.38,0.27,0.2,0.33,
     $  0.43,0.12,0.27,0.3,0.22,0.32,0.,0./
       data klbm(5,4),eldat(5,4),bmdat(1,5,4),bmdat(2,5,4),
     $ bmdat(3,5,4),bmdat(4,5,4),bmdat(5,5,4),bmdat(6,5,4),
     $ bmdat(7,5,4),bmdat(8,5,4),bmdat(9,5,4),bmdat(10,5,4),
     $ bmdat(11,5,4),bmdat(12,5,4)
     $ /'C III]',1909,1.7,2.14,2.4,1.82,
     $  1.66,2.92,1.72,1.87,3.14,1.63,0.,0./
       data klbm(6,4),eldat(6,4),bmdat(1,6,4),bmdat(2,6,4),
     $ bmdat(3,6,4),bmdat(4,6,4),bmdat(5,6,4),bmdat(6,6,4),
     $ bmdat(7,6,4),bmdat(8,6,4),bmdat(9,6,4),bmdat(10,6,4),
     $ bmdat(11,6,4),bmdat(12,6,4)
     $ /'C IV',1549,1.64,2.51,2.6,2.44,
     $  2.05,1.44,2.66,2.18,4.74,1.94,0.,0./
       data klbm(7,4),eldat(7,4),bmdat(1,7,4),bmdat(2,7,4),
     $ bmdat(3,7,4),bmdat(4,7,4),bmdat(5,7,4),bmdat(6,7,4),
     $ bmdat(7,7,4),bmdat(8,7,4),bmdat(9,7,4),bmdat(10,7,4),
     $ bmdat(11,7,4),bmdat(12,7,4)
     $ /'[N II]',6584,1.44,1.49,1.43,1.59,
     $  1.45,1.69,1.47,1.44,1.47,1.38,0.,0./
       data klbm(8,4),eldat(8,4),bmdat(1,8,4),bmdat(2,8,4),
     $ bmdat(3,8,4),bmdat(4,8,4),bmdat(5,8,4),bmdat(6,8,4),
     $ bmdat(7,8,4),bmdat(8,8,4),bmdat(9,8,4),bmdat(10,8,4),
     $ bmdat(11,8,4),bmdat(12,8,4)
     $ /'N III]',1749,0.11,0.12,0.16,0.13,
     $  0.13,0.01,0.11,0.13,0.16,0.16,0.,0./
       data klbm(9,4),eldat(9,4),bmdat(1,9,4),bmdat(2,9,4),
     $ bmdat(3,9,4),bmdat(4,9,4),bmdat(5,9,4),bmdat(6,9,4),
     $ bmdat(7,9,4),bmdat(8,9,4),bmdat(9,9,4),bmdat(10,9,4),
     $ bmdat(11,9,4),bmdat(12,9,4)
     $ /'[N III',5.70E+04,0.,0.13,0.11,
     $  0.12,0.13,0.,0.13,0.13,0.13,0.14,0.,0./
       data klbm(10,4),eldat(10,4),bmdat(1,10,4),bmdat(2,10,4),
     $ bmdat(3,10,4),bmdat(4,10,4),bmdat(5,10,4),bmdat(6,10,4),
     $ bmdat(7,10,4),bmdat(8,10,4),bmdat(9,10,4),bmdat(10,10,4),
     $ bmdat(11,10,4),bmdat(12,10,4)
     $ /'N IV]',1487,0.12,0.2,0.22,
     $  0.2,0.15,0.2,0.21,0.19,0.26,0.17,0.,0./
       data klbm(11,4),eldat(11,4),bmdat(1,11,4),bmdat(2,11,4),
     $ bmdat(3,11,4),bmdat(4,11,4),bmdat(5,11,4),bmdat(6,11,4),
     $ bmdat(7,11,4),bmdat(8,11,4),bmdat(9,11,4),bmdat(10,11,4),
     $ bmdat(11,11,4),bmdat(12,11,4)
     $ /'N V',1240,0.09,0.21,0.17,0.18,
     $  0.12,0.34,0.23,0.15,0.38,0.15,0.,0./
       data klbm(12,4),eldat(12,4),bmdat(1,12,4),bmdat(2,12,4),
     $ bmdat(3,12,4),bmdat(4,12,4),bmdat(5,12,4),bmdat(6,12,4),
     $ bmdat(7,12,4),bmdat(8,12,4),bmdat(9,12,4),bmdat(10,12,4),
     $ bmdat(11,12,4),bmdat(12,12,4)
     $ /'[O I]',6300,0.15,0.14,0.17,0.15,
     $  0.12,0.15,0.14,0.14,0.16,0.13,0.,0./
       data klbm(13,4),eldat(13,4),bmdat(1,13,4),bmdat(2,13,4),
     $ bmdat(3,13,4),bmdat(4,13,4),bmdat(5,13,4),bmdat(6,13,4),
     $ bmdat(7,13,4),bmdat(8,13,4),bmdat(9,13,4),bmdat(10,13,4),
     $ bmdat(11,13,4),bmdat(12,13,4)
     $ /'[O II]',3727,2.23,2.28,2.35,
     $  2.23,2.27,0.,2.31,2.18,2.5,2.14,0.,0./
       data klbm(14,4),eldat(14,4),bmdat(1,14,4),bmdat(2,14,4),
     $ bmdat(3,14,4),bmdat(4,14,4),bmdat(5,14,4),bmdat(6,14,4),
     $ bmdat(7,14,4),bmdat(8,14,4),bmdat(9,14,4),bmdat(10,14,4),
     $ bmdat(11,14,4),bmdat(12,14,4)
     $ /'[O lil]',5007,20.9,20.7,21.8,21.1,
     $  21.4,19.8,19.4,21.1,20.2,20.9,0.,0./
       data klbm(15,4),eldat(15,4),bmdat(1,15,4),bmdat(2,15,4),
     $ bmdat(3,15,4),bmdat(4,15,4),bmdat(5,15,4),bmdat(6,15,4),
     $ bmdat(7,15,4),bmdat(8,15,4),bmdat(9,15,4),bmdat(10,15,4),
     $ bmdat(11,15,4),bmdat(12,15,4)
     $ /'[O lil]',4363,0.16,0.16,0.18,0.16,
     $  0.16,0.19,0.14,0.16,0.16,0.15,0.,0./
       data klbm(16,4),eldat(16,4),bmdat(1,16,4),bmdat(2,16,4),
     $ bmdat(3,16,4),bmdat(4,16,4),bmdat(5,16,4),bmdat(6,16,4),
     $ bmdat(7,16,4),bmdat(8,16,4),bmdat(9,16,4),bmdat(10,16,4),
     $ bmdat(11,16,4),bmdat(12,16,4)
     $ /'[Olil]',5.20E+04,1.43,1.34,
     $  1.39,1.42,1.44,0.96,1.4,1.46,1.26,1.41,0.,0./
       data klbm(17,4),eldat(17,4),bmdat(1,17,4),bmdat(2,17,4),
     $ bmdat(3,17,4),bmdat(4,17,4),bmdat(5,17,4),bmdat(6,17,4),
     $ bmdat(7,17,4),bmdat(8,17,4),bmdat(9,17,4),bmdat(10,17,4),
     $ bmdat(11,17,4),bmdat(12,17,4)
     $ /'[OIV]',2.60E+04,3.62,3.92,3.9,
     $  3.52,3.98,4.48,3.32,3.86,5.01,3.33,0.,0./
       data klbm(18,4),eldat(18,4),bmdat(1,18,4),bmdat(2,18,4),
     $ bmdat(3,18,4),bmdat(4,18,4),bmdat(5,18,4),bmdat(6,18,4),
     $ bmdat(7,18,4),bmdat(8,18,4),bmdat(9,18,4),bmdat(10,18,4),
     $ bmdat(11,18,4),bmdat(12,18,4)
     $ /'O IV]',1403,0.13,0.27,0.36,0.2,
     $  0.23,0.18,0.26,0.33,0.41,0.15,0.,0./
       data klbm(19,4),eldat(19,4),bmdat(1,19,4),bmdat(2,19,4),
     $ bmdat(3,19,4),bmdat(4,19,4),bmdat(5,19,4),bmdat(6,19,4),
     $ bmdat(7,19,4),bmdat(8,19,4),bmdat(9,19,4),bmdat(10,19,4),
     $ bmdat(11,19,4),bmdat(12,19,4)
     $ /'O V]',1218,0.09,0.24,0.,0.2,0.11,0.35,0.29,0.19,0.33,0.,0.,0./
       data klbm(20,4),eldat(20,4),bmdat(1,20,4),bmdat(2,20,4),
     $ bmdat(3,20,4),bmdat(4,20,4),bmdat(5,20,4),bmdat(6,20,4),
     $ bmdat(7,20,4),bmdat(8,20,4),bmdat(9,20,4),bmdat(10,20,4),
     $ bmdat(11,20,4),bmdat(12,20,4)
     $ /'[Ne lil]',1.55E+04,2.51,2.49,2.67,
     $  2.75,2.76,0.72,2.8,2.81,2.71,2.74,0.,0./
       data klbm(21,4),eldat(21,4),bmdat(1,21,4),bmdat(2,21,4),
     $ bmdat(3,21,4),bmdat(4,21,4),bmdat(5,21,4),bmdat(6,21,4),
     $ bmdat(7,21,4),bmdat(8,21,4),bmdat(9,21,4),bmdat(10,21,4),
     $ bmdat(11,21,4),bmdat(12,21,4)
     $ /'[Ne lil]',3869,2.59,2.63,3.2,3.33,
     $  2.27,0.88,2.74,2.44,3.35,2.86,0.,0./
       data klbm(22,4),eldat(22,4),bmdat(1,22,4),bmdat(2,22,4),
     $ bmdat(3,22,4),bmdat(4,22,4),bmdat(5,22,4),bmdat(6,22,4),
     $ bmdat(7,22,4),bmdat(8,22,4),bmdat(9,22,4),bmdat(10,22,4),
     $ bmdat(11,22,4),bmdat(12,22,4)
     $ /'Ne IV]',2423,0.56,0.95,1.05,0.72,
     $  0.74,1.64,0.91,0.74,1.19,0.63,0.,0./
       data klbm(23,4),eldat(23,4),bmdat(1,23,4),bmdat(2,23,4),
     $ bmdat(3,23,4),bmdat(4,23,4),bmdat(5,23,4),bmdat(6,23,4),
     $ bmdat(7,23,4),bmdat(8,23,4),bmdat(9,23,4),bmdat(10,23,4),
     $ bmdat(11,23,4),bmdat(12,23,4)
     $ /'[Ne V]',3426,0.73,0.9,0.79,0.74,0.6,
     $  2.29,0.73,0.61,0.81,0.63,0.,0./
       data klbm(24,4),eldat(24,4),bmdat(1,24,4),bmdat(2,24,4),
     $ bmdat(3,24,4),bmdat(4,24,4),bmdat(5,24,4),bmdat(6,24,4),
     $ bmdat(7,24,4),bmdat(8,24,4),bmdat(9,24,4),bmdat(10,24,4),
     $ bmdat(11,24,4),bmdat(12,24,4)
     $ /'[Ne V]',2.42E+04,1.67,0.88,1.2,0.94,
     $  0.76,1.16,0.81,0.99,0.25,0.95,0.,0./
       data klbm(25,4),eldat(25,4),bmdat(1,25,4),bmdat(2,25,4),
     $ bmdat(3,25,4),bmdat(4,25,4),bmdat(5,25,4),bmdat(6,25,4),
     $ bmdat(7,25,4),bmdat(8,25,4),bmdat(9,25,4),bmdat(10,25,4),
     $ bmdat(11,25,4),bmdat(12,25,4)
     $ /'Mg II',2798,1.48,1.56,2.5,2.33,
     $  1.6,0.63,1.22,1.17,1.15,1.92,0.,0./
       data klbm(26,4),eldat(26,4),bmdat(1,26,4),bmdat(2,26,4),
     $ bmdat(3,26,4),bmdat(4,26,4),bmdat(5,26,4),bmdat(6,26,4),
     $ bmdat(7,26,4),bmdat(8,26,4),bmdat(9,26,4),bmdat(10,26,4),
     $ bmdat(11,26,4),bmdat(12,26,4)
     $ /'[Mg IV]',4.50E+03,0.09,0.12,0.11,
     $  0.12,0.13,0.,0.,0.12,0.14,0.,0.,0./
       data klbm(27,4),eldat(27,4),bmdat(1,27,4),bmdat(2,27,4),
     $ bmdat(3,27,4),bmdat(4,27,4),bmdat(5,27,4),bmdat(6,27,4),
     $ bmdat(7,27,4),bmdat(8,27,4),bmdat(9,27,4),bmdat(10,27,4),
     $ bmdat(11,27,4),bmdat(12,27,4)
     $ /'[Si II]',3.48E+04,0.13,0.18,0.14,0.16,
     $  0.26,0.,0.19,0.17,0.15,0.16,0.,0./
       data klbm(28,4),eldat(28,4),bmdat(1,28,4),bmdat(2,28,4),
     $ bmdat(3,28,4),bmdat(4,28,4),bmdat(5,28,4),bmdat(6,28,4),
     $ bmdat(7,28,4),bmdat(8,28,4),bmdat(9,28,4),bmdat(10,28,4),
     $ bmdat(11,28,4),bmdat(12,28,4)
     $ /'Si II]',2335,0.11,0.23,0.23,0.15,0.,
     $           0.53,0.16,0.16,0.,0.15,0.,0./
       data klbm(29,4),eldat(29,4),bmdat(1,29,4),bmdat(2,29,4),
     $ bmdat(3,29,4),bmdat(4,29,4),bmdat(5,29,4),bmdat(6,29,4),
     $ bmdat(7,29,4),bmdat(8,29,4),bmdat(9,29,4),bmdat(10,29,4),
     $ bmdat(11,29,4),bmdat(12,29,4)
     $ /'Si III]',1892,0.2,0.68,0.79,0.39,
     $               0.32,1.95,0.46,0.45,0.,0.4,0.,0./
       data klbm(30,4),eldat(30,4),bmdat(1,30,4),bmdat(2,30,4),
     $ bmdat(3,30,4),bmdat(4,30,4),bmdat(5,30,4),bmdat(6,30,4),
     $ bmdat(7,30,4),bmdat(8,30,4),bmdat(9,30,4),bmdat(10,30,4),
     $ bmdat(11,30,4),bmdat(12,30,4)
     $ /'Si IV',1397,0.15,0.15,0.1,0.2,
     $  0.15,0.03,0.21,0.17,0.,0.16,0.,0./
       data klbm(31,4),eldat(31,4),bmdat(1,31,4),bmdat(2,31,4),
     $ bmdat(3,31,4),bmdat(4,31,4),bmdat(5,31,4),bmdat(6,31,4),
     $ bmdat(7,31,4),bmdat(8,31,4),bmdat(9,31,4),bmdat(10,31,4),
     $ bmdat(11,31,4),bmdat(12,31,4)
     $ /'[S II]',6720,0.39,0.33,0.24,0.21,
     $  0.45,0.08,0.33,0.43,0.41,0.51,0.,0./
       data klbm(32,4),eldat(32,4),bmdat(1,32,4),bmdat(2,32,4),
     $ bmdat(3,32,4),bmdat(4,32,4),bmdat(5,32,4),bmdat(6,32,4),
     $ bmdat(7,32,4),bmdat(8,32,4),bmdat(9,32,4),bmdat(10,32,4),
     $ bmdat(11,32,4),bmdat(12,32,4)
     $ /'[S 111]',1.87E+04,0.49,0.53,0.6,
     $  0.48,0.49,0.,0.46,0.49,0.6,0.55,0.,0./
       data klbm(33,4),eldat(33,4),bmdat(1,33,4),bmdat(2,33,4),
     $ bmdat(3,33,4),bmdat(4,33,4),bmdat(5,33,4),bmdat(6,33,4),
     $ bmdat(7,33,4),bmdat(8,33,4),bmdat(9,33,4),bmdat(10,33,4),
     $ bmdat(11,33,4),bmdat(12,33,4)
     $ /'[S lil]',9532,2.09,1.91,2.31,2.04,1.89,
     $  0.36,2.05,1.87,2.34,2.42,0.,0./
       data klbm(34,4),eldat(34,4),bmdat(1,34,4),bmdat(2,34,4),
     $ bmdat(3,34,4),bmdat(4,34,4),bmdat(5,34,4),bmdat(6,34,4),
     $ bmdat(7,34,4),bmdat(8,34,4),bmdat(9,34,4),bmdat(10,34,4),
     $ bmdat(11,34,4),bmdat(12,34,4)
     $ /'[S IV]',1.05E+04,1.92,1.84,1.58,1.92,
     $  2.21,0.93,1.81,1.98,2.36,1.94,0.,0./
       data klbm(35,4),eldat(35,4),bmdat(1,35,4),bmdat(2,35,4),
     $ bmdat(3,35,4),bmdat(4,35,4),bmdat(5,35,4),bmdat(6,35,4),
     $ bmdat(7,35,4),bmdat(8,35,4),bmdat(9,35,4),bmdat(10,35,4),
     $ bmdat(11,35,4),bmdat(12,35,4)
     $ /'L(total)',0.,129,132,114,139,136,105,135,136,130,142,0.,0./
       data klbm(36,4),eldat(36,4),bmdat(1,36,4),bmdat(2,36,4),
     $ bmdat(3,36,4),bmdat(4,36,4),bmdat(5,36,4),bmdat(6,36,4),
     $ bmdat(7,36,4),bmdat(8,36,4),bmdat(9,36,4),bmdat(10,36,4),
     $ bmdat(11,36,4),bmdat(12,36,4)
     $ /'T(in)',0.,0.,1.8,0.,1.83,1.78,1.63,1.84,1.78,1.95,1.81,0.,0./
       data klbm(37,4),eldat(37,4),bmdat(1,37,4),bmdat(2,37,4),
     $ bmdat(3,37,4),bmdat(4,37,4),bmdat(5,37,4),bmdat(6,37,4),
     $ bmdat(7,37,4),bmdat(8,37,4),bmdat(9,37,4),bmdat(10,37,4),
     $ bmdat(11,37,4),bmdat(12,37,4)
     $ /'T(H+)',0.,0.,1.26,0.,1.22,1.21,1.32,1.35,1.21,1.29,1.2,0.,0./
       data klbm(38,4),eldat(38,4),bmdat(1,38,4),bmdat(2,38,4),
     $ bmdat(3,38,4),bmdat(4,38,4),bmdat(5,38,4),bmdat(6,38,4),
     $ bmdat(7,38,4),bmdat(8,38,4),bmdat(9,38,4),bmdat(10,38,4),
     $ bmdat(11,38,4),bmdat(12,38,4)
     $ /'<He+>/<H+>',0.,0.,0.69,0.,0.74,
     $       0.74,0.,0.71,0.71,0.6,0.68,0.,0./
       data klbm(39,4),eldat(39,4),bmdat(1,39,4),bmdat(2,39,4),
     $ bmdat(3,39,4),bmdat(4,39,4),bmdat(5,39,4),bmdat(6,39,4),
     $ bmdat(7,39,4),bmdat(8,39,4),bmdat(9,39,4),bmdat(10,39,4),
     $ bmdat(11,39,4),bmdat(12,39,4)
     $ /'R(out) E17',0.,0.,4.02,0.,4.04,4.04,0.,
     $         4.07,4.07,3.83,4.08,0.,0./
c     Table 7 Low Ionization PN, Mean,1,2,3,5,6,10,11,0.,0.,0.,0./
       data nbmdat(6)/8/ 
       data nlnsv2(6)/17/
       data klbm(1,6),eldat(1,6),bmdat(1,1,6),bmdat(2,1,6),
     $ bmdat(3,1,6),bmdat(4,1,6),bmdat(5,1,6),bmdat(6,1,6),
     $ bmdat(7,1,6),bmdat(8,1,6),bmdat(9,1,6),bmdat(10,1,6),
     $ bmdat(11,1,6),bmdat(12,1,6)
     $ /'L(H A)',0.,5.41,5.2,5.56,5.52,
     $                 5.35,5.41,5.38,5.44,0.,0.,0.,0./
       data klbm(2,6),eldat(2,6),bmdat(1,2,6),bmdat(2,2,6),
     $ bmdat(3,2,6),bmdat(4,2,6),bmdat(5,2,6),bmdat(6,2,6),
     $ bmdat(7,2,6),bmdat(8,2,6),bmdat(9,2,6),bmdat(10,2,6),
     $ bmdat(11,2,6),bmdat(12,2,6)
     $ /'He I',5876,0.13,0.12,0.14,0.12,0.14,0.12,0.12,0.15,0.,0.,0.,0./
       data klbm(3,6),eldat(3,6),bmdat(1,3,6),bmdat(2,3,6),
     $ bmdat(3,3,6),bmdat(4,3,6),bmdat(5,3,6),bmdat(6,3,6),
     $ bmdat(7,3,6),bmdat(8,3,6),bmdat(9,3,6),bmdat(10,3,6),
     $ bmdat(11,3,6),bmdat(12,3,6)
     $ /'He II',4686,0.088,0.095,0.082,
     $  0.088,0.088,0.088,0.091,0.086,0.,0.,0.,0./
       data klbm(4,6),eldat(4,6),bmdat(1,4,6),bmdat(2,4,6),
     $ bmdat(3,4,6),bmdat(4,4,6),bmdat(5,4,6),bmdat(6,4,6),
     $ bmdat(7,4,6),bmdat(8,4,6),bmdat(9,4,6),bmdat(10,4,6),
     $ bmdat(11,4,6),bmdat(12,4,6)
     $ /'C III]',1909,1.17,1.53,0.78,0.81,1.25,1.41,1.43,1,0.,0.,0.,0./
       data klbm(5,6),eldat(5,6),bmdat(1,5,6),bmdat(2,5,6),
     $ bmdat(3,5,6),bmdat(4,5,6),bmdat(5,5,6),bmdat(6,5,6),
     $ bmdat(7,5,6),bmdat(8,5,6),bmdat(9,5,6),bmdat(10,5,6),
     $ bmdat(11,5,6),bmdat(12,5,6)
     $ /'C IV',1549,1.38,1.2,1.34,1.31,1.54,1.43,1.51,1.32,0.,0.,0.,0./
       data klbm(6,6),eldat(6,6),bmdat(1,6,6),bmdat(2,6,6),
     $ bmdat(3,6,6),bmdat(4,6,6),bmdat(5,6,6),bmdat(6,6,6),
     $ bmdat(7,6,6),bmdat(8,6,6),bmdat(9,6,6),bmdat(10,6,6),
     $ bmdat(11,6,6),bmdat(12,6,6)
     $ /'[O III]',5007,14.3,16,12.7,13.1,
     $             15.,14.5,14.6,14.3,0.,0.,0.,0./
       data klbm(7,6),eldat(7,6),bmdat(1,7,6),bmdat(2,7,6),
     $ bmdat(3,7,6),bmdat(4,7,6),bmdat(5,7,6),bmdat(6,7,6),
     $ bmdat(7,7,6),bmdat(8,7,6),bmdat(9,7,6),bmdat(10,7,6),
     $ bmdat(11,7,6),bmdat(12,7,6)
     $ /'[OIII]',5.20E+04,0.26,0.28,0.26,
     $  0.26,0.26,0.27,0.,0.26,0.,0.,0.,0./
       data klbm(8,6),eldat(8,6),bmdat(1,8,6),bmdat(2,8,6),
     $ bmdat(3,8,6),bmdat(4,8,6),bmdat(5,8,6),bmdat(6,8,6),
     $ bmdat(7,8,6),bmdat(8,8,6),bmdat(9,8,6),bmdat(10,8,6),
     $ bmdat(11,8,6),bmdat(12,8,6)
     $ /'[O IV]',2.60E+04,0.22,0.24,0.21,
     $  0.23,0.21,0.21,0.22,0.22,0.,0.,0.,0./
       data klbm(9,6),eldat(9,6),bmdat(1,9,6),bmdat(2,9,6),
     $ bmdat(3,9,6),bmdat(4,9,6),bmdat(5,9,6),bmdat(6,9,6),
     $ bmdat(7,9,6),bmdat(8,9,6),bmdat(9,9,6),bmdat(10,9,6),
     $ bmdat(11,9,6),bmdat(12,9,6)
     $ /'[Ne III]',1.55E+04,1.11,1.14,1.09,
     $  1.1,1.1,1.12,1.12,1.1,0.,0.,0.,0./
       data klbm(10,6),eldat(10,6),bmdat(1,10,6),bmdat(2,10,6),
     $ bmdat(3,10,6),bmdat(4,10,6),bmdat(5,10,6),bmdat(6,10,6),
     $ bmdat(7,10,6),bmdat(8,10,6),bmdat(9,10,6),bmdat(10,10,6),
     $ bmdat(11,10,6),bmdat(12,10,6)
     $ /'[Ne III]',3869,1.44,1.66,1.39,1.27,
     $  1.48,1.44,1.45,1.38,0.,0.,0.,0./
       data klbm(11,6),eldat(11,6),bmdat(1,11,6),bmdat(2,11,6),
     $ bmdat(3,11,6),bmdat(4,11,6),bmdat(5,11,6),bmdat(6,11,6),
     $ bmdat(7,11,6),bmdat(8,11,6),bmdat(9,11,6),bmdat(10,11,6),
     $ bmdat(11,11,6),bmdat(12,11,6)
     $ /'Ne IV]',2423,0.1,0.1,0.11,0.11,0.1,0.08,0.08,0.1,0.,0.,0.,0./
       data klbm(12,6),eldat(12,6),bmdat(1,12,6),bmdat(2,12,6),
     $ bmdat(3,12,6),bmdat(4,12,6),bmdat(5,12,6),bmdat(6,12,6),
     $ bmdat(7,12,6),bmdat(8,12,6),bmdat(9,12,6),bmdat(10,12,6),
     $ bmdat(11,12,6),bmdat(12,12,6)
     $ /'[S III]',9532,0.52,0.65,0.23,0.37,
     $      0.26,0.42,0.76,0.99,0.,0.,0.,0./
       data klbm(13,6),eldat(13,6),bmdat(1,13,6),bmdat(2,13,6),
     $ bmdat(3,13,6),bmdat(4,13,6),bmdat(5,13,6),bmdat(6,13,6),
     $ bmdat(7,13,6),bmdat(8,13,6),bmdat(9,13,6),bmdat(10,13,6),
     $ bmdat(11,13,6),bmdat(12,13,6)
     $ /'[SII]',1.05E+04,1.43,1.2,
     $  1.32,1.57,1.32,1.84,1.38,1.37,0.,0.,0.,0./
       data klbm(14,6),eldat(14,6),bmdat(1,14,6),bmdat(2,14,6),
     $ bmdat(3,14,6),bmdat(4,14,6),bmdat(5,14,6),bmdat(6,14,6),
     $ bmdat(7,14,6),bmdat(8,14,6),bmdat(9,14,6),bmdat(10,14,6),
     $ bmdat(11,14,6),bmdat(12,14,6)
     $ /'L(total)',0.,120,126,109,112,122,124,122,121,0.,0.,0.,0./
       data klbm(15,6),eldat(15,6),bmdat(1,15,6),bmdat(2,15,6),
     $ bmdat(3,15,6),bmdat(4,15,6),bmdat(5,15,6),bmdat(6,15,6),
     $ bmdat(7,15,6),bmdat(8,15,6),bmdat(9,15,6),bmdat(10,15,6),
     $ bmdat(11,15,6),bmdat(12,15,6)
     $ /'T(in)',0.,1.78,0.,1.83,1.79,1.76,1.73,1.76,1.81,0.,0.,0.,0./
       data klbm(16,6),eldat(16,6),bmdat(1,16,6),bmdat(2,16,6),
     $ bmdat(3,16,6),bmdat(4,16,6),bmdat(5,16,6),bmdat(6,16,6),
     $ bmdat(7,16,6),bmdat(8,16,6),bmdat(9,16,6),bmdat(10,16,6),
     $ bmdat(11,16,6),bmdat(12,16,6)
     $ /'T(H+)',0.,1.16,0.,1.11,1.11,1.28,1.14,1.2,1.14,0.,0.,0.,0./
       data klbm(17,6),eldat(17,6),bmdat(1,17,6),bmdat(2,17,6),
     $ bmdat(3,17,6),bmdat(4,17,6),bmdat(5,17,6),bmdat(6,17,6),
     $ bmdat(7,17,6),bmdat(8,17,6),bmdat(9,17,6),bmdat(10,17,6),
     $ bmdat(11,17,6),bmdat(12,17,6)
     $ /'<He.>/cH.>',0.,0.91,0.,0.91,0.91,
     $      0.91,0.91,0.9,0.9,0.,0.,0.,0./
c     Table 8 NLR Cloud,Mean,1,2,4,5,6,11,
       data nbmdat(7)/7/
       data nlnsv2(7)/29/
      data klbm(30,7),eldat(30,7),bmdat(1,30,7),bmdat(2,30,7),
     $ bmdat(3,30,7),bmdat(4,30,7),bmdat(5,30,7),bmdat(6,30,7),
     $ bmdat(7,30,7),bmdat(8,30,7),bmdat(9,30,7),bmdat(10,30,7),
     $ bmdat(11,30,7),bmdat(12,30,7)
     $ /'6',0.,0.,0.,0.,1.06,1.37,1.43,1.34,0.,0.,0.,0.,0./
       data klbm(1,7),eldat(1,7),bmdat(1,1,7),bmdat(2,1,7),
     $ bmdat(3,1,7),bmdat(4,1,7),bmdat(5,1,7),bmdat(6,1,7),
     $ bmdat(7,1,7),bmdat(8,1,7),bmdat(9,1,7),bmdat(10,1,7),
     $ bmdat(11,1,7),bmdat(12,1,7)
     $ /'Lyoc',1216,34.2,38.3,32.1,37,32.4,31.5,34.2,0.,0.,0.,0.,0./
       data klbm(2,7),eldat(2,7),bmdat(1,2,7),bmdat(2,2,7),
     $ bmdat(3,2,7),bmdat(4,2,7),bmdat(5,2,7),bmdat(6,2,7),
     $ bmdat(7,2,7),bmdat(8,2,7),bmdat(9,2,7),bmdat(10,2,7),
     $ bmdat(11,2,7),bmdat(12,2,7)
     $ /'He I',5876,0.12,0.11,0.13,0.14,0.12,0.13,0.13,0.,0.,0.,0.,0./
       data klbm(3,7),eldat(3,7),bmdat(1,3,7),bmdat(2,3,7),
     $ bmdat(3,3,7),bmdat(4,3,7),bmdat(5,3,7),bmdat(6,3,7),
     $ bmdat(7,3,7),bmdat(8,3,7),bmdat(9,3,7),bmdat(10,3,7),
     $ bmdat(11,3,7),bmdat(12,3,7)
     $ /'He II',4686,0.24,0.25,0.25,0.,
     $               0.25,0.23,0.24,0.,0.,0.,0.,0./
       data klbm(4,7),eldat(4,7),bmdat(1,4,7),bmdat(2,4,7),
     $ bmdat(3,4,7),bmdat(4,4,7),bmdat(5,4,7),bmdat(6,4,7),
     $ bmdat(7,4,7),bmdat(8,4,7),bmdat(9,4,7),bmdat(10,4,7),
     $ bmdat(11,4,7),bmdat(12,4,7)
     $ /'He II',1640,1.6,1.6,1.74,1.49,1.53,1.56,1.67,0.,0.,0.,0.,0./
       data klbm(5,7),eldat(5,7),bmdat(1,5,7),bmdat(2,5,7),
     $ bmdat(3,5,7),bmdat(4,5,7),bmdat(5,5,7),bmdat(6,5,7),
     $ bmdat(7,5,7),bmdat(8,5,7),bmdat(9,5,7),bmdat(10,5,7),
     $ bmdat(11,5,7),bmdat(12,5,7)
     $ /'CIII]',1909,2.82,2.9,2.99,2.45,2.87,2.83,2.9,0.,0.,0.,0.,0./
       data klbm(6,7),eldat(6,7),bmdat(1,6,7),bmdat(2,6,7),
     $ bmdat(3,6,7),bmdat(4,6,7),bmdat(5,6,7),bmdat(6,6,7),
     $ bmdat(7,6,7),bmdat(8,6,7),bmdat(9,6,7),bmdat(10,6,7),
     $ bmdat(11,6,7),bmdat(12,6,7)
     $ /'CIV',1549,3.18,2.7,3.85,2.28,3.69,3.17,3.36,0.,0.,0.,0.,0./
       data klbm(7,7),eldat(7,7),bmdat(1,7,7),bmdat(2,7,7),
     $ bmdat(3,7,7),bmdat(4,7,7),bmdat(5,7,7),bmdat(6,7,7),
     $ bmdat(7,7,7),bmdat(8,7,7),bmdat(9,7,7),bmdat(10,7,7),
     $ bmdat(11,7,7),bmdat(12,7,7)
     $ /'[NII]',6584,2.33,1.4,3.2,1.21,3.1,2.67,2.4,0.,0.,0.,0.,0./
       data klbm(8,7),eldat(8,7),bmdat(1,8,7),bmdat(2,8,7),
     $ bmdat(3,8,7),bmdat(4,8,7),bmdat(5,8,7),bmdat(6,8,7),
     $ bmdat(7,8,7),bmdat(8,8,7),bmdat(9,8,7),bmdat(10,8,7),
     $ bmdat(11,8,7),bmdat(12,8,7)
     $ /'NIII]',1749,0.19,0.24,0.24,0.01,0.22,0.22,0.22,0.,0.,0.,0.,0./
       data klbm(9,7),eldat(9,7),bmdat(1,9,7),bmdat(2,9,7),
     $ bmdat(3,9,7),bmdat(4,9,7),bmdat(5,9,7),bmdat(6,9,7),
     $ bmdat(7,9,7),bmdat(8,9,7),bmdat(9,9,7),bmdat(10,9,7),
     $ bmdat(11,9,7),bmdat(12,9,7)
     $ /'NIV]',1487,0.2,0.2,0.23,0.12,0.22,0.21,0.21,0.,0.,0.,0.,0./
       data klbm(10,7),eldat(10,7),bmdat(1,10,7),bmdat(2,10,7),
     $ bmdat(3,10,7),bmdat(4,10,7),bmdat(5,10,7),bmdat(6,10,7),
     $ bmdat(7,10,7),bmdat(8,10,7),bmdat(9,10,7),bmdat(10,10,7),
     $ bmdat(11,10,7),bmdat(12,10,7)
     $ /'[OI]',6300,1.61,2.2,1.61,1.41,1.67,1.31,1.46,0.,0.,0.,0.,0./
       data klbm(11,7),eldat(11,7),bmdat(1,11,7),bmdat(2,11,7),
     $ bmdat(3,11,7),bmdat(4,11,7),bmdat(5,11,7),bmdat(6,11,7),
     $ bmdat(7,11,7),bmdat(8,11,7),bmdat(9,11,7),bmdat(10,11,7),
     $ bmdat(11,11,7),bmdat(12,11,7)
     $ /'[O II]',6.30E+04,1.12,0.25,1.13,0.,0.,1.44,1.64,0.,0.,0.,0.,0./
       data klbm(12,7),eldat(12,7),bmdat(1,12,7),bmdat(2,12,7),
     $ bmdat(3,12,7),bmdat(4,12,7),bmdat(5,12,7),bmdat(6,12,7),
     $ bmdat(7,12,7),bmdat(8,12,7),bmdat(9,12,7),bmdat(10,12,7),
     $ bmdat(11,12,7),bmdat(12,12,7)
     $ /'[OIII]',3727,1.72,1.6,1.44,3.18,1.58,1.3,1.2,0.,0.,0.,0.,0./
       data klbm(13,7),eldat(13,7),bmdat(1,13,7),bmdat(2,13,7),
     $ bmdat(3,13,7),bmdat(4,13,7),bmdat(5,13,7),bmdat(6,13,7),
     $ bmdat(7,13,7),bmdat(8,13,7),bmdat(9,13,7),bmdat(10,13,7),
     $ bmdat(11,13,7),bmdat(12,13,7)
     $ /'OIII]',1663,0.56,0.35,0.63,0.,0.61,0.57,0.63,0.,0.,0.,0.,0./
       data klbm(14,7),eldat(14,7),bmdat(1,14,7),bmdat(2,14,7),
     $ bmdat(3,14,7),bmdat(4,14,7),bmdat(5,14,7),bmdat(6,14,7),
     $ bmdat(7,14,7),bmdat(8,14,7),bmdat(9,14,7),bmdat(10,14,7),
     $ bmdat(11,14,7),bmdat(12,14,7)
     $ /'[OIII]',5007,33.1,31.4,34.5,31.1,33,32.8,36,0.,0.,0.,0.,0./
       data klbm(15,7),eldat(15,7),bmdat(1,15,7),bmdat(2,15,7),
     $ bmdat(3,15,7),bmdat(4,15,7),bmdat(5,15,7),bmdat(6,15,7),
     $ bmdat(7,15,7),bmdat(8,15,7),bmdat(9,15,7),bmdat(10,15,7),
     $ bmdat(11,15,7),bmdat(12,15,7)
     $ /'[OIII]',4363,0.32,0.3,0.34,0.,
     $             0.31,0.3,0.33,0.,0.,0.,0.,0./
       data klbm(16,7),eldat(16,7),bmdat(1,16,7),bmdat(2,16,7),
     $ bmdat(3,16,7),bmdat(4,16,7),bmdat(5,16,7),bmdat(6,16,7),
     $ bmdat(7,16,7),bmdat(8,16,7),bmdat(9,16,7),bmdat(10,16,7),
     $ bmdat(11,16,7),bmdat(12,16,7)
     $ /'OIV',1403,0.36,0.49,0.3,0.,0.36,0.42,0.25,0.,0.,0.,0.,0./
       data klbm(17,7),eldat(17,7),bmdat(1,17,7),bmdat(2,17,7),
     $ bmdat(3,17,7),bmdat(4,17,7),bmdat(5,17,7),bmdat(6,17,7),
     $ bmdat(7,17,7),bmdat(8,17,7),bmdat(9,17,7),bmdat(10,17,7),
     $ bmdat(11,17,7),bmdat(12,17,7)
     $ /'[NeIII]',1.55E+04,1.89,1.5,2.01,0.,
     $        1.94,2.05,1.95,0.,0.,0.,0.,0./
       data klbm(18,7),eldat(18,7),bmdat(1,18,7),bmdat(2,18,7),
     $ bmdat(3,18,7),bmdat(4,18,7),bmdat(5,18,7),bmdat(6,18,7),
     $ bmdat(7,18,7),bmdat(8,18,7),bmdat(9,18,7),bmdat(10,18,7),
     $ bmdat(11,18,7),bmdat(12,18,7)
     $ /'[Ne III]',3869,1.91,1.9,2.51,0.84,
     $              2.16,1.72,2.34,0.,0.,0.,0.,0./
       data klbm(19,7),eldat(19,7),bmdat(1,19,7),bmdat(2,19,7),
     $ bmdat(3,19,7),bmdat(4,19,7),bmdat(5,19,7),bmdat(6,19,7),
     $ bmdat(7,19,7),bmdat(8,19,7),bmdat(9,19,7),bmdat(10,19,7),
     $ bmdat(11,19,7),bmdat(12,19,7)
     $ /'[Ne IV]',2423,0.44,0.52,0.42,
     $            0.,0.47,0.41,0.38,0.,0.,0.,0.,0./
       data klbm(20,7),eldat(20,7),bmdat(1,20,7),bmdat(2,20,7),
     $ bmdat(3,20,7),bmdat(4,20,7),bmdat(5,20,7),bmdat(6,20,7),
     $ bmdat(7,20,7),bmdat(8,20,7),bmdat(9,20,7),bmdat(10,20,7),
     $ bmdat(11,20,7),bmdat(12,20,7)
     $ /'[NeV]',3426,0.52,0.59,0.55,0.,0 53,0.44,0.5,0.,0.,0.,0.,0./
       data klbm(21,7),eldat(21,7),bmdat(1,21,7),bmdat(2,21,7),
     $ bmdat(3,21,7),bmdat(4,21,7),bmdat(5,21,7),bmdat(6,21,7),
     $ bmdat(7,21,7),bmdat(8,21,7),bmdat(9,21,7),bmdat(10,21,7),
     $ bmdat(11,21,7),bmdat(12,21,7)
     $ /'MgII',2798,1.78,3.5,1.72,1.48,1.23,1.12,1.61,0.,0.,0.,0.,0./
       data klbm(22,7),eldat(22,7),bmdat(1,22,7),bmdat(2,22,7),
     $ bmdat(3,22,7),bmdat(4,22,7),bmdat(5,22,7),bmdat(6,22,7),
     $ bmdat(7,22,7),bmdat(8,22,7),bmdat(9,22,7),bmdat(10,22,7),
     $ bmdat(11,22,7),bmdat(12,22,7)
     $ /'[SiII]',3.48E+04,0.9,1,0.96,0.,
     $           1.07,0.96,0.52,0.,0.,0.,0.,0./
       data klbm(23,7),eldat(23,7),bmdat(1,23,7),bmdat(2,23,7),
     $ bmdat(3,23,7),bmdat(4,23,7),bmdat(5,23,7),bmdat(6,23,7),
     $ bmdat(7,23,7),bmdat(8,23,7),bmdat(9,23,7),bmdat(10,23,7),
     $ bmdat(11,23,7),bmdat(12,23,7)
     $ /'[SII]',6720,1.33,2.4,1.01,1.58,0.93,0.99,1.1,0.,0.,0.,0.,0./
       data klbm(24,7),eldat(24,7),bmdat(1,24,7),bmdat(2,24,7),
     $ bmdat(3,24,7),bmdat(4,24,7),bmdat(5,24,7),bmdat(6,24,7),
     $ bmdat(7,24,7),bmdat(8,24,7),bmdat(9,24,7),bmdat(10,24,7),
     $ bmdat(11,24,7),bmdat(12,24,7)
     $ /'[S III]',9532,1.88,1.6,2.15,1.73,
     $               2.06,1.67,2.08,0.,0.,0.,0.,0./
       data klbm(25,7),eldat(25,7),bmdat(1,25,7),bmdat(2,25,7),
     $ bmdat(3,25,7),bmdat(4,25,7),bmdat(5,25,7),bmdat(6,25,7),
     $ bmdat(7,25,7),bmdat(8,25,7),bmdat(9,25,7),bmdat(10,25,7),
     $ bmdat(11,25,7),bmdat(12,25,7)
     $ /'[SIII',1.87E+04,0.49,0.36,0.61,0.,
     $             0.57,0.52,0.37,0.,0.,0.,0.,0./
       data klbm(26,7),eldat(26,7),bmdat(1,26,7),bmdat(2,26,7),
     $ bmdat(3,26,7),bmdat(4,26,7),bmdat(5,26,7),bmdat(6,26,7),
     $ bmdat(7,26,7),bmdat(8,26,7),bmdat(9,26,7),bmdat(10,26,7),
     $ bmdat(11,26,7),bmdat(12,26,7)
     $ /'[SIII]',1.05E+04,1.05,0.86,
     $  1.24,1.23,0.82,0.94,1.22,0.,0.,0.,0.,0./
       data klbm(27,7),eldat(27,7),bmdat(1,27,7),bmdat(2,27,7),
     $ bmdat(3,27,7),bmdat(4,27,7),bmdat(5,27,7),bmdat(6,27,7),
     $ bmdat(7,27,7),bmdat(8,27,7),bmdat(9,27,7),bmdat(10,27,7),
     $ bmdat(11,27,7),bmdat(12,27,7)
     $ /'I(total) E0',0.,125,131,128,92,128,131,133,0.,0.,0.,0.,0./
       data klbm(28,7),eldat(28,7),bmdat(1,28,7),bmdat(2,28,7),
     $ bmdat(3,28,7),bmdat(4,28,7),bmdat(5,28,7),bmdat(6,28,7),
     $ bmdat(7,28,7),bmdat(8,28,7),bmdat(9,28,7),bmdat(10,28,7),
     $ bmdat(11,28,7),bmdat(12,28,7)
     $ /'T(in) E4',0.,1.7,1.71,1.7,0.,1.72,1.68,1.68,0.,0.,0.,0.,0./
       data klbm(29,7),eldat(29,7),bmdat(1,29,7),bmdat(2,29,7),
     $ bmdat(3,29,7),bmdat(4,29,7),bmdat(5,29,7),bmdat(6,29,7),
     $ bmdat(7,29,7),bmdat(8,29,7),bmdat(9,29,7),bmdat(10,29,7),
     $ bmdat(11,29,7),bmdat(12,29,7)
     $ /'T(H+) E4',0.,1.17,0.,1.24,1.12,
     $         1.06,1.2,1.23,0.,0.,0.,0.,0./
      data nlnsv(2)/34/
      data (elnsv(1,ml,2),elnsv(2,ml,2),nbmpt(ml,2),ml=1,17)/
     $    4858., 4863.,24,
     $    1215., 1217.,0,
     $    5875., 5877.,1,
     $    2325., 2327.,2,
     $    1334., 1336.,0,
     $    1908., 1910.,3,
     $    6545., 6550.,5,
     $    6580., 6590.,5,
     $    56.5e+4, 57.5e+4, 6,
     $    1218025., 1218028.,4,
     $    2053380., 2053390.,0,
     $    6295., 6305.,0,
     $    6360., 6370.,0,
     $    7320., 7325.,0,
     $    7330., 7335.,0,
     $    3725., 3730.,7,
     $    517500., 518500.,8/
      data (elnsv(1,ml,2),elnsv(2,ml,2),nbmpt(ml,2),ml=18,34)/
     $    883300., 883400.,9,
     $    4950., 4965.,10,
     $    5000., 5010.,10,
     $    4360., 4365.,10,
     $    258500., 259500.,0,
     $    127500., 128500.,11,
     $    154500., 157500.,12,
     $    3865., 3870.,13,
     $    3965., 3970.,13,
     $    6713., 6720.,14,
     $    6728., 6733.,14,
     $    4065., 4078.,0,
     $    180000., 197500.,15,
     $    335000., 345000.,16,
     $    9530., 9535.,17,
     $    9065., 9072.,17,
     $    104500., 105500.,18/
      data nlnsv(1)/32/
      data (elnsv(1,ml,1),elnsv(2,ml,1),nbmpt(ml,1),ml=1,16)/
     $    4858., 4863.,14,
     $    1215., 1217.,0,
     $    5875., 5877.,0,
     $    2325., 2327.,0,
     $    1334., 1336.,0,
     $    1908., 1910.,0,
     $    6545., 6550.,2,
     $    6580., 6590.,2,
     $    127500., 128500.,4,
     $    2053380., 2053390.,0,
     $    6295., 6305.,0,
     $    6360., 6370.,0,
     $    7320., 7325.,0,
     $    7330., 7335.,0,
     $    3725., 3730.,3,
     $    517500., 518500.,0/
      data (elnsv(1,ml,1),elnsv(2,ml,1),nbmpt(ml,1),ml=17,32)/
     $    883300., 883400.,0,
     $    4950., 4965.,0,
     $    5000., 5010.,0,
     $    4360., 4365.,0,
     $    258500., 259500.,0,
     $    127500., 128500.,0,
     $    154500., 155500.,0,
     $    3865., 3870.,0,
     $    3965., 3970.,0,
     $    6713., 6720.,5,
     $    6728., 6733.,5,
     $    3.3e+5, 3.4e+5,7,
     $    180000., 197500.,6,
     $    9530., 9535.,8,
     $    9065., 9072.,8,
     $    104500., 105500.,0/
      data nlnsv(3)/32/
      data (elnsv(1,ml,3),elnsv(2,ml,3),nbmpt(ml,3),ml=1,16)/
     $    4858., 4863.,1,
     $    1215., 1217.,0,
     $    5875., 5877.,2,
     $    2325., 2327.,3,
     $    1334., 1336.,4,
     $    1908., 1910.,5,
     $    6545., 6550.,6,
     $    6580., 6590.,6,
     $    1218025., 1218028.,12,
     $    2053380., 2053390.,0,
     $    6295., 6305.,0,
     $    6360., 6370.,0,
     $    7320., 7325.,8,
     $    7330., 7335.,8,
     $    3725., 3730.,9,
     $    517500., 518500.,10/
      data (elnsv(1,ml,3),elnsv(2,ml,3),nbmpt(ml,3),ml=17,32)/
     $    883300., 883400.,0,
     $    4950., 4965.,11,
     $    5000., 5010.,11,
     $    4360., 4365.,11,
     $    258500., 259500.,0,
     $    127500., 128500.,12,
     $    154500., 155500.,13,
     $    3865., 3870.,14,
     $    3965., 3970.,14,
     $    6713., 6720.,0,
     $    6728., 6733.,0,
     $    4065., 4078.,0,
     $    180000., 197500.,15,
     $    9530., 9535.,16,
     $    9065., 9072.,16,
     $    104500., 105500.,17/
      data nlnsv(4)/45/
      data (elnsv(1,ml,4),elnsv(2,ml,4),nbmpt(ml,4),ml=1,14)/
     $   4861., 4863.,1,
     $   6562., 6564., 0,
     $   1215., 1217., 0,
     $   5875., 5877., 2,
     $   4680., 4690., 3,
     $   2325., 2327., 4,
     $   1908., 1910., 5,
     $   1545., 1555., 6,
     $   5195., 5205., 0,
     $   6545., 6550., 7,
     $   6580., 6590., 7,
     $   1745., 1755., 8,
     $   1485., 1490., 10,
     $   1235., 1245.,11/
      data (elnsv(1,ml,4),elnsv(2,ml,4),nbmpt(ml,4),ml=15,30)/
     $   6295., 6305., 12,
     $   3725., 3730., 13,
     $   4950., 4965., 14,
     $   5000., 5010., 14,
     $   517500., 518500.,16, 
     $   4360., 4365., 15,
     $   258500., 259500., 17,
     $   1400., 1408., 18,
     $   1215., 1220., 19,
     $   127500., 128500.,0, 
     $   154500., 155500., 20,
     $   3865., 3870., 21,
     $   3965., 3970., 21,
     $   2420., 2428., 22,
     $   241500., 242500.,0, 
     $   3420., 3430., 23/
      data (elnsv(1,ml,4),elnsv(2,ml,4),nbmpt(ml,4),ml=31,45)/
     $   3340., 3350., 0,
     $   2795., 2800., 25,
     $   44950., 45500., 26,
     $   55950., 56050., 0,
     $   347950., 348050., 27,
     $   2330., 2340., 28,
     $   1890., 1896., 29,
     $   1390., 1405., 30,
     $   6713., 6720., 31,
     $   6728., 6733., 31,
     $   4065., 4078., 0,
     $   186950., 187050.,32, 
     $   9530., 9535., 33,
     $   9065., 9072., 33,
     $   104500., 105500.,34/
      data nlnsv(5)/45/
      data (elnsv(1,ml,5),elnsv(2,ml,5),nbmpt(ml,5),ml=1,14)/
     $   4861., 4863.,1,
     $   6562., 6564., 0,
     $   1215., 1217., 0,
     $   5875., 5877., 2,
     $   4680., 4690., 3,
     $   2325., 2327., 0,
     $   1908., 1910., 4,
     $   1545., 1555., 5,
     $   5195., 5205., 0,
     $   6545., 6550., 6,
     $   6580., 6590., 6,
     $   1745., 1755., 0,
     $   1485., 1490., 0,
     $   1235., 1245.,0/
      data (elnsv(1,ml,5),elnsv(2,ml,5),nbmpt(ml,5),ml=15,30)/
     $   6295., 6305., 0,
     $   3725., 3730., 7,
     $   4950., 4965., 8,
     $   5000., 5010., 8,
     $   517500., 518500.,9, 
     $   4360., 4365., 8,
     $   258500., 259500., 10,
     $   1400., 1408., 0,
     $   1215., 1220., 0,
     $   127500., 128500.,0, 
     $   154500., 155500., 11,
     $   3865., 3870., 12,
     $   3965., 3970., 12,
     $   2420., 2428., 0,
     $   241500., 242500.,0, 
     $   3420., 3430., 0 /
      data (elnsv(1,ml,5),elnsv(2,ml,5),nbmpt(ml,5),ml=31,45)/
     $   3340., 3350., 0,
     $   2795., 2800., 13,
     $   44950., 45500., 0,
     $   55950., 56050., 0,
     $   347950., 348050., 0,
     $   2330., 2340., 0,
     $   1890., 1896., 14,
     $   1390., 1405., 0,
     $   6713., 6720., 0,
     $   6728., 6733., 0,
     $   4065., 4078., 0,
     $   186950., 187050.,15, 
     $   9530., 9535., 16,
     $   9065., 9072., 16,
     $   104500., 105500.,17/
      data nlnsv(6)/45/
      data (elnsv(1,ml,6),elnsv(2,ml,6),nbmpt(ml,6),ml=1,14)/
     $   4861., 4863.,1,
     $   6562., 6564., 0,
     $   1215., 1217., 0,
     $   5875., 5877., 2,
     $   4680., 4690., 3,
     $   2325., 2327., 0,
     $   1908., 1910., 4,
     $   1545., 1555., 5,
     $   5195., 5205., 0,
     $   6545., 6550., 0,
     $   6580., 6590., 0,
     $   1745., 1755., 0,
     $   1485., 1490., 0,
     $   1235., 1245.,0/
      data (elnsv(1,ml,6),elnsv(2,ml,6),nbmpt(ml,6),ml=15,30)/
     $   6295., 6305., 0,
     $   3725., 3730., 0,
     $   4950., 4965., 6,
     $   5000., 5010., 6,
     $   517500., 518500.,7, 
     $   4360., 4365., 6,
     $   258500., 259500., 8,
     $   1400., 1408., 0,
     $   1215., 1220., 0,
     $   127500., 128500.,0, 
     $   154500., 155500., 9,
     $   3865., 3870., 10,
     $   3965., 3970., 10,
     $   2420., 2428., 11,
     $   241500., 242500.,0, 
     $   3420., 3430., 0 /
      data (elnsv(1,ml,6),elnsv(2,ml,6),nbmpt(ml,6),ml=31,45)/
     $   3340., 3350., 0,
     $   2795., 2800., 0,
     $   44950., 45500., 0,
     $   55950., 56050., 0,
     $   347950., 348050., 0,
     $   2330., 2340., 0,
     $   1890., 1896., 0,
     $   1390., 1405., 0,
     $   6713., 6720., 0,
     $   6728., 6733., 0,
     $   4065., 4078., 0,
     $   186950., 187050.,0, 
     $   9530., 9535., 12,
     $   9065., 9072., 12,
     $   104500., 105500.,13/
      data nlnsv(7)/29/
      data (elnsv(1,ml,7),elnsv(2,ml,7),nbmpt(ml,7),ml=1,14)/
     $    4861., 4863., 1,
     $    1215., 1217., 2,
     $    5875., 5877., 3,
     $    4680., 4690., 4,
     $    1635., 1645., 5,
     $    1908., 1910., 6,
     $    1545., 1555., 7,
     $    5195., 5205., 0,
     $    6545., 6550., 8,
     $    6580., 6590., 8,
     $    1745., 1755., 9,
     $    1485., 1490., 10,
     $    6295., 6305., 11,
     $    630000., 635000., 12/
      data (elnsv(1,ml,7),elnsv(2,ml,7),nbmpt(ml,7),ml=15,29)/
     $    3725., 3730., 13,
     $    4950., 4965., 14,
     $    5000., 5010., 14,
     $    4360., 4365., 15,
     $   1400., 1408., 16,
     $   154500., 155500., 17,
     $    3865., 3870., 18,
     $   2420., 2428., 19,
     $   3420., 3430., 20,
     $    2795., 2800., 21,
     $    6713., 6720., 22,
     $    6728., 6733., 22,
     $    9530., 9535., 23,
     $   186950., 187050.,24, 
     $    104500., 105500., 25/
      data kinam(1)/'h i     '/
      data kinam(2),kinam(3)/'he i    ','he ii   '/
      data kinam(4),kinam(5),kinam(6),kinam(7),kinam(8),
     &     kinam(9)/'c i     ','c ii    ','c iii   ','c iv    ',
     &     'c v     ','c vi    '/
      data kinam(10),kinam(11),kinam(12),kinam(13),kinam(14),
     &     kinam(15),kinam(16)/'n i     ','n ii    ','n iii   ',
     &     'n iv    ','n v     ','n vi    ','n vii   '/
      data kinam(17),kinam(18),kinam(19),kinam(20),kinam(21),
     &     kinam(22),kinam(23),kinam(24)/'o i     ','o ii    ',
     &     'o iii   ','o iv    ','o v     ','o vi    ',
     &     'o vii   ','o viii  '/
      data kinam(25),kinam(26),kinam(27),kinam(28),kinam(29),
     &     kinam(30),kinam(31),kinam(32),kinam(33),kinam(34)
     &     /'ne i    ','ne ii   ','ne iii  ','ne iv   ',
     &     'ne v    ','ne vi   ','ne vii  ','ne viii ',
     &     'ne ix   ','ne x    '/
      data kinam(35),kinam(36),kinam(37),kinam(38),kinam(39),
     &     kinam(40),kinam(41),kinam(42),kinam(43),kinam(44),
     &     kinam(45),kinam(46)/'mg i    ','mg ii   ','mg iii  ',
     &     'mg iv   ','mg v    ','mg vi   ','mg vii  ',
     &     'mg viii ','mg ix   ','mg x    ','mg xi   ',
     &     'mg xii  '/
      data kinam(47),kinam(48),kinam(49),kinam(50),kinam(51),
     &     kinam(52),kinam(53),kinam(54),kinam(55),kinam(56),
     &     kinam(57),kinam(58),kinam(59),kinam(60)/'si i    ',
     &     'si ii   ','si iii  ','si iv   ','si v    ',
     &     'si vi   ','si vii  ','si viii ','si ix   ',
     &     'si x    ','si xi   ','si xii  ','si xiii ',
     &     'si xiv  '/
      data kinam(61),kinam(62),kinam(63),kinam(64),kinam(65),
     &     kinam(66),kinam(67),kinam(68),kinam(69),kinam(70),
     &     kinam(71),kinam(72),kinam(73),kinam(74),kinam(75),
     &     kinam(76)/'s i     ','s ii    ','s iii   ','s iv    ',
     &     's v     ','s vi    ','s vii   ','s viii  ',
     &     's ix    ','s x     ','s xi    ','s xii   ',
     &     's xiii  ','s xiv   ','s xv    ','s xvi   '/
      data kinam(77),kinam(78),kinam(79),kinam(80),kinam(81),
     &     kinam(82),kinam(83),kinam(84),kinam(85),kinam(86),
     &     kinam(87),kinam(88),kinam(89),kinam(90),kinam(91),
     &     kinam(92),kinam(93),kinam(94)/'ar i    ','ar ii   ',
     &     'ar iii  ','ar iv   ','ar v    ','ar vi   ',
     &     'ar vii  ','ar viii ','ar ix   ','ar x    ',
     &     'ar xi   ','ar xii  ','ar xiii ','ar xiv  ',
     &     'ar xv   ','ar xvi  ','ar xvii ','ar xviii'/
      data kinam(95),kinam(96),kinam(97),kinam(98),kinam(99),
     &     kinam(100),kinam(101),kinam(102),kinam(103),
     &     kinam(104),kinam(105),kinam(106),kinam(107),
     &     kinam(108),kinam(109),kinam(110),kinam(111),
     &     kinam(112),kinam(113),kinam(114)/'ca i    ',
     &     'ca ii   ','ca iii  ','ca iv   ','ca v    ',
     &     'ca vi   ','ca vii  ','ca viii ','ca ix   ',
     &     'ca x    ','ca xi   ','ca xii  ','ca xiii ',
     &     'ca xiv  ','ca xv   ','ca xvi  ','ca xvii ',
     &     'ca xviii','ca xix  ','ca xx   '/
      data kinam(115),kinam(116),kinam(117),kinam(118),
     &     kinam(119),kinam(120),kinam(121),kinam(122),
     &     kinam(123),kinam(124),kinam(125),kinam(126),
     &     kinam(127),kinam(128),kinam(129),kinam(130),
     &     kinam(131),kinam(132),kinam(133),kinam(134),
     &     kinam(135),kinam(136),kinam(137),kinam(138),
     &     kinam(139),kinam(140)/'fe i    ','fe ii   ',
     &     'fe iii  ','fe iv   ','fe v    ','fe vi   ',
     &     'fe vii  ','fe viii ','fe ix   ','fe x    ',
     &     'fe xi   ','fe xii  ','fe xiii ','fe xiv  ',
     &     'fe xv   ','fe xvi  ','fe xvii ','fe xviii',
     &     'fe xix  ','fe xx   ','fe xxi  ','fe xxii ',
     &     'fe xxiii','fe xxiv ','fe xxv  ','fe xxvi '/
      data kinam(141),kinam(142),kinam(143),kinam(144),
     &     kinam(145),kinam(146),kinam(147),kinam(148),
     &     kinam(149),kinam(150),kinam(151),kinam(152),
     &     kinam(153),kinam(154),kinam(155),kinam(156),
     &     kinam(157),kinam(158),kinam(159),kinam(160),
     &     kinam(161),kinam(162),kinam(163),kinam(164),
     &     kinam(165),kinam(166),kinam(167),kinam(nni),
     &     kinam(169)/'ni i    ','ni ii   ','ni iii  ',
     &     'ni iv   ','ni v    ','ni vi   ','ni vii  ',
     &     'ni viii ','ni ix   ','ni x    ','ni xi   ',
     &     'ni xii  ','ni xiii ','ni xiv  ','ni xv   ',
     &     'ni xvi  ','ni xvii ','ni xviii','ni xix  ',
     &     'ni xx   ','ni xxi  ','ni xxii ','ni xxiii',
     &     'ni xxiv ','ni xxv  ','ni xxvi ','ni xxvii',
     &     'nixxviii','        '/
c
      scfac=1.
      crtt=0.004
      ergsev=1.602197e-12
c
      nbb=nbmk
      lprii=0
      write (6,*)'benchmark number ',nbb
      nlnprnt=nlnsv2(nbb)
      nlnprs=1
      if (nbb.le.2)  nlnprnt=nlnsv2(nbb)+1
      if (nbb.le.2) nlnprs=nlnprnt
      nlnprnt2=nlnsv(nbb)
c
c     first get the current version
      do 820 ll1=1,nlnprnt2
         ll2=ll1
         elnprnt(ll1)=elnsv(1,ll1,nbb)
         elnprnt(ll1+1)=elnsv(2,ll1,nbb)
         if ((elnprnt(ll1).le.1.e-34).or.(elnprnt(ll1+1).le.1.e-34))
     $           go to 820
         ecen=(elnprnt(ll1)+elnprnt(ll1+1))/2.
         ediff=elnprnt(ll1+1)-elnprnt(ll1)
         eww=0.
         ebar=0.
         asym=0.                            
         fluxbs=0.
         fluxbf=0.
         flxmx=0.
         lllsv(ll2)=1
         if (lprii.ne.0) write (6,*)'ll1=',ll1
         do 821 mm=1,nlsvn
            lll=nlsv(mm)
            if (lprii.ne.0)
     $       write (6,*)'ll2,llk,lll=',ll2,ll1,lll
            if (lll.eq.0) go to 821
            if (elin(lll).le.1.e-8) go to 821 
            if ((elin(lll).gt.elnprnt(ll1+1)).or.
     $          (elin(lll).lt.elnprnt(ll1))) go to 821
            ener=12398.54/elin(lll)  
            tmpflxf=elum(lll)
     $          *(1.e+19/r)*(1.e+19/r)*ener*ergsev/12.56       
            fluxbf=fluxbf+tmpflxf
            tmpflux=(elum(lll)+elumb(lll))
     $          *(1.e+19/r)*(1.e+19/r)*ener*ergsev/12.56       
            if (tmpflux.lt.flxmx) go to 3083
              flxmx=tmpflux
              lllsv(ll2)=lll
3083          continue
            fluxbs=fluxbs+tmpflux
            if (ll1.eq.1) scfac=tmpflux
            fluxrl(ll2)=tmpflux/(scfac+1.e-18)
            fluxrl(ll2)=min(fluxrl(ll2),1.e+6)        
            frac=(elum(lll)+elumb(lll))*ener*ergsev/(etotc+1.e-18)
            asym=elum(lll)/amax1(1.e-34,elum(lll)+elumb(lll))
            nbltp=nblin(lll)
            ewtmp=0.
            if ((nbltp.gt.0).and.(nbltp.lt.numcon))
     $       ewtmp=(elum(lll)+elumb(lll))*ener/
     $         amax1(1.e-34,zremsb(nbltp)+zrems(nbltp))
            eww=eww+ewtmp
            ebar=ebar+tmpflux*elin(lll)
821         continue
         if (ll1.eq.1) scfac=fluxbs
         fluxrl(ll2)=fluxbs/(scfac+1.e-18)                                   
         fluxrl(ll2)=min(fluxrl(ll2),1.e+6)   
         if (lprii.ne.0)
     $     write (6,*)'ll2,fluxrl:',ll2,fluxrl(ll2)
         asym=fluxbf/amax1(1.e-34,fluxbs)
         ebar=ebar/amax1(fluxbs,1.e-34)     
         r19=r*1.e-19
         eltmp=fluxbs*12.56*r19*r19 
820      continue                                                      
c
c     put them together and print out
c     step through the benchmark lines
      do 1039 ll1=1,nlnprnt
         ll2=ll1
         fffrl=0.
c        step through the printed lines
         do 1040 ll3=1,nlnprnt2
            if (nbmpt(ll3,nbb).ne.ll2) go to 1040
            fffrl=fluxrl(ll3)+fffrl
            ll3sv=ll3
 1040       continue
         if (fffrl.le.1.e-34) go to 1039
         fdd=1.
         if (nbb.eq.2) fdd=scfac*12.56*r19*r19*10.
         if (nbb.eq.1) fdd=scfac*12.56*r19*r19*100.
         if (nbb.eq.4) fdd=scfac*12.56*r19*r19*1000.
         if (nbb.eq.5) fdd=scfac*12.56*r19*r19*10000.
         if (nbb.eq.6) fdd=scfac*12.56*r19*r19*10000.
         if (nbb.eq.7) fdd=scfac
         if (nbb.eq.3) fdd=scfac
         if (ll1.eq.nlnprs) fffrl=fffrl*fdd
         bmdat(6,ll2,nbb)=fffrl
 1039    continue
c
c     set up averages over the lexington results
      nlnprnt=nlnsv(nbb)
      do 1013 ll1=1,nlnprnt
         ll2=ll1
         fbar=0.
         nbar=0
         if (lprii.eq.1) write (6,*)'line number ',ll1,ll2
         do 1011 ml1=3,nbmdat(nbb)
            if (bmdat(ml1,ll2,nbb).le.1.e-34) go to 1011
c            if (ml1.eq.6) go to 1011
            fbar=fbar+bmdat(ml1,ll2,nbb)
            nbar=nbar+1
            if (lprii.eq.1) 
     $        write (6,*)'table data',ml1,bmdat(ml1,ll2,nbb),fbar
 1011       continue
         fbar=fbar/float(max0(1,nbar))
         if (nbar.le.0) fbar=0.
         fbsv(ll2)=fbar
         sigsum=0.
         nbar=0
         do 1014 ml1=3,nbmdat(nbb)
            if (bmdat(ml1,ll2,nbb).le.1.e-34) go to 1014
c            if (ml1.eq.6) go to 1014
            sigsum=sigsum+(bmdat(ml1,ll2,nbb)-fbar)**2
            nbar=nbar+1
            if (lprii.eq.1) 
     $        write (6,*)'table disp',ml1,bmdat(ml1,ll2,nbb),
     $        fbar,sigsum
 1014       continue
         sig(ll2)=sqrt(sigsum/float(max0(nbar,1)))
         if (nbar.le.0) sig(ll2)=0.
         if (lprii.eq.1) write (6,*)'average and disp:',
     $               ll2,fbsv(ll2),sig(ll2)
 1013    continue
c
c
c
      nlnprnt=nlnsv2(nbb)
      nlnprs=1
      if (nbb.le.2)  nlnprnt=nlnsv2(nbb)+1
      if (nbb.le.2) nlnprs=nlnprnt
      nlnprnt2=nlnsv(nbb)
      if (lprii.ne.0)
     $  write (6,*)'nlnprnt,nlnprnt2:',nlnprnt,nlnprnt2
c     step through the benchmark lines
      do 1019 ll1=1,nlnprnt
         ll2=ll1
         fffrl=0.
c        step through the printed lines
         do 1020 ll3=1,nlnprnt2
            if (nbmpt(ll3,nbb).ne.ll2) go to 1020
            fffrl=fluxrl(ll3)+fffrl
            if (lprii.ne.0)
     $       write (6,*)'stepping through constituents:',
     $       ll3,lllsv(ll3),elin(lllsv(ll3)),kinam(nilin(lllsv(ll3))),
     $              fluxrl(ll3)
            ll3sv=ll3
 1020       continue
         if (lprii.ne.0)
     $    write (6,*)'fffrl=',ll1,fffrl,ll3sv
         if (fffrl.le.1.e-34) go to 1019
         fdd=1.
         if (nbb.eq.2) fdd=scfac*12.56*r19*r19*10.
         if (nbb.eq.1) fdd=scfac*12.56*r19*r19*100.
         if (nbb.eq.4) fdd=scfac*12.56*r19*r19*1000.
         if (nbb.eq.5) fdd=scfac*12.56*r19*r19*10000.
         if (nbb.eq.6) fdd=scfac*12.56*r19*r19*10000.
         if (nbb.eq.7) fdd=scfac
         if (nbb.eq.3) fdd=scfac
         if (ll1.eq.nlnprs) fffrl=fffrl*fdd
         nbmtmp=nbmdat(nbb)+1
         do 1012 ml1=3,nbmtmp
c            if (ml1.eq.6) go to 1012
            if (ml1.eq.nbmtmp) go to 1015
            if (bmdat(ml1,ll2,nbb).le.1.e-34) go to 1012
            err(ml1)=(bmdat(ml1,ll2,nbb)-fbsv(ll2))
     $                 /amax1(1.e-34,sig(ll2))
            if (lprii.ne.0)
     $       write (6,*)'ml1),bmdat,err:',
     $          ml1,bmdat(ml1,ll2,nbb),fbsv(ll2),sig(ll2),err(ml1)
            go to 1016
 1015       continue
            err(ml1)=(fffrl-fbsv(ll2))
     $                 /amax1(1.e-34,sig(ll2))
            if (lprii.ne.0)
     $       write (6,*)'ml1,bmdat,err:',
     $          ml1,fffrl,fbsv(ll2),sig(ll2),err(ml1)
 1016       continue
            sigsm(ml1)=sigsm(ml1)+err(ml1)*err(ml1)
            err(ml1)=min(amax1(err(ml1),-9.99),9.99)
            nsm(ml1)=nsm(ml1)+1
 1012       continue
          write (6,9901) ll1,klbm(ll1,nbb),eldat(ll1,nbb),
     $    err(nbmtmp),fbsv(ll2),sig(ll2),fffrl
 9901     format (1h ,i4,1x,a8,f10.2,
     $      f5.2,1x,3(1pe10.2))
 1019    continue
      write (6,*)(sigsm(mm),mm=1,nbmtmp)
c
      return
      end
      blockdata bigdat
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
c
c
c
      common /aidata/ caih(1),caihe(2),caic(6),cain(7),caio(8),
     &                caine(10),caimg(12),caisi(14),cais(16),
     &                caiar(18),caica(20),caife(26),caini(28),
     &                eaih(1),eaihe(2),eaic(6),eain(7),eaio(8),
     &                eaine(10),eaimg(12),eaisi(14),eais(16),
     &                eaiar(18),eaica(20),eaife(26),eaini(28)
      common /enerc / epi(ncn),dele(ncn),numcon
      common /cxdat1/ alhh(2,1),alhhe(2,2),alhc(2,6),alhn(2,7),
     &                alho(2,8),alhne(2,10),alhmg(2,12),
     &                alhsi(2,14),alhs(2,16),alhar(2,18),
     &                alhca(2,20),alhfe(2,26),alhni(2,28),bethh(1)
     &               ,bethhe(2),bethc(6),bethn(7),betho(8),
     &                bethne(10),bethmg(12),bethsi(14),beths(16),
     &                bethar(18),bethca(20),bethfe(26),bethni(28)
     &               ,hkihh(1),hkihhe(2),hkihc(6),hkihn(7),
     &                hkiho(8),hkihne(10),hkihmg(12),hkihsi(14),
     &                hkihs(16),hkihar(18),hkihca(20),hkihfe(26),
     &                hkihni(28)
      common /cxdat2/ aleh(2,1),alehe(2,2),alec(2,6),alen(2,7),
     &                aleo(2,8),alene(2,10),alemg(2,12),
     &                alesi(2,14),ales(2,16),alear(2,18),
     &                aleca(2,20),alefe(2,26),aleni(2,28),beteh(1)
     &               ,betehe(2),betec(6),beten(7),beteo(8),
     &                betene(10),betemg(12),betesi(14),betes(16),
     &                betear(18),beteca(20),betefe(26),beteni(28)
     &               ,hkieh(1),hkiehe(2),hkiec(6),hkien(7),
     &                hkieo(8),hkiene(10),hkiemg(12),hkiesi(14),
     &                hkies(16),hkiear(18),hkieca(20),hkiefe(26),
     &                hkieni(28)
      common /rrdat1/ aradh(1),aradhe(2),aradc(6),aradn(7),
     &                arado(8),aradne(10),aradmg(12),aradsi(14),
     &                arads(16),aradar(18),aradca(20),aradfe(26),
     &                aradni(28),etah(1),etahe(2),etac(6),
     &                etan(7),etao(8),etane(10),etamg(12),
     &                etasi(14),etas(16),etaar(18),etaca(20),
     &                etafe(26),etani(28)
      common /rrdat2/ adih(1),adihe(2),adic(6),adin(7),adio(8),
     &                adine(10),adimg(12),adisi(14),adis(16),
     &                adiar(18),adica(20),adife(26),adini(28),
     &                bdih(1),bdihe(2),bdic(6),bdin(7),bdio(8),
     &                bdine(10),bdimg(12),bdisi(14),bdis(16),
     &                bdiar(18),bdica(20),bdife(26),bdini(28),
     &                t0h(1),t0he(2),t0c(6),t0n(7),t0o(8),
     &                t0ne(10),t0mg(12),t0si(14),t0s(16),
     &                t0ar(18),t0ca(20),t0fe(26),t0ni(28),t1h(1)
     &               ,t1he(2),t1c(6),t1n(7),t1o(8),t1ne(10),
     &                t1mg(12),t1si(14),t1s(16),t1ar(18),
     &                t1ca(20),t1fe(26),t1ni(28)
      common /rrdat3/ edilh(1),edilhe(2),edilc(6),ediln(7),
     &                edilo(8),edilne(10),edilmg(12),edilsi(14),
     &                edils(16),edilar(18),edilca(20),edilfe(26),
     &                edilni(28),aph(1),aphe(2),apc(6),apn(7),
     &                apo(8),apne(10),apmg(12),apsi(14),aps(16)
     &               ,apar(18),apca(20),apfe(26),apni(28),
     $                cdd1(57),cdd2(111),
     &                ndilh(1),ndilhe(2),ndilc(6),ndiln(7),
     &                ndilo(8),ndilne(10),ndilmg(12),ndilsi(14),
     &                ndils(16),ndilar(18),ndilca(20),ndilfe(26),
     &                ndilni(28)
      common /ethrsh/ ethh(1),ethhe(2),ethc(6),ethn(7),etho(8),
     &                ethne(10),ethmg(12),ethsi(14),eths(16),
     &                ethar(18),ethca(20),ethfe(26),ethni(28)
      common /abel  / xeh,xehe,xec,xen,xeo,xene,xemg,
     &                xesi,xes,xear,xeca,xefe,xeni,xeln(nni)
     &               ,xelln(nnnl)
      common /swdata/ stwtrt(nni)
      common /ethph / etkh(1),etkhe(2),etkc(6),etlsc(4),etlpc(2)
     &               ,etkn(7),etlsn(5),etlpn(3),etko(8),
     &                etlso(6),etlpo(4),etkne(10),etlsne(8),
     &                etlpne(6),etkmg(12),etlsmg(10),etlpmg(8),
     &                etmsmg(2),etksi(14),etlssi(12),etlpsi(10),
     &                etmssi(4),etmpsi(2),etks(16),etlss(14),
     &                etlps(12),etmss(6),etmps(4),etkar(18),
     &                etlsar(16),etlpar(14),etmsar(8),etmpar(6),
     &                etkca(20),etlsca(18),etlpca(16),etmsca(10),
     &                etmpca(8),etmdca(2),etkfe(26),etlsfe(24),
     &                etlpfe(22),etmsfe(16),etmpfe(14),etmdfe(8),
     &                etnfe(2),etkni(28),etlsni(26),etlpni(24),
     &                etmsni(18),etmpni(16),etmdni(10),etnni(4)
      common /rchdat/ acor1(15,13),acor2(15,13),nup1(15,13),
     &                nup2(15,13),prfrac(26),ngnd(26),nz(nni),
     &                cor2(26),nnnz(nni)
      common /fe2dat/ ggl(10),ggu(6),eel(10),eeu(6),b(10,6),
     &                e(10,6),nblfe2(10,6),f(10,6),g(10,6)
      common /agdata/ amkc(6,6),amkn(7,7),amko(8,8),amkne(10,10),
     &                amkmg(12,12),amlsmg(10,10),amlpmg(8,8),
     &                amksi(14,14),amlssi(12,12),amlpsi(10,10),
     &                amks(16,16),amlss(14,14),amlps(12,12),
     &                amkf1(26,13),amkf2(26,13),amlsf1(24,12),
     &                amlsf2(24,12),amlpf1(22,11),amlpf2(22,11)
      common /lab   / kllab,kulab,k
      common /itdat / enfmxs,ensfrc,critd,crittd,epss,crits,
     $             kmaxs,lppris,nlimd,lpprid,nnmax
c
      character*8 kllab(10),kulab(6),k(10,6)
c
c      block data
      dimension bln(1000),nj(13),abunj(13),conce(30)
      dimension gndrec(30),power(220),rf(500),tau(nni)
      dimension tauhe(nni),tplus(nni),cnc(12,30),pm(4)
      dimension ptot(12,220),abin(1000),bin(1000),crit(30,6)
      common /bln   / bln,blnmin,blnsyz,nbln
      common /params/ abunj,abund,binmin,binsyz,nbin,nj
      common /result/ conce,gndrec,power,rhy,heneut,heplus,
     &                dne,pcool,pou,pot,re,tu,pm
      common /pt    / rf,tau,tauhe,tplus
      common /com   / cnc,ptot,abin,bin
      common /crt   / crit
      data crit/5*0.,555.,1953.,5400.,0.,22000.,0.,
     &     65000.,0.,140000.,0.,270000.,0.,1.6e6,0.,
     &     2.9e6,5*0.,1.8e7,0.,3.5e7,0.,0.,5*0.,5.8e7,
     &     9.5e8,6.7e9,0.,1.2e11,0.,1.1e12,0.,6.8e12,
     &     0.,3.1e13,0.,1.1e14,0.,3.4e14,5*0.,9.1e15,
     &     0.,2.3e16,0.,0.,5*0.,7.1e8,4.4e9,2.4e10,0.,
     &     3.1e11,0.,2.7e12,0.,1.9e13,0.,6.7e13,0.,
     &     2.1e14,0.,5.8e14,5*0.,6.5e15,0.,1.9e16,0.,
     &     0.,5*0.,5.8e7,1.5e8,1.7e9,0.,4.3e10,0.,
     &     3.9e11,0.,2.3e12,0.,1.0e13,0.,4.5e13,0.,
     &     1.4e14,5*0.,2.6e15,0.,7.5e15,0.,0.,11*0.,
     &     174.,0.,877.,0.,12700.,0.,64000.,0.,230000.,
     &     5*0.,8.5e5,0.,2.7e6,0.,0.,11*0.,3.3e9,0.,
     &     6.1e10,0.,1.2e12,0.,1.4e13,0.,8.8e13,5*0.,
     &     4.2e15,0.,1.0e16,0.,0./
      data rf/500*1.0/
      data abunj/10.93,8.52,7.96,8.82,7.92,7.42,7.52,7.2,
     &     6.9,6.3,7.6,6.3,0./
c
      data nlimd/100/,lpprid/0/,critd/1.e-05/,crittd/1.e-06/
      data nnmax/40/,epss/0.07/,crits/1.e-4/,kmaxs/0/,
     &     enfmxs/1.e-4/,ensfrc/0.5/,lppris/0/
c
      data xeh/1./,xehe/0.1/,xec/3.7e-4/,xen/1.1e-4/,
     &     xeo/6.8e-4/,xene/2.8e-5/,xemg/3.5e-5/,xesi/3.5e-5/,
     &     xes/1.6e-5/,xear/4.5e-06/,xeca/2.1e-6/,xefe/2.5e-5/,
     &     xeni/2.e-6/
c
c
      data numcon/299/
c
c     ionization thresholds
      data ethh/13.598/
      data ethhe/24.59,54.42/
      data ethc/11.260,24.383,47.887,64.492,392.08,489.98/
      data ethn/14.534,29.601,47.448,77.472,97.89,552.06,
     &     667.03/
      data etho/13.618,35.117,54.934,77.413,113.9,138.12,
     &     739.32,871.39/
      data ethne/21.564,40.962,63.45,97.11,126.21,157.93,
     &     207.26,239.09,1195.8,1362.2/
      data ethmg/7.646,15.035,80.143,109.31,141.27,186.51,
     &     224.95,265.92,328.0,367.5,1761.8,1963./
      data ethsi/8.151,16.345,33.492,45.141,166.77,205.08,
     &     246.49,303.16,351.1,401.4,476.1,523.,2438.,
     &     2673./
      data eths/10.36,23.33,34.83,47.30,72.68,88.05,280.01,
     &     328.33,379.1,447.1,504.7,565.,652.,707.,3224.,
     &     3494./
      data ethar/15.759,27.629,40.74,59.81,75.04,91.01,
     &     124.4,143.45,422.6,478.9,539.0,618.,686.,756.,
     &     855.,918.,4121.,4426./
      data ethca/6.113,11.871,50.91,67.15,84.43,108.78,
     &     127.7,147.4,188.7,211.3,591.6,657.,726.,817.,
     &     895.,974.,1087.,1157.,5129.,5470./
      data ethfe/07.87,16.16,30.65,54.8,75.5,100.,128.3,
     &     151.12,235.,262.1,290.4,331.,361.,392.,457.,
     &     489.,1262.,1358.,1456.,1582.,1689.,1799.,
     &     1950.,2045.,8828.,9278./
      data ethni/7.635,18.168,35.17,54.9,75.5,108.,134.,
     &     164.,193.,224.6,321.,352.,384.,430.,464.,
     &     499.,571.,607.,1546.,1648.,1756.,1894.,2010.,
     &     2131.,2295.,2398.,10280.,10790./
c
c
      data etkh(1)/1.360E+01/
      data etkhe(1)/2.459E+01/
      data etkhe(2)/5.442E+01/
      data etlpc(1)/1.126E+01/
      data etlsc(1)/1.939E+01/
      data etkc(1)/2.910E+02/
      data etlpc(2)/2.438E+01/
      data etlsc(2)/3.047E+01/
      data etkc(2)/3.076E+02/
      data etlsc(3)/4.789E+01/
      data etkc(3)/3.289E+02/
      data etlsc(4)/6.449E+01/
      data etkc(4)/3.522E+02/
      data etkc(5)/3.921E+02/
      data etkc(6)/4.900E+02/
      data etlpn(1)/1.453E+01/
      data etlsn(1)/2.541E+01/
      data etkn(1)/4.048E+02/
      data etlpn(2)/2.960E+01/
      data etlsn(2)/3.796E+01/
      data etkn(2)/4.236E+02/
      data etlpn(3)/4.745E+01/
      data etlsn(3)/5.545E+01/
      data etkn(3)/4.473E+02/
      data etlsn(4)/7.747E+01/
      data etkn(4)/4.753E+02/
      data etlsn(5)/9.789E+01/
      data etkn(5)/5.043E+02/
      data etkn(6)/5.521E+02/
      data etkn(7)/6.671E+02/
      data etlpo(1)/1.362E+01/
      data etlso(1)/2.848E+01/
      data etko(1)/5.380E+02/
      data etlpo(2)/3.512E+01/
      data etlso(2)/4.599E+01/
      data etko(2)/5.581E+02/
      data etlpo(3)/5.494E+01/
      data etlso(3)/6.551E+01/
      data etko(3)/5.840E+02/
      data etlpo(4)/7.741E+01/
      data etlso(4)/8.737E+01/
      data etko(4)/6.144E+02/
      data etlso(5)/1.139E+02/
      data etko(5)/6.491E+02/
      data etlso(6)/1.381E+02/
      data etko(6)/6.837E+02/
      data etko(7)/7.393E+02/
      data etko(8)/8.714E+02/
      data etlpne(1)/2.156E+01/
      data etlsne(1)/4.847E+01/
      data etkne(1)/8.701E+02/
      data etlpne(2)/4.096E+01/
      data etlsne(2)/6.374E+01/
      data etkne(2)/8.831E+02/
      data etlpne(3)/6.346E+01/
      data etlsne(3)/8.721E+01/
      data etkne(3)/9.131E+02/
      data etlpne(4)/9.712E+01/
      data etlsne(4)/1.132E+02/
      data etkne(4)/9.480E+02/
      data etlpne(5)/1.262E+02/
      data etlsne(5)/1.415E+02/
      data etkne(5)/9.873E+02/
      data etlpne(6)/1.579E+02/
      data etlsne(6)/1.719E+02/
      data etkne(6)/1.031E+03/
      data etlsne(7)/2.073E+02/
      data etkne(7)/1.078E+03/
      data etlsne(8)/2.391E+02/
      data etkne(8)/1.125E+03/
      data etkne(9)/1.196E+03/
      data etkne(10)/1.362E+03/
c     data statements with multiple entries per line 
c      are from clementi, all others from verner
c     NB Mg VII energy is a guess. needs to be checked.
      data etkmg/1334.,1343.,1354.,1391.,1432.,1478.,1500.,
     &     1586.,1646.,1701.,1762.,1963./
      data etksi/1871.,1881.,1893.,1909.,1926.,1976.,2031.,
     &     2090.,2155.,2224.,2296.,2363.,2432.,2673./
      data etks/2502.,2514.,2529.,2545.,2564.,2585.,2608.,
     &     2672.,2740.,2812.,2889.,2971.,3057.,3134.,
     &     3214.,3494./
      data etkar/3226.,3240.,3257.,3276.,3297.,3320.,3345.,
     &     3372.,3400.,3477.,3558.,3643.,3733.,3828.,
     &     3926.,4014.,4105.,4406./
      data etkca/4069.,4069.,4078.,4099.,4122.,4147.,4174.,
     &     4204.,4235.,4267.,4301.,4390.,4486.,4582.,
     &     4686.,4793.,4904.,5003.,5129.,5470./
      data etmsmg(1)/7.646E+00/
      data etlpmg(1)/5.490E+01/
      data etlsmg(1)/9.400E+01/
c      data etkmg(1)/1.311E+03/
      data etmsmg(2)/1.504E+01/
      data etlpmg(2)/6.569E+01/
      data etlsmg(2)/9.881E+01/
c      data etkmg(2)/1.304E+03/
      data etlpmg(3)/8.014E+01/
      data etlsmg(3)/1.111E+02/
c      data etkmg(3)/1.317E+03/
      data etlpmg(4)/1.093E+02/
      data etlsmg(4)/1.411E+02/
c      data etkmg(4)/1.356E+03/
      data etlpmg(5)/1.413E+02/
      data etlsmg(5)/1.735E+02/
c      data etkmg(5)/1.400E+03/
      data etlpmg(6)/1.865E+02/
      data etlsmg(6)/2.076E+02/
c      data etkmg(6)/1.449E+03/
      data etlpmg(7)/2.249E+02/
      data etlsmg(7)/2.444E+02/
c      data etkmg(7)/1.501E+03/
      data etlpmg(8)/2.660E+02/
      data etlsmg(8)/2.839E+02/
c      data etkmg(8)/1.558E+03/
      data etlsmg(9)/3.282E+02/
c      data etkmg(9)/1.618E+03/
      data etlsmg(10)/3.675E+02/
c      data etkmg(10)/1.675E+03/
c      data etkmg(11)/1.762E+03/
c      data etkmg(12)/1.963E+03/
      data etmpsi(1)/8.152E+00/
      data etmssi(1)/1.517E+01/
      data etlpsi(1)/1.060E+02/
      data etlssi(1)/1.560E+02/
c      data etksi(1)/1.846E+03/
      data etmpsi(2)/1.635E+01/
      data etmssi(2)/2.240E+01/
      data etlpsi(2)/1.186E+02/
      data etlssi(2)/1.619E+02/
c      data etksi(2)/1.839E+03/
      data etmssi(3)/3.349E+01/
      data etlpsi(3)/1.311E+02/
      data etlssi(3)/1.744E+02/
c      data etksi(3)/1.852E+03/
      data etmssi(4)/4.514E+01/
      data etlpsi(4)/1.466E+02/
      data etlssi(4)/1.899E+02/
c      data etksi(4)/1.868E+03/
      data etlpsi(5)/1.668E+02/
      data etlssi(5)/2.076E+02/
c      data etksi(5)/1.887E+03/
      data etlpsi(6)/2.051E+02/
      data etlssi(6)/2.468E+02/
c      data etksi(6)/1.946E+03/
      data etlpsi(7)/2.465E+02/
      data etlssi(7)/2.872E+02/
c      data etksi(7)/2.001E+03/
      data etlpsi(8)/3.032E+02/
      data etlssi(8)/3.310E+02/
c      data etksi(8)/2.058E+03/
      data etlpsi(9)/3.511E+02/
      data etlssi(9)/3.756E+02/
c      data etksi(9)/2.125E+03/
      data etlpsi(10)/4.014E+02/
      data etlssi(10)/4.234E+02/
c      data etksi(10)/2.194E+03/
      data etlssi(11)/4.761E+02/
c      data etksi(11)/2.268E+03/
      data etlssi(12)/5.235E+02/
c      data etksi(12)/2.336E+03/
c      data etksi(13)/2.438E+03/
c      data etksi(14)/2.673E+03/
      data etmps(1)/1.036E+01/
      data etmss(1)/2.130E+01/
      data etlps(1)/1.700E+02/
      data etlss(1)/2.350E+02/
c      data etks(1)/2.477E+03/
      data etmps(2)/2.333E+01/
      data etmss(2)/3.190E+01/
      data etlps(2)/1.846E+02/
      data etlss(2)/2.387E+02/
c      data etks(2)/2.469E+03/
      data etmps(3)/3.483E+01/
      data etmss(3)/4.415E+01/
      data etlps(3)/1.995E+02/
      data etlss(3)/2.536E+02/
c      data etks(3)/2.484E+03/
      data etmps(4)/4.731E+01/
      data etmss(4)/5.750E+01/
      data etlps(4)/2.164E+02/
      data etlss(4)/2.703E+02/
c      data etks(4)/2.502E+03/
      data etmss(5)/7.268E+01/
      data etlps(5)/2.350E+02/
      data etlss(5)/2.888E+02/
c      data etks(5)/2.522E+03/
      data etmss(6)/8.805E+01/
      data etlps(6)/2.557E+02/
      data etlss(6)/3.094E+02/
c      data etks(6)/2.544E+03/
      data etlps(7)/2.809E+02/
      data etlss(7)/3.321E+02/
c      data etks(7)/2.569E+03/
      data etlps(8)/3.282E+02/
      data etlss(8)/3.797E+02/
c      data etks(8)/2.641E+03/
      data etlps(9)/3.791E+02/
      data etlss(9)/4.296E+02/
c      data etks(9)/2.705E+03/
      data etlps(10)/4.471E+02/
      data etlss(10)/4.804E+02/
c      data etks(10)/2.782E+03/
      data etlps(11)/5.048E+02/
      data etlss(11)/5.346E+02/
c      data etks(11)/2.859E+03/
      data etlps(12)/5.647E+02/
      data etlss(12)/5.906E+02/
c      data etks(12)/2.941E+03/
      data etlss(13)/6.517E+02/
c      data etks(13)/3.029E+03/
      data etlss(14)/7.072E+02/
c      data etks(14)/3.107E+03/
c      data etks(15)/3.224E+03/
c      data etks(16)/3.494E+03/
      data etmpar(1)/1.576E+01/
      data etmsar(1)/2.892E+01/
      data etlpar(1)/2.492E+02/
      data etlsar(1)/3.260E+02/
c      data etkar(1)/3.203E+03/
      data etmpar(2)/2.763E+01/
      data etmsar(2)/4.198E+01/
      data etlpar(2)/2.662E+02/
      data etlsar(2)/3.317E+02/
c      data etkar(2)/3.195E+03/
      data etmpar(3)/4.074E+01/
      data etmsar(3)/5.637E+01/
      data etlpar(3)/2.801E+02/
      data etlsar(3)/3.455E+02/
c      data etkar(3)/3.211E+03/
      data etmpar(4)/5.981E+01/
      data etmsar(4)/7.174E+01/
      data etlpar(4)/2.987E+02/
      data etlsar(4)/3.642E+02/
c      data etkar(4)/3.228E+03/
      data etmpar(5)/7.502E+01/
      data etmsar(5)/8.828E+01/
      data etlpar(5)/3.200E+02/
      data etlsar(5)/3.852E+02/
c      data etkar(5)/3.253E+03/
      data etmpar(6)/9.101E+01/
      data etmsar(6)/1.056E+02/
      data etlpar(6)/3.426E+02/
      data etlsar(6)/4.076E+02/
c      data etkar(6)/3.277E+03/
      data etmsar(7)/1.243E+02/
      data etlpar(7)/3.667E+02/
      data etlsar(7)/4.314E+02/
c      data etkar(7)/3.303E+03/
      data etmsar(8)/1.435E+02/
      data etlpar(8)/3.925E+02/
      data etlsar(8)/4.570E+02/
c      data etkar(8)/3.331E+03/
      data etlpar(9)/4.225E+02/
      data etlsar(9)/4.845E+02/
c      data etkar(9)/3.361E+03/
      data etlpar(10)/4.787E+02/
      data etlsar(10)/5.403E+02/
c      data etkar(10)/3.446E+03/
      data etlpar(11)/5.390E+02/
      data etlsar(11)/5.992E+02/
c      data etkar(11)/3.523E+03/
      data etlpar(12)/6.183E+02/
      data etlsar(12)/6.584E+02/
c      data etkar(12)/3.613E+03/
      data etlpar(13)/6.861E+02/
      data etlsar(13)/7.217E+02/
c      data etkar(13)/3.702E+03/
      data etlpar(14)/7.558E+02/
      data etlsar(14)/7.856E+02/
c      data etkar(14)/3.798E+03/
      data etlsar(15)/8.548E+02/
c      data etkar(15)/3.898E+03/
      data etlsar(16)/9.180E+02/
c      data etkar(16)/3.988E+03/
c      data etkar(17)/4.121E+03/
c      data etkar(18)/4.426E+03/
      data etmdca(1)/6.113E+00/
      data etmpca(1)/3.443E+01/
      data etmsca(1)/4.830E+01/
      data etlpca(1)/3.523E+02/
      data etlsca(1)/4.425E+02/
c      data etkca(1)/4.043E+03/
      data etmdca(2)/1.187E+01/
      data etmpca(2)/4.090E+01/
      data etmsca(2)/6.037E+01/
      data etlpca(2)/3.638E+02/
      data etlsca(2)/4.415E+02/
c      data etkca(2)/4.022E+03/
      data etmpca(3)/5.091E+01/
      data etmsca(3)/6.920E+01/
      data etlpca(3)/3.731E+02/
      data etlsca(3)/4.507E+02/
c      data etkca(3)/4.032E+03/
      data etmpca(4)/6.727E+01/
      data etmsca(4)/8.680E+01/
      data etlpca(4)/3.944E+02/
      data etlsca(4)/4.719E+02/
c      data etkca(4)/4.054E+03/
      data etmpca(5)/8.451E+01/
      data etmsca(5)/1.054E+02/
      data etlpca(5)/4.175E+02/
      data etlsca(5)/4.948E+02/
c      data etkca(5)/4.078E+03/
      data etmpca(6)/1.088E+02/
      data etmsca(6)/1.249E+02/
      data etlpca(6)/4.423E+02/
      data etlsca(6)/5.193E+02/
c      data etkca(6)/4.105E+03/
      data etmpca(7)/1.272E+02/
      data etmsca(7)/1.452E+02/
      data etlpca(7)/4.687E+02/
      data etlsca(7)/5.455E+02/
c      data etkca(7)/4.133E+03/
      data etmpca(8)/1.472E+02/
      data etmsca(8)/1.664E+02/
      data etlpca(8)/4.967E+02/
      data etlsca(8)/5.732E+02/
c      data etkca(8)/4.163E+03/
      data etmsca(9)/1.883E+02/
      data etlpca(9)/5.270E+02/
      data etlsca(9)/6.018E+02/
c      data etkca(9)/4.198E+03/
      data etmsca(10)/2.113E+02/
      data etlpca(10)/5.569E+02/
      data etlsca(10)/6.326E+02/
c      data etkca(10)/4.229E+03/
      data etlpca(11)/5.919E+02/
      data etlsca(11)/6.649E+02/
c      data etkca(11)/4.265E+03/
      data etlpca(12)/6.572E+02/
      data etlsca(12)/7.287E+02/
c      data etkca(12)/4.362E+03/
      data etlpca(13)/7.267E+02/
      data etlsca(13)/7.968E+02/
c      data etkca(13)/4.453E+03/
      data etlpca(14)/8.177E+02/
      data etlsca(14)/8.642E+02/
c      data etkca(14)/4.555E+03/
      data etlpca(15)/8.946E+02/
      data etlsca(15)/9.357E+02/
c      data etkca(15)/4.659E+03/
      data etlpca(16)/9.745E+02/
      data etlsca(16)/1.008E+03/
c      data etkca(16)/4.767E+03/
      data etlsca(17)/1.087E+03/
c      data etkca(17)/4.880E+03/
      data etlsca(18)/1.157E+03/
c      data etkca(18)/4.982E+03/
c      data etkca(19)/5.129E+03/
c      data etkca(20)/5.470E+03/
      data etnfe(1)/7.902E+00/
      data etmdfe(1)/1.470E+01/
      data etmpfe(1)/6.600E+01/
      data etmsfe(1)/1.040E+02/
      data etlpfe(1)/7.240E+02/
      data etlsfe(1)/8.570E+02/
      data etkfe/7117.0, 7164.0, 7210.0, 7256.0,
     $  7301.0, 7348.0, 7394.0, 7440.0, 7486.0, 7535.0, 7585.0, 7636.0, 
     $  7686.0, 7737.0, 7788.0, 7838.0, 7891.0, 7989.0, 8088.0,
     $  8187.0, 8286.0, 8384.0, 8482.0, 8621., 8755., 9278./
cc      data etkfe(1)/7.124E+03/
      data etnfe(2)/1.619E+01/
      data etmdfe(2)/2.193E+01/
      data etmpfe(2)/7.617E+01/
      data etmsfe(2)/1.102E+02/
      data etlpfe(2)/7.341E+02/
      data etlsfe(2)/8.521E+02/
cc      data etkfe(2)/7.093E+03/
      data etmdfe(3)/3.065E+01/
      data etmpfe(3)/8.705E+01/
      data etmsfe(3)/1.211E+02/
      data etlpfe(3)/7.451E+02/
      data etlsfe(3)/8.631E+02/
cc      data etkfe(3)/7.104E+03/
      data etmdfe(4)/5.480E+01/
      data etmpfe(4)/1.067E+02/
      data etmsfe(4)/1.411E+02/
      data etlpfe(4)/7.669E+02/
      data etlsfe(4)/8.849E+02/
cc      data etkfe(4)/7.125E+03/
      data etmdfe(5)/7.501E+01/
      data etmpfe(5)/1.288E+02/
      data etmsfe(5)/1.633E+02/
      data etlpfe(5)/7.920E+02/
      data etlsfe(5)/9.101E+02/
cc      data etkfe(5)/7.149E+03/
      data etmdfe(6)/9.906E+01/
      data etmpfe(6)/1.527E+02/
      data etmsfe(6)/1.876E+02/
      data etlpfe(6)/8.202E+02/
      data etlsfe(6)/9.383E+02/
cc      data etkfe(6)/7.177E+03/
      data etmdfe(7)/1.250E+02/
      data etmpfe(7)/1.783E+02/
      data etmsfe(7)/2.135E+02/
      data etlpfe(7)/8.512E+02/
      data etlsfe(7)/9.693E+02/
cc      data etkfe(7)/7.207E+03/
      data etmdfe(8)/1.511E+02/
      data etmpfe(8)/2.055E+02/
      data etmsfe(8)/2.409E+02/
      data etlpfe(8)/8.849E+02/
      data etlsfe(8)/1.003E+03/
cc      data etkfe(8)/7.240E+03/
      data etmpfe(9)/2.336E+02/
      data etmsfe(9)/2.696E+02/
      data etlpfe(9)/9.211E+02/
      data etlsfe(9)/1.039E+03/
cc      data etkfe(9)/7.275E+03/
      data etmpfe(10)/2.621E+02/
      data etmsfe(10)/2.990E+02/
      data etlpfe(10)/9.590E+02/
      data etlsfe(10)/1.076E+03/
cc      data etkfe(10)/7.316E+03/
      data etmpfe(11)/2.902E+02/
      data etmsfe(11)/3.292E+02/
      data etlpfe(11)/9.983E+02/
      data etlsfe(11)/1.115E+03/
cc      data etkfe(11)/7.359E+03/
      data etmpfe(12)/3.308E+02/
      data etmsfe(12)/3.600E+02/
      data etlpfe(12)/1.039E+03/
      data etlsfe(12)/1.155E+03/
cc      data etkfe(12)/7.403E+03/
      data etmpfe(13)/3.610E+02/
      data etmsfe(13)/3.916E+02/
      data etlpfe(13)/1.081E+03/
      data etlsfe(13)/1.197E+03/
cc      data etkfe(13)/7.450E+03/
      data etmpfe(14)/3.922E+02/
      data etmsfe(14)/4.238E+02/
      data etlpfe(14)/1.125E+03/
      data etlsfe(14)/1.240E+03/
cc      data etkfe(14)/7.499E+03/
      data etmsfe(15)/4.570E+02/
      data etlpfe(15)/1.181E+03/
      data etlsfe(15)/1.287E+03/
cc      data etkfe(15)/7.553E+03/
      data etmsfe(16)/4.893E+02/
      data etlpfe(16)/1.216E+03/
      data etlsfe(16)/1.329E+03/
cc      data etkfe(16)/7.599E+03/
      data etlpfe(17)/1.262E+03/
      data etlsfe(17)/1.375E+03/
cc      data etkfe(17)/7.651E+03/
      data etlpfe(18)/1.358E+03/
      data etlsfe(18)/1.460E+03/
cc      data etkfe(18)/7.769E+03/
      data etlpfe(19)/1.456E+03/
      data etlsfe(19)/1.559E+03/
cc      data etkfe(19)/7.918E+03/
      data etlpfe(20)/1.582E+03/
      data etlsfe(20)/1.648E+03/
cc      data etkfe(20)/8.041E+03/
      data etlpfe(21)/1.689E+03/
      data etlsfe(21)/1.745E+03/
cc      data etkfe(21)/8.184E+03/
      data etlpfe(22)/1.799E+03/
      data etlsfe(22)/1.847E+03/
cc      data etkfe(22)/8.350E+03/
      data etlsfe(23)/1.950E+03/
cc      data etkfe(23)/8.484E+03/
      data etlsfe(24)/2.046E+03/
cc      data etkfe(24)/8.638E+03/
cc      data etkfe(25)/8.829E+03/
cc      data etkfe(26)/9.278E+03/
      data etkni/8313.,8315.,8332.,8353.,8377.,8404.,8435.,
     &     8468.,8503.,8541.,8582.,8628.,8675.,8724.,
     &     8775.,8829.,8883.,8937.,8992.,9134.,9279.,
     &     9428.,9583.,9741.,9902.,10050.,10190.,10660./
      data etnni(1)/7.637E+00/
      data etmdni(1)/1.700E+01/
      data etmpni(1)/8.200E+01/
      data etmsni(1)/1.250E+02/
      data etlpni(1)/8.760E+02/
      data etlsni(1)/1.024E+03/
c      data etkni(1)/8.348E+03/
      data etmdni(2)/1.817E+01/
      data etmpni(2)/8.232E+01/
      data etmsni(2)/1.219E+02/
      data etlpni(2)/8.753E+02/
      data etlsni(2)/1.009E+03/
c      data etkni(2)/8.306E+03/
      data etmdni(3)/3.532E+01/
      data etmpni(3)/1.003E+02/
      data etmsni(3)/1.401E+02/
      data etlpni(3)/9.084E+02/
      data etlsni(3)/1.028E+03/
c      data etkni(3)/8.325E+03/
      data etmdni(4)/5.490E+01/
      data etmpni(4)/1.201E+02/
      data etmsni(4)/1.597E+02/
      data etlpni(4)/9.358E+02/
      data etlsni(4)/1.059E+03/
c      data etkni(4)/8.353E+03/
      data etmdni(5)/7.610E+01/
      data etmpni(5)/1.447E+02/
      data etmsni(5)/1.849E+02/
      data etlpni(5)/9.576E+02/
      data etlsni(5)/1.077E+03/
c      data etkni(5)/8.372E+03/
      data etmdni(6)/1.080E+02/
      data etmpni(6)/1.709E+02/
      data etmsni(6)/2.119E+02/
      data etlpni(6)/9.886E+02/
      data etlsni(6)/1.112E+03/
c      data etkni(6)/8.400E+03/
      data etmdni(7)/1.330E+02/
      data etmpni(7)/1.971E+02/
      data etmsni(7)/2.378E+02/
      data etlpni(7)/1.019E+03/
      data etlsni(7)/1.139E+03/
c      data etkni(7)/8.432E+03/
      data etmdni(8)/1.620E+02/
      data etmpni(8)/2.266E+02/
      data etmsni(8)/2.682E+02/
      data etlpni(8)/1.051E+03/
      data etlsni(8)/1.174E+03/
c      data etkni(8)/8.460E+03/
      data etmdni(9)/1.930E+02/
      data etmpni(9)/2.561E+02/
      data etmsni(9)/2.972E+02/
      data etlpni(9)/1.092E+03/
      data etlsni(9)/1.211E+03/
c      data etkni(9)/8.503E+03/
      data etmdni(10)/2.246E+02/
      data etmpni(10)/2.877E+02/
      data etmsni(10)/3.290E+02/
      data etlpni(10)/1.132E+03/
      data etlsni(10)/1.251E+03/
c      data etkni(10)/8.542E+03/
      data etmpni(11)/3.210E+02/
      data etmsni(11)/3.620E+02/
      data etlpni(11)/1.174E+03/
      data etlsni(11)/1.293E+03/
c      data etkni(11)/8.584E+03/
      data etmpni(12)/3.521E+02/
      data etmsni(12)/3.933E+02/
      data etlpni(12)/1.207E+03/
      data etlsni(12)/1.328E+03/
c      data etkni(12)/8.620E+03/
      data etmpni(13)/3.840E+02/
      data etmsni(13)/4.291E+02/
      data etlpni(13)/1.262E+03/
      data etlsni(13)/1.379E+03/
c      data etkni(13)/8.680E+03/
      data etmpni(14)/4.302E+02/
      data etmsni(14)/4.620E+02/
      data etlpni(14)/1.299E+03/
      data etlsni(14)/1.419E+03/
c      data etkni(14)/8.720E+03/
      data etmpni(15)/4.637E+02/
      data etmsni(15)/4.988E+02/
      data etlpni(15)/1.356E+03/
      data etlsni(15)/1.471E+03/
c      data etkni(15)/8.783E+03/
      data etmpni(16)/4.984E+02/
      data etmsni(16)/5.347E+02/
      data etlpni(16)/1.405E+03/
      data etlsni(16)/1.519E+03/
c      data etkni(16)/8.838E+03/
      data etmsni(17)/5.713E+02/
      data etlpni(17)/1.456E+03/
      data etlsni(17)/1.569E+03/
c      data etkni(17)/8.894E+03/
      data etmsni(18)/6.071E+02/
      data etlpni(18)/1.506E+03/
      data etlsni(18)/1.618E+03/
c      data etkni(18)/8.950E+03/
      data etlpni(19)/1.541E+03/
      data etlsni(19)/1.669E+03/
c      data etkni(19)/9.007E+03/
      data etlpni(20)/1.648E+03/
      data etlsni(20)/1.760E+03/
c      data etkni(20)/9.125E+03/
      data etlpni(21)/1.756E+03/
      data etlsni(21)/1.870E+03/
c      data etkni(21)/9.300E+03/
      data etlpni(22)/1.894E+03/
      data etlsni(22)/1.965E+03/
c      data etkni(22)/9.423E+03/
      data etlpni(23)/2.011E+03/
      data etlsni(23)/2.077E+03/
c      data etkni(23)/9.609E+03/
      data etlpni(24)/2.131E+03/
      data etlsni(24)/2.184E+03/
c      data etkni(24)/9.771E+03/
      data etlsni(25)/2.295E+03/
c      data etkni(25)/9.937E+03/
      data etlsni(26)/2.399E+03/
c      data etkni(26)/1.008E+04/
c      data etkni(27)/1.029E+04/
c      data etkni(28)/1.078E+04/
c
c
c
c
c
c      data stwtrt
c     $/2.,0.5,2.,1.5,2.,0.5,2.,0.5,2.,1.33,1.5,2.,0.5,2.,0.5,2.
c     $,0.75,1.33,1.5,2.,0.5,2.,0.5,2.,0.5,0.67,0.75,1.33,1.5,2.,0.5,
c     $2.,0.5,2.,0.5,2.,0.5,0.67,0.75,1.33,1.5,2.,0.5,2.,0.5,2.,
c     $1.5,2.,0.5,2.,0.5,0.67,0.75,1.33,1.5,2.,0.5,2.,0.5,2.,0.75,
c     $1.33,1.5,2.,0.5,2.,0.5,0.67,0.75,1.33,1.5,2.,0.5,2.,0.5,2.,0.5,
c     $2.,0.5,0.67,0.75,1.33,1.5,2.,0.5,0.67,0.75,1.33,1.5,2.,0.5,2.,
c     $0.5,0.67,0.75,1.33,1.5,2.,0.5,2.,0.5,2./
c
c
c
c     recombination data
c
C     RECOMBINATION DATA
      DATA
     1 ARADH  /4.3E-13/,
     2 ETAH   /0.8/,
     3 ADIH   /0./,
     4 T0H    /0./,
     5 T1H    /0./,
     6 BDIH   /0./,
     7 EDILH  /0./
C     HELIUM DATA.
      DATA
     1 ARADHE /4.3E-13,1.72E-12/,
     2 ETAHE  /0.672,  0.8/,
C    3 ADIHE  /0., 0./,
     4 T0HE   /47.,    0./,
     5 T1HE   /9.4,    0./,
     6 BDIHE  /0.3,    0./,
     7 EDILHE /40.78,0./,
     3 ADIHE  /1.9E-03,0./
C     CARBON DATA
      DATA
     2 ETAC   /0.624,  0.645,  0.5,  0.817,  0.721,  0.8/,
     4 T0C    /11.,    15.,    9.1,    340.,   410.,   0./,
     5 T1C    /4.9,    23.,    37.,    51.,    76.,    0./,
     6 BDIC   /3.0,    0.5,    2.0,    0.2,    0.2,    0./,
     7 EDILC /0., 12.69, 8.004, 307.9, 367.0, 0./,
     1 ARADC  /4.7E-13,2.3E-12,3.2E-12,7.5E-12,1.7E-11,1.548E-11/,
     3 ADIC   /6.9E-04,7.0E-03,3.8E-03,4.8E-02,4.8E-02,0./
C     NITROGEN DATA.
      DATA
     2 ETAN   /0.608,  0.639,  0.676,  0.743,  0.850,  0.750, 0.8/,
     4 T0N    /13.,    14.,    18.,    11.,    470.,   540.,   0./,
     5 T1N    /4.8,    6.8,    38.,    59.,    72.,    98.,    0./,
     6 BDIN   /3.8,    4.1,    1.4,    3.0,    0.2,    0.2,    0./,
     7  EDILN /11.43,12.51,16.21, 10.00, 430.7, 499.5, 0./,
     1 ARADN/4.1E-13,2.2E-12,5.0E-12,6.5E-12,1.5E-11,2.9E-11,2.11E-11/,
     3 ADIN   /5.2E-04,1.7E-03,1.2E-02,5.5E-03,7.6E-02,6.6E-02,0./
C     OXYGEN DATA
      DATA
     1 ARADO  /3.1E-13,2.0E-12,5.1E-12,9.6E-12,1.2E-11,2.3E-11,4.1E-11,
     $         2.752E-11/,
     2 ETAO   /0.678,  0.646,  0.666,  0.670,  0.779,  0.802,  0.742,
     $         0.8/,
     4 T0O    /17.,    17.,    18.,    22.,    13.,    620.,   700.,
     $         0./,
     5 T1O    /13.,    5.8,    9.1,    59.,    80.,    95.,    130.,
     $         0./,
     6 BDIO   /2.5,    3.3,    6.0,    2.0,    3.2,    0.2,    0.2,
     $         0./,
     7 EDILO   /14.87, 14.86, 15.71, 19.69, 11.99, 547.0, 652.6,
     $         0./,
     3 ADIO   /1.4E-03,1.4E-03,2.8E-03,1.7E-02,7.1E-03,1.1E-01,8.6E-02,
     $         0.0/
C     NEON DATA
      DATA
     1 ARADNE /2.2E-13,1.5E-12,4.4E-12,9.1E-12,1.5E-11,2.3E-11,2.8E-11,
     $         5.0E-11,8.6E-11,4.3E-11/,
     2 ETANE  /0.759,  0.693,  0.675,  0.668,  0.684,  0.704,  0.771,
     $         0.832,  0.769,  0.8/,
     3 ADINE  /1.3E-03,3.1E-03,7.5E-03,5.7E-03,1.0E-02,4.0E-02,1.1E-02,
     $          1.8E-01,1.3E-01,0./,
     4 T0NE   /31.,    29.,    26.,    24.,    24.,    29.,    17.,
     $         980.,   1100.,  0./,
     5 T1NE   /15.,    17.,    45.,    17.,    35.,    110.,   130.,
     $         140.,   260.,   0./,
     6 BDINE  /1.9,    0.6,    0.7,    4.3,    4.8,    1.6,    5.0,
     $         0.2,    0.2,    0./,
     7 EDILNE   /26.88, 25.33, 22.84, 21.71, 22.09, 26.65, 16.02,
     $           921.1, 1020.2, 0./
C     MAGNESIUM DATA
      DATA
     1 ARADMG  /1.4E-13, 8.8E-13,3.5E-12,7.7E-12,1.4E-11,2.3E-11,
     $          3.2E-11, 4.6E-11, 5.8E-11, 9.1E-11, 1.5E-10,2.99E-11/,
     2 ETAMG   /0.885, 0.838, 0.734, 0.718, 0.716, 0.695,
     $          0.691, 0.711, 0.804, 0.830, 0.779, 0.8/,
     4 T0MG    /5.1, 61., 44., 39., 34., 31.,
     $          31., 36., 21., 1400., 1500., 0./,
     5 T1MG    /0.,  0.,  41., 87., 100., 54.,
     $          36., 160.,210.,240.,350., 0./,
     6 BDIMG   /0.,   0.,  3., 3.2,  3.2, 6.7,
     $          4.4,  3.5, 10., 0.2, 0.2, 0./,
     7 EDILMG  /12*0./,
     $ ADIMG   /1.7E-3, 3.5E-3, 3.9E-3, 9.3E-3, 1.5E-2, 1.2E-2,
     $          1.4E-2, 3.8E-2, 1.4E-2, 2.6E-1, 1.7E-1, 0./
C     SILICON DATA
      DATA
     1 ARADSI /5.9E-13,1.0E-12,3.7E-12,5.5E-12,1.2E-11,2.1E-11,3.0E-11,
     $      4.3E-11,5.8E-11,7.7E-11,1.2E-10,1.5E-10,2.1E-10,8.43E-11/,
     2 ETASI  /0.601,  0.786,  0.693,  0.821,  0.735,  0.716,  0.702,
     $         0.688,  0.703,  0.714,  0.855,  0.831,  0.765, 0.8/,
C    3 ADISI  /0.     ,2.8E-3, 2.2E-3, 11*0./,
     4 T0SI     /11.,     12.,     10.,     120.,    55.,     49.,
     $           42.,     38.,     37.,     42.,     25.,     1900.,
     $           2000.,   0./,
     5 T1SI   /0.,     0.,     0.,     0.,     100.,   130.,   170.,
     $         60.,    110.,   250.,   280.,   310.,   440.,   0./,
     6 BDISI  /0.,     0.,     0.,     0.,     10.,    4.,     8.,
     $         6.3,    6.,     5.,     10.5,   0.2,    0.2,    0./,
     7 EDILSI   /0., 10.27, 8.875, 105.2, 50.2, 45.00, 39.03,
     $           35.69, 35.11, 40.84, 24.48, 1864.,2006., 0./,
     3 ADISI  /6.2E-03,1.4E-02,1.1E-02,1.4E-02,7.8E-03,1.6E-02,2.3E-02,
     $         1.1E-02,1.1E-02,4.8E-02,1.8E-02,3.4E-01,2.1E-01,0./
C     SULFUR DATA
      DATA
     1 ARADS  /4.1E-13,1.8E-12,2.7E-12,5.7E-12,1.2E-11,1.7E-11,2.7E-11,
     $         4.0E-11,5.5E-11,7.4E-11,9.2E-11,1.4E-10,1.7E-10,2.5E-10,
     $         3.3E-10,1.101E-10/,
     2 ETAS   /0.630,  0.686,  0.745,  0.755,  0.701,  0.849,  0.733,
     $         0.696,  0.711,  0.716,  0.714,  0.755,  0.832,  0.852,
     $         0.783,  0.8/,
     3 ADIS   /7.3E-05,4.9E-03,9.1E-03,4.3E-02,2.5E-02,3.1E-02,1.3E-02,
     $         2.1E-02,3.5E-02,3.0E-02,3.1E-02,6.3E-02,2.3E-02,4.2E-01,
     $         2.5E-01,0./
      DATA
     4 T0S      /11.,     12.,     13.,     18.,     15.,     190.,
     $           67.,     59.,     55.,     47.,     42.,     50.,
     $           30.,     2400.,   2500.,   0./,
     5 T1S      /0.,      8.8,     15.,     0.,      0.,      0.,
     $           180.,    200.,    230.,    120.,    130.,    340.,
     $           360.,    460.,    550.,    0./,
     6 BDIS   /0.,     2.5,    6.0,    0.,     0.,     0.,     22.,
     $         6.4,    13.,    6.8,    6.3,    4.1,    12.,    0.2,
     $         0.2,    0./,
     7 EDILS   /0., 10.35, 11.59, 15.76, 13.23, 172.1, 62.02,
     $          55.15, 48.22, 50.20, 54.57, 48.30, 407.4, 2460.,
     $          2621.2, 0./
C     ARGON DATA
      DATA
     $ ARADAR  /3.77E-13, 1.95E-12, 3.23E-12, 6.03E-12,
     $          9.12E-12, 1.58E-11, 2.69E-11, 3.55E-11, 4.90E-11,
     $          6.92E-11, 9.55E-11, 1.23E-10, 1.58E-10, 2.14E-10,
     $          2.63E-10, 3.72E-10, 4.95E-10, 1.33E-10/,
     $ ETAAR   /.651, .752, .869, .812, .811, .793, .744, .910, .801,
     $          .811, .793, .702, .790, .774, .907, .899, .816, .726/,
     $ ADIAR   /.0001, .011, .034, .0685, .090, .0635, .0260, .017,
     $          .0210, .0350, .0540, .0713, .0960, .0850, .0170,
     $          .476, .297, 0./,
     $ T0AR    / 32., 29., 23.9, 25.6, 25.0, 21.0, 18., 270., 83.,
     $           69.5, 60.5, 66.8, 65.0, 53.0, 35.5, 3010.,3130.,0./,
     $ T1AR    / 31., 55., 60., 38.1, 33., 21.5, 21.5, 330., 350.,
     $           360., 380., 290., 360., 280., 110., 605., 654., 0./,
     $ BDIAR   /.005, .045, .057, .087, .0769, .140, .120, .100, 1.92,
     $          1.66, 1.67, 1.40, 1.31, 1.02, .245, .294, .277, 0./,
     $ EDILAR  /18*0./
C     CALCIUM DATA
      DATA
     1 ARADCA  /1.12E-13,6.78E-13,3.96E-12,7.08E-12,1.07E-11,1.80E-11,
     $          2.40E-11,3.76E-11,5.04E-11,6.46E-11,8.51E-13,1.18E-10,
     $          1.58E-10,2.04E-10,2.60E-10,3.24E-10,3.81E-10,5.13E-10,
     $          6.46E-10,1.64E-10/,
     2 ETACA  /0.90,0.80,0.70,0.78,0.84,0.82,0.82,0.81,0.78,0.90,0.82,
     $         0.81,0.80,0.73,0.80,0.78,0.85,0.85,0.83,0.726/,
     3 ADICA   /3.28E-4,5.84E-02,1.12E-01,1.32E-01,1.33E-01,1.26E-01,
     $          1.39E-01,9.55E-02,4.02E-01,4.19E-02,2.57E-02,4.45E-02,
     $          5.48E-02,7.13E-02,9.03E-02,1.10E-01,2.05E-02,5.49E-01,
     $          3.55E-01,0./
      DATA
     4 T0CA    /3.46,38.5,40.8,38.2,35.3,31.9,32.2,24.7,22.9,373.,92.6,
     $          79.6,69.0,67.0,47.2,56.7,42.1,3650.,3780.,0./,
     5 T1CA    /1.64,24.5,42.7,69.2,87.8,74.3,69.9,44.3,28.1,584.,489.,
     $          462.,452.,332.,137.,441.,227.,725.,768.,0./,
     6 BDICA   /0.0907,.110,.0174,.132,.114,.162,.0878,.263,.0627,.0616,
     $          2.77,2.23,2.00,1.82,.424,.243,.185,.292,.275,0./,
     7 EDILCA   /20*0./
C     IRON DATA
      DATA
     1 ARADFE  /3.6E-13,2.1E-12,6.5E-12,1.5E-11,2.8E-11,4.7E-11,
     $        7.2E-11,1.0E-10,4.7E-11,6.5E-11,8.7E-11,8.5E-11,1.3E-10,
     $         1.4E-10,2.0E-10,2.3E-10,2.9E-10,3.7E-10,4.4E-10,5.7E-10,
     $         6.0E-10,6.7E-10,7.6E-10,8.1E-10,1.2E-09,1.3E-09/,
     2 ETAFE  /7*1.,   1.,     0.792,  0.826,  0.854,  0.703,  0.836,
     $         0.786,  0.861,  0.843,  0.76,   0.755,  0.794,  0.666,
     $         0.824,  0.809,  0.833,  0.813,  0.779,  0.750/,
     3 ADIFE   /1.8E-3, 3.6E-2,  7.8E-2,  2.2E-1,  1.4E-1,  1.4E-1,
     $           1.1E-1, 6.3E-1, 5.5E-1, 3.6E-1, 2.6E-1, 1.6E-1,
     $           6.6E-2, 2.5E-1, 1.2E-1, 5.0E+0, 3.7E-2, 6.3E-2,
     $           7.0E-2, 1.1E-1, 1.0E-1, 1.1E-1, 3.6E-2, 7.5E-1,
     $           5.2E-1, 0./
c     3 ADIFE   /26*0./
      DATA
     4 T0FE    /5.8,    13.,     28.,     37.,     49.,     63.,
     $          68.,    77.,     73.,     71.,     68.,     61.,  59.,
     $         43.,    35.,    770.,   100.,   87.,    62.,    69.,
     $         68.,    67.,    41.,    5800.,  5900.,  0./,
     5 T1FE    /6*0.,36.,63.,    85.,     89.,     100.,    120., 190.,
     $         190.,   250.,   90.,    630.,   770.,   620.,   510.,
     $         870.,   990.,   1000.,  980.,   1200.,  0./,
     6 BDIFE   /6*0.,1.3,4*0.4,  0.8,     2.7,     0.1,     1.9, 0.1,
     $         26.,    23.,    17.,    8.,     11.7,   15.4,   29.,
     $         0.3,    0.3,    0./,
     7 EDILFE   /0., 14.43, 23.57, 31.96, 42.16, 53.03, 73.58,
     $           72.46, 34.89, 34.97, 34.71, 34.43, 35.59, 43.64,
     $           34.36, 739.3, 119.2, 114.8, 102.5, 82.66, 74.24,
     $           73.71, 1148., 6702., 6927., 0./
C     NICKEL DATA
      DATA
     1 ARADNI  /3.60E-13, 1.00E-12, 1.40E-12, 1.60E-12, 3.85E-12,
     $          9.05E-12, 1.75E-11, 3.04E-11, 8.91E-11, 1.19E-10,
     $          1.50E-10, 1.91E-10, 2.29E-10, 2.63E-10, 3.16E-10,
     $          3.63E-10, 4.03E-10, 4.73E-10, 5.25E-10, 5.75E-10,
     $          6.38E-10, 7.08E-10, 7.94E-10, 8.71E-10, 8.91E-10,
     $          9.14E-10, 1.06E-09, 3.21E-10/,
     2 ETANI  /0.7, 0.7, 0.7, 0.7, 0.746, 0.682, 0.699, 0.728, 0.759,
     $         0.790, 0.810, 0.829, 0.828, 0.834, 0.836, 0.840, 0.846,
     $         0.850, 0.836, 0.824, 0.816, 0.811, 0.808, 0.800, 0.718,
     $         0.677, 0.732, 0.726/,
     3 ADINI   /1.41E-03, 5.20E-03, 1.38E-02, 2.30E-02, 4.19E-02,
     $          6.83E-02, 1.22E-01, 3.00E-01, 1.50E-01, 6.97E-01,
     $          7.09E-01, 6.44E-01, 5.25E-01, 4.46E-01, 3.63E-01,
     $          3.02E-01, 1.02E-01, 2.70E-01, 4.67E-02, 8.35E-02,
     $          9.96E-02, 1.99E-01, 2.40E-01, 1.15E-01, 3.16E-02,
     $          8.03E-01, 5.75E-01, 0./
      DATA
     4 T0NI    /9.82, 20.1, 30.5, 42.0, 55.6, 67.2, 79.3, 90.0, 100.,
     $          78.1, 76.4, 74.4, 66.5, 59.7, 52.4, 49.6, 44.6, 849.,
     $          136., 123., 106., 125., 123., 33.2, 64.5, 6650.,
     $          6810., 0./,
     5 T1NI    /10.1, 19.1, 23.2, 31.8, 45.5, 55.1, 52.8, 0.00, 55.0,
     $          88.7, 180.,125.,  189., 88.4, 129., 62.4, 159., 801.,
     $          932., 945., 945., 801., 757., 264., 193., 1190.,
     $          908., 0./,
     6 BDINI   /.469, .357, .281, .128, .0417, .0558, .0346, 0.,
     $          1.90, .277, .135, .134, .192, .332, .337, .121,
     $          .0514, .183, 7.56, 4.55, 4.87, 2.19, 1.15, 1.23,
     $          .132, .289, .286, 0./,
     7 EDILNI   /28*0./
      DATA CDD1/.24E-02,.1430E-01,.9094E-03,.3500E-01,.3050E-01,
     $  .9043E-02,.1077E-01,.2585E-03,.1953E-03,.8000E-01,
     $  .8715E-02,.1346E-01,.4753E-02,.6304E-02,.1601E-03,
     $  .1574E-03,.5600E-01,.1610E-01,.4081E-02,.7718E-02,
     $  .2910E-02,.4070E-02,.1059E-03,.1306E-03,.3370E-01,
     $  .1023E-01,.4726E-02,.3410E-02,.1660E-02,.3649E-02,
     $  .1412E-02,.2040E-02,.5280E-04,12*0.,.9555E-04,.8100E-01,
     $  .4168E-01,.2792E-01,.2585E-01,.2137E-02,.7325E-03,
     $  .8059E-03,.7821E-03,.6306E-03,.1501E-02,.5546E-03/
      DATA CDD2
     $ /.7711E-03,.1760E-04,.5965E-04,.6600E-01,.2842E-01,
     $  .1740E-01,.1579E-01,.1355E-01,.1221E-01,.1272E-02,
     $  .3673E-03,.4921E-03,.4976E-03,.4592E-03,.1108E-02,
     $  .3973E-03,.5326E-03,.1098E-04,.4948E-04,18*0.,20*0.,9*0.,
     $  .2030E-02,.2299E-02,.2313E-02,.2233E-02,.2734E-02,
     $  .2934E-02,.2319E-02,.3406E-03,.5245E-04,.1246E-03,
     $  .1320E-03,.1711E-03,.4206E-03,.1339E-03,.1461E-03,
     $  .1015E-05,.2508E-04,28*0./
c
c
c     autoionization data
      data caih/0./,eaih/0./
      data caihe/2*0./,eaihe/2*0./
      data caic/1.6e-7,3.4e-8,2.8e-8,2.8e-8,2*0./,
     &     eaic/11.260,24.383,350.00,350.0,392.1,489.98/
      data cain/1.2e-7,2.7e-8,1.0e-8,1.9e-8,1.9e-8,2*0./,
     &     eain/14.534,29.601,47.448,500.0,500.0,552.1,
     &     667.03/
      data caio/6.0e-9,2.3e-8,8.5e-9,3.5e-9,1.4e-8,1.4e-8,
     &     2*0./,eaio/15.660,35.117,54.934,77.413,550.00,
     &     550.00,739.32,871.39/
      data caine/8.2e-8,4.4e-8,7.6e-9,4.9e-9,3.6e-9,3.0e-9,
     &     1.3e-8,1.3e-8,0.,0./,eaine/21.564,40.962,63.45,
     &     97.11,126.21,157.93,800.0,800.0,1195.8,1362.2/
      data caimg/8.2e-7,6.4e-7,2.2e-8,4.2e-9,5.9e-9,2.5e-9,
     &     2.1e-9,1.8e-9,7.2e-9,7.2e-9,0.,0./,eaimg/46.3,
     &     60.,80.143,109.31,141.27,186.51,224.95,265.92,
     &     1330.,1330.,1761.8,1963./
      data caisi/2.2e-7,4.9e-8,4.8e-7,4.2e-7,2.8e-9,3.9e-9,
     &     3.4e-9,1.6e-9,1.4e-9,1.2e-9,5.2e-9,5.2e-9,0.,
     &     0./,eaisi/8.151,16.345,79.20,93.00,166.77,
     &     205.08,164.49,303.16,351.1,401.4,1860.,1860.,
     &     0.,0./
      data cais/1.7e-7,3.4e-8,1.4e-8,9.9e-9,2.6e-7,2.6e-7,
     &     1.7e-9,1.4e-9,1.2e-9,1.1e-9,9.3e-10,8.4e-10,
     &     3.8e-9,3.8e-9,2*0./,eais/10.360,23.33,34.83,
     &     47.30,147.0,152.0,280.0,328.33,379.1,447.1,
     &     504.7,565.,2450.,2450.,2*0.0/
      data caiar/18*0./
      data eaiar/18*0./
      data caica/1.2e-06,6.0e-07,9.3e-09,7.1e-09,5.6e-09,
     &     4.4e-09,3.7e-09,1.6e-07,1.3e-07,1.2e-07,3.3e-09,
     &     7.2e-10,6.5e-10,5.8e-10,5.3e-10,4.9e-10,2.4e-09,
     &     2.4e-09,0.,0./
      data eaica/6.1134,11.871,50.91,67.15,84.43,108.78,
     &     127.7,330.,330.,330.,591.6,657.,726.,817.,
     &     895.,974.,4000.,4000.,0.,0./
      data caife/6.7e-7,3.3e-7,2.2e-7,2.5e-7,2.8e-7,3.3e-7,
     &     5.5e-8,4.7e-8,2.0e-9,1.8e-9,1.6e-9,1.4e-9,
     &     1.3e-9,6.3e-8,6.7e-8,6.1e-8,1.4e-9,3.5e-10,
     &     3.3e-10,3.e-10,2.8e-10,2.6e-10,1.4e-9,1.4e-9,
     &     2*0./
      data eaife/7.87,16.16,170.,150.,140.,120.,128.3,
     &     151.12,235.0,262.1,290.4,331.,361.,900.,900.,
     &     900.,1266.,1358.,1456.,1582.,1689.,1799.,
     &     7000.,7000.,2*0./
      data caini/1.1e-06,1.3e-07,1.3e-07,1.4e-07,1.6e-07,
     &     1.8e-07,2.1e-07,4.3e-08,3.7e-08,1.5e-08,1.5e-09,
     &     1.4e-09,1.2e-09,1.1e-09,1.0e-09,3*3.6e-08,1.1e-09,
     &     2.9e-10,2.7e-10,2.5e-10,2.4e-10,2.2e-10,1.2e-09,
     &     1.2e-09,0.,0./
      data eaini/35.,300.,285.,265.,245.,210.,185.,164.,
     &     193.,224.6,321.,352.,384.,430.,464.,3*1050.,
     &     1546.,1648.,1756.,1894.,2010.,2131.,8000.,
     &     8000.,0.,0./
c
 
c
c
c     charge exchange data
      data alhh(1,1),alhh(2,1),bethh(1),hkihh(1)/4*0./
      data aleh(1,1),aleh(2,1),beteh(1),hkieh(1)/4*0./
      data alehe(1,1),alehe(2,1),betehe(1),hkiehe(1),alehe(1,2)
     &    ,alehe(2,2),betehe(2),hkiehe(2)/8*0./
      data alhhe(1,1),alhhe(2,1),bethhe(1),hkihhe(1),alhhe(1,2)
     &    ,alhhe(2,2),bethhe(2),hkihhe(2)/0.,0.,0.,11.0,
     &     4*0./
c    $            4*0.,
c    $            4*0.,
      data alhc(1,1),alhc(2,1),bethc(1),hkihc(1),alhc(1,2),
     &     alhc(2,2),bethc(2),hkihc(2),alhc(1,3),alhc(2,3),
     &     bethc(3),hkihc(3),alhc(1,4),alhc(2,4),bethc(4),
     &     hkihc(4),alhc(1,5),alhc(2,5),bethc(5),hkihc(5),
     &     alhc(1,6),alhc(2,6),bethc(6),hkihc(6)/4*0.,0.,1.7,
     &     1.e-12,10.80,0.2,0.3,3.6e-09,34.26,1.4,1.4,
     &     7.6e-10,50.88,0.5,0.5,0.,378.4,0.5,0.5,0.,
     &     476.4/
c    $           /24*0./
      data alec(1,1),alec(2,1),betec(1),hkiec(1),alec(1,2),
     &     alec(2,2),betec(2),hkiec(2),alec(1,3),alec(2,3),
     &     betec(3),hkiec(3),alec(1,4),alec(2,4),betec(4),
     &     hkiec(4),alec(1,5),alec(2,5),betec(5),hkiec(5),
     &     alec(1,6),alec(2,6),betec(6),hkiec(6)/4*0.,0.,0.,
     &     0.,-0.198,2.0,1.7,5.1e-11,39.88,0.,0.5,
     &     1.0e-14,367.4,0.5,0.5,0.,367.4,0.5,0.5,0.,
     &     465.4/
c    4            0.4,      1.5,        0.,     63.90,
      data alhn(1,1),alhn(2,1),bethn(1),hkihn(1),alhn(1,2),
     &     alhn(2,2),bethn(2),hkihn(2),alhn(1,3),alhn(2,3),
     &     bethn(3),hkihn(3),alhn(1,4),alhn(2,4),bethn(4),
     &     hkihn(4),alhn(1,5),alhn(2,5),bethn(5),hkihn(5),
     &     alhn(1,6),alhn(2,6),bethn(6),hkihn(6),alhn(1,7),
     &     alhn(2,7),bethn(7),hkihn(7)/0.,0.,1.2e-12,0.9520,
     &     0.1,0.1,8.6e-10,16.00,0.9,0.7,2.9e-9,33.80,
     &     0.4,1.5,1.6e-10,63.90,0.5,0.5,0.,84.30,0.5,
     &     0.5,0.,538.4,0.5,0.5,0.,652.4/
c    $           /28*0./
      data alen(1,1),alen(2,1),beten(1),hkien(1),alen(1,2),
     &     alen(2,2),beten(2),hkien(2),alen(1,3),alen(2,3),
     &     beten(3),hkien(3),alen(1,4),alen(2,4),beten(4),
     &     hkien(4),alen(1,5),alen(2,5),beten(5),hkien(5),
     &     alen(1,6),alen(2,6),beten(6),hkien(6),alen(1,7),
     &     alen(2,7),beten(7),hkien(7)/0.,0.,0.,-10.05,0.,
     &     0.3,3.3e-10,5.002,-0.2,0.5,1.1e-10,22.80,-0.4,
     &     -0.1,2.0e-09,52.90,0.5,0.5,0.,73.30,0.5,0.5,
     &     0.,527.4,0.5,0.5,0.,641.4/
c    4            0.3,      0.6,        0.,     63.80,
      data alho(1,1),alho(2,1),betho(1),hkiho(1),alho(1,2),
     &     alho(2,2),betho(2),hkiho(2),alho(1,3),alho(2,3),
     &     betho(3),hkiho(3),alho(1,4),alho(2,4),betho(4),
     &     hkiho(4),alho(1,5),alho(2,5),betho(5),hkiho(5),
     &     alho(1,6),alho(2,6),betho(6),hkiho(6),alho(1,7),
     &     alho(2,7),betho(7),hkiho(7),alho(1,8),alho(2,8),
     &     betho(8),hkiho(8)/0.,0.,4.e-10,0.022,0.1,0.5,
     &     7.7e-10,21.52,0.1,0.4,8.6e-09,41.33,0.3,0.6,
     &     2.6e-10,63.80,0.5,0.5,0.,100.3,0.5,0.5,0.,
     &     124.5,0.5,0.5,0.,725.4,0.5,0.5,0.,856.4/
c    1           /32*0./
      data aleo(1,1),aleo(2,1),beteo(1),hkieo(1),aleo(1,2),
     &     aleo(2,2),beteo(2),hkieo(2),aleo(1,3),aleo(2,3),
     &     beteo(3),hkieo(3),aleo(1,4),aleo(2,4),beteo(4),
     &     hkieo(4),aleo(1,5),aleo(2,5),beteo(5),hkieo(5),
     &     aleo(1,6),aleo(2,6),beteo(6),hkieo(6),aleo(1,7),
     &     aleo(2,7),beteo(7),hkieo(7),aleo(1,8),aleo(2,8),
     &     beteo(8),hkieo(8)/0.,0.,0.,-10.98,0.3,0.9,
     &     2.0e-10,10.52,-0.2,0.0,1.0e-09,30.33,-0.3,0.0,
     &     6.5e-10,52.80,0.5,0.5,0.,89.27,0.5,0.5,0.,
     &     113.5,0.5,0.5,0.,714.4,0.5,0.5,0.,845.4/
      data alhne(1,1),alhne(2,1),bethne(1),hkihne(1),alhne(1,2)
     &    ,alhne(2,2),bethne(2),hkihne(2),alhne(1,3),
     &     alhne(2,3),bethne(3),hkihne(3),alhne(1,4),alhne(2,4)
     &    ,bethne(4),hkihne(4),alhne(1,5),alhne(2,5),bethne(5)
     &    ,hkihne(5)/0.,0.,1.e-14,7.966,0.,0.,1.0e-11,
     &     27.48,0.2,0.4,0.,49.85,0.,0.5,0.,83.50,
     &     0.5,0.5,0.,112.6/
      data alhne(1,6),alhne(2,6),bethne(6),hkihne(6),alhne(1,7)
     &    ,alhne(2,7),bethne(7),hkihne(7),alhne(1,8),
     &     alhne(2,8),bethne(8),hkihne(8),alhne(1,9),alhne(2,9)
     &    ,bethne(9),hkihne(9),alhne(1,10),alhne(2,10),
     &     bethne(10),hkihne(10)/0.5,0.5,1.7e-08,144.3,0.5,
     &     0.5,2.4e-08,193.7,0.5,0.5,3.3e-08,225.5,0.5,
     &     0.5,4.3e-08,1182.,0.5,0.5,5.4e-08,1348./
      data alene(1,1),alene(2,1),betene(1),hkiene(1),alene(1,2)
     &    ,alene(2,2),betene(2),hkiene(2),alene(1,3),
     &     alene(2,3),betene(3),hkiene(3),alene(1,4),alene(2,4)
     &    ,betene(4),hkiene(4),alene(1,5),alene(2,5),betene(5)
     &    ,hkiene(5)/0.,0.,0.,-3.034,0.,0.,1.0e-14,
     &     16.48,0.,0.,1.0e-14,38.85,0.,0.5,1.7e-09,
     &     72.50,0.5,0.5,5.3e-9,101.6/
      data alene(1,6),alene(2,6),betene(6),hkiene(6),alene(1,7)
     &    ,alene(2,7),betene(7),hkiene(7),alene(1,8),
     &     alene(2,8),betene(8),hkiene(8),alene(1,9),alene(2,9)
     &    ,betene(9),hkiene(9),alene(1,10),alene(2,10),
     &     betene(10),hkiene(10)/0.5,0.5,8.3e-09,133.3,0.5,
     &     0.5,1.2e-08,182.7,0.5,0.5,1.6e-08,214.5,0.5,
     &     0.5,2.1e-8,1171.,0.5,0.5,2.7e-08,1337./
      data alhmg(1,1),alhmg(2,1),bethmg(1),hkihmg(1)/4*0./
c    3            0.,       0.,    0.,    19.89,
c    $            16*0./
      data alhmg(1,2),alhmg(2,2),bethmg(2),hkihmg(2),alhmg(1,3)
     &    ,alhmg(2,3),bethmg(3),hkihmg(3),alhmg(1,4),
     &     alhmg(2,4),bethmg(4),hkihmg(4),alhmg(1,5),alhmg(2,5)
     &    ,bethmg(5),hkihmg(5),alhmg(1,6),alhmg(2,6),bethmg(6)
     &    ,hkihmg(6),alhmg(1,7),alhmg(2,7),bethmg(7),hkihmg(7)
     &     /0.,0.,8.6e-14,2.747,0.,0.,6.5e-09,19.89,0.,
     &     0.1,6.5e-09,31.54,0.5,0.5,1.1e-8,153.2,0.5,
     &     0.5,1.7e-8,191.6,0.5,0.5,2.4e-8,232.9/
c    $           /20*0./
      data alhmg(1,8),alhmg(2,8),bethmg(8),hkihmg(8),alhmg(1,9)
     &    ,alhmg(2,9),bethmg(9),hkihmg(9),alhmg(1,10),
     &     alhmg(2,10),bethmg(10),hkihmg(10),alhmg(1,11),
     &     alhmg(2,11),bethmg(11),hkihmg(11),alhmg(1,12),
     &     alhmg(2,12),bethmg(12),hkihmg(12)/0.5,0.5,3.3e-8,
     &     289.6,0.5,0.5,4.3e-8,337.5,0.5,0.5,5.4e-8,
     &     387.8,0.5,0.5,6.7e-8,462.5,0.5,0.5,8.1e-8,
     &     509.7/
      data alemg(1,1),alemg(2,1),betemg(1),hkiemg(1)/4*0./
c    $           /24*0./
      data alemg(1,2),alemg(2,2),betemg(2),hkiemg(2),alemg(1,3)
     &    ,alemg(2,3),betemg(3),hkiemg(3),alemg(1,4),
     &     alemg(2,4),betemg(4),hkiemg(4),alemg(1,5),alemg(2,5)
     &    ,betemg(5),hkiemg(5),alemg(1,6),alemg(2,6),betemg(6)
     &    ,hkiemg(6),alemg(1,7),alemg(2,7),betemg(7),hkiemg(7)
     &     /0.,0.,0.,-8.253,0.8,0.6,9.6e-10,8.894,0.,
     &     0.1,1.2e-9,20.54,0.5,0.5,5.3e-9,142.2,0.5,
     &     0.5,8.3e-9,180.6,0.5,0.5,1.2e-8,221.9/
c    $          /20*0./
      data alemg(1,8),alemg(2,8),betemg(8),hkiemg(8),alemg(1,9)
     &    ,alemg(2,9),betemg(9),hkiemg(9),alemg(1,10),
     &     alemg(2,10),betemg(10),hkiemg(10),alemg(1,11),
     &     alemg(2,11),betemg(11),hkiemg(11),alemg(1,12),
     &     alemg(2,12),betemg(12),hkiemg(12)/0.5,0.5,1.6e-8,
     &     278.6,0.5,0.5,6.2e-9,326.5,0.5,0.5,2.7e-8,
     &     376.8,0.5,0.5,3.3e-8,451.3,0.5,0.5,4.0e-8,
     &     498.7/
      data alhsi(1,1),alhsi(2,1),bethsi(1),hkihsi(1)/4*0./
c    $            12*0./
      data alhsi(1,2),alhsi(2,2),bethsi(2),hkihsi(2),alhsi(1,3)
     &    ,alhsi(2,3),bethsi(3),hkihsi(3),alhsi(1,4),
     &     alhsi(2,4),bethsi(4),hkihsi(4),alhsi(1,5),alhsi(2,5)
     &    ,bethsi(5),hkihsi(5),alhsi(1,6),alhsi(2,6),bethsi(6)
     &    ,hkihsi(6),alhsi(1,7),alhsi(2,7),bethsi(7),hkihsi(7)
     &     /0.40,0.15,4.e-09,2.747,0.,0.,4.1e-10,19.89,
     &     0.,0.1,2.3e-09,31.54,0.5,0.5,1.1e-8,153.2,
     &     0.5,0.5,1.7e-8,191.6,0.5,0.5,2.4e-8,232.9/
c    $          /28*0./
      data alhsi(1,8),alhsi(2,8),bethsi(8),hkihsi(8),alhsi(1,9)
     &    ,alhsi(2,9),bethsi(9),hkihsi(9),alhsi(1,10),
     &     alhsi(2,10),bethsi(10),hkihsi(10),alhsi(1,11),
     &     alhsi(2,11),bethsi(11),hkihsi(11),alhsi(1,12),
     &     alhsi(2,12),bethsi(12),hkihsi(12),alhsi(1,13),
     &     alhsi(2,13),bethsi(13),hkihsi(13),alhsi(1,14),
     &     alhsi(2,14),bethsi(14),hkihsi(14)/0.5,0.5,3.3e-8,
     &     289.6,0.5,0.5,4.3e-8,337.5,0.5,0.5,5.4e-8,
     &     387.8,0.5,0.5,6.7e-8,462.5,0.5,0.5,8.1e-8,
     &     509.7,0.5,0.5,9.6e-8,2424.,0.5,0.5,1.1e-7,
     &     2659./
      data alesi(1,1),alesi(2,1),betesi(1),hkiesi(1)/4*0./
c    $           /24*0./
      data alesi(1,2),alesi(2,2),betesi(2),hkiesi(2),alesi(1,3)
     &    ,alesi(2,3),betesi(3),hkiesi(3),alesi(1,4),
     &     alesi(2,4),betesi(4),hkiesi(4),alesi(1,5),alesi(2,5)
     &    ,betesi(5),hkiesi(5),alesi(1,6),alesi(2,6),betesi(6)
     &    ,hkiesi(6),alesi(1,7),alesi(2,7),betesi(7),hkiesi(7)
     &     /0.,0.,0.,-8.253,0.8,0.6,9.6e-10,8.894,0.,
     &     0.1,1.2e-9,20.54,0.5,0.5,5.3e-9,142.2,0.5,
     &     0.5,8.3e-9,180.6,0.5,0.5,1.2e-8,221.9/
c    $          /28*0./
      data alesi(1,8),alesi(2,8),betesi(8),hkiesi(8),alesi(1,9)
     &    ,alesi(2,9),betesi(9),hkiesi(9),alesi(1,10),
     &     alesi(2,10),betesi(10),hkiesi(10),alesi(1,11),
     &     alesi(2,11),betesi(11),hkiesi(11),alesi(1,12),
     &     alesi(2,12),betesi(12),hkiesi(12),alesi(1,13),
     &     alesi(2,13),betesi(13),hkiesi(13),alesi(1,14),
     &     alesi(2,14),betesi(14),hkiesi(14)/0.5,0.5,1.6e-8,
     &     278.6,0.5,0.5,6.2e-9,326.5,0.5,0.5,2.7e-8,
     &     376.8,0.5,0.5,3.3e-8,451.3,0.5,0.5,4.0e-8,
     &     498.7,0.5,0.5,4.8e-8,2413.,0.5,0.5,5.6e-8,
     &     2648./
      data alhs(1,1),alhs(2,1),beths(1),hkihs(1)/4*0./
      data alhs(1,2),alhs(2,2),beths(2),hkihs(2),alhs(1,3),
     &     alhs(2,3),beths(3),hkihs(3),alhs(1,4),alhs(2,4),
     &     beths(4),hkihs(4),alhs(1,5),alhs(2,5),beths(5),
     &     hkihs(5),alhs(1,6),alhs(2,6),beths(6),hkihs(6),
     &     alhs(1,7),alhs(2,7),beths(7),hkihs(7),alhs(1,8),
     &     alhs(2,8),beths(8),hkihs(8)/0.,0.,1.0e-14,9.813,
     &     -0.2,0.,2.3e-09,21.40,0.3,0.1,6.5e-09,33.71,
     &     0.5,0.5,1.1e-8,59.08,0.5,0.5,1.7e-8,74.45,
     &     0.5,0.5,2.4e-8,267.4,0.5,0.5,3.3e-8,314.8/
      data alhs(1,9),alhs(2,9),beths(9),hkihs(9),alhs(1,10),
     &     alhs(2,10),beths(10),hkihs(10),alhs(1,11),alhs(2,11)
     &    ,beths(11),hkihs(11),alhs(1,12),alhs(2,12),beths(12)
     &    ,hkihs(12),alhs(1,13),alhs(2,13),beths(13),hkihs(13)
     &    ,alhs(1,14),alhs(2,14),beths(14),hkihs(14),
     &     alhs(1,15),alhs(2,15),beths(15),hkihs(15),alhs(1,16)
     &    ,alhs(2,16),beths(16),hkihs(16)/0.5,0.5,4.3e-8,
     &     365.4,0.5,0.5,5.4e-8,433.5,0.5,0.5,6.7e-8,
     &     491.0,0.5,0.5,8.1e-8,550.9,0.5,0.5,9.6e-8,
     &     638.3,0.5,0.5,1.1e-7,693.2,0.5,0.5,1.3e-7,
     &     3210.,0.5,0.5,1.5e-7,3480./
      data ales(1,1),ales(2,1),betes(1),hkies(1)/4*0./
      data ales(1,2),ales(2,2),betes(2),hkies(2),ales(1,3),
     &     ales(2,3),betes(3),hkies(3),ales(1,4),ales(2,4),
     &     betes(4),hkies(4),ales(1,5),ales(2,5),betes(5),
     &     hkies(5),ales(1,6),ales(2,6),betes(6),hkies(6),
     &     ales(1,7),ales(2,7),betes(7),hkies(7),ales(1,8),
     &     ales(2,8),betes(8),hkies(8)/0.,0.,0.,-1.187,
     &     0.30,0.,2.e-10,10.40,0.50,0.50,3.e-09,22.71,
     &     0.5,0.5,5.3e-09,48.08,0.5,0.5,8.3e-09,63.49,
     &     0.5,0.5,1.2e-8,256.4,0.5,0.5,1.6e-8,303.8/
      data ales(1,9),ales(2,9),betes(9),hkies(9),ales(1,10),
     &     ales(2,10),betes(10),hkies(10),ales(1,11),ales(2,11)
     &    ,betes(11),hkies(11),ales(1,12),ales(2,12),betes(12)
     &    ,hkies(12),ales(1,13),ales(2,13),betes(13),hkies(13)
     &    ,ales(1,14),ales(2,14),betes(14),hkies(14),
     &     ales(1,15),ales(2,15),betes(15),hkies(15),ales(1,16)
     &    ,ales(2,16),betes(16),hkies(16)/0.5,0.5,2.1e-8,
     &     354.4,0.5,0.5,2.7e-8,422.5,0.5,0.5,3.3e-8,
     &     480.0,0.5,0.5,4.e-8,539.9,0.5,0.5,4.8e-8,
     &     627.3,0.5,0.5,5.6e-8,682.2,0.5,0.5,6.5e-8,
     &     3199.,0.5,0.5,7.5e-8,3469./
      data alhar(1,1),alhar(2,1),bethar(1),hkihar(1)/4*0./
      data alhar(1,2),alhar(2,2),bethar(2),hkihar(2),alhar(1,3)
     &    ,alhar(2,3),bethar(3),hkihar(3),alhar(1,4),
     &     alhar(2,4),bethar(4),hkihar(4),alhar(1,5),alhar(2,5)
     &    ,bethar(5),hkihar(5),alhar(1,6),alhar(2,6),bethar(6)
     &    ,hkihar(6),alhar(1,7),alhar(2,7),bethar(7),hkihar(7)
     &    ,alhar(1,8),alhar(2,8),bethar(8),hkihar(8)/28*0./
      data alhar(1,9),alhar(2,9),bethar(9),hkihar(9),alhar(1,10)
     &    ,alhar(2,10),bethar(10),hkihar(10),alhar(1,11),
     &     alhar(2,11),bethar(11),hkihar(11),alhar(1,12),
     &     alhar(2,12),bethar(12),hkihar(12),alhar(1,13),
     &     alhar(2,13),bethar(13),hkihar(13),alhar(1,14),
     &     alhar(2,14),bethar(14),hkihar(14),alhar(1,15),
     &     alhar(2,15),bethar(15),hkihar(15),alhar(1,16),
     &     alhar(2,16),bethar(16),hkihar(16)/32*0./
      data alhar(1,17),alhar(2,17),bethar(17),hkihar(17),
     &     alhar(1,18),alhar(2,18),bethar(18),hkihar(18)/8*0./
      data alear(1,1),alear(2,1),betear(1),hkiear(1)/4*0./
      data alear(1,2),alear(2,2),betear(2),hkiear(2),alear(1,3)
     &    ,alear(2,3),betear(3),hkiear(3),alear(1,4),
     &     alear(2,4),betear(4),hkiear(4),alear(1,5),alear(2,5)
     &    ,betear(5),hkiear(5),alear(1,6),alear(2,6),betear(6)
     &    ,hkiear(6),alear(1,7),alear(2,7),betear(7),hkiear(7)
     &    ,alear(1,8),alear(2,8),betear(8),hkiear(8)/28*0./
      data alear(1,9),alear(2,9),betear(9),hkiear(9),alear(1,10)
     &    ,alear(2,10),betear(10),hkiear(10),alear(1,11),
     &     alear(2,11),betear(11),hkiear(11),alear(1,12),
     &     alear(2,12),betear(12),hkiear(12),alear(1,13),
     &     alear(2,13),betear(13),hkiear(13),alear(1,14),
     &     alear(2,14),betear(14),hkiear(14),alear(1,15),
     &     alear(2,15),betear(15),hkiear(15),alear(1,16),
     &     alear(2,16),betear(16),hkiear(16)/32*0./
      data alear(1,17),alear(2,17),betear(17),hkiear(17),
     &     alear(1,18),alear(2,18),betear(18),hkiear(18)/8*0./
      data alhca(1,1),alhca(2,1),bethca(1),hkihca(1)/4*0./
      data alhca(1,2),alhca(2,2),bethca(2),hkihca(2),alhca(1,3)
     &    ,alhca(2,3),bethca(3),hkihca(3),alhca(1,4),
     &     alhca(2,4),bethca(4),hkihca(4),alhca(1,5),alhca(2,5)
     &    ,bethca(5),hkihca(5),alhca(1,6),alhca(2,6),bethca(6)
     &    ,hkihca(6),alhca(1,7),alhca(2,7),bethca(7),hkihca(7)
     &    ,alhca(1,8),alhca(2,8),bethca(8),hkihca(8)/28*0./
      data alhca(1,9),alhca(2,9),bethca(9),hkihca(9),alhca(1,10)
     &    ,alhca(2,10),bethca(10),hkihca(10),alhca(1,11),
     &     alhca(2,11),bethca(11),hkihca(11),alhca(1,12),
     &     alhca(2,12),bethca(12),hkihca(12),alhca(1,13),
     &     alhca(2,13),bethca(13),hkihca(13),alhca(1,14),
     &     alhca(2,14),bethca(14),hkihca(14),alhca(1,15),
     &     alhca(2,15),bethca(15),hkihca(15),alhca(1,16),
     &     alhca(2,16),bethca(16),hkihca(16)/32*0./
      data alhca(1,17),alhca(2,17),bethca(17),hkihca(17),
     &     alhca(1,18),alhca(2,18),bethca(18),hkihca(18),
     &     alhca(1,19),alhca(2,19),bethca(19),hkihca(19),
     &     alhca(1,20),alhca(2,20),bethca(20),hkihca(20)/16*0./
      data aleca(1,1),aleca(2,1),beteca(1),hkieca(1)/4*0./
      data aleca(1,2),aleca(2,2),beteca(2),hkieca(2),aleca(1,3)
     &    ,aleca(2,3),beteca(3),hkieca(3),aleca(1,4),
     &     aleca(2,4),beteca(4),hkieca(4),aleca(1,5),aleca(2,5)
     &    ,beteca(5),hkieca(5),aleca(1,6),aleca(2,6),beteca(6)
     &    ,hkieca(6),aleca(1,7),aleca(2,7),beteca(7),hkieca(7)
     &    ,aleca(1,8),aleca(2,8),beteca(8),hkieca(8)/28*0./
      data aleca(1,9),aleca(2,9),beteca(9),hkieca(9),aleca(1,10)
     &    ,aleca(2,10),beteca(10),hkieca(10),aleca(1,11),
     &     aleca(2,11),beteca(11),hkieca(11),aleca(1,12),
     &     aleca(2,12),beteca(12),hkieca(12),aleca(1,13),
     &     aleca(2,13),beteca(13),hkieca(13),aleca(1,14),
     &     aleca(2,14),beteca(14),hkieca(14),aleca(1,15),
     &     aleca(2,15),beteca(15),hkieca(15),aleca(1,16),
     &     aleca(2,16),beteca(16),hkieca(16)/32*0./
      data aleca(1,17),aleca(2,17),beteca(17),hkieca(17),
     &     aleca(1,18),aleca(2,18),beteca(18),hkieca(18),
     &     aleca(1,19),aleca(2,19),beteca(19),hkieca(19),
     &     aleca(1,20),aleca(2,20),beteca(20),hkieca(20)/16*0./
      data alhfe(1,1),alhfe(2,1),bethfe(1),hkihfe(1)/4*0./
      data alhfe(1,2),alhfe(2,2),bethfe(2),hkihfe(2),alhfe(1,3)
     &    ,alhfe(2,3),bethfe(3),hkihfe(3),alhfe(1,4),
     &     alhfe(2,4),bethfe(4),hkihfe(4),alhfe(1,5),alhfe(2,5)
     &    ,bethfe(5),hkihfe(5),alhfe(1,6),alhfe(2,6),bethfe(6)
     &    ,hkihfe(6),alhfe(1,7),alhfe(2,7),bethfe(7),hkihfe(7)
     &    ,alhfe(1,8),alhfe(2,8),bethfe(8),hkihfe(8)/0.,0.,
     &     6.7e-10,2.582,0.10,0.25,2.7e-9,21.14,0.50,
     &     0.50,6.e-9,40.13,0.5,0.5,1.1e-8,61.40,0.5,
     &     0.5,1.7e-8,85.40,0.5,0.5,2.4e-8,111.4,0.5,
     &     0.5,3.3e-8,138.0/
      data alhfe(1,9),alhfe(2,9),bethfe(9),hkihfe(9),alhfe(1,10)
     &    ,alhfe(2,10),bethfe(10),hkihfe(10),alhfe(1,11),
     &     alhfe(2,11),bethfe(11),hkihfe(11),alhfe(1,12),
     &     alhfe(2,12),bethfe(12),hkihfe(12),alhfe(1,13),
     &     alhfe(2,13),bethfe(13),hkihfe(13),alhfe(1,14),
     &     alhfe(2,14),bethfe(14),hkihfe(14),alhfe(1,15),
     &     alhfe(2,15),bethfe(15),hkihfe(15),alhfe(1,16),
     &     alhfe(2,16),bethfe(16),hkihfe(16),alhfe(1,17),
     &     alhfe(2,17),bethfe(17),hkihfe(17)/0.5,0.5,4.3e-8,
     &     221.3,0.5,0.5,5.4e-8,248.4,0.5,0.5,6.7e-8,
     &     276.7,0.5,0.5,8.1e-8,237.2,0.5,0.5,9.6e-8,
     &     347.4,0.5,0.5,1.1e-7,378.6,0.5,0.5,1.3e-7,
     &     443.4,0.5,0.5,1.5e-7,476.4,0.5,0.5,1.7e-7,
     &     1248./
      data alhfe(1,18),alhfe(2,18),bethfe(18),hkihfe(18),
     &     alhfe(1,19),alhfe(2,19),bethfe(19),hkihfe(19),
     &     alhfe(1,20),alhfe(2,20),bethfe(20),hkihfe(20),
     &     alhfe(1,21),alhfe(2,21),bethfe(21),hkihfe(21),
     &     alhfe(1,22),alhfe(2,22),bethfe(22),hkihfe(22),
     &     alhfe(1,23),alhfe(2,23),bethfe(23),hkihfe(23),
     &     alhfe(1,24),alhfe(2,24),bethfe(24),hkihfe(24),
     &     alhfe(1,25),alhfe(2,25),bethfe(25),hkihfe(25),
     &     alhfe(1,26),alhfe(2,26),bethfe(26),hkihfe(26)/0.5,
     &     0.5,1.9e-7,1344.,0.5,0.5,2.2e-7,1442.,0.5,
     &     0.5,2.4e-7,1568.,0.5,0.5,2.7e-7,1675.,0.5,
     &     0.5,2.9e-7,1785.,0.5,0.5,3.2e-7,1936.,0.5,
     &     0.5,3.5e-7,2031.,0.5,0.5,3.8e-7,8814.,0.5,
     &     0.5,4.2e-7,9264./
      data alefe(1,1),alefe(2,1),betefe(1),hkiefe(1),alefe(1,2)
     &    ,alefe(2,2),betefe(2),hkiefe(2)/8*0./
      data alefe(1,3),alefe(2,3),betefe(3),hkiefe(3),alefe(1,4)
     &    ,alefe(2,4),betefe(4),hkiefe(4),alefe(1,5),
     &     alefe(2,5),betefe(5),hkiefe(5),alefe(1,6),alefe(2,6)
     &    ,betefe(6),hkiefe(6),alefe(1,7),alefe(2,7),betefe(7)
     &    ,hkiefe(7),alefe(1,8),alefe(2,8),betefe(8),hkiefe(8)
     &     /0.3,0.,2.e-10,10.16,0.5,0.5,3.e-9,29.15,
     &     0.5,0.5,5.3e-9,50.42,0.5,0.5,8.3e-9,74.42,
     &     0.5,0.5,1.2e-8,100.4,0.5,0.5,1.6e-8,127.0/
      data alefe(1,9),alefe(2,9),betefe(9),hkiefe(9),alefe(1,10)
     &    ,alefe(2,10),betefe(10),hkiefe(10),alefe(1,11),
     &     alefe(2,11),betefe(11),hkiefe(11),alefe(1,12),
     &     alefe(2,12),betefe(12),hkiefe(12),alefe(1,13),
     &     alefe(2,13),betefe(13),hkiefe(13),alefe(1,14),
     &     alefe(2,14),betefe(14),hkiefe(14),alefe(1,15),
     &     alefe(2,15),betefe(15),hkiefe(15),alefe(1,16),
     &     alefe(2,16),betefe(16),hkiefe(16),alefe(1,17),
     &     alefe(2,17),betefe(17),hkiefe(17)/0.5,0.5,6.2e-9,
     &     210.3,0.5,0.5,2.7e-8,237.8,0.5,0.5,3.3e-8,
     &     265.7,0.5,0.5,4.e-8,306.2,0.5,0.5,4.8e-8,
     &     336.4,0.5,0.5,5.6e-8,367.6,0.5,0.5,6.5e-8,
     &     432.4,0.5,0.5,7.5e-8,465.4,0.5,0.5,8.5e-8,
     &     1237./
      data alefe(1,18),alefe(2,18),betefe(18),hkiefe(18),
     &     alefe(1,19),alefe(2,19),betefe(19),hkiefe(19),
     &     alefe(1,20),alefe(2,20),betefe(20),hkiefe(20),
     &     alefe(1,21),alefe(2,21),betefe(21),hkiefe(21),
     &     alefe(1,22),alefe(2,22),betefe(22),hkiefe(22),
     &     alefe(1,23),alefe(2,23),betefe(23),hkiefe(23),
     &     alefe(1,24),alefe(2,24),betefe(24),hkiefe(24),
     &     alefe(1,25),alefe(2,25),betefe(25),hkiefe(25),
     &     alefe(1,26),alefe(2,26),betefe(26),hkiefe(26)/0.5,
     &     0.5,9.6e-8,1333.,0.5,0.5,1.1e-7,1431.,0.5,
     &     0.5,1.2e-7,1557.,0.5,0.5,1.3e-7,1664.,0.5,
     &     0.5,1.5e-7,1774.,0.5,0.5,1.6e-7,1925.,0.5,
     &     0.5,1.8e-7,2020.,0.5,0.5,1.9e-7,8803.,0.5,
     &     0.5,2.1e-7,9253./
c
      data alhni(1,1),alhni(2,1),bethni(1),hkihni(1)/4*0./
      data alhni(1,2),alhni(2,2),bethni(2),hkihni(2),alhni(1,3)
     &    ,alhni(2,3),bethni(3),hkihni(3),alhni(1,4),
     &     alhni(2,4),bethni(4),hkihni(4),alhni(1,5),alhni(2,5)
     &    ,bethni(5),hkihni(5),alhni(1,6),alhni(2,6),bethni(6)
     &    ,hkihni(6),alhni(1,7),alhni(2,7),bethni(7),hkihni(7)
     &    ,alhni(1,8),alhni(2,8),bethni(8),hkihni(8)/28*0./
      data alhni(1,9),alhni(2,9),bethni(9),hkihni(9),alhni(1,10)
     &    ,alhni(2,10),bethni(10),hkihni(10),alhni(1,11),
     &     alhni(2,11),bethni(11),hkihni(11),alhni(1,12),
     &     alhni(2,12),bethni(12),hkihni(12),alhni(1,13),
     &     alhni(2,13),bethni(13),hkihni(13),alhni(1,14),
     &     alhni(2,14),bethni(14),hkihni(14),alhni(1,15),
     &     alhni(2,15),bethni(15),hkihni(15),alhni(1,16),
     &     alhni(2,16),bethni(16),hkihni(16),alhni(1,17),
     &     alhni(2,17),bethni(17),hkihni(17)/36*0./
      data alhni(1,18),alhni(2,18),bethni(18),hkihni(18),
     &     alhni(1,19),alhni(2,19),bethni(19),hkihni(19),
     &     alhni(1,20),alhni(2,20),bethni(20),hkihni(20),
     &     alhni(1,21),alhni(2,21),bethni(21),hkihni(21),
     &     alhni(1,22),alhni(2,22),bethni(22),hkihni(22),
     &     alhni(1,23),alhni(2,23),bethni(23),hkihni(23),
     &     alhni(1,24),alhni(2,24),bethni(24),hkihni(24),
     &     alhni(1,25),alhni(2,25),bethni(25),hkihni(25),
     &     alhni(1,26),alhni(2,26),bethni(26),hkihni(26)/36*0./
      data alhni(1,27),alhni(2,27),bethni(27),hkihni(27),
     &     alhni(1,28),alhni(2,28),bethni(28),hkihni(28)/8*0./
      data aleni(1,1),aleni(2,1),beteni(1),hkieni(1),aleni(1,2)
     &    ,aleni(2,2),beteni(2),hkieni(2)/8*0./
      data aleni(1,3),aleni(2,3),beteni(3),hkieni(3),aleni(1,4)
     &    ,aleni(2,4),beteni(4),hkieni(4),aleni(1,5),
     &     aleni(2,5),beteni(5),hkieni(5),aleni(1,6),aleni(2,6)
     &    ,beteni(6),hkieni(6),aleni(1,7),aleni(2,7),beteni(7)
     &    ,hkieni(7),aleni(1,8),aleni(2,8),beteni(8),hkieni(8)
     &     /24*0./
      data aleni(1,9),aleni(2,9),beteni(9),hkieni(9),aleni(1,10)
     &    ,aleni(2,10),beteni(10),hkieni(10),aleni(1,11),
     &     aleni(2,11),beteni(11),hkieni(11),aleni(1,12),
     &     aleni(2,12),beteni(12),hkieni(12),aleni(1,13),
     &     aleni(2,13),beteni(13),hkieni(13),aleni(1,14),
     &     aleni(2,14),beteni(14),hkieni(14),aleni(1,15),
     &     aleni(2,15),beteni(15),hkieni(15),aleni(1,16),
     &     aleni(2,16),beteni(16),hkieni(16),aleni(1,17),
     &     aleni(2,17),beteni(17),hkieni(17)/36*0./
      data aleni(1,18),aleni(2,18),beteni(18),hkieni(18),
     &     aleni(1,19),aleni(2,19),beteni(19),hkieni(19),
     &     aleni(1,20),aleni(2,20),beteni(20),hkieni(20),
     &     aleni(1,21),aleni(2,21),beteni(21),hkieni(21),
     &     aleni(1,22),aleni(2,22),beteni(22),hkieni(22),
     &     aleni(1,23),aleni(2,23),beteni(23),hkieni(23),
     &     aleni(1,24),aleni(2,24),beteni(24),hkieni(24),
     &     aleni(1,25),aleni(2,25),beteni(25),hkieni(25),
     &     aleni(1,26),aleni(2,26),beteni(26),hkieni(26)/36*0./
      data aleni(1,27),aleni(2,27),beteni(27),hkieni(27),
     &     aleni(1,28),aleni(2,28),beteni(28),hkieni(28)/8*0./
c
c
c
c
c
      data kllab(1),eel(1),ggl(1)/' a6d    ',0.,24./,kllab(2)
     &    ,eel(2),ggl(2)/' a4f    ',0.25,20./,kllab(3),
     &     eel(3),ggl(3)/' a4d    ',1.01,16./,kllab(4),eel(4)
     &    ,ggl(4)/' a4p    ',1.66,12./,kllab(5),eel(5),
     &     ggl(5)/' b4p    ',2.57,12./,kllab(6),eel(6),ggl(6)
     &     /' b4f    ',2.79,20./,kllab(7),eel(7),ggl(7)
     &     /' a6s    ',2.82,6./,kllab(8),eel(8),ggl(8)
     &     /' a4g    ',3.18,24./,kllab(9),eel(9),ggl(9)
     &     /' b2h    ',3.27,14./,kllab(10),eel(10),ggl(10)
     &     /' b4d    ',3.87,16./
      data kulab(1),eeu(1),ggu(1)/' z6do   ',4.77,24./,
     &     kulab(2),eeu(2),ggu(2)/' z6fo   ',5.20,30./,
     &     kulab(3),eeu(3),ggu(3)/' z6po   ',5.29,18./,
     &     kulab(4),eeu(4),ggu(4)/' z4do   ',5.50,16./,
     &     kulab(5),eeu(5),ggu(5)/' z4fo   ',5.51,20./,
     &     kulab(6),eeu(6),ggu(6)/' z4po   ',5.85,12./
c
      data k(1,1),e(1,1),b(1,1),f(1,1),g(1,1)/' uv1    ',
     &     2610.,0.9992,0.332,13./,k(2,1),e(2,1),b(2,1),
     &     f(2,1),g(2,1)/' uv32   ',2765.,8.718e-5,3.25e-5,
     &     6./,k(3,1),e(3,1),b(3,1),f(3,1),g(3,1)/' 1      ',
     &     3280.,6.940e-4,3.64e-4,11./,k(4,1),e(4,1),b(4,1)
     &    ,f(4,1),g(4,1)/' 3      ',3950.,1.816e-5,1.38e-5,
     &     8./,k(5,1),e(5,1),b(5,1),f(5,1),g(5,1)/' 24     ',
     &     5800.,5.860e-7,9.61e-7,8./
      data k(6,1),e(6,1),b(6,1),f(6,1),g(6,1)/' 34     ',
     &     6225.,1.309e-6,2.47e-6,4./,k(7,1),e(7,1),b(7,1),
     &     f(7,1),g(7,1)/' 40     ',6430.,2.612e-5,5.26e-5,
     &     3./,k(8,1),e(8,1),b(8,1),f(8,1),g(8,1)/'        ',
     &     0.,0.,0.,0./,k(9,1),e(9,1),b(9,1),f(9,1),
     &     g(9,1)/'        ',0.,0.,0.,0./,k(10,1),e(10,1),
     &     b(10,1),f(10,1),g(10,1)/'        ',0.,0.,0.,0./
      data k(1,2),e(1,2),b(1,2),f(1,2),g(1,2)/' uv2    ',
     &     2390.,0.9930,0.327,14./,k(2,2),e(2,2),b(2,2),
     &     f(2,2),g(2,2)/' uv33   ',2525.,8.582e-4,3.16e-4,
     &     5./,k(3,2),e(3,2),b(3,2),f(3,2),g(3,2)/' 2      ',
     &     2965.,6.044e-3,3.07e-3,5./,k(4,2),e(4,2),b(4,2),
     &     f(4,2),g(4,2)/' 4      ',3480.,5.270e-5,3.68e-5,
     &     8./,k(5,2),e(5,2),b(5,2),f(5,2),g(5,2)/' 25     ',
     &     4850.,1.216e-5,1.65e-5,8./
      data k(6,2),e(6,2),b(6,2),f(6,2),g(6,2)/' 35     ',
     &     5150.,5.636e-6,8.63e-6,12./,k(7,2),e(7,2),b(7,2)
     &    ,f(7,2),g(7,2)/' 41     ',5250.,5.171e-5,8.23e-5,
     &     3./,k(8,2),e(8,2),b(8,2),f(8,2),g(8,2)/' 46     ',
     &     6080.,3.343e-6,7.13e-6,11./,k(9,2),e(9,2),b(9,2)
     &    ,f(9,2),g(9,2)/'       ',0.,0.,0.,0./,k(10,2),
     &     e(10,2),b(10,2),f(10,2),g(10,2)/'       ',0.,0.,
     &     0.,0./
      data k(1,3),e(1,3),b(1,3),f(1,3),g(1,3)/' uv3    ',
     &     2350.,0.9821,0.326,9./,k(2,3),e(2,3),b(2,3),
     &     f(2,3),g(2,3)/' uv34   ',2455.,3.831e-3,1.39e-3,
     &     3./,k(3,3),e(3,3),b(3,3),f(3,3),g(3,3)/' uv61   ',
     &     2880.,1.092e-2,5.45e-3,5./,k(4,3),e(4,3),b(4,3),
     &     f(4,3),g(4,3)/' 5      ',3360.,3.325e-5,2.26e-5,
     &     6./,k(5,3),e(5,3),b(5,3),f(5,3),g(5,3)/' 26     ',
     &     4580.,2.684e-5,3.39e-5,6./
      data k(6,3),e(6,3),b(6,3),f(6,3),g(6,3)/' 36     ',
     &     4970.,3.661e-5,5.44e-5,3./,k(7,3),e(7,3),b(7,3),
     &     f(7,3),g(7,3)/' 42     ',5020.,3.153e-3,4.78e-3,
     &     3./,k(8,3),e(8,3),b(8,3),f(8,3),g(8,3)/' 47     ',
     &     5850.,5.760e-7,1.19e-6,3./,k(9,3),e(9,3),b(9,3),
     &     f(9,3),g(9,3)/'        ',0.,0.,0.,0./,k(10,3),
     &     e(10,3),b(10,3),f(10,3),g(10,3)/'        ',0.,0.,
     &     0.,0./
      data k(1,4),e(1,4),b(1,4),f(1,4),g(1,4)/' uv5    ',
     &     2260.,2.693e-2,7.56e-3,8./,k(2,4),e(2,4),b(2,4),
     &     f(2,4),g(2,4)/' uv36   ',2375.,2.695e-1,8.36e-2,
     &     9./,k(3,4),e(3,4),b(3,4),f(3,4),g(3,4)/' uv63   ',
     &     2746.,6.825e-1,0.283,10./,k(4,4),e(4,4),b(4,4),
     &     f(4,4),g(4,4)/' 6      ',3200.,1.835e-2,1.03e-2,
     &     8./,k(5,4),e(5,4),b(5,4),f(5,4),g(5,4)/' 27     ',
     &     4300.,1.439e-3,1.47e-3,8./
      data k(6,4),e(6,4),b(6,4),f(6,4),g(6,4)/' 38     ',
     &     4550.,9.749e-4,1.11e-3,9./,k(7,4),e(7,4),b(7,4),
     &     f(7,4),g(7,4)/' 43     ',4660.,4.176e-5,4.99e-5,
     &     3./,k(8,4),e(8,4),b(8,4),f(8,4),g(8,4)/' 48     ',
     &     5350.,2.700e-4,4.25e-4,6./,k(9,4),e(9,4),b(9,4),
     &     f(9,4),g(9,4)/'        ',0.,0.,0.,0./,k(10,4),
     &     e(10,4),b(10,4),f(10,4),g(10,4)/' 73    ',7400.,
     &     6.32e-5,1.9e-4,10./
      data k(1,5),e(1,5),b(1,5),f(1,5),g(1,5)/' uv4    ',
     &     2257.,1.941e-2,4.47e-3,9./,k(2,5),e(2,5),b(2,5),
     &     f(2,5),g(2,5)/' uv35   ',2365.,1.279e-1,3.22e-2,
     &     10./,k(3,5),e(3,5),b(3,5),f(3,5),g(3,5)
     &     /' uv62   ',2750.,8.484e-1,0.288,9./,k(4,5),
     &     e(4,5),b(4,5),f(4,5),g(4,5)/' 7      ',3185.,
     &     2.549e-3,1.16e-3,6./,k(5,5),e(5,5),b(5,5),f(5,5)
     &    ,g(5,5)/' 28     ',4200.,4.257e-4,3.38e-4,6./
      data k(6,5),e(6,5),b(6,5),f(6,5),g(6,5)/' 37     ',
     &     4550.,4.627e-4,4.31e-4,10./,k(7,5),e(7,5),b(7,5)
     &    ,f(7,5),g(7,5)/' 44     ',4660.,2.023e-5,1.98e-5,
     &     1./,k(8,5),e(8,5),b(8,5),f(8,5),g(8,5)/' 49     ',
     &     5260.,7.777e-4,9.66e-4,9./,k(9,5),e(9,5),b(9,5),
     &     f(9,5),g(9,5)/' 55     ',5530.,4.160e-5,5.72e-5,
     &     3./,k(10,5),e(10,5),b(10,5),f(10,5),g(10,5)
     &     /' 72    ',7300.,9.46e-6,2.27e-5,5./
      data k(1,6),e(1,6),b(1,6),f(1,6),g(1,6)/' uv6    ',
     &     2152.,1.999e-3,4.79e-4,5./,k(3,6),e(3,6),b(3,6),
     &     f(2,6),g(2,6)/' uv64   ',2570.,0.9089,0.311,8./,
     &     k(4,6),e(4,6),b(4,6),f(3,6),g(3,6)/' 8      ',
     &     2980.,8.843e-2,4.06e-2,5./,k(5,6),e(5,6),b(5,6),
     &     f(4,6),g(4,6)/' 29     ',3900.,3.871e-5,3.05e-5,7./
      data k(6,6),e(6,6),b(6,6),f(5,6),g(5,6)/' 39     ',
     &     4100.,4.450e-6,3.87e-5,5./,k(2,6),e(2,6),b(2,6),
     &     f(6,6),g(6,6)/'        ',0.,0.,0.,0./,k(7,6),
     &     e(7,6),b(7,6),f(7,6),g(7,6)/' 45     ',4190.,
     &     4.931e-5,4.48e-5,2./,k(8,6),e(8,6),b(8,6),f(8,6)
     &    ,g(8,6)/'        ',0.,0.,0.,0./,k(9,6),e(9,6),
     &     b(9,6),f(9,6),g(9,6)/'        ',0.,0.,0.,0./,
     &     k(10,6),e(10,6),b(10,6),f(10,6),g(10,6)/' 74     ',
     &     6250.,5.99e-4,1.21e-3,8./
c
c
c
c
c
c     auger data
c
c      recombination emission data
      data ngnd/2*1,8*2,14*3,2*4/
      data nnnz/1,1,2,1,2,3,4,5,6,1,2,3,4,5,
     &     6,7,1,2,3,4,5,6,7,8,1,2,3,4,5,
     &     6,7,8,9,10,1,2,3,4,5,6,7,8,9,10,
     &     11,12,1,2,3,4,5,6,7,8,9,10,11,12,
     &     13,14,1,2,3,4,5,6,7,8,9,10,11,12,
     &     13,14,15,16,1,2,3,4,5,6,7,8,9,10,
     &     11,12,13,14,15,16,17,18,1,2,3,4,5,
     &     6,7,8,9,10,11,12,13,14,15,16,17,18,
     &     19,20,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,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/
      data nz/1,2,1,6,5,4,3,2,1,7,6,5,4,3,
     &     2,1,8,7,6,5,4,3,2,1,10,9,8,7,6,
     &     5,4,3,2,1,12,11,10,9,8,7,6,5,4,
     &     3,2,1,14,13,12,11,10,9,8,7,6,5,4,
     &     3,2,1,16,15,14,13,12,11,10,9,8,7,
     &     6,5,4,3,2,1,18,17,16,15,14,13,12,
     &     11,10,9,8,7,6,5,4,3,2,1,20,19,18,
     &     17,16,15,14,13,12,11,10,9,8,7,6,5,
     &     4,3,2,1,26,25,24,23,22,21,20,19,18,
     &     17,16,15,14,13,12,11,10,9,8,7,6,5,
     &     4,3,2,1,28,27,26,25,24,23,22,21,20,
     &     19,18,17,16,15,14,13,12,11,10,9,8,7,
     &     6,5,4,3,2,1/
      data prfrac/1.,0.25,1.,0.25,1.,0.75,0.67,0.38,
     &     0.33,0.25,1.,0.25,1.,0.75,0.67,0.38,0.33,
     &     0.25,1.,0.75,0.68,0.38,0.33,0.25,1.,0.25/
      data cor2/2*1.,2*4.,6*1.33,2*9.,6*3.,6*1.6,2*16./
      data acor1/2*1.,13*0.,2*1.,0.,0.25,0.75,10*0.,3.,
     &     0.333,0.556,0.,0.111,10*0.,3.,0.33,0.,0.,
     &     0.56,0.11,0.,1.,7*0.,0.,0.56,0.,0.1675,
     &     0.1675,0.111,0.,1.,7*0.,0.56,0.,0.33,0.11,
     &     0.,0.,1.,8*0.,0.56,0.,0.33,0.11,0.,0.,
     &     1.,8*0.,0.56,0.,0.33,0.11,0.,0.,1.,8*0.,
     &     0.56,0.,0.33,0.11,0.,0.,1.,8*0.,0.56,0.,
     &     0.33,0.11,0.,0.,1.,8*0.,3.,0.1875,0.,
     &     0.3125,0.4375,0.0625,5.,0.3125,0.1875,3*0.,1.,
     &     2*0.,3.,0.1875,0.,0.3125,0.4375,0.0625,5.,
     &     0.3125,0.1875,3*0.,1.,2*0.,0.,0.1875,0.,
     &     0.0625,0.3125,0.4375,1.667,0.4375,3*0.,1.,3*0./
      data acor2/0.0625,0.1875,2*0.,0.3125,0.4375,1.667,
     &     0.1875,4*0.,1.,2*0.,0.0625,0.1875,2*0.,0.3125,
     &     0.4375,1.667,0.1875,4*0.,1.,2*0.,0.0625,
     &     0.1875,2*0.,0.3125,0.4375,1.667,0.1875,4*0.,
     &     1.,2*0.,0.0625,0.1875,2*0.,0.3125,0.4375,
     &     1.667,0.1875,4*0.,1.,2*0.,0.0625,0.1875,2*0.,
     &     0.3125,0.4375,1.667,0.1875,4*0.,1.,2*0.,
     &     0.1875,1.,0.44,12*0.,0.1875,1.,0.44,12*0.,
     &     0.1875,1.,0.44,12*0.,0.1875,1.,0.44,12*0.,
     &     0.1875,1.,0.44,12*0.,0.1875,1.,0.44,12*0.,
     &     3.,14*0.,3.,14*0./
      data nup1/3,2,3,12*0,3,2,3,4,4,10*0,1,2,
     &     2,2,2,10*0,1,2,2,0,2,2,0,4,7*0,0,
     &     2,2,2,2,2,0,4,7*0,2,2,2,2,0,0,4,
     &     8*0,2,2,2,2,0,0,4,8*0,2,2,2,2,0,
     &     0,4,8*0,2,2,2,2,0,0,4,8*0,2,2,2,
     &     2,0,0,4,8*0,1,2,2,2,2,2,1,2,2,0,
     &     0,0,4,2*0,1,2,2,2,2,2,1,2,2,0,0,
     &     0,4,2*0,0,2,2,2,2,2,1,2,0,0,0,4,
     &     3*0/
      data nup2/2,2,2,2,2,2,1,2,0,0,0,0,4,
     &     2*0,2,2,2,2,2,2,1,2,0,0,0,0,4,
     &     2*0,2,2,2,2,2,2,1,2,0,0,0,0,4,
     &     2*0,2,2,2,2,2,2,1,2,0,0,0,0,4,
     &     2*0,2,2,2,2,2,2,1,2,0,0,0,0,4,
     &     2*0,2,4,2,12*0,2,4,2,12*0,2,4,2,
     &     12*0,2,4,2,12*0,2,4,2,12*0,2,4,2,
     &     12*0,1,14*0,1,14*0/
c
c
c
      data amkne/0.,1.,8*0.,2*0.,1.,7*0.,3*0.,1.,6*0.,
     &     4*0.,1.,5*0.,5*0.,1.,4*0.,6*0.,1.,3*0.,
     &     7*0.,1.,2*0.,7*0.,1.,2*0.,8*0.,1.,0.,9*0.,
     &     1./
      data amko/0.,1.,6*0.,2*0.,1.,5*0.,3*0.,1.,4*0.,
     &     4*0.,1.,3*0.,5*0.,1.,2*0.,5*0.,1.,2*0.,
     &     6*0.,1.,0.,7*0.,1./
      data amkn/0.,1.,5*0.,2*0.,1.,4*0.,3*0.,1.,3*0.,
     &     4*0.,1.,2*0.,4*0.,1.,2*0.,5*0.,1.,0.,6*0.,
     &     1./
      data amkc/0.,1.,4*0.,2*0.,1.,3*0.,3*0.,1.,2*0.,
     &     3*0.,1.,2*0.,4*0.,1.,0.,5*0.,1./
      data amksi/2*0.,0.6,0.4,10*0.,3*0.,0.6,0.4,9*0.,
     &     4*0.,0.6,0.4,8*0.,4*0.,0.6,0.4,8*0.,5*0.,
     &     1.,8*0.,6*0.,1.,7*0.,7*0.,1.,6*0.,8*0.,1.,
     &     5*0.,9*0.,1.,4*0.,10*0.,1.,3*0.,11*0.,1.,
     &     2*0.,11*0.,1.,2*0.,12*0.,1.,0.,13*0.,1./
      data amlssi/3*0.,1.,8*0.,3*0.,1.,8*0.,3*0.,1.,
     &     8*0.,4*0.,1.,7*0.,5*0.,1.,6*0.,6*0.,1.,
     &     5*0.,6*0.,1.,5*0.,7*0.,1.,4*0.,8*0.,1.,
     &     3*0.,9*0.,1.,2*0.,10*0.,1.,0.,11*0.,1./
      data amlpsi/0.,1.,8*0.,2*0.,1.,7*0.,3*0.,1.,6*0.,
     &     3*0.,1.,6*0.,4*0.,1.,5*0.,5*0.,1.,4*0.,
     &     6*0.,1.,3*0.,7*0.,1.,2*0.,8*0.,1.,0.,9*0.,
     &     1./
      data amks/3*0.,0.7,0.3,11*0.,4*0.,0.7,0.3,10*0.,
     &     5*0.,0.7,0.3,9*0.,6*0.,1.,9*0.,6*0.,0.7,
     &     0.3,8*0.,7*0.,0.7,0.3,7*0.,7*0.,0.7,0.3,
     &     7*0.,8*0.,1.,7*0.,9*0.,1.,6*0.,10*0.,1.,
     &     5*0.,11*0.,1.,4*0.,12*0.,1.,3*0.,13*0.,1.,
     &     2*0.,13*0.,1.,2*0.,14*0.,1.,0.,15*0.,1./
      data amlss/2*0.,1.,11*0.,3*0.,1.,10*0.,4*0.,1.,
     &     9*0.,5*0.,1.,8*0.,5*0.,1.,8*0.,6*0.,1.,
     &     7*0.,6*0.,1.,7*0.,7*0.,1.,6*0.,8*0.,1.,
     &     5*0.,9*0.,1.,4*0.,10*0.,1.,3*0.,11*0.,1.,
     &     2*0.,12*0.,1.,0.,13*0.,1./
      data amlps/0.,1.,10*0.,2*0.,1.,9*0.,3*0.,1.,8*0.,
     &     4*0.,1.,7*0.,5*0.,1.,6*0.,6*0.,1.,5*0.,
     &     6*0.,1.,5*0.,7*0.,1.,4*0.,8*0.,1.,3*0.,
     &     9*0.,1.,2*0.,10*0.,1.,0.,11*0.,1./
      data amkf1/6*0.,0.60,0.40,18*0.,7*0.,0.60,0.40,
     &     17*0.,8*0.,0.60,0.40,16*0.,9*0.,0.60,0.40,
     &     15*0.,9*0.,0.60,0.40,15*0.,10*0.,0.60,0.40,
     &     14*0.,11*0.,0.60,0.40,13*0.,12*0.,0.60,0.40,
     &     12*0.,12*0.,0.60,0.40,12*0.,12*0.,0.60,0.40,
     &     12*0.,13*0.,0.60,0.40,11*0.,14*0.,0.60,0.40,
     &     10*0.,15*0.,1.,10*0./
      data amkf2/15*0.,0.60,0.40,9*0.,16*0.,0.60,0.40,
     &     8*0.,16*0.,0.60,0.40,8*0.,17*0.,1.,8*0.,
     &     18*0.,1.,7*0.,19*0.,1.,6*0.,20*0.,1.,5*0.,
     &     21*0.,1.,4*0.,22*0.,1.,3*0.,23*0.,1.,2*0.,
     &     23*0.,1.,2*0.,24*0.,1.,0.,25*0.,1./
      data amlsf1/5*0.,1.,18*0.,6*0.,1.,17*0.,7*0.,1.,
     &     16*0.,8*0.,1.,15*0.,8*0.,1.,15*0.,9*0.,1.,
     &     14*0.,10*0.,1.,13*0.,11*0.,1.,12*0.,11*0.,
     &     1.,12*0.,12*0.,1.,11*0.,12*0.,1.,11*0.,
     &     13*0.,1.,10*0./
      data amlsf2/14*0.,1.,9*0.,15*0.,1.,8*0.,15*0.,1.,
     &     8*0.,16*0.,1.,7*0.,16*0.,1.,7*0.,17*0.,1.,
     &     6*0.,18*0.,1.,5*0.,19*0.,1.,4*0.,20*0.,1.,
     &     3*0.,21*0.,1.,2*0.,22*0.,1.,0.,23*0.,1./
      data amlpf1/3*0.,1.,18*0.,4*0.,1.,17*0.,5*0.,1.,
     &     16*0.,6*0.,1.,15*0.,6*0.,1.,15*0.,7*0.,1.,
     &     14*0.,8*0.,1.,13*0.,9*0.,1.,12*0.,9*0.,1.,
     &     12*0.,10*0.,1.,11*0.,11*0.,1.,10*0./
      data amlpf2/12*0.,1.,9*0.,13*0.,1.,8*0.,14*0.,1.,
     &     7*0.,15*0.,1.,6*0.,15*0.,1.,6*0.,16*0.,1.,
     &     5*0.,17*0.,1.,4*0.,18*0.,1.,3*0.,19*0.,1.,
     &     2*0.,20*0.,1.,0.,21*0.,1./
      end
      subroutine bkhsgo(sg,et,d,b,na,a,ss,nmax,nz,nsh)
c
c
c
c
c     this routine does the work in computing cross sections by the
c     method of barfield, et. al.
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,nna,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /enerc / epi(ncn),dele(ncn),numcon
c
      character*72 ktitle
c
      dimension sg(ncn,nz),et(nz),b(na),a(11,na),ss(nmax)
c
c      data sigth/6.65e-25/
      data sigth/1.e-34/
c
      if (lpri.gt.2) write (6,*)'in bkhsgo:',nmax,nz,nsh
      lprisv=lpri
c      lpri=0
c
      ldon = 0
      tmp1 = 0.
      jj = 1
      do 100 i = 1,numcon
         epii = epi(i)
         if ( epii.gt.et(1) ) then
            xx = epii*(1.e-3) - d
            if ( xx.le.0. ) goto 100
            if ( ldon.ne.1 ) then
               if ( xx.ge.b(jj) ) jj = jj + 1
               if ( jj.gt.na ) ldon = 1
               if ( ldon.ne.1 ) then
                  yyl = yy
                  xx = amax1(xx,0.)
                  yy = alog10(xx)
                  tmpl = tmp
                  tmp = 0.
                  do 5 lk = 1,11
                     kk = 12 - lk
                     tmp = a(kk,jj) + yy*tmp
                     if (lpri.gt.2)
     $                 write (6,*)lk,kk,yy,tmp,a(kk,jj)
 5                continue
                  tmp = min(amax1(-50.,tmp),24.)
                  sgtmp = 10.**(tmp-24.)
                  if (lpri.gt.2)
     $             write (6,9982)i,epii,ll,nmax,nz,xx,
     $               tmp,sgtmp
                  goto 20
               endif
            endif
            xx = amax1(xx,0.)
            zz = alog10(xx)
            ttmp = (tmp-tmpl)*(zz-yyl)/(yy-yyl+1.e-34)+tmpl
            ttmp = min(ttmp,24.)
            sgtmp = 10.**(ttmp-24.)
 20         do 40 ll = 1,nmax
               if ( epii.ge.et(ll) ) then
                  nelec = min0(nmax+1-ll,nsh)
                  enelec = float(nelec)
                  tmp1o = tmp1
c                 tmp1=sgtmp*ss(ll)
                  tmp1 = amax1(sigth*enelec,sgtmp*ss(ll))
                  if ( epii.ge.5.e+4 ) tmp1 = min(tmp1,tmp1o)
                  sg(i,ll) = sg(i,ll) + tmp1
                  if (lpri.gt.2)
     $             write (6,9982)i,epii,ll,nmax,nz,et(ll),
     $               sgtmp,ss(ll),nelec,tmp1
 9982             format (' ',i4,e12.4,3i4,3e12.4,i4,e12.4)
               endif
 40         continue
         endif
 100  continue
c
      if (lpri.gt.2) write (6,*)'leaving bkhsgo'
      lpri=lprisv
c
      return
      end
      subroutine bremem
c
c
c
c
c     this routine computes emissivities due to thermal bremsstrahlung.
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /temp  / t,to
      common /enerc / epi(ncn),dele(ncn),numcon
      common /cemis / rccems(ncn),cocems(ncn),dicems(ncn),
     &                brcems(ncn)
      common /abel  / xel(nl),xeln(nni),xelln(nnnl)
c
      character*72 ktitle
c
      dimension nnz(13)
c
      data nnz/1,2,6,7,8,10,12,14,16,18,20,26,
     &     28/
c      data cc/8.223e-15/
      data cc/1.032e-13/
c
      lskp=1
      if ((lffst.eq.1).and.(numcon.gt.1000)) lskp=10
c
      ekt = t*(0.861707)
      t6 = t/100.
c
      if (lpri.gt.0) write (6,*)'in bremem',t
c
      do 100 kl = 1,numcon,lskp
         brcems(kl) = 0.
 100  continue
c
      jkk = 0
c      nel2=2
      nel2=1
      do 200 jk = 1,nel2
         nnmx = nnz(jk)
         do 150 kl = 1,nnmx
            jkk = jkk + 1
               zz = float(kl)
               enz2 = xpx*xel(jk)*xiip(jkk)*zz*zz
               do 110 kk = 1,numcon,lskp
                  temp = epi(kk)/ekt
c                 gau=(0.5513289)*besek0(temp/2.)
                  gam = zz*zz*(0.158)/t6
                  if ( lpri.gt.2 ) write (6,99001) jk,kl,kk,jkk,
     &                 zz,enz2,gam,temp,gau,brtmp
                  gau = 1.
                  if ( temp.lt.100. ) gau = fbg(temp,gam)
                  brtmp = cc*xnx*enz2*gau*expo(-temp)/sqrt(t)
                  brcems(kk) = brcems(kk) + brtmp
c                 brcems(kk)=brcems(kk)*(1.e-34)
 110           continue
 150     continue
 200  continue
c
c
      return
99001 format (' ',4i4,6e12.4)
      end
      subroutine bremsc
c
      real brcl,enz2,t,to
c
c
c
c     this subroutine computes the cooling rate due to bremstrahlung.
c     the rate is returned in the common block brcool.
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common /brcool/ brcl
      common /temp  / t,to
c
      enz2 = 1.
      brcl = (1.435e-25)*enz2*sqrt(t)
c
      return
      end
      subroutine charex
c
c
c
c
c     this routine computes charge transfer rates and heating rates.
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /hcxrt / hcxrt(2,nni),hecxrt(2,nni)
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /temp  / t,to
      common /swdata/ stwtrt(nni)
      common /cxdat1/ alh(2,nni),beth(nni),hkih(nni) 
      common /cxdat2/ alhe(2,nni),bethe(nni),hkihe(nni)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
c
c
      data ergsev/1.602197e-12/
c
      ekt = t*(0.861707)
c
c
      ntcs = 2
      if ( t.lt.1. ) ntcs = 1
c
      if (lpri.gt.2) write (6,*)'in charex',t,ntcs
      do 100 j = 1,nni
         hcxrt(1,j) = 0.
         hecxrt(1,j) = 0.
         if (lpri.gt.2) write (6,*)j,xiip(j),xiin(1)
         if ((xiip(j).ge.1.e-6).and.(xiin(1).gt.1.e-6)
     $              .and.(t.lt.10.)) then
            hcxrt(1,j) = beth(j)*t**alh(ntcs,j)
            hecxrt(1,j) = bethe(j)*t**alhe(ntcs,j)
            if (lpri.gt.2) 
     $        write (6,*)beth(j),alh(ntcs,j),hcxrt(1,j)
         endif
 100  continue
c
      hcxrt(2,17) = hcxrt(1,17)*0.75
c
      if (lpri.gt.2) write (6,*)'finishing charex'
c
c
      return
      end
      function cion(n,j,e,t)
c
      external bigdat,newdat,rr3,nfllns
c
      real a,a0,a1,a2,a3,alpha,b,b0,b1,b2,b3,
     &     beta,c,c0,c1,c2,c3,ch,ch2,ch3
      real chi,chir,cion,d,d0,d1,d2,d3,e,expo,fchi,
     &     t
      integer iso,j,j2,j3,n
c
c  sm younger jqsrt 26, 329; 27, 541; 29, 61   with moores for undone
c  a0 for b-like ion has twice 2s plus one 2p  as in summers et al
c  chi = kt / i
c
      dimension a0(30),a1(30),a2(30),a3(30),b0(30),b1(30),
     &          b2(30),b3(30),c0(30),c1(30),c2(30),c3(30),
     &          d0(30),d1(30),d2(30),d3(30)
c
      data a0/13.5,27.0,9.07,11.80,20.2,28.6,37.0,45.4,
     &     53.8,62.2,11.7,38.8,37.27,46.7,57.4,67.0,
     &     77.8,90.1,106.,120.8,135.6,150.4,165.2,180.0,
     &     194.8,209.6,224.4,239.2,154.0,268.8/
      data a1/ - 14.2,-60.1,4.30,27*0./
      data a2/40.6,140.,7.69,27*0./
      data a3/ - 17.1,-89.8,-7.53,27*0./
c
      data b0/ - 4.81,-9.62,-2.47,-3.28,-5.96,-8.64,-11.32,
     &     -14.00,-16.68,-19.36,-4.29,-16.7,-14.58,-16.95,
     &     -19.93,-23.05,-26.00,-29.45,-34.25,-38.92,
     &     -43.59,-48.26,-52.93,-57.60,-62.27,-66.94,
     &     -71.62,-76.29,-80.96,-85.63/
      data b1/9.77,33.1,-3.78,27*0./
      data b2/ - 28.3,-82.5,-3.59,27*0./
      data b3/11.4,54.6,3.34,27*0./
c
      data c0/1.85,3.69,1.34,1.64,2.31,2.984,3.656,4.328,
     &     5.00,5.672,1.061,1.87,3.26,5.07,6.67,8.10,
     &     9.92,11.79,7.953,8.408,8.863,9.318,9.773,
     &     10.228,10.683,11.138,11.593,12.048,12.505,12.96/
      data c1/0.,4.32,.343,27*0./
      data c2/0.,-2.527,-2.46,27*0./
      data c3/0.,.262,1.38,27*0./
c
      data d0/ - 10.9,-21.7,-5.37,-7.58,-12.66,-17.74,
     &     -22.82,-27.9,-32.98,-38.06,-7.34,-28.8,-24.87,
     &     -30.5,-37.9,-45.3,-53.8,-64.6,-54.54,-61.70,
     &     -68.86,-76.02,-83.18,-90.34,-97.50,-104.66,
     &     -111.82,-118.98,-126.14,-133.32/
      data d1/8.90,42.5,-12.4,27*0./
      data d2/ - 35.7,-131.,-8.09,27*0./
      data d3/16.5,87.4,1.23,27*0./
c
      cion = 0.
      chir = t/(11590.*e)
      if ( chir.le..0115 ) return
      chi = amax1(chir,0.1)
      ch2 = chi*chi
      ch3 = ch2*chi
      alpha = (.001193+.9764*chi+.6604*ch2+.02590*ch3)
     &        /(1.0+1.488*chi+.2972*ch2+.004925*ch3)
      beta = (-.0005725+.01345*chi+.8691*ch2+.03404*ch3)
     &       /(1.0+2.197*chi+.2457*ch2+.002503*ch3)
      j2 = j*j
      j3 = j2*j
      iso = n - j + 1
c
      a = a0(iso) + a1(iso)/j + a2(iso)/j2 + a3(iso)/j3
      b = b0(iso) + b1(iso)/j + b2(iso)/j2 + b3(iso)/j3
      c = c0(iso) + c1(iso)/j + c2(iso)/j2 + c3(iso)/j3
      d = d0(iso) + d1(iso)/j + d2(iso)/j2 + d3(iso)/j3
c
c  fe ii experimental ionization montague et al: d. neufeld fit
      if ( n.eq.26 .and. j.eq.2 ) then
         a = -13.825
         b = -11.0395
         c = 21.07262
         d = 0.
      endif
c
      ch = 1./chi
      fchi = 0.3*ch*(a+b*(1.+ch)+(c-(a+b*(2.+ch))*ch)*alpha+d*beta*ch)
      cion = 2.2e-6*sqrt(chir)*fchi*expo(-1./chir)/(e*sqrt(e))
      return
      end
      function cmpfnc(ee,sxx)
c
      external bigdat,newdat,rr3,nfllns
c
      real cmpfnc,ddede,ddedsx,ddezde,de,dele,delsx,dez,
     &     e,ee,eeez,ez,sx,sxx,tmp
      integer ll,llm1,mm,mmm1
c
c
      common /comptn/ de(61,61),e(61),sx(61),dez(61),ez(61)
      ll = 0
 100  ll = ll + 1
      if ( ll.le.61 ) then
         if ( sxx.gt.sx(ll) ) goto 100
         if ( ll.eq.1 ) then
c
            mm = 0
         else
            mm = 0
 120        mm = mm + 1
            if ( mm.gt.61 ) goto 200
            if ( ee.gt.e(mm) ) goto 120
            if ( mm.eq.1 ) then
               mm = 0
            else
               mmm1 = mm - 1
               llm1 = ll - 1
               ddedsx = (de(ll,mm)-de(llm1,mm)+de(ll,mmm1)-de(llm1,mmm1)
     &                  )/(2.*(sx(ll)-sx(llm1)))
               ddede = (de(ll,mm)-de(ll,mmm1)+de(llm1,mm)-de(llm1,mmm1))
     &                 /(2.*(e(mm)-e(mmm1)))
               dele = ee - e(mmm1)
               delsx = sxx - sx(llm1)
               cmpfnc = ddedsx*delsx + ddede*dele + de(llm1,mmm1)
               return
            endif
         endif
 150     mm = mm + 1
         if ( mm.le.61 ) then
            if ( ee.gt.ez(mm) ) goto 150
            if ( mm.eq.1 ) then
c
               cmpfnc = 4.*sxx - ee
               return
            else
               mmm1 = mm - 1
               ddezde = (dez(mm)-dez(mmm1))/(ez(mm)-ez(mmm1))
               tmp = ddezde*(ee-ez(mmm1)) + dez(mmm1)
               eeez = 4.*1.e-6 - tmp
               cmpfnc = 4.*sxx - eeez
               return
            endif
         endif
      endif
c
 200  print 99002,ee,sxx
      cmpfnc = 0.
c
      return
c
c     print 9903,(kk,e(kk),sx(kk),kk=1,61)
99001 format (' ',i4,2e12.4)
99002 format (' ',' value out of range ',2e12.4)
      end
      subroutine cmpstp(tau)
c
c
c
c     the green's function weights from lightman, rybicki, and lamb
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /cmppss/ gg(800)
c
      character*72 ktitle
c
      dimension pstup(800),pstdn(800),pzup(800)
c
      if (lpri.gt.2) write (6,9910)tau,nnmxx
9910   format (' ',' in cmpstp ',e12.4,i4)
      epi = 3.14159
      nnmxx = 2*int(tau*tau) + 6
      nnmxx = min0(nnmxx,50)
      sumg = 0.
      sq3 = 1.7320508
      yy = sq3*tau
      expyy = expo(-yy)
      pzup(1) = expyy/2.
      pzup(2) = (2.*yy+1.)*expyy/8.
      pstup(1) = yy*expyy/2.
      pstup(2) = yy*(1.+yy)*expyy/8.
      pstdn(1) = expyy/4.
      pstdn(2) = (1.+yy)*expyy/8.
      do 100 kl = 3,nnmxx
         ztp = 3.*tau*tau/4./float(kl)
         expztp = expo(-ztp)
         pzup(kl) = (1.+yy)*expztp/2./1.772/float(kl)**1.5
         pstup(kl) = yy*expztp/2./1.772/float(kl)**1.5
         pstdn(kl) = (2.+yy)*expztp/2./1.772/float(kl)**1.5
 100  continue
      do 200 kl = 1,nnmxx
         gg(kl) = pzup(kl)
         sumg = sumg + gg(kl)
         if (lpri.gt.2)
     $    write (6,9901)kl,pstup(kl),pstdn(kl),pzup(kl),gg(kl)
 9901    format (1h ,i4,4(1pe11.3))
 200  continue
c
c     renormalize
      do 300 kl = 1,nnmxx
         gg(kl) = gg(kl)/sumg
 300  continue
c
      return
c          gg(kl)=pstup(kl)
c         if (tau.ge.1.e-34) gg(kl)=pstup(kl)+pstdn(kl)
99002 format (' ',' weights ',i4,4e12.4)
c         write (6,9922)kl,n,gg(kl)
99003 format (' ',2i4,e12.4)
c      write (6,9981)sumg
99004 format (' ',' sumg=',e12.4)
      end
      subroutine cmpztn(zrmso,nener,tau)
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /enerc / epi(ncn),dele(ncn),numcon
      common /copak / opakc(ncn),opakco(ncn)
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /cmppss/ gg(800)
c
      character*72 ktitle
c
      dimension zrmso(ncn),ff(ncn),fff(ncn),delamm(ncn),
     &          zrms1(ncn),zrms2(ncn)
c
      data cc/2.998e+10/,ehh/6.6262e-28/,ergsev/1.602197e-12/,
     &     elamc/2.42630e-2/,emc2/5.11e+5/,epss/1.e-4/
c
c     set up
      nmxx = 2*int(tau*tau) + 6
      nmxx = min0(nmxx,50)
c      nmxx=200
      elam = emc2/epi(nener)
      nb1=nbinc(100.)
      nb1=1
      do 100 kl = nb1, numcon
         zrmso(kl) = 0.
         zrms1(kl) = 0.
         zrms2(kl) = 0.
         elamf = emc2/epi(kl)
         delam = (elamf-elam)
         delamm(kl) = delam
 100  continue
c
c     set up absorption
      sigth = 6.65e-25
      xx = 1./elam
      sum = 0.
      tmp = 0.
      xx0 = xx
      nbcrit = nbinc(10000.)
      ncut = nbcrit
c      ncut = 1
c
c     step through numbers of scatterings
      do 300 jk = 1,nmxx
         if ( gg(jk).gt.1.e-3 ) then
            sum = 0.
            sumf = 0.
            do 120 kl = 1,numcon
               ff(kl) = 0.
               fff(kl) = 0.
 120        continue
c
c        step through energies
            do 140 klp = nb1,nener
c
               kl = nener + 1 - klp
c
               elamf = emc2/epi(kl)
               delam = (elamf-elam)
c
               fff(kl) = 0.
               ff(kl) = 0.
c
               if ( nener.le.ncut ) then
c
c           low energy --> coherent
                  fff(kl) = 0.
                  if ( kl.eq.(nener) ) fff(kl) = 1.
                  ff(kl) = fff(kl)
c                if (kl.le.ncut) go to 2
c
               elseif ( jk.eq.1 ) then
c
c           one scattering
                  fff(kl) = 0.
                  if ( (delam.ge.0.) .and. (delam.le.2.) ) then
                     fff(kl) = 3.*(1.+(delam-1.)*(delam-1.))/8.
c                    if (kl.eq.nener) fff(kl)=0.
                     ff(kl) = fff(kl)*ergsev*emc2/(epi(kl)*epi(kl))
                  endif
               elseif ( jk.eq.2 ) then
c
c           two scatterings
                  fff(kl) = 0.
                  if ( (delam.ge.0.) .and. (delam.le.4.) ) then
                     xx = delam
                     if ( delam.gt.2. ) xx = 4. - delam
                     fff(kl) = 9.*xx*(4.+xx*(-4.+xx*(2.+xx*(-1.+xx/10.)/
     &                         3.)))/64.
c                    if (kl.eq.nener) fff(kl)=0.
                     ff(kl) = fff(kl)*ergsev*emc2/(epi(kl)*epi(kl))
                  endif
               else
c
c           more than 2 scatterings
                  signn = 0.4*float(jk)
                  delnn = float(jk)
                  tmp = (delam-delnn)*(delam-delnn)/(2.*signn)
                  fff(kl) = 0.
                  if ( tmp.le.10. ) then
                     fff(kl) = exp(-tmp)/sqrt(6.28*signn)
c                    if (kl.eq.nener) fff(kl)=0.
                     ff(kl) = fff(kl)*ergsev*emc2/(epi(kl)*epi(kl))
                  endif
               endif
c
 140        continue
c
c
 
c        normalize
            sum = 0.
            sumf = 0.
            nenerp = nener + 1
            do 160 kl = nb1+1, nenerp
c            if ((nener.gt.ncut).and.(kl.le.ncut)) go to 56
               sumf = sumf + (fff(kl)+fff(kl-1))
     &                *(delamm(kl)-delamm(kl-1))/2.
               sum = sum + (ff(kl)+ff(kl-1))*(epi(kl)-epi(kl-1))/2.
 160        continue
            sumf = -sumf
            sum = sum*ergsev
c            write (6,9928)sum,sumf
 9928       format (1x,' sum, sumf=',2e12.4)
            do 180 kl = nb1+1, nenerp
c            if ((nener.gt.ncut).and.(kl.le.ncut)) go to 560
               if ( sumf.gt.1.e-34 ) fff(kl) = fff(kl)/sumf
               if ( sum.gt.1.e-34 ) ff(kl) = ff(kl)/sum
               if ( (nener.gt.ncut) .and. (kl.le.ncut) ) fff(kl) = 0.
               if ( (nener.gt.ncut) .and. (kl.le.ncut) ) ff(kl) = 0.
               zrms1(kl) = zrms1(kl) + gg(jk)*fff(kl)
               zrms2(kl) = zrms2(kl) + gg(jk)*ff(kl)
 180        continue
c
            sum = 0.
            sumf = 0.
            do 200 kl =nb1+1, nenerp
               sum = sum + (ff(kl)+ff(kl-1))*(epi(kl)-epi(kl-1))/2.
               sumf = sumf + (fff(kl)+fff(kl-1))
     &                *(delamm(kl)-delamm(kl-1))/2.
 200        continue
            sum = sum*ergsev
            sumf = -sumf
         endif
c
 300  continue
c
      sum = 0.
      sumf = 0.
      do 400 kl =nb1+1, numcon
         if ((epi(kl).gt.1000.).and.(lpri.gt.2))
     $   write (6,9983)kl,delamm(kl),zrms1(kl),epi(kl),zrms2(kl)
 9983    format (1h ,i4,4(1pe11.3))
         sum = sum + (zrms1(kl)+zrms1(kl-1))*(delamm(kl)-delamm(kl-1))
     &         /2.
         sumf = sumf + (zrms2(kl)+zrms2(kl-1))*(epi(kl)-epi(kl-1))/2.
 400  continue
      sumf = sumf*ergsev
      sumo = abs(sum)*ergsev
      if (lpri.gt.2) write (6,9928)sum,sumf
c
c       go to 3003
c
      if (lpri.gt.2) write (6,*)'the absorption part'
c     step through energies
      sigth = 6.65e-25
      xx = 1./elam
      sum = 0.
      tmp = 0.
      xx0 = xx
      nen2 = numcon
      if ( nener.gt.nbcrit ) then
         eps = 1./(1.+xpx*sigth/amax1(opakc(nbcrit),1.e-34))
         epsh = sqrt(eps)
         wabs2 = (1.-epsh)/(1.+epsh)
         xx = epi(nbcrit)/emc2
         xx0 = epi(nen2)/emc2
         wtmp = 0.25/xx0**4 - 0.25/xx**4
         cc1 = alog(wabs2)/wtmp
      endif
      xx = xx0
      wabs4 = 0.
      do 500 klp = nb1, nener
c
         kl = nener + 1 - klp
c
c           high energy explicit integral
         xxo = xx
         xx = epi(kl)/emc2
         tmpo = tmp
         tmp = amax1(0.,opakc(kl)/xpx/sigth-1.)/xx/xx
         sum = sum + (tmp+tmpo)*(xx-xxo)/2.
         wabs3 = expo(-abs(sum))
c
c           low energy limit
         eps = 1./(1.+xpx*sigth/amax1(opakc(kl),1.e-34))
         epsh = sqrt(eps)
         wabs2 = (1.-epsh)/(1.+epsh)
c
c           analytic integral
c            cc1=1.e-5
         wtmp = 0.25/xx0**4 - 0.25/xx**4
         wabs1 = expo(cc1*wtmp)
c
c           piecewise version
         wabs4 = wabs2
         if ( (kl.gt.nbcrit) .and. (nener.gt.nbcrit) ) wabs4 = wabs1
c
c           geometric mean of exponents
         eps = 1./(1.+xpx*sigth/amax1(opakc(kl),1.e-34))
         epsh = sqrt(eps)
         wabs2a = (1.-epsh)/(1.+epsh)
         xx = epi(kl)/emc2
c            xx0=epi(nener)/emc2
         xx0 = amax1(epi(nener),3.e+4)/emc2
         wtmp = 0.25/xx0**4 - 0.25/xx**4
         cc1a = alog(wabs2a)/(1.e-34+wtmp)
         cc1b = 1.e-5
         cc1 = 1./(1./abs(cc1a)+1./cc1b)
         wabs4 = expo(cc1*wtmp)
c
c           geometric mean version
c            wabs4=1./(1./wabs2+1./wabs1)
c
          wabs=wabs2
c
         zrms1(kl) = zrms1(kl)*wabs
         zrms2(kl) = zrms2(kl)*wabs
         if ( ((epi(kl).gt.10000.) .and. (epi(kl).le.20000.)) .and. 
     &        (lpri.gt.2) ) write (6,99005) kl,epi(kl),epi(nener),
     &                             wabs2a,wtmp,cc1a,cc1,wabs4,
     &                             zrms1(kl)
 500  continue
      do 600 kl = nb1, numcon
         zrmso(kl) = zrms1(kl)
 600  continue
c
c
      return
c
c            if ((epi(kl).gt.10000.).and.(epi(kl).lt.20000.).and.
c     $         (lpri.ge.1))
c     $       write (6,9904)jk,kl,epi(kl),elam,elamf,delam,fff(kl),ff(kl)
99001 format (' ',2i4,6e12.4)
c         if (lpri.gt.2) write (6,9905)jk
99002 format (' ',' greens function, n=',i4)
c            if ((fff(kl).gt.1.e-34).and.(lpri.gt.2)
c     $        .and.(epi(kl).gt.5.e+3).and.(epi(kl).le.2.e+4))
c     $       write (6,9983)jk,kl,delamm(kl),fff(kl),epi(kl),ff(kl),
c     $              wabs(kl),zrms1(kl),zrms2(kl)
99003 format (' ',2i4,7e12.4)
c         if (lpri.gt.2) write (6,9928)sum,sumf
99004 format (' ',' normalization ',2e12.4)
99005 format (' ',i4,8e12.4)
c
c
c      if (lpri.gt.2) write (6,9901)tau,epi(nener)
99006 format (' ',' the greens function, tau=',e12.4,' ener=',e12.4)
      end
      subroutine cocem
c
c
c
c
c     this routine computes comptonized spectra
c     elastic scattering approximation
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /radius/ delr,r,rl,rstp,rdel,radexp,rscale,rsave
      common /spectc/ bremsa(ncn),brems(ncn),zrems(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /enerc / epi(ncn),dele(ncn),numcon
      common /cemis / rccems(ncn),cocems(ncn),dicems(ncn),
     &                brcems(ncn)
      common /copak / opakc(ncn),opakco(ncn)
      common /temp  / t,to
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
c
c     compute flux
      r19 = r*1.e-19
      fpr2 = 12.56*r*r
      emc2 = 5.11e+5
      sigth = 6.65e-25
      ergsev = 1.602197e-12
      ekt = (0.861707)*t
      deltau = sigth*xnx*delr
      do 100 i = 1,numcon
         cocems(i) = 0.
 100  continue
c
c      do 200 i = 1,numcon
c         delese=(epi(i)-4.*ekt)/emc2
c         delese = 0.
c         delese=amax1(delese,0.)
c         idest=nbinc(epi(i)*(1.-delese))
c         idest = i
c         cocems(idest) = cocems(idest) + zremso(i)
c     &                   *deltau/delr/12.56/r19/r19
c         if (i.eq.numcon)
c         print 99001,i,epi(i),delr,fpr2,deltau,idest,
c     &         cocems(idest)
c 200  continue
c
c
      return
99001 format (' ',' in cocem',i4,4e12.4,i4,e12.4)
      end
      subroutine collem
c
c
c
c     this routine computes emmissivities due to collisional
c     excitation.
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /temp  / t,to
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /diemis/ diem(nnnl)
      common /ceemis/ ceem(nnnl)
      common /diemso/ diemo(nnnl)
      common /ceemso/ ceemo(nnnl)
      common /abel  / xel(nl),xeln(nni),xelln(nnnl)
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /linsel/ nlsv(nnnl),nlsvn
      common /lindat/ elin(nnnl),blin(nnnl),
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &     flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
      dimension nnz(13)
c
      data nnz/1,2,6,7,8,10,12,14,16,18,20,26,
     &     28/
c
c
      jj = 0
      jk = 0
      do 100 n = 1,nel
         nmx = nnz(n)
         do 50 j = 1,nmx
            jj = jj + 1
            jklm = nlin(jj)
            abund = xnx*xpx*xiin(jj)*xel(n)
            do 20 jkk = 1,jklm
               jk = jk + 1
               if ( (jk.le.0) .or. (jk.gt.nnnl) ) goto 100
               if ( lichk(jj).ne.1 ) then
                  ceem(jk) = 0.
                  diem(jk) = 0.
               else
c              if (cslin(jk).le.1.e-10) go to 1
                  ceem(jk) = ceemo(jk)*abund
                  diem(jk) = diemo(jk)*abund
                  if ( lpri.gt.2 ) write (6,99001) n,j,jj,xel(n),
     &                 xiin(jj),jk,elin(jk),abund,ceem(jk)
               endif
 20         continue
 50      continue
 100  continue
c      ceem(1)=ceem(1)+pxrtot*xpx
c
      return
99001 format (' ',' in collem ',3i4,2e12.4,i4,3e12.4)
c
c     print 9901,ceem(1),pxrtot,xpx
99002 format (' ',' in collem ',3e12.4)
c
c
      end
      subroutine collemn
c
c
c
c     this routine computes emmissivities due to collisional
c     excitation.
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /temp  / t,to
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /diemis/ diem(nnnl)
      common /ceemis/ ceem(nnnl)
      common /diemso/ diemo(nnnl)
      common /ceemso/ ceemo(nnnl)
      common /abel  / xel(nl),xeln(nni),xelln(nnnl)
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /linsel/ nlsv(nnnl),nlsvn
      common /lindat/ elin(nnnl),blin(nnnl),
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &     flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
      dimension nnz(13)
c
      data nnz/1,2,6,7,8,10,12,14,16,18,20,26,
     &     28/
c
c
      jj = 0
      jk = 0
      do 100 n = 1,nel
         nmx = nnz(n)
         do 50 j = 1,nmx
            jj = jj + 1
            jklm = nlin(jj)
            abund = xnx*xpx*xiin(jj)*xel(n)
            do 20 jkk = 1,jklm
               jk = jk + 1
               if ( (jk.le.0) .or. (jk.gt.nnnl) ) goto 100
               if ( lichk(jj).ne.1 ) then
                  ceem(jk) = 0.
c                  diem(jk) = 0.
               else
c              if (cslin(jk).le.1.e-10) go to 1
                  ceem(jk) = ceemo(jk)*abund
c                  diem(jk) = diemo(jk)*abund
                  if ( lpri.gt.2 ) write (6,99001) n,j,jj,xel(n),
     &                 xiin(jj),jk,elin(jk),abund,ceem(jk)
               endif
 20         continue
 50      continue
 100  continue
c      ceem(1)=ceem(1)+pxrtot*xpx
c
      return
99001 format (' ',' in collem ',3i4,2e12.4,i4,3e12.4)
c
c     print 9901,ceem(1),pxrtot,xpx
99002 format (' ',' in collem ',3e12.4)
c
c
      end
      subroutine collex
c
c
c
c
c     this subroutine computes the cooling due to collisional excitatio
c     the rate is returned in the common block cecool
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
c
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nl2,na2,
     &   nnnl2,nni2,nnp2,lnoinwd,lffst,ktitle
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /linsel/ nlsv(nnnl),nlsvn
      common /temp  / t,to
      common /ceemso/ ceem(nnnl)
      common /diemso/ diem(nnnl)
      common /cecool/ cecl(nni)
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /ffesc / fesc(nnnl)
      common /ffescb/ fescb(nnnl)
      common /lindat/ elin(nnnl),blin(nnnl),
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &      flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
      dimension nnz(13)
      dimension cccrth(6,6)
c
      data nnz/1,2,6,7,8,10,12,14,16,18,20,26,
     &     28/
      data cc/8.626e-08/,ergsev/1.602197e-12/
      data ccee/1.986e-08/
      data cccrth(2,1),cccrth(3,1),cccrth(3,2),cccrth(4,1),
     &     cccrth(4,2),cccrth(4,3),cccrth(5,1),cccrth(5,2),
     &     cccrth(5,3),cccrth(5,4),cccrth(6,1),cccrth(6,2),
     &     cccrth(6,3),cccrth(6,4),cccrth(6,5)/9.66e-9,0.,
     &     2.77e-7,0.,4.34e-08,1.26e-06,0.,1.10e-08,
     &     2.00e-07,4.40e-06,3*0.,6.00e-07,1.20e-05/
c
c     compute collisional excitation emissivities.
c
c
c     the raymond part
      dene = xpx
      t2 = t*(1.e+4)
      if ( lpri.ge.1 ) write (6,99001)
c
      lprisv=lpri
c
      num = 13
c
c
c     element loop
      sqt = sqrt(t)
      st = sqrt(t2)
      kkkl = 0
      jkk = 0
      do 100 no = 1,nl
         n = nnz(no)
         do 50 il = 1,n
            jkk = jkk + 1
            if ( (jkk.eq.1) .or. (jkk.eq.3) ) then
               klmx=nlin(jkk)
               do 10 ll=1,klmx
                  kkkl=kkkl+1
                  ceem(kkkl)=0.
 10               continue
            else
               iy = nlin(jkk)
               if ( iy.gt.0 ) then
                  do 15 l = 1,iy
                     kkkl = kkkl + 1
                     kkl = nlsv(kkkl)
                     ceem(kkl) = 0.
                     if ( lichk(jkk).eq.1 ) then
c                     if (xii(jkk+no-1).le.1.e-6) go to 260
                        elm = elin(kkl)
                        fln = flin1(kkl)
                        elx = eex(kkl)
                        g = 0.
                        pw = 0.
                        pwa = 0.
                        csl = 0.
                        if ( elin(kkl).gt.0. ) then
                           if ( elx.gt.(1.e-34) ) then
                              g = gaunt(t2,elx,n,il,l,dene)
                              g = amax1(g,0.)
                              tmp = 10590.*elx/t2
                              tmp = min(tmp,30.)
c                              pwa = alphdi(n,il,l,kkl,t2)
                              pw = (1.70e-3)*fln*expo(-tmp)*g/(st*elx)
                              csl = (196.7)*fln*g/elx
                           endif
                        endif
                        cslin(kkl) = csl
                        sxl = 0.
                        if ( fln.gt.(1.e-10) )
     &                       sxl = csl*elm*elm*sqt/((7.73e+23)*fln)
                        sxlin(kkl) = sxl
                        if ( lpri.gt.2 ) write (6,99003) kkl,elin(kkl)
     &                      ,eex(kkl),nilin(kkl),fln,g,pw,
     &                       n,il,l
c                        diem(kkl)= pwa
                        ceem(kkl) = pw
                     endif
 15               continue
               endif
            endif
 50      continue
 100  continue
c
      if ( lpri.gt.2 ) then
         do 150 jkk = 1,nlsvn
            jk = nlsv(jkk)
            write (6,99004) jk,nilin(jk),elin(jk),cslin(jk),
     &                      flin1(jk),sxlin(jk),eex(jk)
 150     continue
      endif
c
c
c
      nnln = 0
      do 200 jk = 1,nni
         nlim = nlin(jk)
         if ( (nlim.gt.0) .and. (nlim.le.15) ) then
            cecl(jk) = 0.
            do 160 kl = 1,nlim
               nnln = nnln + 1
               cecl(jk) = cecl(jk) + ceem(nnln)*eex(nnln)
     &                    *ergsev*(fescb(nnln)+fesc(nnln))
 160        continue
         endif
 200  continue
c
      lpri=lprisv
c
      return
99001 format (' ',' in collex ')
99002 format (' ',3i4,5e12.4)
99003 format (' ',i4,2e12.4,i4,3e12.4,3i4)
99004 format (' ',2('%',i4),5('%',e12.4))
      end
      subroutine colli
c
c
c
c
c     this subroutine computes the collisional ionization rates, and
c     the collisional ionization cooling rates.  all data are from
c     summers, appleton lab report, 1974.
c
c
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /temp  / t,to
      common /cirate/ cirt(nni)
      common /ethrsh/ eth(nni)
      common /swdata/ stwtrt(nni)
      common /tbrate/ tbrt(nni)
      common /tbheat/ tbht(nni)
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
      dimension nnz(13)
c
      data nnz/1,2,6,7,8,10,12,14,16,18,20,26,
     &     28/
c      data c5/3.718e-40/,c4/5.957e-52/
      data c1/1.3e-06/,c3/2.2e-01/,c2/2.08e-18/
c
c
      ekt = t*(0.861707)
      tsq = sqrt(t)
c
      if (lpri.gt.2) write (6,*)'in colli:',t
c
      tr = t*1.e+4
      jj = 0
      do 100 n = 1,nel
         nlm = nnz(n)
         do 50 j = 1,nlm
            jj = jj + 1
            cirt(jj) = 0.
            if ( lichk(jj).eq.1 ) then
               e = eth(jj)
               cirt(jj) = cion(nlm,j,e,tr)
               if (lpri.gt.2) write (6,*)jj,nlm,e,j,cirt(jj)
            endif
 50      continue
 100  continue
c
      if (lpri.gt.2) write (6,*)'finishing colli:'
c
c
      return
      end
      subroutine collrd
c
c
c
!-- barry's mods feb. 1990 to interface with subroutine recems to
!--   do recombination continuum.  note well:  changes to line list
!--   or transition numbers will break that routine !
c
      external bigdat,newdat,rr3,nfllns
!--
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel2,
     &   na2,nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /lindat/ elin(nnnl),blin(nnnl),
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &    flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
      common /lindat2/ itrans(nnnl),kion(nni)
!--barry's variables: itrans is a transition number,
!--                   kion is a pointer that gives the index within
!--                      the nnnl-arrays of the first line of ion nni.
c      common /ethrsh/ eth(nni)
      common /linsel/ nlsv(nnnl),nlsvn
      common /o6dat / elm6(20),aa6(20),cs6(20,4),tk6(4)
     &               ,ee6(20),ndx6(20)
      common /o5dat / elm5(20),aa5(20),cs5(20,4),tk5(4)
     &               ,ee5(20),ndx5(20)
      common /o4dat / elm4(200),aa4(200),cs4(200,4),
     &                tk4(4),ee4(200),ndx4(200)
      common /o3dat / elm3(110),aa3(110),cs3(110,4),
     &                tk3(4),ee3(110),ndx3(110)
      common /o2dat / elm2(100),aa2(100),cs2(100,4),
     &                tk2(10,4),ee2(100),ndx2(100)
      common /o1dat / elm1(90),aa1(90),cs1(90,4),tk1(4)
     &               ,ee1(90),ndx1(90)
      common /ne2dat/ elmne2(10),aane2(10),csne2(10,4)
     &               ,tkne2(4),eene2(10),ndxne2(10)
      common /fllndt/ efln(400),nfln(400),jfln(400)
      common /levdat/eexlv(nnml),nilev(nnml),nbcn(nnml),nbcns(nnml),
     $   nlvv(nni)
c
      character*72 ktitle
c
      dimension eth(169)
      dimension ikey(13),nn(13)
      dimension eltp(3),eetp(3),fltp(3)
      dimension eltph(15),eetph(15),fltph(15)
      dimension eltphe(15),eetphe(15),fltphe(15)
      dimension l1bse(13),l2bse(13),l3bse(13),l4bse(13),
     &          l5bse(13),l6bse(13),ln2bse(13)
      dimension nsh(28),lifz(20,28),aa0(10,10)
      dimension gg(10),nprn(10)
c
      data nprn/1,2*2,3,4,5,6,8,16,65/
c      data nprn/1,2*2,3,4,5,6,8,15,60/
      data gg/2.,2.,6.,18.,32.,50.,72.,588.,4970.,670960./
      data aa0/0.,0.,62.57,5.574,1.279,.4123,.1644,3.079e-2,
     $              16.38e-4,38.63e-7,
     $         3*0.,0.7478,0.1812,.0593,0.02380,.4481e-2,2.396e-4,
     $              5.368e-7,
     $         3*0.,3.660,0.6603,0.1936,0.07345,1.315e-2,6.738e-4,
     $              16.10e-7,
     $         4*0.,0.8993,.2201,.07780,1.319e-2,6.474e-4,14.93e-7,
     $         5*0.,.2700,.07714,1.147e-2,5.145e-4,11.51e-7,
     $         6*0.,0.1025,1.144e-2,4.397e-4,9.415e-7,
     $         7*0.,1.392e-2,3.976e-4,8.022e-7,
     $         8*0.,16.74e-4,24.42e-7,
     $         9*0.,49.22e-7,
     $             10*0./
      data lifz/20*0,  0,2*1,3*0,1,0,1,11*1,  20*0, 0,1,1,1,1,1,14*1,
     $         2*0,1,3*0,4*1,10*1,  2*0,1,3*0,2*1,12*1,
     $         0,1,0,1,0,1,0,1,12*1,  5*0,1,0,2*0,1,10*1,
     $         3*0,1,0,3*1,2*1,10*1, 1,0,1,4*0,2*0,1,1,1,8*1,
     $         10*0,2*0,8*1,  2*0,4*1,2*1,1,11*1, 1,2*0,1,0,1,0,1,12*1,
     $         4*0,2*1,14*1,  20*0, 20*0, 20*0, 4*0,1,15*0, 20*0,
     $         20*0, 160*0/
      data nsh/0,2*1,7*2,2*3,6*4,6*5,4*6/
      data l1bse/0,0,0,0,36,45,7*0/
      data l2bse/0,0,0,30,40,50,0,0,80,4*0/
      data l3bse/0,0,0,33,44,55,0,0,88,4*0/
      data l4bse/0,0,40,60,80,0,0,0,160,4*0/
      data l5bse/0,0,4,6,8,10,0,14,16,4*0/
      data l6bse/0,0,4,6,8,0,12,14,16,4*0/
      data ln2bse/0,0,0,0,0,5,6,7,5*0/
 
      data ikey/1,2,4,10,17,25,35,47,61,77,95,
     &     115,141/
      data nn/1,2,6,7,8,10,12,14,16,18,20,26,28/
      data e8447/8847./,e11287/11287./
      data eah,s2h,s3h,s4h,s5h,srh,llh/13.6,0.0,0.000,
     &     0.000,0.000,0.00,5/
      data (eltph(ll),eetph(ll),fltph(ll),ll=1,15)/1216.,10.2,.416,
     &      1026.,12.2,.079,972.0,12.8,.029,949.0,13.1,
     &      0.14,938.0,13.2,.008,6563.,12.1,.641,4862.,
     &      12.8,.120,4335.,13.1,.022,4105.,13.2,0.012,
     &      18790.,12.8,.841,12780.,13.1,.150,10970.,
     &      13.2,0.055,40000.,13.1,1.04,26380.,13.2,.180,
     &      77490.,13.2,.276/
      data (eltphe(ll),eetphe(ll),fltphe(ll),ll=1,15)/304.8,40.8,
     &      .416,256.5,48.4,.079,243.0,51.2,.029,237.2,
     &      52.4,0.014,234.5,52.8,.008,1640.,48.4,.641,
     &      1216.,51.2,.120,1084.,52.4,.022,1026.,52.8,
     &      0.012,4686.,51.2,.841,3195.,52.4,.150,2742.,
     &      52.8,.055,10000.,52.4,1.04,6595.,52.8,.180,
     &      19373.,52.8,.276/
c
c
      lprisv=lpri
c      lpri=3
      if (lpri.ge.1) write (6,*)'in collrd',lpri
c
      jkk = 0
      mmfl = 1
      ne = nel2
      if ( ne.ge.13 ) ne = 13
      kkl = 0
      kklo = kkl
      eps = 1.e-34
      j=9000
      n=0
c
      do 200 no = 1,ne
c
         ix = 0
!-- note all ikey's are nonzero now, so jtst is a superfluous variable.
!--  it is preserved in this version for future flexibility to handle
!--  raymond-smith data files containing elements this code does not hav
         jtst = ikey(no)
c
         isum = 0.
 50      if ( jtst.gt.0 ) jkk = jkk + 1
         if (lpri.ge.2) write (6,*)'j=',j,no
         kion(jkk) = kkl + 1
c
c     the raymond part
         if ( jkk.eq.1 ) then
            niseq = 1
            nlev=10
c            nlev=3
            do 52 mk = 1,nlev
               do 552 mk2=1,nlev
                   if (mk2.le.mk) go to 552
                   if (aa0(mk2,mk).le.1.e-34) go to 552
                   etst=abs(13.598*(1./nprn(mk2)**2-1./nprn(mk)**2))
                   ggu=gg(mk2)
                   ggl=gg(mk)
                   eltst =12398.54/amax1(1.e-34,etst)
                   elammu=eltst*1.e-4
                   aa=1.e7*aa0(mk2,mk)
                   fltmp=ggl*(1.488e-08*ggu*elammu*elammu*aa/ggl)
c                   if (fltmp.lt.1.e-1) go to 552
                   kkl=kkl+1
                   elin(kkl)=eltst
                   eex(kkl) = etst
                   itrans(kkl) = kkl
                   nlsv(kkl) = kkl
                   nlsvn = kkl
                   flin2(kkl)=fltmp
                   flin1(kkl)=flin2(kkl)
                   nilin(kkl) = jkk
                   if (lpri.gt.2)
     $              write (6,*)jkk,kkl,mk,mk2,etst,aa,ggl,ggu,elin(kkl),
     $                elammu,flin1(kkl)
 552               continue
 52             continue
 60         continue
         else
            if (lpri.ge.2) write (6,*)'before read:'
            read (55,99001) n,j,eth(jkk),ea,s2,s3,s5,sr,
     &                      ll
            niseq = n - j + 1
            if ( lpri.ge.2 ) print 99002,no,jtst,jkk,n,j,ll
            iy = ll
            if ( iy.gt.0 ) then
               do 70 l = 1,iy
                  read (55,99003) (eltp(mm),eetp(mm),fltp(mm),mm=1,3)
                  if ( jkk.ne.3 ) then
                     if ( jtst.gt.0 ) then
                        do 62 mk = 1,3
                           if ( eltp(mk).gt.eps ) then
                              kkl = kkl + 1
                              if ( kkl.gt.nnnl ) goto 300
                              itrans(kkl) = (l-1)*3 + mk
                              nlsv(kkl) = kkl
                              nlsvn = kkl
                              elin(kkl) = eltp(mk)
                              eex(kkl) = eetp(mk)
                              flin1(kkl) = fltp(mk)
                              flin2(kkl)=flin1(kkl)
                              nilin(kkl) = jkk
                           endif
 62                     continue
                     endif
                  endif
 70            continue
c
c           go through and zero oscillator strengths for 
c              lines where raymond has scaled them
            nltmp=kkl-kklo
            do 71 ml=1,nltmp
               if (lifz(ml,niseq).ne.1) go to 71
               flin2(kklo+ml)=1.e-12
 71            continue
            endif
c
c     ne ii isosequence for ions neii, mgiv, sivi
c note only one transition per ion included
            if ( niseq.eq.9 .and. no.le.8 ) then
               lk = 1
               lktmp = lk + ln2bse(no)
               eltst = abs(elmne2(lktmp))
               if ( (lktmp.gt.lk) .and. (eltst.gt.0.1) ) then
                  kkl = kkl + 1
!-- barry's transition number is left zero for these lines,
!--   as a flag to non-raymond lines, replacing the old eex=0 flag.
                  itrans(kkl) = 0
                  elin(kkl) = eltst
                  ndxne2(lktmp) = kkl
                  flin1(kkl) = aane2(lktmp)*elin(kkl)*elin(kkl)
     &                        /(6.669e+15)
                  flin2(kkl)=flin1(kkl)
c                 cslin(kkl)=csne2(lktmp,2)
                  cslin(kkl) = 0.
                  eex(kkl) = eene2(lktmp)
                  nilin(kkl) = jkk
                  nlsv(kkl) = kkl
                  nlsvn = kkl
               endif
            endif
 
c     o vi isosequence for ions civ, nv, ovi, mgii, siiv, and svi
            if ( (niseq.eq.3 .and. no.le.5) .or. 
     &           (niseq.eq.11 .and. no.ge.7) ) then
               do 80 lk = 1,2
                  lktmp = lk + l6bse(no)
                  sw=2.
                  if (lk.eq.2) sw=1.
                  eltst = abs(elm6(lktmp))
                  if ( (lktmp.gt.lk) .and. (eltst.gt.0.1) ) then
                     kkl = kkl + 1
                     itrans(kkl) = 0
                     elin(kkl) = eltst
                     ndx6(lktmp) = kkl
                     flin1(kkl) = aa6(lktmp)*elin(kkl)*elin(kkl)
     &                           *sw/(6.669e+15)
                     flin2(kkl)=flin1(kkl)
c                    cslin(kkl)=cs6(lktmp,2)
                     cslin(kkl) = 0.
c                     eex(kkl)= ee6(lktmp)
                     eex(kkl) = 0.
                     nilin(kkl) = jkk
                     nlsv(kkl) = kkl
                     nlsvn = kkl
                  endif
 80            continue
            endif
 
c     o v isosequence for ions ciii, niv, ov,siiv, and sv
            if ( (niseq.eq.4 .and. no.le.6) .or. 
     &           (niseq.eq.12 .and. no.ge.8) ) then
               do 90 lk = 1,2
                  lktmp = lk + l5bse(no)
                  eltst = abs(elm5(lktmp))
                  if ( (lktmp.gt.lk) .and. (eltst.gt.0.1) ) then
                     kkl = kkl + 1
                     itrans(kkl) = 0
                     elin(kkl) = eltst
                     ndx5(lktmp) = kkl
                     flin1(kkl) = aa5(lktmp)*elin(kkl)*elin(kkl)
     &                           /(6.669e+15)
                     flin2(kkl)=flin1(kkl)
c                     cslin(kkl)=cs5(lktmp,2)
                     cslin(kkl) = 0.
                     eex(kkl) = ee5(lktmp)
                     nilin(kkl) = jkk
                     nlsv(kkl) = kkl
                     nlsvn = kkl
                  endif
 90            continue
            endif
 
c     o iv isosequence for ions cii, niii, oiv and siv
            ltrans=0
            if ( (niseq.eq.5 .and. no.le.5) .or. 
     &           (niseq.eq.13 .and. no.ge.9) ) then
               if ( no.eq.3 ) then
                  ltrans = 20
c               elseif ( no.eq.4 ) then
c                  ltrans = 1
               elseif (no.eq.4.or.no.eq.5.or.no.eq.9 ) then
                  ltrans = 10
               endif
               if (lpri.ge.2) write (6,*)'o4 isosequence:',no,l4bse(no)
               if (ltrans.le.0) go to 9099
               do 100 lk = 1,ltrans
                  lktmp = lk + l4bse(no)
                  eltst = abs(elm4(lktmp))
                  if ( (lktmp.gt.lk) .and. (eltst.gt.0.1) ) then
                     kkl = kkl + 1
                     itrans(kkl) = 0
                     elin(kkl) = eltst
                     ndx4(lktmp) = kkl
                     flin1(kkl) = aa4(lktmp)*elin(kkl)*elin(kkl)
     &                           /(6.669e+15)
                     flin2(kkl)=flin1(kkl)
c                     cslin(kkl)=cs4(lktmp,2)
                     cslin(kkl) = 0.
                     eex(kkl) = ee4(lktmp)
                     nilin(kkl) = jkk
                     nlsv(kkl) = kkl
                     nlsvn = kkl
                  endif
 100           continue
 9099          continue
            endif
 
c     o iii isosequence
            if ( (niseq.eq.6 .and. no.le.6) .or. 
     &           (niseq.eq.14 .and. no.ge.9) ) then
               if ( lpri.ge.2 ) print 99004,no,niseq,l3bse(no)
               do 110 lk = 1,11
                  lktmp = lk + l3bse(no)
                  eltst = abs(elm3(lktmp))
                  if ( (lktmp.gt.lk) .and. (eltst.gt.0.1) ) then
                     kkl = kkl + 1
                     itrans(kkl) = 0
                     elin(kkl) = eltst
                     ndx3(lktmp) = kkl
                     flin1(kkl) = aa3(lktmp)*elin(kkl)*elin(kkl)
     &                           /(6.669e+15)
                     flin2(kkl)=flin1(kkl)
c                     cslin(kkl)=cs3(lktmp,2)
                     cslin(kkl) = 0.
                     eex(kkl) = ee3(lktmp)
                     nilin(kkl) = jkk
                     nlsv(kkl) = kkl
                     nlsvn = kkl
                  endif
 110           continue
            endif
c
c     o ii  isosequence
            if ( (niseq.eq.7 .and. no.le.6) .or. 
     &           (niseq.eq.15 .and. no.ge.9) ) then
               do 120 lk = 1,10
                  lktmp = lk + l2bse(no)
                  eltst = abs(elm2(lktmp))
                  if ( (lktmp.gt.lk) .and. (eltst.gt.0.1) ) then
                     kkl = kkl + 1
                     itrans(kkl) = 0
                     elin(kkl) = eltst
                     ndx2(lktmp) = kkl
                     flin1(kkl) = aa2(lktmp)*elin(kkl)*elin(kkl)
     &                           /(6.669e+15)
                     flin2(kkl)=flin1(kkl)
c                     cslin(kkl)=cs2(lktmp,2)
                     cslin(kkl) = 0.
                     nilin(kkl) = jkk
                     eex(kkl) = ee2(lktmp)
                     nlsv(kkl) = kkl
                     nlsvn = kkl
                  endif
 120           continue
            endif
c
c     o i  isosequence
            if ( niseq.eq.8 .and. no.le.6 ) then
               do 130 lk = 1,9
                  lktmp = lk + l1bse(no)
                  eltst = abs(elm1(lktmp))
                  if ( (lktmp.gt.lk) .and. (eltst.gt.0.1) ) then
                     kkl = kkl + 1
                     itrans(kkl) = 0
                     elin(kkl) = eltst
                     ndx1(lktmp) = kkl
                     flin1(kkl) = aa1(lktmp)*elin(kkl)*elin(kkl)
     &                           /(6.669e+15)
                     flin2(kkl)=flin1(kkl)
c                     cslin(kkl)=cs1(lktmp,2)
                     cslin(kkl) = 0.
                     nilin(kkl) = jkk
                     eex(kkl) = ee1(lktmp)
                     nlsv(kkl) = kkl
                     nlsvn = kkl
                  endif
 130           continue
            endif
c
c        o i lines (not collisional excitation)
            if ( jkk.eq.17 ) then
               kkl = kkl + 1
               itrans(kkl) = 0
               nlsv(kkl) = kkl
               nlsvn = kkl
               elin(kkl) = e8447
               eex(kkl) = 0.
               flin1(kkl) = 0.
               flin2(kkl)=flin1(kkl)
               nilin(kkl) = jkk
               kkl = kkl + 1
               nlsv(kkl) = kkl
               nlsvn = kkl
               elin(kkl) = e11287
               eex(kkl) = 0.
               flin1(kkl) = 0.
               flin2(kkl)=flin1(kkl)
               nilin(kkl) = jkk
            endif
c
c        fe ii lines
            if ( jkk.eq.116 ) then
               kkl = kkl + 1
               itrans(kkl) = 0
               nlsv(kkl) = kkl
               nlsvn = kkl
               elin(kkl) = 2600.
               eex(kkl) = 0.
               flin1(kkl) = 0.
               flin2(kkl)=flin1(kkl)
               nilin(kkl) = jkk
               kkl = kkl + 1
               nlsv(kkl) = kkl
               nlsvn = kkl
               elin(kkl) = 5000.
               eex(kkl) = 0.
               flin1(kkl) = 0.
               flin2(kkl)=flin1(kkl)
               nilin(kkl) = jkk
            endif
c
c
            if ( jkk.eq.3 ) then
c           helium ii
               ll = 5
               if ( lpri.ge.2 ) print 99002,no,jtst,jkk,n,j,
     &                                ll
               iy = ll
               if ( iy.gt.0 ) then
                  do 135 l = 1,iy
                     eltp(1) = eltphe(1+3*(l-1))
                     eetp(1) = eetphe(1+3*(l-1))
                     fltp(1) = fltphe(1+3*(l-1))
                     eltp(2) = eltphe(2+3*(l-1))
                     eetp(2) = eetphe(2+3*(l-1))
                     fltp(2) = fltphe(2+3*(l-1))
                     eltp(3) = eltphe(3+3*(l-1))
                     eetp(3) = eetphe(3+3*(l-1))
                     fltp(3) = fltphe(3+3*(l-1))
                     if ( jtst.gt.0 ) then
                        do 132 mk = 1,3
                           if ( eltp(mk).gt.eps ) then
                              kkl = kkl + 1
                              itrans(kkl) = (l-1)*3 + mk
                              if ( kkl.gt.nnnl ) goto 300
                              nlsv(kkl) = kkl
                              nlsvn = kkl
                              elin(kkl) = eltp(mk)
                              eex(kkl) = eetp(mk)
                              flin1(kkl) = fltp(mk)
                              flin2(kkl)=flin1(kkl)
                              nilin(kkl) = jkk
                           endif
 132                    continue
                     endif
c
c        hydrogen.
 135              continue
               endif
            endif
         endif
c
c        add the fluorescence lines
         nshmx = nsh(niseq)
         nflntp = 0
         if ( nshmx.gt.0 ) then
            do 140 nflntp = 1,nshmx
               efltp = 9.e+4
               if ( jkk.eq.nfln(mmfl) ) then
                  efltp = efln(mmfl)
                  mmfl = mmfl + 1
               endif
               kkl = kkl + 1
               nlsv(kkl) = kkl
               nlsvn = nlsvn + 1
               elin(kkl) = efltp
               cslin(kkl) = 0.
               eex(kkl) = 0.
               nilin(kkl) = jkk
               flin1(kkl) = 0.
               flin2(kkl)=flin1(kkl)
c               write (6,*)jkk,kkl,mmfl,efltp
 140        continue
         endif
c
         if ( jtst.gt.0 ) nlin(jkk) = kkl - kklo
         if ( lpri.ge.2 ) print 99005,jkk,kkl,kklo,nlin(jkk)
         kklo = kkl
c
         if ( n.gt.j ) goto 50
c
c
 200  continue
c
 300  do 400 mm = nlsvn,nnnl
         elin(mm) = 1.0e10
         flin1(mm) = 1.e-20
         flin2(mm)=flin1(mm)
         eex(mm) = 1.e-20
         nilin(mm) = nni + 1
         nblin(mm) = ncn
         blin(mm) = 0.
         cslin(mm) = 0.
         sxlin(mm) = 0.
 400  continue
c
      if ( lpri.eq.0 ) return
c     write (6,9989)(mm,elin(mm),flin1(mm),eex(mm),nilin(mm),mm=1,nlsvn)
c9989  format (1h ,i4,3e12.4,i4)
      write (1,99006)
      no = 1
      do 500 mm = 1,nlsvn - 1
         if ( no.ne.13 ) then
            if ( nilin(mm).eq.ikey(no+1) ) then
               no = no + 1
            endif
         endif
         n = nn(no)
         j = nilin(mm) - ikey(no) + 1
         jk = nilin(mm)
         write (6,99007) mm,n,j,itrans(mm),elin(mm),eex(mm),
     &                   flin1(mm),flin2(mm),cslin(mm),sxlin(mm), 
     &                   nilin(mm),nlin(jk),kion(jk)
 500  continue
c
      lpri=lprisv
c
      return
99001 format (2i5,f5.0,5f7.0,i5)
99002 format (' ',6i4)
99003 format (9f6.0)
99004 format (' ',' o3 seq ',3i4)
99005 format (' ',4i4)
99006 format (' ',' in collrd '/'   mm   n   j   nt wavelength',
     &        '     eex(ev)      flin   nilin nlin kion'/)
99007 format (' ',4i4,1p6e12.3,3i5)
c
      end
      subroutine comp
c
c
c
c
c     this subroutine computes the heating - cooling due to compton
c     scattering.  the rate is returned in the common block coheat.
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /temp  / t,to
      common /spectc/ bremsa(ncn),brems(ncn),zrems(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /spectl/ fline(ncn)
      common /coheat/ cmp1,cmp2,cohc
      common /enerc / epi(ncn),dele(ncn),numcon
c
      character*72 ktitle
c
      data c1o/1.301e-30/,c2/8.219e-06/,c3/1.6863e-06/
c
      lprisv=lpri
c      lpri=3
      if (lpri.ge.1) write (6,*)'in comp'
c
      sigth = 6.65e-25
c      c1 = c1o/sigth
      c1=1.95639e-6
      tmp1 = 0.
      tmp2 = 0.
      c2 = 0.
c
c     due to continuum.
c      fac1=bremsa(1)*(1.e+38)*epi(1)*(1.-c2*epi(1))
c      fac3=bremsa(1)*(1.e+38)*4.
      fac1 = sigth*bremsa(1)*epi(1)*(1.-c2*epi(1))
      fac3 = sigth*bremsa(1)*4.
c
      if ( lpri.gt.2 ) write (6,*) 'in comp'
c
      do 100 i = 2,numcon
c
         delt = epi(i) - epi(i-1)
c         fac2=bremsa(i)*(1.e+38)*epi(i)*(1.-c2*epi(i))
         fac2 = sigth*bremsa(i)*epi(i)*(1.-c2*epi(i))
         tmp1 = tmp1 + (fac1+fac2)*delt/2.
         fac1 = fac2
c         fac4=bremsa(i)*(1.e+38)*4.
         fac4 = sigth*bremsa(i)*4.
         tmp2 = tmp2 + (fac3+fac4)*delt/2.
         fac3 = fac4
         if ( lpri.gt.2 ) write (6,99001) i,epi(i),bremsa(i),
     &                           fac1,fac3,tmp1,tmp2
 100  continue
c
      ebar = tmp1*4./(1.e-30+tmp2)
      if ( lpri.gt.2 ) write (6,*) 'ebar=',ebar
c
c
      if (lpri.gt.2)  write (6,*)c1,tmp1,tmp2
      cmp1 = c1*tmp1
      cmp2 = c1*tmp2
      if (lpri.gt.2) write (6,*)cmp1,cmp2
      lpri=lprisv
c
      return
99001 format (' ',i4,6e12.4)
      end
      subroutine comp2
c
c
c
c
c
c     this routine calculates the compton heating-cooling
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /comptn/ de(61,61),e(61),sx(61),dez(61),ez(61)
      common /temp  / t,to
      common /spectc/ bremsa(ncn),brems(ncn),zrems(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /coheat/ cmp1,cmp2,cohc
      common /enerc / epi(ncn),dele(ncn),numcon
c
      character*72 ktitle
c
      data emc2/5.11e+5/,sigth/6.65e-25/,ergsev/1.602197e-12/
c
      if (lpri.ge.1) write (6,*)'in comp2'
c
      ekt = t*0.861707
      xx = emc2/(ekt+1.e-10)
      sxx = 1./xx
      zrmstp = bremsa(1)
      eee = epi(1)
      ee = eee/emc2
      tmp1 = zrmstp*cmpfnc(ee,sxx)
      sum1 = 0.
      do 100 kl = 2,numcon
         tmp1o = tmp1
         eeeo = eee
         eee = epi(kl)
         ee = eee/emc2
         zrmstp = bremsa(kl)
         tmp1 = zrmstp*cmpfnc(ee,sxx)
         sum1 = sum1 + (tmp1+tmp1o)*(eee-eeeo)/2.
 100  continue
      ans = sum1
      cohc = -ans*sigth
c    $    *1.e+38
c
      return
c     print 9924,jk,kl,sxx,ee,zrmstp,tmp1,sum0,sum1
99001 format (' ',2i4,6e12.4)
c     print 9922,jk,t,sxx,sum1,sum0,ans
99002 format (' ',' the answer ',i4,5e12.4)
      end
      function cvmgp(a,b,c)
c
      real a,b,c,cvmgp
c
      if ( c.ge.0. ) then
         cvmgp = a
         return
      endif
      cvmgp = b
      return
      end
      function delt(n,j,l)
c
      external bigdat,newdat,rr3,nfllns
c
      real delt
      integer i,j,l,n
c
c  our very own modifications to jacobs
c  density dependence external
c  take 0.5 for merts et al   delta n .ne. 0 except s
c  assume 3d of n,o,f interp between c and ne isosequences
c  this uses younger'ar claim that delt=1 for he-like resonance line;
c  try bely-dubau??????
      delt = 0.
      if ( j.eq.1 ) return
      i = n - j + 1
      if ( l.eq.12 .and. i.ne.10 ) then
         delt = 1.
      else
         if ( l.eq.1 .and. i.gt.2 ) then
            if ( i.ne.13 ) then
               delt = 1.
               goto 100
            endif
         endif
         if ( i.ge.19 ) then
            delt = 0.25
         elseif ( i.eq.18 ) then
            delt = 0.25
            if ( l.le.3 ) delt = 1.
            if ( n.ne.20 ) return
            delt = 0.
            if ( l.eq.6 ) delt = 0.05
         else
            if ( i.lt.15 ) then
               if ( i.eq.2 ) then
                  if ( l.eq.4 .or. l.eq.5 ) delt = 0.1
                  if ( l.eq.9 ) delt = 1.0
               elseif ( i.eq.3 ) then
                  if ( l.ge.2 .and. l.le.4 )
     &                 delt = .5*(-.35+1.26*n/(n+11.))
               elseif ( i.eq.4 ) then
                  if ( l.eq.7 ) delt = amax1(0.5*(-.55+1.50*n/(n+11.)),
     &                                 0.05)
               elseif ( i.eq.5 ) then
                  if ( l.le.6 ) delt = 1.
                  if ( l.eq.4 .or. l.eq.5 )
     &                 delt = 0.5*(-.54+2.2*n/(n+11.))
               elseif ( i.eq.6 ) then
                  if ( l.le.5 ) delt = 1.
                  if ( l.eq.4 ) delt = amax1(0.5*(-1.28+3.2*n/(n+11)),
     &                                 0.05)
               elseif ( i.eq.7 ) then
                  if ( l.eq.4 ) delt = 1.
                  if ( l.eq.5 ) delt = amax1(0.5*(-1.44+3.4*n/(n+11.)),
     &                                 0.05)
                  if ( l.eq.7 ) delt = amax1(0.25*(-1.44+3.4*n/(n+11.)),
     &                                 0.025)
               elseif ( i.eq.8 ) then
                  if ( l.le.3 ) delt = 0.5*(-1.60+3.6*n/(n+11.))
                  if ( l.eq.4 .or. l.eq.5 ) delt = 1.
                  if ( l.eq.7 ) delt = .25*(-1.6+3.6*n/(n+11.))
                  if ( l.eq.15 ) delt = 1.
               elseif ( i.eq.9 ) then
                  if ( l.le.3 ) delt = 0.5*(-1.75+3.8*n/(n+11.))
                  if ( l.eq.5 ) delt = 1.
                  if ( l.eq.6 ) delt = 0.25*(-1.75+3.8*n/(n+11.))
               elseif ( i.eq.10 ) then
                  if ( l.le.2 ) delt = 1.
                  if ( l.ge.3 .and. l.le.5 )
     &                 delt = 0.5*(-1.9+4.0*n/(n+11.))
                  if ( l.ge.6 .and. l.lt.8 )
     &                 delt = .25*(-1.9+4.*n/(n+11.))
                  if ( l.eq.14 ) delt = 1.
               elseif ( i.eq.11 ) then
                  if ( l.eq.2 .or. l.eq.3 .or. l.eq.6 ) delt = .25
               elseif ( i.eq.12 ) then
                  if ( l.eq.2 ) delt = .25
               elseif ( i.eq.13 ) then
                  if ( l.eq.2 .or. l.ge.9 ) delt = 1.
                  if ( l.eq.3 .or. l.eq.5 ) delt = .5
                  if ( l.eq.7 ) delt = 0.25
               elseif ( i.eq.14 ) then
                  goto 20
               else
c   burgess & tworkowski are in alphadi
                  if ( l.eq.1 ) delt = 1.
                  if ( l.gt.1 ) delt = 0.1
                  if ( l.eq.5 ) delt = 0.
               endif
               goto 100
            endif
 20         if ( l.le.2 ) delt = 1.
            if ( l.eq.3 .or. l.eq.4 ) delt = .25
         endif
      endif
 100  return
      end
      subroutine diden
c
c
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /rrdat2/ adi(nni),bdi(nni),t0(nni),t1(nni)
      common /rrdat3/ edi(nni),ap(nni),cdd(nni),ndi(nni)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
      if (lpri.ge.1) write (6,*)'in diden'
c
      enn = xpx**(0.2)
c
      do 100 jk = 1,nni
         ap(jk) = 1.
         if ( lichk(jk).eq.1 ) then
            ap(jk) = 1./(1.+cdd(jk)*enn)
         endif
 100  continue
c
c
      return
      end
      subroutine dircem
c
c
c
c
c     htis routine computes emmissivities due to dielectronic
c     recombination.
c
      external bigdat,newdat,rr3,nfllns
c
c
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /abel  / xel(nl),xeln(nni),xelln(nnnl)
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /diemis/ diem(nnnl)
      common /lindat/ elin(nnnl), blin(nnnl),
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &     flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
c
c
      if (lpri.ge.1) write (6,*)'in dircem'
c
      kkk = 0
      do 100 jk = 1,nni
         nalim = nlin(jk)
         abund = xiip(jk)*xeln(jk)*xpx*xnx
         do 50 kk = 1,nalim
            kkk = kkk + 1
            diem(kkk) = diem(kkk)*abund
 50      continue
 100  continue
c
c
c
      return
      end
      real function drat(n,iso)
c
      external bigdat,newdat,rr3,nfllns
c
      real dratg1,dratg2
      integer iso,n,nob
c
c***
c*** returns the degeneracy ratio for recombination from the ground leve
c***   of the unrecombined ion of element n to the ground term of the
c***   recombined ion.
c***
c*** internal arrays:
c***   dratg1(iso), the deg. ratio for recomb. to ground term for
c***      isosequences thru argon-like, the same for all elements.
c***   dratg2(iso-18,iel), the deg. ratio for recomb. to ground term for
c***      isosequences above argon-like, different for each element,
c***      where the second arg is 1=ca, 2=fe, 3=ni.
c***
      dimension dratg1(18),dratg2(10,3)
 
      data dratg1/2.,.5,2.,.5,6.,1.5,.44,2.25,.667,
     &     .167,2.,.5,6.,1.5,.44,2.25,.667,.167/
      data dratg2/2.,.5,8*0.,10.,2.1,1.33,.89,.24,4.17,
     &     1.17,.833,2*0.,10.,2.1,1.33,.89,.24,4.17,
     &     1.12,.75,.476,2.1/
c***
c*** set drat to zero, mostly for debugging flag.
      drat = 0.
 
      if ( iso.le.18 ) then
         drat = dratg1(iso)
      else
         if ( n.eq.20 ) nob = 1
         if ( n.eq.26 ) nob = 2
         if ( n.eq.28 ) nob = 3
         drat = dratg2(iso-18,nob)
      endif
      return
      end

      subroutine dsec(lnerr,nlim,crit,critt,ensfrc,lppri)
c
c
c
c
c     this routine solves for temperature and electron density by the
c     double secant method
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /temp  / t,to
      common /tlim  / tinf
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /heat  / httot,cltot,hmctot
      common /elect / elcter
      common /numit / lnerrs,lnerrd,ntmpit,nelit,ntotit,
     &                npttit,nstpnm
c
      character*72 ktitle
c
      if (lpri.ne.0) write (6,*)'in dsec'
c
      nnt = 0
      nntt=0
      lnerr = 0
      lppri0 = lppri
      nlimt = nlim
      nlimx = nlim*2
      nlimtt=max0(nlimt/10,1)
      nlimxx=max0(nlimx/10,1)
c      write (6,*)'nlimtt,nlimxx,lppri--',nlimtt,nlimxx,lppri
      fact = 1.1
      facx = 1.1
      epst = crit
      epsx = crit
      epstt = critt
      epsxx = critt
      to = 1.e+30
      tl = 0.
      th = 0.
      xeel = 0.
      xeeh = 0.
      elctrl = 0.
      elctrh = 0.
      hmctth = 0.
      hmcttl = 0.
c
      iht = 0
      ilt = 0
      iuht = 0
      iult = 0
c
 100  nnx = 0
      nnxx=0
      ihx = 0
      ilx = 0
      xeeo = 1.e+30
 200  call func(lferr)
c     go to 302
c     if (nnx.gt.(nlim/2)) lppri=1
      if ( lppri.lt.0 ) write (6,99001) nnx,xee,xeel,xeeh,
     &                                  elcter,elctrl,elctrh
      npttit = npttit + 1
      ntotit = ntotit + 1
      nnx = nnx + 1
      if (lferr.ne.0) nnxx=nnxx+1
      if (nnxx.ge.nlimxx) go to 300
c      write (6,*)'nnx,nnxx,lferr--',nnx,nnxx,lferr
      if ( nnx.ge.nlimx ) then
c
         lnerr = 1
c        if (lppri.eq.0) go to 202
         write (6,99002)
         write (6,99003) nnx,xee,xeel,xeeh,elcter,elctrl,
     &                   elctrh
         goto 500
      else
         if ( elcter.lt.0 ) then
            ihx = 1
            xeeh = xee
            elctrh = elcter
            if ( ilx.ne.1 ) then
               xee = xee*facx
               goto 200
            endif
         elseif ( elcter.eq.0 ) then
            goto 300
         else
            ilx = 1
            xeel = xee
            elctrl = elcter
            if ( ihx.ne.1 ) then
               xee = xee/facx
               goto 200
            endif
         endif
         test = abs(elcter)
         if ( test.gt.epsx ) then
            testx = abs(1.-xee/xeeo)
            if ( testx.lt.epsxx ) then
c
               lnerr = -1
               if ( lppri.lt.0 ) then
                  write (6,99004)
                  write (6,99003) nnx,xee,xeel,xeeh,elcter,
     &                            elctrl,elctrh
               endif
            else
               xeeo = xee
               xee = (xeel*elctrh-xeeh*elctrl)/(elctrh-elctrl)
               goto 200
            endif
         endif
      endif
c
c
c     if (nnt.gt.(nlim/2)) lppri=1
 300  if ( lppri.lt.0 ) write (6,99005) nnt,t,tl,th,hmctot,
     &                                  hmcttl,hmctth
      if (lferr.ne.0) nntt=nntt+1
      nnt = nnt + 1
c     call htprt
      if (nntt.ge.nlimtt) go to 500
      if ( nnt.lt.nlimt ) then
         if ( hmctot.lt.0 ) then
            iht = 1
            th = t
            hmctth = hmctot
            hmctht = hmctth
            iuht = 1
            if ( iult.eq.0 ) hmcttl = hmcttl/2.
            iult = 0
            if ( ilt.ne.1 ) then
               t = t/fact
               t = amax1(t,tinf)
               if ( t.ge.tinf ) goto 100
               goto 400
            endif
         elseif ( hmctot.eq.0 ) then
            goto 500
         else
            ilt = 1
            tl = t
            hmcttl = hmctot
            hmctlt = hmcttl
            iult = 1
            if ( iuht.eq.0 ) hmctth = hmctth/2.
            iuht = 0
            if ( iht.ne.1 ) then
               t = t*fact
               goto 100
            endif
         endif
         test = abs(hmctot)
         if ( test.le.epst ) goto 500
         testt = abs(1.-t/to)
         if ( testt.lt.epstt ) then
c
            lnerr = -2
            if ( lppri.lt.0 ) then
               write (6,99004)
               write (6,99006) nnt,t,tl,th,hmctot,hmcttl,
     &                         hmctth
            endif
            goto 500
         else
            to = t
            t = (tl*hmctth-th*hmcttl)/(hmctth-hmcttl)
            t = amax1(t,tinf)
            if ( t.gt.tinf ) goto 100
         endif
      endif
c
 400  lnerr = 2
c     if (lppri.eq.0) go to 202
      write (6,99002)
      write (6,99006) nnt,t,tl,th,hmctot,hmcttl,hmctth
      t = amax1(t,tinf)
c
 500  if ( lppri.lt.0 ) write (6,99007) test,epst,hmctot
      ntmpit = ntmpit + nnt
      nelit = nelit + nnx
      lppri = lppri0
c
      return
99001 format (' ',' electrons -- ',i4,6e12.4)
99002 format (' ','**** note: in dsec --  too many iterations **** ')
99003 format (' ',' electrons ',i4,6e16.8)
99004 format (' ',' warrning -- dsec not converging ')
99005 format (' ',' temperature --',i4,6e12.4)
99006 format (' ',' temperature ',i4,6e16.8)
99007 format (' ',' finishing dsec -- test,epst,hmctot',3e12.4)
      end
      function ee1(x)
c
      real ee1,expo,x
c
c
c
c     this routine computes the first exponential integral.
c
c
c
c
      if ( x.ge.1. ) then
         ee1 = (1./x)*(0.250621+x*(2.334733+x))/(1.68153+x*(3.330657+x))
         return
      endif
c
      ee1 = (-alog(x)-0.57721566+
     &      x*(0.99999193+x*(-0.24991055+x*(0.05519968+
     &      x*(-0.00976004+x*0.0010707857)))))*expo(x)
c
      return
      end
      subroutine egrat
c
c
c
c
c     this routine computes hydrogenic recombination rates.
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /temp  / t,to
      common /hrcrte/ hrcrt(20,28),hrcrtt(28)
c
      character*72 ktitle
c
      dimension hrec(520),temp(520),zz(520),enn(520)
c
      equivalence (hrec(1),hrcrt(1,1))
c
      data c1/5.195e-14/,etkh/13.598/
c
      ekt = t*(0.861707)
c
      if ( lpri.ge.1 ) write (6,*) 'in egrat'
c
      do 100 nnz = 1,26
         z = float(nnz)
         const = etkh*z*z/ekt
         nnn = 20*(nnz-1)
         do 50 n = 1,20
            temp(nnn+n) = min((const/(float(n)*float(n))),160.)
            enn(nnn+n) = float(n)
            zz(nnn+n) = z
 50      continue
 100  continue
c
      hsum=0.
      jsv=0
      do 200 j = 1,520
c         if ( temp(j).le.1. ) then
c            tmp1 = (-alog(temp(j))-0.57721566+temp(j)
c     &             *(0.99999193+temp(j)
c     &             *(-0.24991055+temp(j)*(0.05519968+temp(j)
c     &             *(-0.00976004+temp(j)*0.0010707857)))))*expo(temp(j))
c         else
c            tmp1 = (0.250621+temp(j)*(2.334733+temp(j)))
c     &             /(1.68153+temp(j)*(3.330657+temp(j)))/temp(j)
c         endif
 300     continue
         tmp1=exint1(temp(j),2)
         hrec(j) = ((3.262e-12)*tmp1*zz(j)**4)/(t**(1.5)*enn(j)**3)
         hsum=hsum+hrec(j)
         if (mod(j,20).ne.0) go to 200
           jsv=jsv+1
           hrcrtt(jsv)=hsum
           hsum=0.
 200  continue
      if ( lpri.gt.2 ) write (6,99001) hrec
c
c
      return
99001 format (' ',9e12.4)
      end
      function eheat(e)
c
      real e,eheat
c
      eheat = e
      return
      end
      subroutine electt
c
c
c
c
c     this routine computes the electron number density function.
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /elect / elcter
      common /temp  / t,to
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /abel  / xel(nl),xeln(nni),xelln(nnnl)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
      dimension nell(nni)
c
      data nell/1,1,2,1,2,3,4,5,6,1,2,3,4,5,
     &     6,7,1,2,3,4,5,6,7,8,1,2,3,4,5,
     &     6,7,8,9,10,1,2,3,4,5,6,7,8,9,10,
     &     11,12,1,2,3,4,5,6,7,8,9,10,11,12,
     &     13,14,1,2,3,4,5,6,7,8,9,10,11,12,
     &     13,14,15,16,1,2,3,4,5,6,7,8,9,10,
     &     11,12,13,14,15,16,17,18,1,2,3,4,5,
     &     6,7,8,9,10,11,12,13,14,15,16,17,18,
     &     19,20,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,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/
c
      xeel = xee
c
      xee = 0.
c
      if (lpri.ge.1) write (6,*)'in electt'
c
      do 100 jk = 1,nni
         if ( lichk(jk).eq.1 ) then
            xtmp = nell(jk)*xiip(jk)*xeln(jk)
            xee = xee + xtmp
         endif
 100  continue
c
c
c
      elcter = 1. - xee/xeel
c
      xee = xeel
c
c
      xnx = xee*xpx
c
      return
      end
      subroutine ener
c
      external bigdat,newdat,rr3,nfllns
c
      real dele,dele1,dele2,dele3,dele4,epi
      integer kl,klm,ll,ml,nener1,nener2,nener3,nener4,
     &        numcon
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common /enerc / epi(ncn),dele(ncn),numcon
c
c
      numcon = ncn
      numcon = ncn
c     4 regions
      ebnd1=1.e-7
      ebnd2=9.
c      ebnd2=2.
      ebnd3=2.e+4
c      ebnd3=200.
      ebnd4=5.11e+5
      epi(1) = ebnd1
      kl = 1
      dele1 = 10.
      nener1 = 6
      do 100 ll = 1,nener1
         kl = kl + 1
         epi(kl) = epi(kl-1)*dele1
 100  continue
      nener2 = ncn/10
      dele2 = (ebnd2/epi(kl))**(1./float(nener2-1))
      do 200 ml = 1,nener2
         kl = kl + 1
         epi(kl) = epi(kl-1)*dele2
 200  continue
      nener4 = max(10,ncn/100)
      dele4 = (ebnd4/ebnd3)**(1./float(nener4-1))
      klm = numcon
      epi(numcon) = ebnd4
      do 300 ml = 1,nener4
         klm = klm - 1
         epi(klm) = epi(klm+1)/dele4
 300  continue
      nener3 = klm - kl
      dele3 = (epi(klm)/epi(kl))**(1./float(nener3-1))
      do 400 ml = 1,nener3
         kl = kl + 1
         epi(kl) = epi(kl-1)*dele3
 400  continue
c
      return
c
c      write (6,9901)(epi(mm),mm=1,numcon)
99001 format (4x,5e12.4,' - ')
c
c
      end
      function ensc(tautz,aaaa)
c
      external bigdat,newdat,rr3,nfllns
c
      real aaaa,ensc,tautz
c
      if ( tautz.ge.5. ) then
         ensc = tautz*(1.6+(1.5)/(1.+(0.2)*aaaa*tautz))
      else
         ensc = tautz*((6.5)*tautz-alog(amax1(tautz,1.e-30)))
     &          /(1.+2.*tautz)
         ensc = amax1(ensc,1.)
      endif
      return
      end

      subroutine errbnd(lferr)
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /linsel/ nlsv(nnnl),nlsvn
      common /prs   / p,p0
      common /temp  / t,to
      common /sigh  / zeta
      common /nmrc  / numrec,npass
      common /tlim  / tinf
      common /dpttau/ tauth
      common /xcol  / xcc(183)
      common /icc   / lichk(nni),lipin
      common /prtop / elnprnt(400),elimdb(2),nstpt,nlnprnt,lstpt(20)
      common /enerc / epi(ncn),dele(ncn),numcon
      common /spectc/ bremsa(ncn),brems(ncn),zrems(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /radius/delr,r,rl,rmax,rdel,radexp,rscale,rsave
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /itdat / enfmxs,ensfrc,critd,crittd,epss,crits,
     $             kmaxs,lppris,nlimd,lpprid,nnmax
      common /comptn/ de(61,61),e(61),sx(61),dez(61),ez(61)
      common /tmper/ ntmper,ntmpermx
c
      character*72 ktitle
c
      if (lpri.ge.1) write (6,*)'in errbnd'
c
      lferr=0
      lerr = 5
c      if ( xpx.gt.1.e+15 ) lerr = 1
      if ( t.gt.3.e+8 ) lerr = 2
      if ((t.le.tinf).and.(nlimd.gt.0)) lerr = 3
c      if ( tauth.gt.1. ) lerr = 4
      if ( lerr.eq.2 ) then
         write (6,*) '**** error: temperature too large ****'
         stop
      elseif ( lerr.eq.3 ) then
         ntmper=ntmper+1
         t = amax1(t,tinf)
         lferr=1
c         if (ntmper.lt.ntmpermx) return  
c         write (6,*)'**** warning: temperature too small, iteration ',
c     $     'disabled ****'
         return
      elseif ( lerr.eq.4 ) then
         write (6,*) '**** error: thomson depth too large ****'
         stop
      elseif ( lerr.ne.5 ) then
         write (6,*) '**** error: density out of bounds ****'
         stop
      endif
c
c
      return
      end
      function exint1(xs,jump)
c
      real*8 exint1d, x,x2,x3,x4
      integer jump
c
c     r. moore october 1976
c   jump=1    exint1=e1(x)
c   jump=2    exint1=expo(x)*e1(x)
c   jump=3    exint1=x*expo(x)*e1(x)
      x=xs
      if ( x.ge.1.d0 ) then
         x2 = x*x
         x3 = x2*x
         x4 = x3*x
         exint1d = (x4+8.5733287401d0*x3+18.059016973d0*x2+
     &            8.6347608925d0*x+.2677737343d0)
     &            /(x4+9.5733223454d0*x3+25.6329561486d0*x2+
     &            21.0996530827d0*x+3.9584969228d0)
         exint1=exint1d
         if ( jump.eq.2 ) then
            exint1 = exint1/xs
         elseif ( jump.ne.3 ) then
            exint1 = exint1*expo(-xs)/xs
            return
         endif
      else
         exint1d = ((((((((7.102452d-7*x-1.766345d-6)*x+2.928433d-5)*x-
     &            .0002335379d0)*x+.001664156d0)*x-.01041576d0)
     &            *x+.05555682d0)*x-.2500001d0)*x+.9999999d0)*x - log(x)
     &            - .57721566490153d0
         exint1=exint1d
         if ( jump.eq.1 ) then
         elseif ( jump.eq.3 ) then
            exint1 = xs*expo(xs)*exint1
            return
         else
            exint1 = expo(xs)*exint1
            return
         endif
      endif
      return
      end
      real function expcal(chi,i,kt)
c
      external bigdat,newdat,rr3,nfllns
c
      real chi,dele,delle,deltae,ecen,eminus,epi,eplus
      integer i,numcon
c
c 
c*** returns the integral of exp(-e/kt) over an interval centered (in so
c***   sense) on energy point epi(i).
c*** for feb. 1990 version, points are log spaced, so choose bin centers
c***   also log spaced to make error in trapezoidal rule for power law
c***   small when it is removed from the integration.
 
      real kt
 
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common /enerc / epi(ncn),dele(ncn),numcon
 
c*** statement function, dependent on current choice of bins.  for
c***   arbitrary bins, replace ecen with an external function like nbinc
c*** n.b. e(i-1) < ecen(i-1) < e(i) < ecen(i) < e(i+1)
c      ecen(i) = 10.**((i-0.5)*delle - 1.)
      ecen(i) = sqrt(epi(i)*epi(min0(i+1,numcon)))
 
c*** this value of delle is loaded in barry's version of ener, feb. 1990
      delle = dele(1)
 
      eminus = ecen(i-1)
      eplus = ecen(i)
      deltae = eplus - eminus
      expcal = kt*(exp((chi-eminus)/kt)-exp((chi-eplus)/kt))/deltae
c      write (6,*)'in expcal,',chi,i,kt,eminus,eplus,expcal
      return
      end
      function expo(x)
c
c      real*8 x8,dexpo
c
c      x8=x
c      dexpo=dexp(dmin1(dmax1(x8,-600.d0),600.d0))
c      dexpo=exp(min(max(x8,-600.0),600.0))
c      expo=dexpo
      expo=exp(min(amax1(x,-30.),30.))
c
      return
      end
      function fbg(u,gam)
c
c     this function computes the free-free gaunt factor
c      u=h nu/kT
c      gam=z**2 Ry/kT
c         z=charge of scattering ion
c         Ry=rydberg constant
c         kT=kT, etc.
c 
      external bigdat,newdat,rr3,nfllns
c
      real a,a1,a2,a3,ai,ak,born,fbg,g1,g2,gam,
     &     gam1,gam2,gam3,p,power,t,u,u1,u2
      real u4
      integer m,m1,n
c
c      real*8 t,ai,ak,u4
      dimension a(6,7,3),gam2(6),gam3(6)
      dimension a1(6,7),a2(6,7),a3(6,7)
c
      equivalence (a1(1,1),a(1,1,1)),(a2(1,1),a(1,1,2)),
     &             (a3(1,1),a(1,1,3))
c
      data gam2/.7783,1.2217,2.6234,4.3766,20.,70./
      data gam3/1.,1.7783,3.,5.6234,10.,30./
      data a1/1.001,1.004,1.017,1.036,1.056,1.121,1.001,
     &     1.005,1.017,1.046,1.073,1.115,.9991,1.005,
     &     1.030,1.055,1.102,1.176,.9970,1.005,1.035,
     &     1.069,1.134,1.186,.9962,1.004,1.042,1.100,
     &     1.193,1.306,.9874,.9962,1.047,1.156,1.327,
     &     1.485,.9681,.9755,.8363,1.208,1.525,1.955/
      data a2/.30290,.16160,.04757,.01300,.00490,-.00320,
     &     .49050,.21550,.08357,.02041,.00739,.00029,
     &     .65400,.28330,.08057,.03257,.00759,-.00151,
     &     1.0290,.39100,.12660,.05149,.01274,.00324,
     &     .95690,.48910,.17640,.05914,.01407,-.00024,
     &     1.2690,.75790,.32600,.10770,.02800,.00548,
     &     1.3270,1.0170,1.3980,.20500,.06050,.00187/
      data a3/ - 1.3230,-.25400,-.01571,-.001000,-.000184,
     &     .00008,-4.7620,-.33860,-.03571,-.001786,-.000300,
     &     .00001,-8.3490,-.42060,-.02571,-.003429,-.000234,
     &     .00005,-13.231,-.59000,-.04571,-.005714,-.000445,
     &     -.00004,-7.6720,-.68520,-.06430,-.005857,-.000420,
     &     .00004,-7.1430,-.99470,-.12000,-.010070,-.000851,
     &     -.00004,-3.1750,-1.1160,-.84140,-.018210,-.001729,
     &     .00023/
c
 
      gam1 = gam*1000.
      if ( gam1.gt.100. ) then
         power = -.134/(gam**.2097)
         fbg = 1.5*(3.*u)**power
         return
      else
         u2 = u**2
c
c*****compute born approximation gaunt factor
c
         u1 = u/2.
         t = u1/3.75
         u4 = u1/2.
         if ( u1.gt.2. ) then
c
            ak = 1.2533141 - .07832358/u4 + .02189568/u4**2 - 
     &           .01062446/u4**3 + .00587872/u4**4 - .00251540/u4**5 + 
     &           .00053208/u4**6
            ak = ak/(exp(u1)*sqrt(u1))
         else
            ai = 1.0 + 3.5156229*t**2 + 3.0899424*t**4 + 
     &           1.2067492*t**6 + 0.2659732*t**8 + 0.0360768*t**10 + 
     &           0.0045813*t**12
            ak = -1.*log(u4)*ai - .57721566 + .42278420*u4**2 + 
     &           .23069758*u4**4 + .0348859*u4**6 + .00262698*u4**8 + 
     &           .00010750*u4**10 + .0000074*u4**12
         endif
         born = .5513*exp(u1)*ak
c
c*****compute polymonial factor to multiply born approximation
c
         if ( gam1.ge.1. ) then
            if ( u.ge..003 ) then
               if ( u.le..03 ) n = 1
               if ( (u.le..3) .and. (u.gt..03) ) n = 2
               if ( (u.le.1.) .and. (u.gt..3) ) n = 3
               if ( (u.le.5.) .and. (u.gt.1.) ) n = 4
               if ( (u.le.15.) .and. (u.gt.5.) ) n = 5
               if ( u.gt.15. ) n = 6
               if ( gam1.le.1.7783 ) m = 1
               if ( (gam1.le.3.) .and. (gam1.gt.1.7783) ) m = 2
               if ( (gam1.le.5.6234) .and. (gam1.gt.3.) ) m = 3
               if ( (gam1.le.10.) .and. (gam1.gt.5.6234) ) m = 4
               if ( (gam1.le.30.) .and. (gam1.gt.10.) ) m = 5
               if ( (gam1.le.100.) .and. (gam1.gt.30.) ) m = 6
               m1 = m + 1
               g1 = (a(n,m,1)+a(n,m,2)*u+a(n,m,3)*u2)*born
               g2 = (a(n,m1,1)+a(n,m1,2)*u+a(n,m1,3)*u2)*born
               p = (gam1-gam3(m))/gam2(m)
               fbg = (1.0-p)*g1 + p*g2
               return
            endif
         endif
      endif
      fbg = born
      return
      end
      subroutine fe2em
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /temp  / t,to
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /cecool/ cecl(nni)
      common /abel  / xel(nl),xeln(nni),xelln(nnnl)
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /cdpth / dpthc(ncn)
      common /bdpth / dpthb(ncn)
      common /linsel/ nlsv(nnnl),nlsvn
      common /lindat/ elin(nnnl),blin(nnnl),
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &       flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
      common /fe2emm/ emis(10,6),xxl(10)
      common /fe2dat/ ggl(10),ggu(6),eel(10),eeu(6),bb(10,6),
     &                elam(10,6),nblfe2(10,6),ffe(10,6),gfe(10,6)
      common /fe2lum/ elmfe2(60),oemfe2(60),t0fe2(10,6),
     &                t1fe2(10,6),elmf2b(60),oemf2b(60)
      common /icc   / lichk(nni),lipin
      common /ceemso/ ceem(nnnl)
      common /rcemis/ rcem(nnnl)
c
      character*72 ktitle
c
      dimension atmp(10)
      dimension cdrat(6)
c
      data ergsev/1.602197e-12/
      data cdrat/0.6,1.0,2.7,1.5,1.5,1.5/
c
      if ( lichk(116).ne.1 ) return
c
      if (lpri.ge.1) write (6,*)'in fe2em'
c
      lprisv = lpri
c      lpri=1
c
c     calculate level populations
      xxl(1) = 1.
      xsum = 1.
      ekt = 0.861707*t
      ggref = ggl(1)
      eeref = eel(1)
      do 100 kl = 2,10
         dele = eel(kl) - eeref
         xxl(kl) = ggl(kl)*expo(-dele/ekt)/ggref
         xsum = xsum + xxl(kl)
         if ( lpri.gt.2 ) write (6,99001) kl,eel(kl),ggl(kl),
     &                           dele,ekt,ggref,xxl(kl),xsum
 100  continue
      xxl(1) = 1./xsum
      do 200 kl = 2,10
         xxl(kl) = xxl(1)*xxl(kl)
 200  continue
c
c
c     calculate excitation rates
      cecl(116) = 0.
      cdx = 2.2e-7/sqrt(t)
      n2600 = 1238
      n5000 = 1239
      n2607 = 1235
      n2404 = 1236
      n2343 = 1237
      ceem(n2600) = 0.
      ceem(n5000) = 0.
      rcem(n2600) = 0.
      rcem(n5000) = 0.
      ceem(n2607) = 0.
      ceem(n2404) = 0.
      ceem(n2343) = 0.
      rcem(n2607) = 0.
      rcem(n2404) = 0.
      rcem(n2343) = 0.
      j = 0
      do 300 kl = 1,10
         do 250 lm = 1,6
            emis(kl,lm) = 0.
 250     continue
 300  continue
      do 500 lm = 1,6
         sum1 = 0.
         sum2 = 0.
         sum3 = 0.
         do 350 kl = 1,10
            xlow = xxl(kl)
            elow = eel(kl)
            glow = ggl(kl)
            dele = eeu(lm) - elow
            ptherm = 0.
            if ( (elam(kl,lm).ge.0.001) .and. (ffe(kl,lm).ge.1.e-10) )
     &           then
               aaa = (6.67e+15)*ffe(kl,lm)/(elam(kl,lm)*elam(kl,lm))
               ptherm = xnx*cdx*cdrat(lm)/aaa
            endif
            cex = cdx*cdrat(lm)*xlow*ggu(lm)*expo(-dele/ekt)/glow
            pesc = (pescc(t0fe2(kl,lm),0.)+pescc(t1fe2(kl,lm),0.))
     &             *gfe(kl,lm)
            depth = min(dpthc(nblfe2(kl,lm)),dpthb(nblfe2(kl,lm)))
c           pesc=pesc*expo(-5.*depth**(0.75))
            sum1 = sum1 + xlow*cex
            sum2 = sum2 + aaa*(ptherm+pesc)
            sum3 = sum3 + aaa*pesc*dele*ergsev
            atmp(kl) = aaa*pesc
 350     continue
         cecl(78) = cecl(78) + sum1*sum3/sum2
         do 400 kl = 1,10
            emis(kl,lm) = sum1*atmp(kl)/sum2 + emis(kl,lm)
            if ( lpri.gt.2 ) write (6,99002) kl,lm,xlow,cdx,
     &                              cex,bb(kl,lm),emis(kl,lm)
            if ( (elam(kl,lm).ge.0.001) .and. (ffe(kl,lm).ge.1.e-10) )
     &           then
               if ( elam(kl,lm).lt.3900. ) then
                  ceem(n2600) = ceem(n2600) + emis(kl,lm)*(2600.)
     &                          /elam(kl,lm)
               else
                  ceem(n5000) = ceem(n5000) + emis(kl,lm)*(5000.)
     &                          /elam(kl,lm)
               endif
            endif
 400     continue
 500  continue
c
      lpri = lprisv
c
c
      return
99001 format (' ',' in fe2em ',i4,7e12.4)
99002 format (' ',2i4,5e12.4)
      end
      subroutine fe2lm
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /fe2emm/ emmfe2(60),xxlfe2(10)
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /temp  / t,to
      common /llumin/ elum(nnnl),oelum(nnnl)
      common /llumnb/ elumb(nnnl),oelmb(nnnl)
      common /fe2dat/ ggl(10),ggu(6),eel(10),eeu(6),bb(60),
     &                elam(60),nblfe(60),ffe(60),gfe(60)
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /abel  / xeh(nl),xeln(nni),xelln(nnnl)
      common /fe2lum/ elmfe2(60),oemfe2(60),t0fe2(60),t1fe2(60),
     &                elmf2b(60),oemf2b(60)
      common /radius/ delr,r,rl,rstp,rdel,radexp,rscale,rsave
      common /spectl/ fline(ncn)
      common /enerc / epi(ncn),dele(ncn),numcon
      common /copak / opakc(ncn),opakco(ncn)
      common /cdpth / dpthc(ncn)
      common /bdpth / dpthb(ncn)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
c
      if ( lichk(116).ne.1 ) return
c
      if (lpri.ge.1) write (6,*)'in fe2lm'
c
c     fpr2=12.56*r*r
      n2600 = 1238
      n5000 = 1239
      elum(n2600) = 0.
      elum(n5000) = 0.
      elumb(n2600) = 0.
      elumb(n5000) = 0.
      abund = xpx*xnx*xeh(12)*xiin(116)
      do 100 j = 1,60
         if ( elam(j).ge.0.1 ) then
            jk = nblfe(j)
c     fddg=t1fe2(j)/(t1fe2(j)+t0fe2(j)+1.)
c     dtemp1=expo(-5.*(dpthc(jk))**(0.75))
c     dtemp2=expo(-5.*(dpthb(jk))**(0.75))
            dtemp1 = 1.
            dtemp2 = 1.
            pesc1 = pescc(t1fe2(j),0.)*dtemp1*gfe(j)
            pesc0 = pescc(t0fe2(j),0.)*dtemp2*gfe(j)
            fddg = 1./(1.+pesc1/(pesc0+1.e-20))
c     elmfe2(j)=oemfe2(j)
c    $  +emmfe2(j)*fpr2*delr*abund*fddg
            elmfe2(j) = oemfe2(j) + emmfe2(j)*12.56*(r/1.e+19)
     &                  *(r/1.e+19)*delr*abund*(1.-fddg)
c     elmf2b(j)=oemf2b(j)
c    $  +emmfe2(j)*fpr2*delr*abund*(1.-fddg)
            elmf2b(j) = oemf2b(j) + emmfe2(j)*12.56*(r/1.e+19)
     &                  *(r/1.e+19)*delr*abund*(fddg)
            if ( lpri.gt.2 ) write (6,99001) j,elam(j),oemfe2(j),
     &                              emmfe2(j),dtemp1,delr,abund,
     &                              fddg
            if ( elam(j).lt.3900. ) then
               elum(n2600) = elum(n2600) + elmfe2(j)*(2600.)/elam(j)
               elumb(n2600) = elumb(n2600) + elmf2b(j)*(2600.)/elam(j)
            else
               elum(n5000) = elum(n5000) + elmfe2(j)*(5000.)/elam(j)
               elumb(n5000) = elumb(n5000) + elmf2b(j)*(5000.)/elam(j)
            endif
         endif
 100  continue
      oelum(n2600) = elum(n2600)
      oelum(n5000) = elum(n5000)
      oelmb(n2600) = elumb(n2600)
      oelmb(n5000) = elumb(n5000)
c
c
c
c
      return
99001 format (' ',' in fe2lm ',i4,7e12.4)
      end
      function fh2lke(z,e,eth)
c
      external bigdat,newdat,rr3,nfllns
c
      real aa0,e,eth,fh2lke,sigth,y,z,zap
c
c
c
c
      data aa0/6.3e-18/
c      data sigth/6.65e-25/
      data sigth/1.e-34/
c
      fh2lke = 0.
      zap = e/eth - 1.
      if ( zap.le.0. ) return
      y = e/eth
      yy=sqrt(zap)
      yy=amax1(yy,1.e-04)
      fh2lke=(aa0/(z*z))*y**(-4)*expo(4.-4.*atan(yy)/yy)
     $  /(1.-expo(-6.2832/yy))
c      fh2lke = aa0*((1.8)/y**(3.2)-(0.8)/y**(4.2))/(z*z)
      fh2lke = amax1(fh2lke,sigth)
c      write (6,9901)z,e,eth,y,fh2lke
9901  format (' ',' in fh2lke',5e12.4)
c
      return
      end
      subroutine flmap
c
c
c
 
c     this routine maps fluorescence emissivitites
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /abion / xii(nnip),xih(1),xihe(2),xic(6),xin(7),
     &                xio(8),xine(10),ximg(12),xisi(14),xis(16)
     &               ,xiar(18),xica(20),xife(26),xini(28),
     &                xiip(nni),xiln(nnnl),xilp(nnnl),xiio(nnip)
      common /flem2 / fflmtt(nnnl)
      common /lindat/ elin(nnnl),blin(nnnl),
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &      flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
      common /flpass/ fflmt(1530)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
      dimension nflshl(26,6),nin(13)
      dimension nflnk(26),nflnls(26),nflnlp(26),nflnms(26),
     &          nflnmp(26),nflnmd(26)
      dimension nsh(28)
c
      equivalence (nflnk(1),nflshl(1,1)),(nflnls(1),nflshl(1,2))
      equivalence (nflnlp(1),nflshl(1,3)),(nflnms(1),nflshl(1,4))
      equivalence (nflnmp(1),nflshl(1,5)),(nflnmd(1),nflshl(1,6))
c
c
c
      data nsh/0,2*1,7*2,2*3,6*4,6*5,4*6/
      data nin/1,2,6,7,8,10,12,14,16,18,20,26,
     &     28/
      data ergsev/1.602192e-12/
      data nflnk/0,2*1,7,7,5*6,2*12,10,5*12,6*8,2*7/
      data nflnls/3*0,1,1,5*5,2*10,9,5*11,6*7,2*6/
      data nflnlp/10*0,2*11,11,5*10,6*6,2*5/
      data nflnms/12*0,4,5*9,6*5,2*4/
      data nflnmp/18*0,6*4,2*3/
      data nflnmd/24*0,2*2/
c
c
      lprisv=lpri
c      lpri=3
      if (lpri.ge.1) write (6,*)'in flmap'
c
      if ( lpri.gt.2 ) write (6,99001)
      do 100 ii = 1,1530
         if ( fflmt(ii).gt.(1.e-34) ) then
            if ( lpri.gt.2 ) write (6,99002) ii,fflmt(ii)
         endif
 100  continue
c
c     map emissivities to new system
      jj = 0
      jjo = 0
      libse = 0
      do 200 jk = 1,13
         nnimx = nin(jk)
         do 150 kl = 1,nnimx
            jj = jj + 1
            nlmx = nlin(jj)
            do 120 ll = 1,nlmx
               fflmtt(ll+libse) = 0.
 120        continue
            if ( (jk.ne.13) .and. (jk.ne.11) .and. (jk.ne.10) ) then
               jjo = jjo + 1
               if ( lichk(jj).eq.1 ) then
                  niso = nnimx + 1 - kl
                  nshmx = nsh(niso)
                  do 125 ll = 1,nshmx
                     nlnind = nflshl(niso,ll)
                     lind = libse + nlmx - ll + 1
                     if (lpri.gt.2) 
     $                write (6,*)ll,elin(lind),nlmx,libse,lind,
     $                           nlnind,niso,kl,jj,jk
                     if ( (nlnind.ne.0) .and. (nlnind.le.15) ) then
                        lindo = 15*(jjo-1) + nlnind
                        if (elin(lind).ge.9.e+4) lind=lind-1
c                       lind=libse+nlmx-nshmx+ll
                        if ( (elin(lind).lt.9.e+4) .and. 
     &                       (elin(lind).gt.0.1) ) then
                           fflmtt(lind) = fflmt(lindo)
                           if ( lpri.gt.2 ) write (6,99003) jk,kl,
     &                          jj,ll,lind,libse,elin(lind),
     &                          nilin(lind),jjo,nlnind,
     &                          fflmtt(lind)
                        endif
                     endif
 125              continue
               endif
            endif
            libse = libse + nlin(jj)
 150     continue
 200  continue
c
      lpri=lprisv
c
      if (lpri.gt.2) write (6,*)'done with flmap'
c
      return
99001 format (' ',' in flmap ')
99002 format (' ',i4,e12.4)
99003 format (' ',6i5,e12.4,3i5,e12.4)
      end
      subroutine fluoem
c
c
c
c     this routine computes emissivities due to fluorescence.
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /abel  / xel(nl),xeln(nni),xelln(nnnl)
      common /flem2 / fflmtt(nnnl)
      common /linsel/ nlsv(nnnl),nlsvn
      common /flemis/ flem(nnnl)
      common /lindat/ elin(nnnl),blin(nnnl),
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &      flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
      if (lpri.ge.1) write (6,*)'in fluoem'
c
      lprisv=lpri
c      lpri=1
c
      jkk = 0
      if ( nni.le.2 ) return
      do 100 ik = 2,nni
         nalim = nlin(ik)
         do 50 kj = 1,nalim
            jkk = jkk + 1
            jk = nlsv(jkk)
            flem(jk) = 0.
c      write (6,*)jk,jkk,lichk(jkk),fflmtt(jk)
c            if ( fflmtt(jk).gt.1.e-34 ) then
               ikk = nilin(jk)
               if (ikk.le.3) go to 50
c               if ( lichk(ikk).eq.1 ) then
                  abund = xeln(ikk)*xpx*xiin(ikk-1)
                  flem(jk) = fflmtt(jk)*abund
                  if ( lpri.gt.2 ) write (6,99001) jk,elin(jk),
     &                 nilin(jk),fflmtt(jk),abund,flem(jk)
c               endif
c            endif
 50      continue
 100  continue
c
      lpri=lprisv
c
      return
99001 format (' ',' in fluoem ',i4,e12.4,i4,3e12.4)
      end
      subroutine func(lferr)
c
c
c
c
c     this routine computes function.
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /funct / fe,fh
      common /num   / nn
      common /temp  / t,to
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /heat  / httot,cltot,hmctot
      common /elect / elcter
c
      character*72 ktitle
c
c
      if (lpri.ge.1) write (6,*)'in func'
c
      lferr=0
      call remtms(nt0)
      nlf=2
      if (lffst.eq.0) nlf=1
      do 9008 ll=1,nlf
        call rrrec
        call autoi
        call colli
        call collex
        call bremsc
        call egrat
        call remtms(nt1)
        call charex
        if (lfast.ne.1) call augcmp
        told=float(nt1-nt0)/1000.
        call hcor
        call he2cor
        call remtms(nt2)
        thcor=float(nt2-nt1)/1000.
        if (llte.eq.1) call saha
        if (llte.eq.0) call istruc
        call electt
        call remtms(nt3)
        tistruc=float(nt3-nt2)/1000.
        call o1cor
        call o2cor
        call o3cor
        call o4cor
        call o5cor
        call o6cor
        call ne2cor
        call remtms(nt4)
        tcor=float(nt4-nt3)/1000.
c       NB this order must be maintained for the following 2 calls
        call rccem
        call recem
        call bremem
        call dircem
        call fe2em
        call collem
        call dircem
        call fluoem
        call fe2lm
        call o1old
        call heatt
c        call pprint(9)
c        call pprint(10)
c        call pprint(11)
 9008   continue
c      if (lffst.eq.0) call heatto
      call remtms(nt5)
      theat=float(nt5-nt4)/1000.
      if (lpri.gt.2) 
     $  write (6,*)'told,thcor,tistruc,tcor,theat:',
     $            told,thcor,tistruc,tcor,theat
      call errbnd(lferr)
      nn = nn + 1
      fe = hmctot
      fh = elcter
c
c
c
      return
      end
      subroutine funcn(lferr)
c
c
c
c
c     this routine computes function.
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /funct / fe,fh
      common /num   / nn
      common /temp  / t,to
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /heat  / httot,cltot,hmctot
      common /elect / elcter
c
      character*72 ktitle
c
      dimension emtmp(100)
c
      if (lpri.ge.1) write (6,*)'in funcn'
c
      lferr=0
      call remtms(nt0)
      do 9008 ll=1,2
        call rrrec
        call autoi
        call colli
        call collex
        call bremsc
        call egrat
        call remtms(nt1)
        call charex
        if (lfast.ne.1) call augcmp
        told=float(nt1-nt0)/1000.
        call hcor
        call he2cor
        call hecor(emtmp)
        call remtms(nt2)
        thcor=float(nt2-nt1)/1000.
        if (llte.eq.1) call saha
        if (llte.eq.0) call istruc
        call electt
        call remtms(nt3)
        tistruc=float(nt3-nt2)/1000.
        call o1cor
        call o2cor
        call o3cor
        call o4cor
        call o5cor
        call o6cor
        call ne2cor
        call remtms(nt4)
        tcor=float(nt4-nt3)/1000.
c       NB this order must be maintained for the following 2 calls
        call rccem
        call recem
        call bremem
        call fe2em
        call collem
        call fluoem
        call fe2lm
        call o1old
        call heatt
c        call pprint(9)
c        call pprint(10)
c        call pprint(11)
 9008   continue
      call heatto
      call remtms(nt5)
      theat=float(nt5-nt4)/1000.
      if (lpri.gt.2) write (6,*)'told,thcor,tistruc,tcor,theat:',
     $            told,thcor,tistruc,tcor,theat
      call errbnd(lferr)
      nn = nn + 1
      fe = hmctot
      fh = elcter
c
c
c
      return
      end
      function gaunt(t,e,n,j,l,dene)
c
      external bigdat,newdat,rr3,nfllns
c
      real a,abin,abund,abunj,ah,b,bespec,bh,bin,
     &     binmin,binsyz,bln,blnmin,blnsyz,c,cc,cn,cnc,
     &     conce,crit
      real dene,dne,e,em,ex,exint1,expo,gal,gal2,
     &     gaunt,gb,gbe,gbe1,gbe2,gbe3,gbe4,gbe5,gc,
     &     gca,gf
      real ghe,gk,gmg,gmgii,gmgp,gmshll,gn,gna,gna4,
     &     gncrch,gndrec,gne,gnt,gox,heneut,heplus,pcool,
     &     pm,pot,pou
      real power,ptot,re,rf,rhy,st,t,tau,tauhe,tl,
     &     tplus,tu,x,y
      integer i,ii,j,l,ll,m,n,nbin,nbln,nj
c
c     may '82 version relying heavily on mann and robb calculations,
c     bhatia for delta n = 0 and bhatia and mason delta n = 1
c
      dimension bln(1000),nj(13),abunj(13),conce(30)
      dimension gndrec(30),power(220),rf(500),tau(168)
      dimension tauhe(168),tplus(168),cnc(12,30),pm(4)
      dimension ptot(12,220),abin(1000),bin(1000),crit(30,6)
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /bln   / bln,blnmin,blnsyz,nbln
      common /params/ abunj,abund,binmin,binsyz,nbin,nj
      common /result/ conce,gndrec,power,rhy,heneut,heplus,
     &                dne,pcool,pou,pot,re,tu,pm
      common /pt    / rf,tau,tauhe,tplus
      common /com   / cnc,ptot,abin,bin
      common /crt   / crit
c
      dimension ah(5),bh(5)
      data ah/0.,.08,.08,.08,0./
      data bh/.22,.16,.19,.20,0./
      dimension ghe(24)
      data ghe/.03785,.0002038,.04214,-.001901,-.03263,
     &     .004462,.28,0.,.02327,-.0007424,-.06369,.001865,
     &     .07711,.000058,0.,0.,-.03168,.0008439,.182,
     &     -.007289,-.05873,.009605,0.,0./
      dimension gbe(8,5)
      data gbe/.7114,.00558,-.9277,-.00153,.2711,.00523,
     &     0.0,0.0,0.0,0.0,-.044,.00735,.482,-.01855,
     &     0.0,0.0,.44,0.0,-.010,5*0.0,.077,.00666,
     &     6*0.,-.2943,-.00084,.2574,.01167,.04852,-.00777,
     &     .2671,.00555/
      dimension gbe1(4),gbe2(4),gbe3(11),gbe4(11),gbe5(11),
     &          bespec(4,3)
      data gbe1/ - .0264,0.03,0.0,0.20/
      data gbe2/.0881,0.10,.117,0.10/
      data gbe3/0.0,.064,.069,.048,.035,.0303,.025,.02,
     &     .02,.032,.032/
      data gbe4/0.0,.342,.39,.192,.103,.0836,.063,.043,
     &     .043,0.0,0.0/
      data gbe5/0.0,3*0.0,55000.,64000.,86000.,97000.,
     &     108000.,156000.,168000./
      data bespec/.00069,.102,.0059,.0063,.0016,.13,.0073,
     &     .0058,.0017,.127,.0087,.0040/
      dimension gb(8,6)
      data gb/.2392,.00543,.3723,.0335,.0321,-.0253,.4591,
     &     -.00232,.2317,.00654,-.1479,.03186,.3038,
     &     -.02130,.3904,-.00302,.0811,.01318,-.2523,
     &     .04591,.2102,-.02192,.2304,.00639,-.112,.0063,
     &     .050,.011,.0808,-.005,.239,.0023,.126,0.0,
     &     .287,0.0,0.0,0.0,.28,0.0,.51,-.10,-1.84,
     &     .53,.55,-.091,-2.80,.51/
      dimension gc(8,9)
      data gc/.3539,.00039,.2314,.02314,.0358,-.01534,
     &     .5449,-.00858,.2005,.00395,-.3012,.04332,
     &     -.09599,.01606,.3727,-.001517,.3229,-.002883,
     &     .0212,.02481,.0783,-.01326,.4671,-.008106,-.112,
     &     .0063,.050,.011,.0808,-.005,.239,.0023,.51,
     &     -.10,-1.84,.53,.55,-.091,-2.80,.51,-.269,
     &     -.00117,.0318,.0233,-.0102,-.0075,.235,.0172,
     &     .22,.0056,6*0.,.198,.0069,6*0.,8*0./
      dimension gn(8,4)
      data gn/ - .01876,.0011,.0083,.0182,.0135,-.0083,
     &     .040,.0040,.51,-.1,-1.84,.53,.55,-.091,
     &     -2.80,.51,.51,-.1,-1.84,.53,.55,-.091,-2.80,
     &     .51,-.07504,.0042,.033,.0726,.054,-.033,.159,
     &     .0015/
c
      dimension gox(8,8)
      data gox/.69,0.0,4*0.0,.46,0.0,-.112,.0063,.050,
     &     .011,.0808,-.005,.2391,.0023,-.112,.0063,.050,
     &     .011,.0808,-.005,.2391,.0023,.51,-.1,-1.84,
     &     .53,.55,-.091,-2.80,.51,.51,-.1,-1.84,.53,
     &     .55,-.091,-2.80,.51,.22,.0056,6*0.0,8*0.,
     &     .1261,0.0,.2869,0.0,0.0,0.0,.28,0.0/
      dimension gf(8,9)
      data gf/.2246,.0075,.3055,.0062,-.0575,-.0017,.4248,
     &     -.0049,-.063,0.,.407,0.,-.0238,0.,.478,0.,
     &     -.0157,0.,.188,0.,.0195,0.,.283,0.,-.001,
     &     0.,.134,0.,.123,0.,.158,0.,.51,-.1,-1.84,
     &     .53,.55,-.091,-2.8,.51,.198,.0669,6*0.,8*0.,
     &     .22,.056,6*0.,8*0./
      dimension gne(5,12)
      data gne/ - .72117,1.2406,11.746,8.2169,-7.7772,1.0227,
     &     .70828,4.5400,4.1450,-3.8657,-1.04290,.84411,
     &     6.7031,3.1927,-3.1693,-.039582,.26837,.25803,
     &     .086929,-.086641,-.017323,.29514,.29301,.13223,
     &     -.13071,-.071593,.15504,.12598,-.000449,.000523,
     &     .040202,.25113,.14858,.030780,-.030745,.45761,
     &     .38477,.52142,.92153,-.91649,-.17862,.32249,
     &     .28172,.040677,-.040639,-.062670,.14921,1.5354,
     &     1.0586,-1.0219,-.057871,.030701,.36471,.14784,
     &     -.14293,.093106,-.001108,-.067652,-.021663,.021657/
c
      dimension gna(8,2),gna4(3,3),gmgii(12)
      data gna/.1586,.007375,.1866,.04156,.02403,-.02416,
     &     .3100,-.00098,-.3245,0.0,.5548,0.0,-.1562,0.0,
     &     .266,0./
      data gna4/1.153,-.0333,0.0,.001,.0053,.058,.67,
     &     -.0133,0.0/
      data gmgii/.24,37.3,68.3,96.,96.,2.39,5.99,5.99,
     &     0.,0.,0.,.142/
      dimension gmg(10),gmgp(8,2)
      data gmg/.9,.2,.25,.23,.23,.2,.2,.2,.14,.0094/
      data gmgp/ - .1333,.0155,-.6758,.0577,.5057,-.0323,
     &     .314,0.0,-.294,0.0,.5043,0.0,-.1619,0.0,
     &     .2606,0.0/
      dimension gal(10),gal2(10),a(10),b(10),c(10)
      data gal/0.0139,.01,.06,0.,0.2,3*0.,1.64,.11/
      data gal2/0.0,.28,.28,0.,0.,3*0.,.00,.28/
      data a/.022,.625,.660,.240,.061,.256,.0368,.271,
     &     .833,.696/
      data b/.0035,.360,.432,.019,.364,.354,.343,.794,
     &     .404,.387/
      data c/.1261,.1261,.1261,.477,.162,.0108,.138,
     &     .0719,.1261,.1261/
      dimension gmshll(6,4)
      data gmshll/.453,.91,.38,.93,.2,.2,.7,.98,.38,
     &     .93,0.,0.,.59,.95,.38,.93,0.,0.,.51,.95,
     &     .20,1.04,0.,0./
      dimension gk(10),gca(10)
      data gk/.35,.35,1.1,.8,.91,.97,1.1,3*0./
      data gca/.35,.21,43.,.14,.12,.43,37.,.20,.11,4./
c  should put in sensible f'ar for potassium isosequence
c
c
      if (lpri.gt.2) write (6,*)'entering gaunt:',t,e,n,j,l,dene
c
      st = sqrt(t)
      gaunt = 0.2
      y = e*11590./t
      cc = exint1(y,2)
      if ( j.eq.1 .and. n.gt.2 ) then
         if ( y.le..02 ) gaunt = 1.
         if ( y.gt.10. ) gaunt = .01
         if ( y.gt..02 .and. y.le.10. ) gaunt = expo(-.7*alog(y)-2.3)
      else
c
         ii = n - j + 1
         if ( ii.ge.18 ) then
            if ( ii.le.18 ) then
               go to 3000
c               return
            elseif ( ii.gt.19 ) then
               if ( l.le.3 ) gaunt = amax1(.2,-.606*alog10(y)-.052)
               go to 3000
c               return
            else
               gaunt = gk(l)
               if ( n.eq.20 ) gaunt = gca(l)
               go to 3000
c               return
            endif
         elseif ( ii.eq.2 ) then
c  helium-like ions:  pradhan+cascades for n=2, mewe n=3,4
c  neutral he from bhadra,callaway,henry pra 19 for n=2
c  l = 9 has gaunt = 0.0,  satellite lines : l = 6 done by branch from
            if ( n.eq.2 ) then
               if ( l.eq.1 .or. l.eq.4 .or. l.eq.5 ) gaunt = .30*cc
               if ( l.eq.2 ) gaunt = .089
               if ( l.eq.3 ) gaunt = .14*(y-y*y*cc)
               if ( l.eq.6 ) gaunt = 0.0
               if ( l.eq.7 ) gaunt = 4.08e-7*t**.941
               if ( l.eq.8 ) gaunt = 2.46e-8*t**1.22
               if ( l.eq.9 ) gaunt = 0.0
            elseif ( l.gt.3 ) then
               if ( l.eq.4 ) gaunt = (1.+7./n)
     &                               *(.053+.022*(y*y*y*cc-y*y+y)
     &                               +.276*cc)
               if ( l.eq.5 ) gaunt = (1+1.5/n)
     &                               *(.053+.022*(y*y*y*cc-y*y+y)
     &                               +.276*cc)
               if ( l.eq.6 ) gaunt = 0.
               if ( l.eq.7 ) gaunt = .04*(y-y*y*cc)
               if ( l.eq.8 ) gaunt = .02
               if ( l.eq.9 ) gaunt = 0.
               go to 3000
c               return
            else
               gaunt = gncrch(ghe,l,y,cc,n)
               go to 3000
c               return
            endif
         elseif ( ii.eq.3 ) then
c  lithium-like ions: mewe modified to fit close-coupling calculations
            x = 1./(n-3.)
            if ( l.eq.1 ) gaunt = (0.68+.02*n)
     &                            *((.7+.35*x)+((1.-.8*x)*y+(.5-.5*x)
     &                            *y*y+.28)*cc-(.5-.5*x)*y)
            if ( l.eq.2 ) gaunt = .053 + .16*cc
            if ( l.eq.3 .or. l.eq.4 ) gaunt = -(.16+.32*x)
     &           + ((.8-.56*x)*y+.2*y*y+.28)*cc - .2*y
            if ( l.eq.5 ) gaunt = (.19+.25*x) + .079*cc
            if ( l.eq.6 ) gaunt = .31 - .1*y*cc
            if ( l.eq.7 ) gaunt = .096 + .32*x
            if ( l.eq.8 ) gaunt = .13
         elseif ( ii.eq.4 ) then
c  beryllium-like ions:  qub for n=2 up through ne; mann, robb & sampso
c  mann and malinovsky for n = 3 and qub o v n=3 from widing
c  n = 4 from johnston & kunze, mason & storey (fe xxii) and li-like
            i = n - 5
            if ( n.ge.10 ) i = n/2 - 1
            if ( n.ge.26 ) i = n/2 - 3
            if ( l.eq.1 ) then
               tl = alog10(t)
               gaunt = .54 + .0125*n + .135*cc
               if ( n.le.10 ) gaunt = gbe1(i) + gbe2(i)*tl
            elseif ( l.ne.2 ) then
               if ( l.le.7 ) gaunt = gncrch(gbe,l-2,y,cc,n)
               if ( l.eq.8 ) gaunt = .1261 + .2869*y*cc + .276*cc
               if ( n.le.8 ) then
                  em = -4.67 + 1.86*n
                  ex = expo(-em*11590./t)
                  m = n - 5
                  if ( l.eq.10 ) gaunt = bespec(1,m)*(1.-pm(1))
     &                 *ex + bespec(2,m)*pm(1)
                  if ( l.eq.11 ) gaunt = bespec(3,m)*(1.-pm(1))
     &                 *ex + bespec(4,m)*pm(1)
               endif
            else
               gnt = gbe3(i)/(1.+gbe4(i)/y) + gbe5(i)/t
               if ( n.eq.6 ) gnt = .046/(1.+t*t/6.25e10)
               gaunt = gnt*st*crit(n,2)/(dene+st*crit(n,2))
            endif
         elseif ( ii.eq.5 ) then
c  boron isosequence: n=2 interpolated from o iv and fe xxii of robb; g
c  na-s, dere et al ar, mann c ii;  overest by 36% near threshold wrt r
c  n = 3 interpolated c ii and fe xxii from mann; 2s-3l scaled from be-
c  to 8% for 2s-3p.  n = 4 from mason & storey
c  l = 9 intercombination line
            if ( l.le.6 ) gaunt = gncrch(gb,l,y,cc,n)
            if ( l.eq.9 ) gaunt = st*crit(n,3)/(dene+st*crit(n,3))
            if ( l.eq.12 ) gaunt = 0.
         elseif ( ii.eq.6 ) then
c  carbon isosequence: n=2 interp from mann and robb;  agrees to 5-10%
c  n=3,4 general b-f; agrees 3-10% with mann 2p-3d; l=6 intercomb
            if ( l.le.5 ) gaunt = gncrch(gc,l,y,cc,n)
            if ( l.eq.7 ) gaunt = .198 + .0069*n
            if ( l.eq.8 ) gaunt = .22 + .0056*n
            if ( l.eq.9 ) gaunt = .1261 + (.2869*y+.28)*cc
            if ( l.eq.6 ) gaunt = st*crit(n,4)/(dene+st*crit(n,4))
            if ( l.eq.6 .and. n.eq.6 ) gaunt = sqrt(.0001*t)
     &           *st*crit(6,4)/(dene+st*crit(6,4))
            if ( l.eq.12 ) gaunt = 0.
         elseif ( ii.eq.7 ) then
c  nitrogen sequence:   n=2 from mann fe xx and mason & bhatia mg,si,s,
c  n=3 and 4 general b-f
            if ( l.eq.1 ) gaunt = (1.086-1.71/j)
     &                            *(.3642+.9358*y*cc-.3758*(y-y*y*cc)
     &                            +.3586*cc)
            if ( l.ge.2 .and. l.le.5 ) gaunt = gncrch(gn,l-1,y,cc,n)
            if ( l.eq.12 ) gaunt = 0.
            if ( l.eq.8 ) gaunt = .22 + .0056*n
            if ( l.eq.9 ) gaunt = .1261 + .2869*y*cc + .276*cc
         elseif ( ii.eq.8 ) then
c  oxygen isosequence:  n=2 from mann, robb fe xix and from bhatia,f&d
c  others generic b-f
            if ( l.le.8 ) gaunt = gncrch(gox,l,y,cc,n)
            if ( l.eq.10 ) gaunt = .16 + .0015*n
            if ( l.eq.15 ) gaunt = 0.
         elseif ( ii.eq.9 ) then
c  fluorine sequence:   n=2 from mann al v and robb fe xviii;   others
            if ( l.le.8 ) gaunt = gncrch(gf,l,y,cc,n)
            if ( l.eq.9 ) gaunt = .1261 + (.2869*y+.28)*cc
         elseif ( ii.eq.10 ) then
c     neon sequence: smith et al including cascades and resonances
c     assume they are all like fe xvii
            if ( l.le.12 ) gaunt = gne(1,l)
     &                             + (gne(2,l)+gne(3,l)*y+gne(4,l)*y*y)
     &                             *exint1(y,2) + gne(5,l)*y
         elseif ( ii.eq.11 ) then
c     sodium sequence:  mann, flower & nussbaumer, and blaha
            if ( n.eq.12 ) then
               gaunt = gmgii(l)
               if ( l.eq.1 ) gaunt = .112 + (.0269*y-.0998*y*y+.318)
     &                               *cc + .0998*y
               if ( l.eq.2 ) gaunt = 141 + (59.3*y-671*y*y+.858)
     &                               *cc + 671*y
               go to 3000
c               return
            elseif ( l.le.2 ) then
               gaunt = gncrch(gna,l,y,cc,n-10)
               if ( n.eq.14 .and. l.eq.2 ) gaunt = -.0172 + 
     &              (.832*y+.029*y*y+.3513)*cc - .029*y
               go to 3000
c               return
            elseif ( l.gt.5 ) then
               if ( l.eq.6 ) gaunt = -.16 + .8*y*cc - .2*(y-y*y*cc)
     &                               + .276*cc
               if ( l.eq.7 ) gaunt = .44 - 0.1*y*cc
               if ( l.eq.8 ) gaunt = .15 - .05*y*cc
               if ( l.eq.9 .or. l.eq.10 ) gaunt = 0.03
               if ( l.eq.11 ) gaunt = 0.07
               if ( l.eq.12 ) gaunt = 0.15
               go to 3000
c               return
            else
               ll = l - 2
               gaunt = gna4(1,ll) + gna4(2,ll)*n + gna4(3,ll)*cc
               go to 3000
c               return
            endif
         elseif ( ii.eq.12 ) then
c     magnesium sequence:   interpolate si to fe for 3p, 4p excitations
c     use mann fe gaunt factors for 3d, 4s, 4f, and intercomb.  assume
c     g for 4d = g for 4f;  l=10 is intercombination line
            gaunt = gmg(l)
            if ( l.le.2 ) gaunt = gncrch(gmgp,l,y,cc,n)
            if ( l.eq.10 ) gaunt = st*crit(n,6)/(dene+st*crit(n,6))
               go to 3000
c            return
         elseif ( ii.eq.13 ) then
c     aluminum iso-sequence:   si ii from roberts, s iv 3p from mann, 3
c     fe xiv from blaha used for ni and for all n=4
c     resonances included for metastable using bhatia collision strengt
c     si ii 1814 lines from brown, ferraz and jordan
c     fe xiv resonances computed as in smith et al from blaha omegas
            if ( l.lt.4 .or. l.gt.8 ) then
               if ( n.le.14 ) then
                  gaunt = gal(l) + gal2(l)*cc
                  if ( l.eq.1 ) gaunt = gal(1)*1.9e7*st/(dene+st*1.9e7)
                  go to 3000
c                  return
               elseif ( n.le.20 ) then
                  cn = st*2.7*10.**(7.+j/2.)
                  if ( l.eq.1 ) gaunt = ((.128+(.3449*y+.3544*y*y)*cc-
     &                                  .3544*y)*1.8/(1.+.25/y))
     &                                  *cn/(dene+cn)
                  if ( l.eq.2 ) gaunt = .0405 + 
     &                                  (.2052*y+.0328*y*y+.2311)
     &                                  *cc - .0328*y
                  if ( l.eq.3 ) gaunt = .142 + .147*cc
                  if ( l.eq.9 ) gaunt = .1330 + 
     &                                  (.3833*y+.0934*y*y+.1611)
     &                                  *cc - .0934*y
                  if ( l.eq.10 ) gaunt = .1684 + 
     &                 (.2432*y+.0484*y*y+.2638)*cc - .0484*y
                  go to 3000
c                  return
               endif
            endif
            gaunt = a(l) + b(l)/(1.+c(l)/y)
            if ( l.eq.1 ) gaunt = (.0121+.0036/(1.+.1261/y))
     &                            *6.0e17/(dene+6.0e17)
            go to 3000
c            return
         elseif ( ii.eq.14 .or. ii.eq.15 .or. ii.eq.16 .or. ii.eq.17 )
     &            then
c
c  silicon through chlorine sequences
            if (l.gt.6) go to 3000
            gaunt = gmshll(l,ii-13)
            if ( l.eq.3 .and. ii.ne.17 ) gaunt = gmshll(l,ii-13)
     &           - .344/(1.+.138/y)
             go to 3000
c            return
         else
c
c  hydrogenic ions: mewe; hayes and seaton: 3s,3d from thomas; others m
            if (l.le.5) gaunt = ah(l) + bh(l)*y*cc + .276*cc
            if ( l.eq.5 ) gaunt = .212 - .203*(y-y*y*cc) - .25*cc
            if ( n.gt.2 ) go to 3000
            if ( l.eq.5 ) gaunt = .1198*y*cc - .1194*(y-y*y*cc)
     &                            + .0328*cc
         endif
      endif
c
 3000 continue
c
      if (lpri.gt.2) write (6,*)'finishing gaunt'
c
      return
      end
      function ggrat(niso,nlin,nlnmx)
c
c
c
c
c     this routine calculates the statistical weight ratios
c     needed by the milne relation in rccemo
c
      external bigdat,newdat,rr3,nfllns
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
c
       character*72 ktitle
c
      dimension stwt(200),nstwt(28),stwt1(125),stwt2(75)
c
      equivalence (stwt(1),stwt1(1)),(stwt(126),stwt2(1))
c
      data stwt1/8.,18.,32.,50.,0.,2.,3.,3.,9.,3.,
     &     3.,0.,15.,5.,4*0.,1.,6.,6.,6.,6.,10.,
     &     10.,2.,2.,2.,3.,9.,5.,15.,13.,1.,3.,
     &     3.,1.,3*0.,10.,32.,2.,3*0.,2.,3*0.,20.,
     &     4.,3*0.,16.,9.,0.,10.,4.,2.,20.,3*0.,
     &     16.,4.,0.,15.,9.,24.,3.,2*0.,32.,50.,0.,
     &     9.,0.,24.,8.,150.,30.,3*0.,32.,50.,6.,
     &     9.,3.,9.,3.,12.,12.,24.,0.,0.,0.,50.,
     &     0.,1.,6.,6.,2.,10.,14.,6.,12.,14.,4*0.,
     &     2.,3.,12.,4.,28.,20.,25.,3*0.,1./
      data stwt2/8*0.,6.,6*0.,9.,4*0.,4.,4*0.,9.,4*0.,
     &     6.,5*0.,1.,7*0.,10.,6*0.,15.,3*0.,1.,0.,
     &     1.,0.,1.,0.,1.,3*0.,1.,2*0.,1.,2*0.,1.,
     &     2*0.,1./
      data nstwt/5,12,8,8,9,9,9,10,10,12,12,9,
     &     8,6,4,4,4,5,7,6,3,1,1,1,3,2,2,
     &     2/
c
c
      ggrat = 0
      if ( nlin.eq.nlnmx ) then
         enum = stwt(indsm+nstwt(niso)+1)
      else
         if ( nlin.gt.nstwt(niso) ) return
c
         indsm = 0
         if ( niso.ne.1 ) then
            nisom = niso - 1
            do 20 kl = 1,nisom
               indsm = indsm + nstwt(kl) + 1
 20         continue
         endif
         enum = stwt(nlin+indsm)
      endif
      denom = 1.
      if ( indsm.gt.0 ) denom = stwt(indsm)
      ggrat = enum/amax1(denom,1.e-34)
      if ( lpri.gt.2 ) write (6,*) 'in ggrat',niso,nlin,indsm,
     &                             enum,denom,ggrat
c
c
 
      return
      end
      function gncrch(r,l,y,cc,n)
c
      external bigdat,newdat,rr3,nfllns
c
      real a,b,c,cc,d,gncrch,r,y
      integer il,l,n
c
      dimension r(1000)
      il = 8*(l-1)
      a = r(il+1) + r(il+2)*n
      b = r(il+3) + r(il+4)*n
      c = r(il+5) + r(il+6)*n
      d = r(il+7) + r(il+8)*n
      gncrch = a + b*y*cc + c*(y-y*y*cc) + d*cc
      return
      end
      subroutine hcor
c
      external bigdat,newdat,rr3,nfllns
c 
      parameter (nztpp=700)
c
c
c
c     this routine calculates hydrogenic level populations
c       using the procedure of Cota
c
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /prs   / p,p0
      common /temp  / t,to
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /radius/delr,r,rl,rmax,rdel,radexp,rscale,rsave
      common /abel  / xeh(nl),xeln(nni),xelln(nnnl)
      common /abh   / xihh(11),xihho(11),bbrt(11),enrt(11)
      common /rrcool/ rrcl(nni)
      common /rrrate/ rrrt(nni)
      common /tau0ln/ tau0(nnnl)
      common /tau1ln/ tau1(nnnl)
      common /lopak / oplin(nnnl),oplno(nnnl)
      common /ffesc / fesc(nnnl)
      common /ffescb/ fescb(nnnl)
      common /pqrtt / pqrtot
      common /phrat2/ pirt2(6)
      common /phhht2/ piht2(6)
      common /phrate/ pirt(nni)
      common /cdpth / dpthc(ncn)
      common /bdpth / dpthb(ncn)
      common /hrcrte/ hrcrt(20,28),hrcrtt(28)
      common /ceemis/ ceem(nnnl)
      common /rcemis/ rcem(nnnl)
      common /copak / opakc(ncn),opakco(ncn)
      common /lindat/ elin(nnnl),blin(nnnl),
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &      flin1(nnnl),flin2(nnnl),nbl(nnnl),nilin(nnnl),nlin(nni)
      common /pheat / htt(nni),htcmp
      common /pcool / cll(nni),clbr,clcmp
      common /rrrthh/ rrrths(11,11)
      common /ccrthh/ cirthhs(11,11)
      common /icc   / lichk(nni),lipin
      common /cirate/ cirt(nni)
      common /enerc/epi(ncn),dele(ncn),numcon
c
      character*72 ktitle
c
      dimension rrrth(100,100),nprn(100)
      dimension cirthh(100,100)
      dimension aa0(10,10),aa0a(10,10)
      dimension eee(10)
      dimension cccrthh(10,10),cccrthha(10,10)
      dimension nprno(100)
      dimension gg(11)
      dimension zz(100)
      real*8 x(100),y(100,100),z(100),wkarea(600)
      dimension bbrat(11),enrat(11),xihht(11)
      dimension cirthhn(10),cibeta(10),ccbeta(10,10)
      dimension cirthhna(10),cibetaa(10),ccbetaa(10,10)
      dimension aarec(10),bbrec(10),ccrec(10)
      dimension binb(5,3),cinb(5,3),be09nb(5,9),cc09nb(5,9),
     $          be08nb(5,8),cc08nb(5,8),be07nb(5,7),cc07nb(5,7),
     $          aa09nb(5,9),aa08nb(5,8),aa07nb(5,7)
      dimension denscl(5),aldnscl(5)
c
c     Cota's density scale
      data denscl/1.4e+11,1.4e+9,2.6e+6,1.3,0./
      data aldnscl/11.1461,9.14613,6.41497,0.113943,-36./
c     these are recombination rate coefficients from Osterbrock
      data nprno/1,2*2,3,4,5,6,8,15,60,90*0/
      data cc1/1.e-06/,cc2/1.602196e-18/
      data ethh/13.598/
      data cc/8.626e-08/,ergsev/1.602197e-12/
      data ccee/1.986e-08/
      data c1/1.3e-06/,c2/2.08e-18/
      data ccs/5.465e-09/
      data etkh/13.598/
      data crit/0.5/,lmx/5/
      data ccc/3.018e-15/,emmpe2/918.5/,sqem/10.30676/,
     $     emsq/8.436422e+05/
      data gg/2.,2.,6.,18.,32.,50.,72.,588.,4970.,670960.,1./
      data eee/109737.35,27434.34,27434.35,12193.04,6858.58,4389.49,
     $         3048.26,1504.85,433.77,26.22/      
c     note that Cota's 2s rec rate is 40% low
c     but don't change it now because it messes everything else up
      data aarec/-8.3281,-8.9776,-9.1508,-9.2150,-9.4583,-9.6516,
     $           -9.8112,-9.4942,-9.5858,-9.5028/,
     $     bbrec/-0.10809,-0.06256,-0.12667,-0.12898,-0.12236,-0.11481,
     $           -0.10747,-0.093811,-0.070572,-0.045593/,
     $     ccrec/6.1135,7.2302,4.9748,4.9933,4.7567,4.5614,4.3913,
     $           4.0573,3.2727,1.4592/
      data aa0a/0.,8.230e-07,62.57,5.574,1.279,.4123,.1644,3.0077e-2,
     $              15.96e-4,36.51e-7,
     $         3*0.,0.7478,0.1812,.0593,0.02380,.4377e-2,2.335e-4,
     $              5.075e-7,
     $         3*0.,3.660,0.6603,0.1936,0.07345,1.284e-2,6.564e-4,
     $              15.23e-7,
     $         4*0.,0.8993,.2201,.07780,1.287e-2,6.305e-4,14.11e-7,
     $         5*0.,.2700,.07714,1.118e-2,5.009e-4,10.88e-7,
     $         6*0.,0.1025,1.112e-2,4.278e-4,8.898e-7,
     $         7*0.,1.346e-2,3.886e-4,7.580e-7,
     $         8*0.,16.20e-4,23.05e-7,
     $         9*0.,46.17e-7,
     $             10*0./
      data aa0/0.,8.230e-07,62.57,5.574,1.279,.4123,.1644,3.079e-2,
     $              16.38e-4,38.63e-7,
     $         3*0.,0.7478,0.1812,.0593,0.02380,.4481e-2,2.396e-4,
     $              5.368e-7,
     $         3*0.,3.660,0.6603,0.1936,0.07345,1.315e-2,6.738e-4,
     $              16.10e-7,
     $         4*0.,0.8993,.2201,.07780,1.319e-2,6.474e-4,14.93e-7,
     $         5*0.,.2700,.07714,1.147e-2,5.145e-4,11.51e-7,
     $         6*0.,0.1025,1.144e-2,4.397e-4,9.415e-7,
     $         7*0.,1.392e-2,3.976e-4,8.022e-7,
     $         8*0.,16.74e-4,24.42e-7,
     $         9*0.,49.22e-7,
     $             10*0./
      data aa07nb/3.253,2.995,3.068,3.078,3.079,
     $            .4734,.4359,.4465,.4480,.4481,
     $            1.392,1.279,1.311,1.315,1.315,
     $            1.398,1.382,1.314,1.319,1.319,
     $            1.219,1.113,1.143,1.147,1.147,
     $            1.222,1.107,1.139,1.144,1.144,
     $            1.504,1.341,1.385,1.392,1.392/
      data aa08nb/17.36,17.36,15.87,16.37,16.38,
     $            2.539,2.539,2.322,2.395,2.396,
     $            7.144,7.144,6.528,6.733,6.738,
     $            6.867,6.867,6.271,6.469,6.474,
     $            5.462,5.462,4.982,5.141,5.145,
     $            4.674,4.674,4.255,4.394,4.397,
     $            4.233,4.233,3.845,3.973,3.976,
     $            18.04,18.04,16.12,16.73,16.74/
      data aa09nb/42.89,42.89,42.89,37.33,38.63,
     $            5.958,5.958,5.958,5.188,5.368,
     $            17.87,17.87,17.87,15.56,16.10,
     $            16.57,16.57,16.57,14.43,14.93,
     $            3*12.77,11.12,11.51,
     $            3*10.46,9.098,9.415,
     $            3*8.913,7.752,8.022,
     $            3*27.16,23.59,24.42,
     $            3*55.43,47.49,49.22/
      data be07nb/-.3068,-.2242,-.2429,-.2453,-.2455,
     $            .0459,.1330,.1132,.1104,.1104,
     $            .0459,.1330,.1132,.1104,.1104,
     $            .2093,.3019,.2807,.2778,.2779,
     $            .2980,.3669,.3435,.3402,.3400,
     $            .2922,.4176,.3898,.3858,.3860,
     $            .3789,.5412,.5062,.5009,.5007/
      data cc07nb/0.02331,0.02144,0.02196,0.02204,0.02204,
     $            .7316,.6702,.6874,.6898,.6900,
     $            2.195,2.010,2.062,2.070,2.070,
     $            45.51,41.40,42.54,2*42.71,
     $            423.5,380.5,392.3,394.0,394.1,
     $            3498.,3075.,3188.,3205.,3206.,
     $            46890.,39600.,41470.,41760.,41770./
      data cc08nb/.01029,.01029,.009403,.009698,.009705,
     $            2*.2948,.2691,.2776,.2778,
     $            2*.8843,.8072,.8328,.8334,
     $            2*15.65,14.25,14.72,14.73,
     $            2*110.4,100.2,103.5,103.6,
     $            2*546.8,493.1,511.0,511.5,
     $            2*2212.,1983.,2057.,2059.,
     $            2*1.387e+6,1.162e+6,1.225e+6,1.227e+6/
      data be08nb/2*-.2895,-.2098,-.2332,-.2334,
     $            2*0.0666,.1481,.1242,.1239,
     $            2*0.0666,.1481,.1242,.1239,
     $            2*0.2262,.3097,.2854,.2850,
     $            2*.2723,.3585,.3337,.3335,
     $            2*.2830,.3736,.3474,.3474,
     $            2*.2828,.3794,.3522,.3515,
     $            2*.3640,.5322,.4809,.4807/
      data cc09nb/3*.003435,.002991,.003095,
     $            3*.09481,.08254,.08541,
     $            3*.2844,.2476,.2562,
     $            3*4.742,4.126,4.270,
     $            3*30.54,26.55,27.48,
     $            3*132.8,115.3,119.4,
     $            3*447.2,388.0,401.6,
     $            3*26800.,23100.,23920.,
     $            3*1.163e+8,9.431e+7,9.820e+7/
      data be09nb/-.2772,-.2773,-.2772,-.1702,-.1746,
     $            3*.0803,.1876,.1830,
     $            3*.0803,.1876,.1830,
     $            3*.2389,.3466,.3423,
     $            3*.2828,.3914,.3866,
     $            3*.2912,.4004,.3955,
     $            3*.2876,.3979,.3931,
     $            3*.2610,.3761,.3711,
     $            3*.3137,.4801,.4744/
      data cinb/1.273e+6,1.328e+6,1.311e+6,1.309e+6,1.308e+6,
     $          2*5.362e+7,5.550e+7,5.475e+7,5.473e+7,
     $          3*2.557e+11,2.615e+11,2.588e+11/
      data binb/0.3875,.3345,.3472,.3489,.3489,
     $          2*.2521,.2184,.2298,.2299,
     $          3*.0517,.0347,.0359/
      data cccrthha/0.,0.303,0.5150,0.1497,0.5490,0.02639,0.01476,
     $                 0.02152,0.009455,0.002926,
     $             2*0.,10880.,13.19,2.685,1.027,.5123,0.6729,
     $                 0.2705,0.08074,
     $             3*0.,39.57,8.055,3.081,1.537,2.019,
     $                 0.8116,0.2422,
     $             4*0.,477.6,98.48,38.38,41.57,
     $                 14.33,4.0351,
     $             5*0.,2636.,517.,382.1,100.7,25.96,
     $             6*0.,10610.,3087.,496.4,112.7,
     $             7*0.,39710.,1993.,379.0,
     $             8*0.,1.161e+6,22520.,
     $             9*0.,8.964e+7,
     $             10*0./
      data ccbetaa/3*0.,-0.2753,-0.2682,-0.2650,-0.2635,
     $                -0.2444,-0.2324,-0.1761,
     $            3*0.,0.0649,0.0792,0.0861,0.0897,0.1116,0.1248,.1817,
     $            3*0.,0.0649,0.0792,0.0861,0.0897,0.1116,0.1248,.1817,
     $            4*0.,0.3271,0.2739,0.2637,0.2793,0.2862,0.3411,
     $            5*0.,0.4423,0.3480,0.3417,0.3343,0.3855,
     $            6*0.,0.4840,0.3873,0.3486,0.3944,
     $            7*0.,0.5028,0.3526,0.3918,
     $            8*0.,0.4828,0.3701,
     $            9*0.,0.4744,
     $             10*0./
c     remember cota's 2s2p rate disagrees with osterbrock.
      data cccrthh/0.,0.303,0.5150,0.1497,0.5490,0.02639,0.01476,
     $                 0.02204,0.009705,0.003095,
     $             2*0.,12450.7,13.19,2.685,1.027,.5123,0.6900,
     $                 0.2778,0.08541,
     $             3*0.,39.57,8.055,3.081,1.537,2.070,
     $                 0.8334,0.2562,
     $             4*0.,477.6,98.48,38.38,42.71,
     $                 14.73,4.270,
     $             5*0.,2636.,517.,394.1,103.6,27.48,
     $             6*0.,10610.,3206.,511.5,119.4,
     $             7*0.,41770.,2059.,401.6,
     $             8*0.,1.227e+6,23920.,
     $             9*0.,9.820e+7,
     $             10*0./
      data ccbeta/3*0.,-0.2753,-0.2682,-0.2650,-0.2635,
     $                -0.2455,-0.2332,-0.1746,
     $            2*0.,-0.2,0.0649,0.0792,0.0861,0.0897,
     $                 0.1104,0.1239,.1830,
     $            2*0.,-0.2,0.0649,0.0792,0.0861,0.0897,
     $                  0.1104,0.1239,.1830,
     $            4*0.,0.3271,0.2739,0.2637,0.2779,0.2850,0.3423,
     $            5*0.,0.4423,0.3480,0.3400,0.3335,0.3866,
     $            6*0.,0.4840,0.3860,0.3474,0.3955,
     $            7*0.,0.5007,0.3515,0.3931,
     $            8*0.,0.4807,0.3711,
     $            9*0.,0.4744,
     $             10*0./
      data cirthhna/1.623,41.43,124.3,1529.,6945.,21560.,52950.,
     $            1.323e+6,5.523e+7,2.605e+11/
      data cibetaa/0.7641,0.8178,0.8178,0.7382,0.6442,0.5671,0.5064,
     $            0.3463,0.2289,0.0365/
      data cirthhn/1.623,41.43,124.3,1529.,6945.,21560.,52950.,
     $            1.308e+6,5.473e+7,2.588e+11/
      data cibeta/0.7641,0.8178,0.8178,0.7382,0.6442,0.5671,0.5064,
     $            0.3489,0.2299,0.0359/
c
      lprisv=lpri
c
      if (lpri.ge.1) write (6,*)'in hcor'
c
c
      nsize=100
      nlevo=10
      nlev=10
c      nlevo=3
c      nlev=3
      nlevm=nlev-1
      nlevp=nlev+1
c
c     calculate collisional rates
      do 100 kl = 1,nsize
         nprn(kl)=nprno(kl)
         do 50 ll = 1,nsize
            cirthh(kl,ll) = 0.
 50      continue
 100  continue
c
      sqt = sqrt(t)
      vtherm = 6.211e+07*sqrt(t)
c
        algt=alog10(t)+4.
        zzz=1.
        zeff=1.
        csig=8.79737e-17
        sq3=1.732050
        pi=3.141592
        ekt=t*(0.861707)
        tt3s2=(t*1.e+4)**(-1.5)
c
      do 500 kl = 1,nsize
         do 400 ll = 1,nsize
            rrrth(kl,ll) = 0.
            cirthh(kl,ll)=0.
 400     continue
 500  continue
c
c     saha
      ekt = t*0.8617
      do 1200 jk = 1,nlev
         deleev=eee(jk)*(1.2398544e-4)
         tmp=deleev/ekt
         ener=deleev
         enrat(jk)=(ccc/ekt)**1.5*(gg(jk)/(gg(nlevp)))
     $              *expo(ener/ekt)
 1200 continue
      enrat(nlevp) = 1.
      bbrat(nlevp) = 1.
c
c     prepare by finding density scaling factor
      alxnx=alog10(amax1(xnx,1.e-34))
      call hunt(aldnscl,5,alxnx,jlo,lpri)
      jlo=min0(max0(1,jlo),5)
      if (lpri.gt.2) write (6,*)'density scale:',alxnx,jlo,aldnscl(jlo)
c
       if (lpri.ge.3)
     $   write (6,*)'filling collisional excitation:'
c
      nlevcrt=7
      do 401 ll=1,nlev
         deleev=eee(ll)*(1.24241e-4)
         tmpp=deleev/ekt
         citmp=cirthhn(ll)
         bitmp=cibeta(ll)
         nprll=ll
         if (lpri.ge.3) write (6,*)'nprll=',nprll
         if (nprll.le.nlevcrt) go to 4401
c
         llr=ll-7
         bitmp=binb(jlo,llr)
         citmp=cinb(jlo,llr)
c
 4401    continue
c
         cirthh(ll,nlevp)=(4.1416e-9)*cirthhn(ll)*t**cibeta(ll)
     $                   *expo(-tmpp)/gg(ll)
         cirthh(nlevp,ll)=cirthh(ll,nlevp)*enrat(ll)
c
         llm=ll-1
         if (llm.le.0) go to 401
c
         do 402 ml=1,llm

c           special cases for Cota levels
            cctmp=cccrthh(ll,ml)
            betmp=ccbeta(ll,ml)
            if (nprll.le.nlevcrt) go to 4550
c
            if (nprll.ne.8) go to 4551
            cctmp=cc07nb(jlo,ml)
            betmp=be07nb(jlo,ml)
 4551       continue
            if (nprll.ne.9) go to 4552
            cctmp=cc08nb(jlo,ml)
            betmp=be08nb(jlo,ml)
 4552       continue
            if (nprll.ne.10) go to 4553
            cctmp=cc09nb(jlo,ml)
            betmp=be09nb(jlo,ml)
 4553       continue
c
 4550       continue

           qmn=(8.629e-8)*cctmp*t**betmp/gg(ll)
c           if ((ll.eq.3).and.(ml.eq.2)) qmn=qmn*2.
           cirthh(ll,ml)=qmn
           deleev=(eee(ml)-eee(ll))*(1.24241e-4)
           tmp=deleev/ekt
           cirthh(ml,ll)=qmn*gg(ll)*expo(-tmp)/gg(ml)
           if (lpri.ge.3) write (6,*)ll,ml,cctmp,betmp,qmn,cirthh(ml,ll)
 402       continue
 401     continue
c
c     calculate radiative rates
      ekt = t*0.861707
      xst = sqrt(t)
c      lpri=lprisv
c
      if (lpri.ge.3)
     $ write (6,*)'filling radiative rates'
      ll = 0
      if (nlev.le.1) go to 3082
      do 900 jk = 1,nlevm
         jkp1 = jk + 1
         do 850 kl = jkp1,nlev
c
c           special cases for Cota levels
            aatmp=aa0(kl,jk)
            if (aatmp.le.1.e-34) go to 850
            nprkl=kl
            if (lpri.ge.3) write (6,*)'nprkl=',nprkl
            if (nprkl.le.nlevcrt) go to 8550
c
            if (nprkl.ne.8) go to 8551
            aatmp=aa07nb(jlo,jk)*(0.01)
 8551       continue
            if (nprkl.ne.9) go to 8552
            aatmp=aa08nb(jlo,jk)*(1.e-4)
 8552       continue
            if (nprkl.ne.10) go to 8553
            aatmp=aa09nb(jlo,jk)*(1.e-7)
 8553       continue
c
 8550       continue
            fesctmp=1.
            if ((kl.eq.2).and.(jk.eq.1)) go to 8851
               ll = ll + 1
               fesctmp=fesc(ll)+fescb(ll)
 8851          continue
            if ((lbcase.eq.1).and.(jk.eq.1).and.(kl.gt.nlevo)) 
     $          fesctmp=0.
            rrrth(kl,jk)=(1.e+7)*fesctmp*aatmp
            if (lpri.ge.3)
     $       write (6,*)jk,kl,ll,fesctmp,aatmp
c            if ((jk.eq.2).and.(kl.ge.7)) rrrth(kl,jk)=rrrth(kl,jk)*(5.)
 850     continue
 900  continue
      rrrth(2,1)=aa0(2,1)*(1.e+7)
 3082 continue
c
c    now put in continuum rates
c
c     first recombination
      rrmax=rrrt(1)
      rrsum=0.
      nst=1
      if (lbcase.eq.1) nst=2
      do 800 kl=nst,nlev
         rrrth(nlevp,kl)=
     $    10.**(aarec(kl)+bbrec(kl)*(algt-ccrec(kl))**2)/t/1.e+4
         rrsum=rrsum+rrrth(nlevp,kl)
 800  continue
      rrcor=1.
      if (lbcase.ne.1) rrcor=rrmax/rrsum
      do 808 kl=nst,nlev
         rrrth(nlevp,kl)=rrrth(nlevp,kl)*rrcor
 808     continue
      rrrthoo=rrrth(7,1)
      nlyc=nbinc(13.6)
      if ((lbcase.eq.0).and.(lnoinwd.eq.0).and.(lthin.eq.0))
     $ rrrth(7,1) = rrrthoo*(expo(-dpthc(nlyc))+expo(-dpthb(nlyc)))/2.
c
c     now photoionization
      do 600 jk = 1,nlev
         jk2=nprn(jk)
         if ((jk2.eq.0).or.(jk2.gt.6)) go to 600
         rrrth(jk,nlevp) = pirt2(jk2)
 600  continue
      rrrth(1,nlevp) = rrrth(1,nlevp) + pqrtot
      n584=nlin(1)+1
      n304=nlin(1)+nlin(2)+1
      eps=1.e-34
c      rrrth(1,nlevp)=rrrth(1,nlevp)
c     $  +(rcem(n584)+ceem(n584))*(1.656e-18)
c     $  *min(delr,1./(oplin(n584)+eps))
c     $  +(rcem(n304)+ceem(n304))*(2.337e-19)
c     $  *min(delr,1./(oplin(n584)+eps))
c     rrrth(2,nlevp)=rrrth(2,nlevp)
c    $ +(rcem(526)+ceem(526))*(1.137e-17)/(oplin(526)+eps)
c    $ +(rcem(1156)+ceem(1156))*(9.132e-18)/(oplin(1156)+eps)
c    $ +(rcem(244)+ceem(244))*(1.152e-18)/(oplin(244)+eps)
c
      if ( lpri.gt.2 ) then
         do 350 jk = 1,nlevp
            do 320 kl = 1,nlevp
               write (6,99001) jk,kl,cirthh(jk,kl)
 320        continue
 350     continue
      endif
c
      if ( lpri.gt.2 ) then
         do 950 jk = 1,nlevp
            do 920 kl = 1,nlevp
               write (6,99002) jk,kl,rrrth(jk,kl)
 920        continue
 950     continue
      endif
c
c
c     calculate level populations
      if ( lcdd.eq.0 ) xpx = p/(1.4e-12*t*(1.+xee))
      xnx = xpx*xee
      do 1100 jk = 1,nlevp
         x(jk) = 0.
         z(jk) = 0.
         do 1000 kl = 1,nlevp
            y(jk,kl) = 0.
 1000    continue
 1100 continue
c
c     test to see if thin approximation is good
      rrsum = 0.
      do 1300 ll = 1,nlev
         rrsum = rrsum + rrrth(nlevp,ll)
 1300 continue
      rrrta=rrsum
      xihht(1) = xnx*rrsum/(rrrth(1,nlevp)+xnx*cirthh(1,nlevp)
     $                           +xnx*rrsum+1.e-30)
      xihht(nlevp) = 1. - xihht(1)
      if ( lpri.gt.2 ) write (6,99003) rrsum,xnx,rrrth(1,nlevp),
     &                                 xihht(1),xihht(nlevp)
      if ( nlevm.ge.2 ) then
         do 1350 ll = 2,nlev
            xihht(ll) = (xihht(1)*xnx*cirthh(1,ll)
     $                 +xihht(nlevp)*xnx*rrrth(nlevp,ll)
     &                 )/(rrrth(ll,1)+xnx*cirthh(ll,1)+rrrth(ll,nlevp))
            if ( lpri.gt.2 ) write (6,99004) ll,cirthh(1,ll),
     &                              rrrth(nlevp,ll),rrrth(ll,1),
     &                              cirthh(ll,1),rrrth(ll,nlevp),
     &                              xihht(ll)
 1350    continue
      endif
      do 1400 ll = 1,nlev
       bbrat(ll) = xihht(ll)/amax1(1.e-18,(xihht(nlevp)*enrat(ll)*xnx))
       if ( lpri.gt.2) write (6,99005) ll,enrat(ll),bbrat(ll)
       if (t.lt.100.)  go to 1400
          bbrt(ll)=bbrat(ll)
          enrt(ll)=enrat(ll)
          xihh(ll)=bbrt(ll)*enrat(ll)
 1400 continue
      if (t.lt.100.) go to 1401
         bbrt(nlevp)=bbrat(nlevp)
         enrt(nlevp)=enrat(nlevp)
         xihh(nlevp)=xihht(nlevp)
         pirt(1)=rrrth(1,nlevp)
         cirt(1)=cirthh(1,nlevp)
         rrrt(1)=rrsum
 1401    continue
c
c      if (t.gt.100.) go to 9822
c
c     print matrices
      if ( lpri.gt.2 ) then
         do 1450 jk = 1,nlevp
            write (6,99007) jk,bbrat(jk),enrat(jk)
 1450    continue
      endif
c
c     fill the equation matrices for bound levels
      sumc = 0.
      xnxt=xnx
      do 1500 jk = 1,nlev
         sum = 0.
         if ( jk.gt.1 ) then
            jkm1 = jk - 1
            do 1460 kl = 1,jkm1
               sum = sum + enrat(jk)*(rrrth(jk,kl)+cirthh(jk,kl)*xnxt)
               y(jk,kl) = -enrat(kl)*(rrrth(kl,jk)+cirthh(kl,jk)*xnxt)
 1460       continue
         endif
         if ( jk.lt.nlev ) then
            jkp1 = jk + 1
            do 1480 kl = jkp1,nlev
               y(jk,kl) = -enrat(kl)*(cirthh(kl,jk)*xnxt+rrrth(kl,jk))
               sum = sum +(cirthh(jk,kl)*xnxt+rrrth(jk,kl))*enrat(jk)
 1480       continue
         endif
         y(jk,nlevp)=-enrat(nlevp)*xnx*(cirthh(nlevp,jk)*xnxt
     $                                      +rrrth(nlevp,jk))
         y(nlevp,jk)=enrat(jk)
         z(jk) = 0.
         zz(jk) = z(jk)
         y(jk,jk)=sum+enrat(jk)*(rrrth(jk,nlevp)+cirthh(jk,nlevp)*xnxt)
 1500 continue
      y(nlevp,nlevp)=enrat(nlevp)
      z(nlevp)=1.
      zz(nlevp)=1.
c
      if ( lpri.gt.2 ) then
         do 1550 jk = 1,nlevp
            do 1551 ll=1,nlevp
               write (6,*) jk,ll,y(jk,ll)
 1551          continue
            write (6,*)jk,z(jk)
 1550    continue
      endif
c
c     solve for bound level departure coefficients
      m = 1
      n = nlevp
      ia = 100
      idgt = nlevp
      call leqt2f(y,m,n,ia,z,idgt,wkarea,ier,lpri)
c
      if ( lpri.gt.2 ) then
c     check solution
         write (6,*)'checking solution'
         errsum = 0.
         zzsum = 0.
         do 1600 jk = 1,nlevp
            sum = 0.
            termmx = 0.
            do 1560 kl = 1,nlevp
               term = y(jk,kl)*z(kl)
               sum = sum + term
               termmx = amax1(termmx,abs(term))
 1560       continue
            termmx = amax1(termmx,abs(zz(jk)))
            err = sum - zz(jk)
            errrl = err/(1.e-36+termmx)
            errsum = errsum + err*err
            zsum = zsum + z(jk)*z(jk)
            write (6,*) jk,(y(jk,mm),mm=1,2),z(jk),zz(jk)
     &                     ,err,errrl
 1600    continue
         write (6,99010) errsum,zsum
      endif
c
      sum = 0.
      sum2 = 1.
      do 1700 jk = 1,nlevp
         bbrat(jk) = z(jk)
         sum = sum + bbrat(jk)*enrat(jk)
 1700 continue
c
 9822 continue
c
c     calculate level populations
      xccc=1.
      if (lpri.gt.2) write (6,*)'the solution:'
      rrsum=0.
      pirtsum=0.
      collsum=0.
      do 1808 mm=1,nlevo+1
         xihh(mm)=0.
         enrt(mm)=0.
         bbrt(mm)=0.
         do 1809 ml=1,nlevo+1
            rrrths(mm,ml)=0.
            cirthhs(mm,ml)=0.
 1809       continue
 1808    continue
      do 1800 jk = 1,nlevo
         jk2=jk
         xihhtmp=enrat(jk)*bbrat(jk)*xccc
         if (jk.eq.1) xihhgnd=xihhtmp
         xihh(jk2) = xihh(jk2)+xihhtmp
         enrt(jk2) = enrt(jk2)+enrat(jk)
         bbrt(jk2) = bbrt(jk2)+bbrat(jk)
         if (lpri.gt.2) write (6,*)jk,enrat(jk),bbrat(jk),xihhtmp
         rrsum=rrsum+rrrth(nlevp,jk)
         pirtsum=pirtsum+rrrth(jk,nlevp)*xihhtmp
     $            /amax1(1.e-34,xihhgnd)
         collsum=collsum+cirthh(jk,nlevp)*xihhtmp
     $            /amax1(1.e-34,xihhgnd)
         do 1802 kl=1,nlevo
            kl2=kl
            rrrths(jk2,kl2)=rrrths(jk2,kl2)+rrrth(jk,kl)
            cirthhs(jk2,kl2)=cirthhs(jk2,kl2)+cirthh(jk,kl)
 1802       continue
         rrrths(jk2,nlevo+1)=rrrths(jk2,nlevo+1)+rrrth(jk,nlevp)
         rrrths(nlevo+1,jk2)=rrrths(nlevo+1,jk2)+rrrth(nlevp,jk)
         cirthhs(jk2,nlevo+1)=cirthhs(jk2,nlevo+1)+cirthh(jk,nlevp)
         cirthhs(nlevo+1,jk2)=cirthhs(nlevo+1,jk2)+cirthh(nlevp,jk)
 1800 continue
      do 1801 jk=nlevo+1,nlev
         rrsum=rrsum+rrrth(nlevp,jk)         
 1801    continue
      pirt(1)=pirtsum
c      cirt(1)=collsum
      cirt(1)=cirthhs(1,nlevo+1)
      rrrt(1)=rrsum
      xihh(nlevo+1)=enrat(nlevp)*bbrat(nlevp)
      enrt(nlevo+1)=enrat(nlevp)
      bbrt(nlevo+1)=bbrat(nlevp)
c      rrrt(1)=xihh(1)*(pirt(1)+xnx*cirt(1))
c     $             /max(1.e-34,xihh(nlevo+1)*xnx)
c      cirt(1)=0.
      if (lpri.gt.2) 
     $   write (6,*)nlevo,enrt(nlevo+1),bbrt(nlevo+1),xihh(nlevo+1)
c
c
c     calculate effective recombination rates
      if (lpri.lt.3) go to 1953
      write (6,*)'effective recombination rates:'
      do 1950 ll=1,nlevo
        rin=(rrrths(nlevo+1,ll)+xnx*cirthhs(nlevo+1,ll))
     $                 *xnx*xihh(nlevo+1)
        llp1=ll+1
        if (ll.eq.nlevo) go to 1952
        do 1951 ml=llp1,nlevo
           rin=rin+xihh(ml)*(rrrths(ml,ll)+xnx*cirthhs(ml,ll))
 1951      continue
 1952   continue
        alpheff=rin/amax1(1.e-34,xnx*xihh(nlevo+1))
        write (6,*)ll,xihh(ll),alpheff
 1950   continue
 1953 continue
c
c     fill ion abundance arrays
      xii(2) = xihh(nlevo+1)
c      xii(1) = 1. - xihh(nlevo+1)
      xii(1)=xihh(1)
      xiip(1) = xii(2)
      xiin(1) = xii(1)
c
c
c      if (lpri.ge.3) stop
c
      lpri=lprisv
c
      return
99001 format (' ',' in collh ',2i4,2e12.4)
99002 format (' ',' in rrradh ',2i4,2e12.4)
99003 format (' ',6e12.4)
99004 format (' ',i4,6e12.4)
99005 format (' ',i4,2e12.4)
99006 format (' ',' non simple h ')
99007 format (' ',i4,4e12.4)
99008 format (' ',i4,7e12.4)
99009 format (' ',i4,10e12.4)
99010 format (' ',2e12.4)
99011 format (' ',i4,2e12.4)
c
      end
      subroutine he2cor
c
c
c
c     this routine calculates  level populations for he+
c     note that all internal variable names are the same as for
c     hydrogen
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /prs   / p,p0
      common /temp  / t,to
      common /phrate/ pirt(nni)
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /abel  / xeh(nl),xeln(nni),xelln(nnnl)
      common /abhe2 / xihh(7),xihho(7),bbrt(7),enrt(7)
      common /rrcool/ rrcl(nni)
      common /linsel/ nlsv(nnnl),nlsvn
      common /rrrate/ rrrt(nni)
      common /tau0ln/ tau0(nnnl)
      common /tau1ln/ tau1(nnnl)
      common /lopak / oplin(nnnl),oplno(nnnl)
      common /ffesc / fesc(nnnl)
      common /ffescb/ fescb(nnnl)
      common /pqrtt / pqrtot
      common /phrah2/ pirt2(6)
      common /phhhh2/ piht2(6)
      common /pqrah2/ piqt2(6)
      common /cdpth / dpthc(ncn)
      common /bdpth / dpthb(ncn)
      common /hrcrte/ hrcrt(20,28),hrcrtt(28)
      common /ceemis/ ceem(nnnl)
      common /rcemis/ rcem(nnnl)
      common /copak / opakc(ncn),opakco(ncn)
      common /lindat/ elin(nnnl),blin(nnnl),
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &     flin1(nnnl),flin2(nnnl),nbl(nnnl),nilin(nnnl),nlin(nni)
      common /pheat / htt(nni),htcmp
      common /pcool / cll(nni),clbr,clcmp
      common /rrrthe/ rrrth(7,7)
      common /ccrthe/ cirthh(7,7)
      common /icc   / lichk(nni),lipin
      common /cirate/ cirt(nni)
c
      character*72 ktitle
c
      dimension aa0(6,6)
      dimension eee(7)
      dimension cccrth(6,6)
      dimension ff(6,6)
      dimension eth(7),gg(7)
      dimension zz(6)
      real*8 x(6),y(6,6),z(6),wkarea(600)
      dimension bbrat(7),enrat(7)
      dimension aarec(10),bbrec(10),ccrec(10)
c
      data aarec/-8.3281,-8.9776,-9.1508,-9.2150,-9.4583,-9.6516,
     $           -9.8112,-9.4942,-9.5858,-9.5028/,
     $     bbrec/-0.10809,-0.06256,-0.12667,-0.12898,-0.12236,-0.11481,
     $           -0.10747,-0.093811,-0.070572,-0.045593/,
     $     ccrec/6.1135,7.2302,4.9748,4.9933,4.7567,4.5614,4.3913,
     $           4.0573,3.2727,1.4592/
      data cc1/1.e-06/,cc2/1.602196e-18/
      data ethh/13.598/
      data aa0/0.,2.139e-09,1.818e-08,8.333e-08,2.500e-07,
     &     6.173e-07,2*0.,2.326e-08,1.205e-07,4.000e-07,
     &     1.087e-06,3*0.,1.124e-07,4.545e-07,1.299e-06,4*0.,
     &     3.704e-07,1.299e-06,5*0.,9.901e-07,6*0./
      data eee/0.,40.8,48.36,51.0,52.24,52.9,54.4/
      data cc/8.626e-08/,ergsev/1.602197e-12/
      data ccee/1.986e-08/
      data c1/1.3e-06/,c2/2.08e-18/
c     data c4/5.957e-52/,c5/3.718e-40/
      data ccs/5.465e-09/
      data etkh/54.4/
      data ff(1,1),ff(2,1),ff(3,1),ff(4,1),ff(5,1),ff(6,1),
     &     ff(1,2),ff(2,2),ff(3,2),ff(4,2),ff(5,2),ff(6,2),
     &     ff(1,3),ff(2,3),ff(3,3),ff(4,3),ff(5,3),ff(6,3),
     &     ff(1,4),ff(2,4),ff(3,4),ff(4,4),ff(5,4),ff(6,4),
     &     ff(1,5),ff(2,5),ff(3,5),ff(4,5),ff(5,5),ff(6,5),
     &     ff(1,6),ff(2,6),ff(3,6),ff(4,6),ff(5,6),ff(6,6)
     &     /0.,0.4162,0.0791,0.0290,0.0139,0.0078,2*0.,
     &     0.6412,0.1195,0.0224,0.0124,3*0.,0.8413,0.1500,
     &     0.0554,4*0.,1.0380,0.1799,5*0.,0.1,6*0./
      data cccrth(2,1),cccrth(3,1),cccrth(3,2),cccrth(4,1),
     &     cccrth(4,2),cccrth(4,3),cccrth(5,1),cccrth(5,2),
     &     cccrth(5,3),cccrth(5,4),cccrth(6,1),cccrth(6,2),
     &     cccrth(6,3),cccrth(6,4),cccrth(6,5)/9.66e-9,1.291e-8, 
     &     2.77e-7,4.74e-9,4.34e-08,1.26e-06,1.273e-9,1.10e-08, 
     &     2.00e-07,4.40e-06 ,3*0.,6.00e-07,1.20e-05/
      data crit/0.5/,lmx/5/
      data eth/0.,40.8,48.36,51.0,52.24,52.9,54.4/
      data gg/1.,4.,9.,16.,25.,36.,2./
      data ccc/2.395e-15/
c     
      lprisv=lpri
      lpri=0
      if (lpri.ne.0) write (6,*)'in he2cor',t
c
c      if ((lichk(3).ne.1).or.(t.lt.0.5)) return
      if (lpri.ne.0) lpri=2
c
c     calculate collisional rates
      do 100 kl = 1,7
         do 50 ll = 1,7
            cirthh(kl,ll) = 0.
 50      continue
 100  continue
c
      ekt = t*0.8617
      sqt = sqrt(t)
      vtherm = 6.211e+07*sqrt(t)
c
      cirthh(1,7)=(4.1416e-9)*(1.623)*t**(0.7641)
     $             *expo(-13.598/0.861707)/8.
c      cirthh(1,7) = 0.
      sqt = sqrt(t)
      cirthh(2,7) = (1.64e-9)/4.
      cirthh(3,7) = (7.44e-8)/4.
      cirthh(4,7) = (5.06e-7)/4.
      cirthh(5,7) = (1.64e-6)/4.
      cirthh(6,7) = (2.80e-5)/4.
      do 200 ll = 1,6
         ethh = (54.4)/(float(ll)*float(ll))
         cirthh(ll,7) = cirthh(ll,7)*expo(-ethh*(1./ekt-0.29))/sqt
 200  continue
c
      do 300 kl = 1,5
         klp1 = kl + 1
         do 250 ll = klp1,6
            ett = eee(ll) - eee(kl)
            fact = ett*(1.-1./t)/0.8617
            tmp = (0.8617*t)/ett
            cirthh(ll,kl) = cccrth(ll,kl)/sqt/4.
c    $ *(expo(-tmp)+(1.-expo(-tmp))/sqt)
            cirthh(kl,ll) = cirthh(ll,kl)*expo(-ett/(0.8617*t))
     &                      *ll*ll/(kl*kl)
 250     continue
 300  continue
      ett = 0.1002
      fact = ett*(1.-1./t)/0.8617
      crt67 = 3.68e-5*expo(fact)
      cirthh(6,7) = cirthh(6,7) + (0.6667)*crt67
c
      if ( lpri.gt.1 ) then
         do 350 jk = 1,7
            do 320 kl = 1,7
               write (6,99001) jk,kl,cirthh(jk,kl)
 320        continue
 350     continue
      endif
c
c
c
c
c     calculate radiative rates
      ekt = t*0.861707
      xst = sqrt(t)
      do 500 kl = 1,7
         do 400 ll = 1,7
            rrrth(kl,ll) = 0.
 400     continue
 500  continue
      do 600 jk = 1,6
         rrrth(jk,7) = pirt2(jk)
 600  continue
c      rrrth(1,7) = rrrth(1,7) + pqrtot*(0.1)
      eps = 1.e-30
c     rrrth(1,7)=rrrth(1,7)
c    $  +(rcem(16)+ceem(16))*(1.656e-18)/(oplin(16)+eps)
c    $  +(rcem(31)+ceem(31))*(2.337e-19)/(oplin(31)+eps)
c     rrrth(2,7)=rrrth(2,7)
c    $ +(rcem(526)+ceem(526))*(1.137e-17)/(oplin(526)+eps)
c    $ +(rcem(1156)+ceem(1156))*(9.132e-18)/(oplin(1156)+eps)
c    $ +(rcem(244)+ceem(244))*(1.152e-18)/(oplin(244)+eps)
c
      rrtmp = 0.
      nst = 1
      ekt = (0.8617)*t
      nlyc = nbinc(54.4)
      nbac = nbinc(13.6)
c      if ( (dpthc(nbac).gt.0.01) .and. (dpthb(nbac).gt.0.01) )
c     &     rrsum = 0.
      rrsum=0.
      tfak=t/4.
      algt=alog10(tfak)+4.
      klp=0
      do 800 kl = nst,6
         ethhh = 54.4/float(kl*kl)
         klp=klp+1
         rrrth(7,kl) =2.*
     $    10.**(aarec(klp)+bbrec(klp)*(algt-ccrec(klp))**2)/tfak/1.e+4
         if (kl.ne.2) go to 801
         klp=klp+1
         rrrth(7,kl)=rrrth(7,kl)+2.*
     $    10.**(aarec(klp)+bbrec(klp)*(algt-ccrec(klp))**2)/tfak/1.e+4
 801     continue
         rrsum=rrsum+rrrth(7,kl)
 800  continue
      rrsum=max(0.,rrrt(3)-rrsum)
      if (lpri.ne.0) write (6,*)'he II rrsum:',rrsum,rrrt(3)
      rrrth(7,6)=rrrth(7,6)+rrsum
      if (lnoinwd.ne.1)
     $ rrrth(7,1) = rrrth(7,1)*(expo(-dpthc(nlyc))+expo(-dpthb(nlyc)))/2.
c      if ((dpthc(nbac).gt.(0.01)).and.(dpthb(nbac).gt.(0.01)))
c     $rrrth(7,2)=rrrth(7,2)*(expo(-dpthc(nbac))
c     $  *(1.+dpthc(nbac)*((0.35)*t**(0.75)+(0.09)*dpthc(nbac)*t))
c     $                     +expo(-dpthb(nbac))
c     $  *(1.+dpthb(nbac)*((0.35)*t**(0.75)+(0.09)*dpthb(nbac)*t)))
c     $    /2.
c
c     nie assumption
c      if (lbcase.eq.1) rrrth(7,1)=0.
c
      ll = nlin(1) + nlin(2)
      do 900 jk = 1,5
         jkp1 = jk + 1
         do 850 kl = jkp1,6
            ll = ll + 1
c            if ((lbcase.eq.1).and.(jk.eq.1)) then
c              fesc(ll)=0.
c              fescb(ll)=0.
c              endif
            rrrth(kl,jk) = 16.*(fesc(ll)+fescb(ll))
     &                     /max(aa0(kl,jk),1.e-10)
            entp = ergsev*(12398.54)/elin(ll)
 850     continue
 900  continue
      if (lbcase.eq.0)
     $ rrrth(2,1) = rrrth(2,1) + 7./4.
c
      if ( lpri.gt.1 ) then
         do 950 jk = 1,7
            do 920 kl = 1,7
               write (6,99002) jk,kl,rrrth(jk,kl)
 920        continue
 950     continue
      endif
c
c
c
c     calculate level populations
      if ( lcdd.eq.0 ) xpx = p/(1.4e-12*t*(1.+xee))
      xnx = xpx*xee
c      if ( t.gt.100. ) go to 3001
      nlev = 7
      nlevm = nlev - 1
      nlevm2 = nlev - 2
      do 1100 jk = 1,nlevm
         x(jk) = 0.
         z(jk) = 0.
         do 1000 kl = 1,nlevm
            y(jk,kl) = 0.
 1000    continue
 1100 continue
c
      ekt = t*0.8617
      gg(7) = 1.
      ensum=0.
      do 1200 jk = 1,nlevm
         ener = eth(7) - eth(jk)
         tmp = ener/ekt
         tmp = min(tmp,80.)
         gg(jk) = 2.*float(jk*jk)
         enrat(jk) = xnx*(ccc/ekt)**1.5*(gg(jk)/(gg(7)))*exp(tmp)
         ensum=ensum+enrat(jk)
 1200 continue
      enrat(nlev)=1./(1.+ensum)
      do 1201 jk=1,nlevm
         enrat(jk)=enrat(jk)*enrat(nlev)
 1201    continue
      bbrat(nlev) = 1.
c
c     test to see if thin approximation is good
      rrsum = 0.
      do 1300 ll = 1,nlevm
         rrsum = rrsum + rrrth(7,ll)
 1300 continue
      xihh(1) = xnx*rrsum/(rrrth(1,7)+xnx*rrsum+1.e-30)
      xihh(7) = 1. - xihh(1)
      if ( lpri.gt.1 ) write (6,99003) rrsum,xnx,rrrth(1,7),
     &                                 xihh(1),xihh(7)
      if ( nlevm.ge.2 ) then
         do 1350 ll = 2,nlevm
            xihh(ll) = (xihh(1)*xnx*cirthh(1,ll)+xihh(7)*xnx*rrrth(7,ll)
     &                 )/(rrrth(ll,1)+xnx*cirthh(ll,1)+rrrth(ll,7))
            if ( lpri.gt.1 ) write (6,99004) ll,cirthh(1,ll),
     &                              rrrth(7,ll),rrrth(ll,1),
     &                              cirthh(ll,1),rrrth(ll,7),
     &                              xihh(ll)
 1350    continue
      endif
      do 1400 ll = 1,nlevm
         enrt(ll) = enrat(ll)
c         bbrt(ll) = 1.
         bbrt(ll)=xihh(ll)/(xihh(7)*enrt(ll)*xnx)
         if ( lpri.gt.1 ) write (6,99005) ll,enrt(ll),bbrt(ll)
 1400 continue
      enrt(7) = 1.
      bbrt(7) = 1.
      tst = bbrt(2)/(bbrt(1)+1.e-30)
c
c     print matrices
      lpppri = lpri
      if ( lpppri.gt.1 ) then
         do 1450 jk = 1,nlev
            write (6,99007) jk,bbrat(jk),enrat(jk)
 1450    continue
      endif
c
c     fill the equation matrices for bound levels
      sumc = 0.
      do 1500 jk = 1,nlevm
         sum = 0.
         if ( jk.gt.1 ) then
            jkm1 = jk - 1
            do 1460 kl = 1,jkm1
               sum = sum + enrat(jk)*(rrrth(jk,kl)+cirthh(jk,kl)*xnx)
               y(jk,kl) = -enrat(jk)*cirthh(jk,kl)*xnx
 1460       continue
         endif
         if ( jk.lt.nlevm ) then
            jkp1 = jk + 1
            do 1480 kl = jkp1,nlevm
               y(jk,kl) = -enrat(kl)*(cirthh(kl,jk)*xnx+rrrth(kl,jk))
               sum = sum + cirthh(kl,jk)*xnx*enrat(kl)
 1480       continue
         endif
         z(jk) = (rrrth(7,jk)+xnx*cirthh(7,jk))
         zz(jk) = z(jk)
         y(jk,jk) = sum + enrat(jk)*(rrrth(jk,7)+cirthh(jk,7)*xnx)
 1500 continue
c
      if (abs(y(1,1)).le.1.e-37) go to 9098
      if ( lpppri.gt.1 ) then
         do 1550 jk = 1,nlevm
            write (6,99008) jk,(y(jk,ll),ll=1,nlevm),z(jk)
 1550    continue
      endif
c
c     solve for bound level departure coefficients
      m = 1
      n = 6
      ia = 6
      idgt = 6
      call leqt2f(y,m,n,ia,z,idgt,wkarea,ier,lpri)
c
c      go to 3552
      if ( lpppri.gt.1 ) then
c     check solution
         if (lpri.gt.1) write (6,*)'checking solution'
         errsum = 0.
         zzsum = 0.
         do 1600 jk = 1,nlevm
            sum = 0.
            termmx = 0.
            do 1560 kl = 1,nlevm
               write (6,*)jk,kl,y(jk,kl),z(kl),sum,termmx
               term = y(jk,kl)*z(kl)
               sum = sum + term
               termmx = max(termmx,abs(term))
 1560       continue
            termmx = max(termmx,abs(zz(jk)))
            err = sum - zz(jk)
            errrl = err/max(1.e-24,termmx)
            errsum = errsum + err*err
c            zsum = zsum + z(jk)*z(jk)
            write (6,99009) jk,(y(jk,mm),mm=1,nlevm),z(jk),zz(jk)
     &                     ,err,errrl
 1600    continue
         write (6,99010) errsum,zsum
      endif
 3552 continue
c
      sum = 0.
      sum2 = 1.
      do 1700 jk = 1,nlevm
         bbrat(jk) = z(jk)
         if (lpri.ge.2) write (6,*)jk,bbrat(jk),enrat(jk),sum
         sum = sum + bbrat(jk)*enrat(jk)
 1700 continue
c
c     calculate level populations
      xccc = 1./(1.+sum*xnx)
      do 1800 jk = 1,nlevm
         xihh(jk) = enrat(jk)*bbrat(jk)*xccc*xnx
         enrt(jk) = enrat(jk)
         bbrt(jk) = bbrat(jk)
 1800 continue
      xihh(7) = xccc
      enrt(7) = enrat(nlev)
      bbrt(7) = bbrat(nlev)
c
 9098 continue
c
c     fill ion abundance arrays
      if (lpri.gt.1) write (6,*)xihh(7),xnx,pirt(3)
      rrrt(3)=xihh(1)*(pirt(3)+cirt(3)*xnx)/(xihh(7)*xnx+1.e-34)
      if ( lpri.gt.1 ) write (6,99012) xihh(7),xnx,pirt(3),rrrt(3)
c
c     print out
      if ( lpri.gt.1) then
      write (6,99013) (xihh(ll),ll=1,7)
      write (6,99014) (bbrt(ll),ll=1,7)
      write (6,99015) (enrt(ll),ll=1,7)
      endif
c
 3001 continue
      lpri=lprisv
c
c
      return
99001 format (' ',' in collh ',2i4,2e12.4)
99002 format (' ',' in rrradh ',2i4,2e12.4)
99003 format (' ',6e12.4)
99004 format (' ',i4,6e12.4)
99005 format (' ',i4,2e12.4)
c     if (tst.le.1.e-6) go to 8806
c     if (lpri.gt.1) write (6,9989
99006 format (' ',' non simple h ')
99007 format (' ',i4,4e12.4)
99008 format (' ',i4,7e12.4)
99009 format (' ',i4,10e12.4)
99010 format (' ',2e12.4)
c     write (6,9923)jk,bbrat(jk)
99011 format (' ',i4,2e12.4)
99012 format (' ',' rrrt(3) --',4e12.4)
99013 format (' ',' the level populations      --',7e12.4)
99014 format (' ',' the departure coefficients --',7e12.4)
99015 format (' ',' lte level populations  --',7e12.4)
      end
      subroutine he2corn
c
c
c
c     this routine calculates  level populations for he+
c     note that all internal variable names are the same as for
c     hydrogen
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /prs   / p,p0
      common /temp  / t,to
      common /phrate/ pirt(nni)
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /abel  / xeh(nl),xeln(nni),xelln(nnnl)
      common /abhe2 / xihh(7),xihho(7),bbrt(7),enrt(7)
      common /rrcool/ rrcl(nni)
      common /linsel/ nlsv(nnnl),nlsvn
      common /rrrate/ rrrt(nni)
      common /tau0ln/ tau0(nnnl)
      common /tau1ln/ tau1(nnnl)
      common /lopak / oplin(nnnl),oplno(nnnl)
      common /ffesc / fesc(nnnl)
      common /ffescb/ fescb(nnnl)
      common /pqrtt / pqrtot
      common /phrah2/ pirt2(6)
      common /phhhh2/ piht2(6)
      common /pqrah2/ piqt2(6)
      common /cdpth / dpthc(ncn)
      common /bdpth / dpthb(ncn)
      common /hrcrte/ hrcrt(20,28),hrcrtt(28)
      common /ceemis/ ceem(nnnl)
      common /rcemis/ rcem(nnnl)
      common /copak / opakc(ncn),opakco(ncn)
      common /lindat/ elin(nnnl),blin(nnnl),
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &     flin1(nnnl),flin2(nnnl),nbl(nnnl),nilin(nnnl),nlin(nni)
      common /pheat / htt(nni),htcmp
      common /pcool / cll(nni),clbr,clcmp
      common /rrrthe/ rrrth(7,7)
      common /ccrthe/ cirthh(7,7)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
      dimension aa0(6,6)
      dimension eee(7)
      dimension cccrth(6,6)
      dimension ff(6,6)
      dimension eth(7),gg(7)
      dimension zz(6)
      real*8 x(6),y(6,6),z(6),wkarea(600)
      dimension bbrat(7),enrat(7)
      dimension aarec(10),bbrec(10),ccrec(10)
c
      data aarec/-8.3281,-8.9776,-9.1508,-9.2150,-9.4583,-9.6516,
     $           -9.8112,-9.4942,-9.5858,-9.5028/,
     $     bbrec/-0.10809,-0.06256,-0.12667,-0.12898,-0.12236,-0.11481,
     $           -0.10747,-0.093811,-0.070572,-0.045593/,
     $     ccrec/6.1135,7.2302,4.9748,4.9933,4.7567,4.5614,4.3913,
     $           4.0573,3.2727,1.4592/
      data cc1/1.e-06/,cc2/1.602196e-18/
      data ethh/13.598/
      data aa0/0.,2.139e-09,1.818e-08,8.333e-08,2.500e-07,
     &     6.173e-07,2*0.,2.326e-08,1.205e-07,4.000e-07,
     &     1.087e-06,3*0.,1.124e-07,4.545e-07,1.299e-06,4*0.,
     &     3.704e-07,1.299e-06,5*0.,9.901e-07,6*0./
      data eee/0.,40.8,48.36,51.0,52.24,52.9,54.4/
      data cc/8.626e-08/,ergsev/1.602197e-12/
      data ccee/1.986e-08/
      data c1/1.3e-06/,c2/2.08e-18/
c     data c4/5.957e-52/,c5/3.718e-40/
      data ccs/5.465e-09/
      data etkh/54.4/
      data ff(1,1),ff(2,1),ff(3,1),ff(4,1),ff(5,1),ff(6,1),
     &     ff(1,2),ff(2,2),ff(3,2),ff(4,2),ff(5,2),ff(6,2),
     &     ff(1,3),ff(2,3),ff(3,3),ff(4,3),ff(5,3),ff(6,3),
     &     ff(1,4),ff(2,4),ff(3,4),ff(4,4),ff(5,4),ff(6,4),
     &     ff(1,5),ff(2,5),ff(3,5),ff(4,5),ff(5,5),ff(6,5),
     &     ff(1,6),ff(2,6),ff(3,6),ff(4,6),ff(5,6),ff(6,6)
     &     /0.,0.4162,0.0791,0.0290,0.0139,0.0078,2*0.,
     &     0.6412,0.1195,0.0224,0.0124,3*0.,0.8413,0.1500,
     &     0.0554,4*0.,1.0380,0.1799,5*0.,0.1,6*0./
      data cccrth(2,1),cccrth(3,1),cccrth(3,2),cccrth(4,1),
     &     cccrth(4,2),cccrth(4,3),cccrth(5,1),cccrth(5,2),
     &     cccrth(5,3),cccrth(5,4),cccrth(6,1),cccrth(6,2),
     &     cccrth(6,3),cccrth(6,4),cccrth(6,5)/9.66e-9,0.,
     &     2.77e-7,0.,4.34e-08,1.26e-06,0.,1.10e-08,
     &     2.00e-07,4.40e-06,3*0.,6.00e-07,1.20e-05/
      data crit/0.5/,lmx/5/
      data eth/0.,40.8,48.36,51.0,52.24,52.9,54.4/
      data gg/1.,4.,9.,16.,25.,36.,2./
      data ccc/2.395e-15/
c     
      if (lpri.ge.1) write (6,*)'in he2corn',t
      lprisv=lpri
c
      if ((lichk(3).ne.1).or.(t.lt.0.5)) return
      if (lpri.gt.2) lpri=2
c
c     calculate collisional rates
      do 100 kl = 1,7
         do 50 ll = 1,7
            cirthh(kl,ll) = 0.
 50      continue
 100  continue
c
      ekt = t*0.8617
      sqt = sqrt(t)
      vtherm = 6.211e+07*sqrt(t)
c
      cirthh(1,7) = 0.
      sqt = sqrt(t)
      cirthh(2,7) = (1.64e-9)/4.
      cirthh(3,7) = (7.44e-8)/4.
      cirthh(4,7) = (5.06e-7)/4.
      cirthh(5,7) = (1.64e-6)/4.
      cirthh(6,7) = (2.80e-5)/4.
      do 200 ll = 1,6
         ethh = (54.4)/(float(ll)*float(ll))
         cirthh(ll,7) = cirthh(ll,7)*expo(-ethh*(1./ekt-0.29))/sqt
 200  continue
c
      do 300 kl = 1,5
         klp1 = kl + 1
         do 250 ll = klp1,6
            ett = eee(ll) - eee(kl)
            fact = ett*(1.-1./t)/0.8617
            tmp = (0.8617*t)/ett
            cirthh(ll,kl) = cccrth(ll,kl)/sqt
c    $ *(expo(-tmp)+(1.-expo(-tmp))/sqt)
            cirthh(kl,ll) = cirthh(ll,kl)*expo(-ett/(0.8617*t))
     &                      *ll*ll/(kl*kl)
 250     continue
 300  continue
      ett = 0.1002
      fact = ett*(1.-1./t)/0.8617
      crt67 = 3.68e-5*expo(fact)
      cirthh(6,7) = cirthh(6,7) + (0.6667)*crt67
c
      if ( lpri.gt.2 ) then
         do 350 jk = 1,7
            do 320 kl = 1,7
               write (6,99001) jk,kl,cirthh(jk,kl)
 320        continue
 350     continue
      endif
c
c
c
c
c     calculate radiative rates
      ekt = t*0.861707
      xst = sqrt(t)
      do 500 kl = 1,7
         do 400 ll = 1,7
            rrrth(kl,ll) = 0.
 400     continue
 500  continue
      do 600 jk = 1,6
         rrrth(jk,7) = pirt2(jk)
 600  continue
      rrrth(1,7) = rrrth(1,7) + pqrtot*(0.1)
      eps = 1.e-30
c     rrrth(1,7)=rrrth(1,7)
c    $  +(rcem(16)+ceem(16))*(1.656e-18)/(oplin(16)+eps)
c    $  +(rcem(31)+ceem(31))*(2.337e-19)/(oplin(31)+eps)
c     rrrth(2,7)=rrrth(2,7)
c    $ +(rcem(526)+ceem(526))*(1.137e-17)/(oplin(526)+eps)
c    $ +(rcem(1156)+ceem(1156))*(9.132e-18)/(oplin(1156)+eps)
c    $ +(rcem(244)+ceem(244))*(1.152e-18)/(oplin(244)+eps)
c
      rrtmp = 0.
      ekt = (0.8617)*t
      nlyc = nbinc(54.4)
      nbac = nbinc(13.6)
c      if ( (dpthc(nbac).gt.0.01) .and. (dpthb(nbac).gt.0.01) )
c     &     rrsum = 0.
      rrsum=0.
      tfak=t/4.
      algt=alog10(tfak)+4.
      klp=0
      nst = 1
      do 800 kl = nst,6
         ethhh = 54.4/float(kl*kl)
         klp=klp+1
         rrrth(7,kl) =2.*
     $    10.**(aarec(klp)+bbrec(klp)*(algt-ccrec(klp))**2)/tfak/1.e+4
         if (kl.ne.2) go to 801
         klp=klp+1
         rrrth(7,kl)=rrrth(7,kl)+2.*
     $    10.**(aarec(klp)+bbrec(klp)*(algt-ccrec(klp))**2)/tfak/1.e+4
 801     continue
         rrsum=rrsum+rrrth(7,kl)
 800  continue
      rrsum=amax1(0.,rrrt(3)-rrsum)
      if (lpri.gt.2) write (6,*)'he II rrsum:',rrsum,rrrt(3)
      rrrth(7,6)=rrrth(7,6)+rrsum
      rrrth(7,1) = rrrth(7,1)*(expo(-dpthc(nlyc))+expo(-dpthb(nlyc)))/2.
c      if ((dpthc(nbac).gt.(0.01)).and.(dpthb(nbac).gt.(0.01)))
c     $rrrth(7,2)=rrrth(7,2)*(expo(-dpthc(nbac))
c     $  *(1.+dpthc(nbac)*((0.35)*t**(0.75)+(0.09)*dpthc(nbac)*t))
c     $                     +expo(-dpthb(nbac))
c     $  *(1.+dpthb(nbac)*((0.35)*t**(0.75)+(0.09)*dpthb(nbac)*t)))
c     $    /2.
c
c     nie assumption
      if (lbcase.eq.1) rrrth(7,1)=0.
      if (lbcase.eq.1) rrrth(7,2)=0.
c
      ll = nlin(1) + nlin(2)
      do 900 jk = 1,5
         jkp1 = jk + 1
         do 850 kl = jkp1,6
            ll = ll + 1
            rrrth(kl,jk) = 16.*(fesc(ll)+fescb(ll))
     &                     /amax1(aa0(kl,jk),1.e-10)
            entp = ergsev*(12398.54)/elin(ll)
 850     continue
 900  continue
      rrrth(2,1) = rrrth(2,1) + 7./4.
c
      if ( lpri.gt.2 ) then
         do 950 jk = 1,7
            do 920 kl = 1,7
               write (6,99002) jk,kl,rrrth(jk,kl)
 920        continue
 950     continue
      endif
c
c
c
c     calculate level populations
      if ( lcdd.eq.0 ) xpx = p/(1.4e-12*t*(1.+xee))
      xnx = xpx*xee
c      if ( t.gt.100. ) go to 3001
      nlev = 7
      nlevm = nlev - 1
      nlevm2 = nlev - 2
      do 1100 jk = 1,nlevm
         x(jk) = 0.
         z(jk) = 0.
         do 1000 kl = 1,nlevm
            y(jk,kl) = 0.
 1000    continue
 1100 continue
c
      ekt = t*0.8617
      gg(7) = 1.
      do 1200 jk = 1,nlevm
         ener = eth(7) - eth(jk)
         tmp = ener/ekt
         tmp = min(tmp,80.)
         gg(jk) = 2.*float(jk*jk)
         enrat(jk) = (ccc/ekt)**1.5*(gg(jk)/(gg(7)))*expo(tmp)
 1200 continue
      enrat(nlev) = 1.
      bbrat(nlev) = 1.
c
c     test to see if thin approximation is good
      rrsum = 0.
      do 1300 ll = 1,nlevm
         rrsum = rrsum + rrrth(7,ll)
 1300 continue
      xihh(1) = xnx*rrsum/(rrrth(1,7)+xnx*rrsum+1.e-30)
      xihh(7) = 1. - xihh(1)
      if ( lpri.gt.2 ) write (6,99003) rrsum,xnx,rrrth(1,7),
     &                                 xihh(1),xihh(7)
      if ( nlevm.ge.2 ) then
         do 1350 ll = 2,nlevm
            xihh(ll) = (xihh(1)*xnx*cirthh(1,ll)+xihh(7)*xnx*rrrth(7,ll)
     &                 )/(rrrth(ll,1)+xnx*cirthh(ll,1)+rrrth(ll,7))
            if ( lpri.gt.2 ) write (6,99004) ll,cirthh(1,ll),
     &                              rrrth(7,ll),rrrth(ll,1),
     &                              cirthh(ll,1),rrrth(ll,7),
     &                              xihh(ll)
 1350    continue
      endif
      do 1400 ll = 1,nlevm
         enrt(ll) = enrat(ll)
         bbrt(ll) = 1.
c     bbrt(ll)=xihh(ll)/(xihh(7)*enrt(ll)*xnx)
         if ( lpri.gt.2 ) write (6,99005) ll,enrt(ll),bbrt(ll)
 1400 continue
      enrt(7) = 1.
      bbrt(7) = 1.
      tst = bbrt(2)/(bbrt(1)+1.e-30)
c
c     print matrices
      lpppri = lpri
      if ( lpppri.gt.1 ) then
         do 1450 jk = 1,nlev
            write (6,99007) jk,bbrat(jk),enrat(jk)
 1450    continue
      endif
c
c     fill the equation matrices for bound levels
      sumc = 0.
      do 1500 jk = 1,nlevm
         sum = 0.
         if ( jk.gt.1 ) then
            jkm1 = jk - 1
            do 1460 kl = 1,jkm1
               sum = sum + enrat(jk)*(rrrth(jk,kl)+cirthh(jk,kl)*xnx)
               y(jk,kl) = -enrat(jk)*cirthh(jk,kl)*xnx
 1460       continue
         endif
         if ( jk.lt.nlevm ) then
            jkp1 = jk + 1
            do 1480 kl = jkp1,nlevm
               y(jk,kl) = -enrat(kl)*(cirthh(kl,jk)*xnx+rrrth(kl,jk))
               sum = sum + cirthh(kl,jk)*xnx*enrat(kl)
 1480       continue
         endif
         z(jk) = (rrrth(7,jk)+xnx*cirthh(7,jk))
         zz(jk) = z(jk)
         y(jk,jk) = sum + enrat(jk)*(rrrth(jk,7)+cirthh(jk,7)*xnx)
 1500 continue
c
      if ( lpppri.gt.1 ) then
         do 1550 jk = 1,nlevm
            write (6,99008) jk,(y(jk,ll),ll=1,nlevm),z(jk)
 1550    continue
      endif
c
c     solve for bound level departure coefficients
      m = 1
      n = 6
      ia = 6
      idgt = 6
      call leqt2f(y,m,n,ia,z,idgt,wkarea,ier,lpri)
c
c      go to 3552
      if ( lpppri.gt.1 ) then
c     check solution
         if (lpri.gt.2) write (6,*)'checking solution'
         errsum = 0.
         zzsum = 0.
         do 1600 jk = 1,nlevm
            sum = 0.
            termmx = 0.
            do 1560 kl = 1,nlevm
               write (6,*)jk,kl,y(jk,kl),z(kl),sum,termmx
               term = y(jk,kl)*z(kl)
               sum = sum + term
               termmx = amax1(termmx,abs(term))
 1560       continue
            termmx = amax1(termmx,abs(zz(jk)))
            err = sum - zz(jk)
            errrl = err/amax1(1.e-34,termmx)
            errsum = errsum + err*err
            zsum = zsum + z(jk)*z(jk)
            write (6,99009) jk,(y(jk,mm),mm=1,nlevm),z(jk),zz(jk)
     &                     ,err,errrl
 1600    continue
         write (6,99010) errsum,zsum
      endif
 3552 continue
c
      sum = 0.
      sum2 = 1.
      do 1700 jk = 1,nlevm
         bbrat(jk) = z(jk)
         if (lpri.gt.2) write (6,*)jk,bbrat(jk),enrat(jk),sum
         sum = sum + bbrat(jk)*enrat(jk)
 1700 continue
c
c     calculate level populations
      xccc = 1./(1.+sum*xnx)
      do 1800 jk = 1,nlevm
         xihh(jk) = enrat(jk)*bbrat(jk)*xccc*xnx
         enrt(jk) = enrat(jk)
         bbrt(jk) = bbrat(jk)
 1800 continue
      xihh(7) = xccc
      enrt(7) = enrat(nlev)
      bbrt(7) = bbrat(nlev)
c
c     fill ion abundance arrays
      if (lpri.gt.2) write (6,*)xihh(7),xnx,pirt(3)
      rrrt(3) = (1.-xihh(7))*pirt(3)/(xihh(7)*xnx+1.e-34)
      if ( lpri.gt.2 ) write (6,99012) xihh(7),xnx,pirt(3),rrrt(3)
c
c     print out
      if ( lpri.gt.2) then
      write (6,99013) (xihh(ll),ll=1,7)
      write (6,99014) (bbrt(ll),ll=1,7)
      write (6,99015) (enrt(ll),ll=1,7)
      endif
c
 3001 continue
      lpri=lprisv
c
c
      return
99001 format (' ',' in collh ',2i4,2e12.4)
99002 format (' ',' in rrradh ',2i4,2e12.4)
99003 format (' ',6e12.4)
99004 format (' ',i4,6e12.4)
99005 format (' ',i4,2e12.4)
c     if (tst.le.1.e-6) go to 8806
c     if (lpri.gt.2) write (6,9989
99006 format (' ',' non simple h ')
99007 format (' ',i4,4e12.4)
99008 format (' ',i4,7e12.4)
99009 format (' ',i4,10e12.4)
99010 format (' ',2e12.4)
c     write (6,9923)jk,bbrat(jk)
99011 format (' ',i4,2e12.4)
99012 format (' ',' rrrt(3) --',4e12.4)
99013 format (' ',' the level populations      --',7e12.4)
99014 format (' ',' the departure coefficients --',7e12.4)
99015 format (' ',' lte level populations  --',7e12.4)
      end
      subroutine heath
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /prs   / p,p0
      common /temp  / t,to
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /abel  / xeh(nl),xeln(nni),xelln(nnnl)
      common /abh   / xihh(11),xihho(11),bbrt(11),enrt(11)
      common /rctot / recj,rectot,rectto
      common /rrcool/ rrcl(nni)
      common /rrrate/ rrrt(nni)
      common /tau0ln/ tau0(nnnl)
      common /tau1ln/ tau1(nnnl)
      common /lopak / oplin(nnnl),oplno(nnnl)
      common /ffesc / fesc(nnnl)
      common /ffescb/ fescb(nnnl)
      common /pqrtt / pqrtot
      common /phrat2/ pirt2(6)
      common /phhht2/ piht2(6)
      common /phrah2/ pirte2(6)
      common /phhhh2/ pihte2(6)
      common /cdpth / dpthc(ncn)
      common /bdpth / dpthb(ncn)
      common /hrcrte/ hrcrt(20,28),hrcrtt(28)
      common /ceemis/ ceem(nnnl)
      common /rcemis/ rcem(nnnl)
      common /copak / opakc(ncn),opakco(ncn)
      common /lindat/ elin(nnnl),blin(nnnl),
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &    flin1(nnnl),flin2(nnnl),nbl(nnnl),nilin(nnnl),nlin(nni)
      common /pheat / htt(nni),htcmp
      common /pcool / cll(nni),clbr,clcmp
      common /rrrthh/ rrrth(11,11)
      common /rrrthe/ rrrthe(7,7)
      common /ccrthe/ cirthe(7,7)
      common /ccrthh/ cirthh(11,11)
      common /abhe2 / xihhe(7),xihheo(7),bbrte(7),enrte(7)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
      data ergsev/1.602197e-12/
c
      ekt = (0.861707)*t
c
      if (lpri.ge.1) write (6,*)'in heath'
c
      abund=xeh(1)*xnx*xpx*xihh(7)
      if (lpri.gt.2) write (6,*)'h rec. cooling', 
     $  xnx,xpx,xihh(7),xeh(1),abund
      do 100 jk = 1,6
         ethr = 13.6/float(jk*jk)
         etmp=ergsev*(ekt+ethr)
         rectmp= abund*rrrth(7,jk)*etmp
         recj = recj + rectmp
         if (lpri.gt.2) write (6,*)jk,ethr,etmp,rrrth(7,jk),rectmp
 100  continue
c
c
c
c
c
c      if (t.lt.5.) return
c
      abund=xeh(2)*xnx*xpx*xihhe(7)*(xiin(3)+xiip(3))
      if (lpri.gt.2) write (6,*)'he II rec. cooling', 
     $  xnx,xpx,xihhe(7),xiin(3),xiip(3),xeh(2),abund
      do 200 jk = 1,6
         ethr = 54.4/float(jk*jk)
         etmp=ergsev*(ekt+ethr)
         rectmp= abund*rrrthe(7,jk)*etmp
         recj = recj + rectmp
         if (lpri.gt.2) write (6,*)jk,ethr,etmp,rrrthe(7,jk),rectmp
 200  continue
c
c
      return
      end
      subroutine heatho
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /prs   / p,p0
      common /temp  / t,to
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /abel  / xeh(nl),xeln(nni),xelln(nnnl)
      common /abh   / xihh(11),xihho(11),bbrt(11),enrt(11)
      common /rctot / recj,rectot,rectto
      common /rrcool/ rrcl(nni)
      common /rrrate/ rrrt(nni)
      common /tau0ln/ tau0(nnnl)
      common /tau1ln/ tau1(nnnl)
      common /lopak / oplin(nnnl),oplno(nnnl)
      common /ffesc / fesc(nnnl)
      common /ffescb/ fescb(nnnl)
      common /pqrtt / pqrtot
      common /phrat2/ pirt2(6)
      common /phhht2/ piht2(6)
      common /phrah2/ pirte2(6)
      common /phhhh2/ pihte2(6)
      common /cdpth / dpthc(ncn)
      common /bdpth / dpthb(ncn)
      common /hrcrte/ hrcrt(20,28),hrcrtt(28)
      common /ceemis/ ceem(nnnl)
      common /rcemis/ rcem(nnnl)
      common /copak / opakc(ncn),opakco(ncn)
      common /lindat/ elin(nnnl),blin(nnnl),
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &     flin1(nnnl),flin2(nnnl),nbl(nnnl),nilin(nnnl),nlin(nni)
      common /pheat / htt(nni),htcmp
      common /pcool / cll(nni),clbr,clcmp
      common /rrrthh/ rrrth(11,11)
      common /ccrthh/ cirthh(11,11)
      common /rrrthe/ rrrthe(7,7)
      common /ccrthe/ cirthe(7,7)
      common /abhe2 / xihhe(7),xihheo(7),bbrte(7),enrte(7)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
      data ergsev/1.602197e-12/
c
      if (lpri.ge.1) write (6,*)'in heatho'
c
      ekt = (0.861707)*t
c
      abund=xeh(1)*xnx*xpx*xihh(7)
      if (lpri.gt.2) write (6,*)'h rec. cooling old', 
     $  xnx,xpx,xihh(7),xeh(1),abund
      do 100 jk = 1,6
         ethr = 13.6/float(jk*jk)
         etmp=ergsev*(ekt)
         rectmp= abund*rrrth(7,jk)*etmp
         recj = recj + rectmp
         if (lpri.gt.2) write (6,*)jk,ethr,etmp,rrrth(7,jk),rectmp
 100  continue
c
c
c
c
c
      abund=xeh(2)*xnx*xpx*xihhe(7)*(xiin(3)+xiip(3))
      if (lpri.gt.2) write (6,*)'he II rec. cooling old', 
     $  xnx,xpx,xihhe(7),xiin(3),xiip(3),xeh(2),abund
      do 200 jk = 1,6
         ethr = 54.4/float(jk*jk)
         etmp=ergsev*(ekt)
         rectmp= abund*rrrthe(7,jk)*etmp
         recj = recj + rectmp
         if (lpri.gt.2) write (6,*)jk,ethr,etmp,rrrthe(7,jk),rectmp
 200  continue
c
c
      return
      end
      subroutine heatt
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /linsel/ nlsv(nnnl),nlsvn
      common /prs   / p,p0
      common /radius/ delr,r,rl,rstp,rdel,radexp,rscale,rsave
      common /heat  / httot,cltot,hmctot
      common /temp  / t,to
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /phrate/ pirt(nni)
      common /abel  / xel(nl),xeln(nni),xelln(nnnl)
      common /phheat/ piht(nni)
      common /flemis/ flem(nnnl)
      common /ffesc / fesc(nnnl)
      common /ffescb/ fescb(nnnl)
      common /dirate/ dirt(nni)
      common /cicool/ cicl(nni)
      common /aicool/ aicl(nni)
      common /tbheat/ tbht(nni)
      common /diemis/ diem(nnnl)
      common /rrcool/ rrcl(nni)
      common /rrrate/ rrrt(nni)
      common /ceemis/ ceem(nnnl)
      common /rcemis/ rcem(nnnl)
      common /rctot / recj,rectot,rectto
      common /cdpth / dpthc(ncn)
      common /bdpth / dpthb(ncn)
      common /lindat/ elin(nnnl),blin(nnnl), 
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &      flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
      common /ethrsh/ eth(nni)
      common /dicool/ dicl(nni)
      common /brcool/ brcl
      common /llumin/ elum(nnnl),oelum(nnnl)
      common /llumnb/ elumb(nnnl),oelmb(nnnl)
      common /coheat/ cmp1,cmp2,cohc
      common /pcool / cll(nni),clbr,clcmp
      common /trans / trnsl(nnnl),trnsb(nnnl)
      common /hcxht / hxh(2,nni),hexh(2,nni)
      common /pheat / htt(nni),htcmp
      common /cecool/ cecl(nni)
      common /rccool/ rccl(nni)
      common /spectc/ bremsa(ncn),brems(ncn),zrems(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /spctcb/ zremsb(ncn),zrmsbo(ncn),bremsb(ncn),
     &                brmsab(ncn)
      common /enerc / epi(ncn),dele(ncn),numcon
      common /etot  / etotc,etotco,etotl,etotlo
     $               ,etotc1,etotc2,etotc3,etotl1,etotl2
      common /copak / opakc(ncn),opakco(ncn)
      common /phsgcs/ skhc(ncn,nni)
      common /abh   / xihh(11),xihho(11),bbrt(11),enrt(11)
      common /phsgc2/ skh2(ncn,6)
      common /cemis / rccems(ncn),cocems(ncn),dicems(ncn),
     &                brcems(ncn)
      common /comptn/ de(61,61),e(61),sx(61),dez(61),ez(61)
      common /spectl/ fline(ncn)
      common /icc   / lichk(nni),lipin
      common /pehcl/ hth(13),clh(13)
c
      dimension htmp(168),cltmp2(168),nprn(10),netmp(168)
c
      character*8 kinam(169)
      character*72 ktitle
c
c
      data nprn/1,2*2,3,4,5,6,8,15,60/
      data netmp/1,2*2,6*3,7*4,8*5,10*6,12*7,14*8,16*9,18*10,20*11,
     $           26*12,28*13/
      data kinam(1)/'h i     '/
      data kinam(2),kinam(3)/'he i    ','he ii   '/
      data kinam(4),kinam(5),kinam(6),kinam(7),kinam(8),
     &     kinam(9)/'c i     ','c ii    ','c iii   ','c iv    ',
     &     'c v     ','c vi    '/
      data kinam(10),kinam(11),kinam(12),kinam(13),kinam(14),
     &     kinam(15),kinam(16)/'n i     ','n ii    ','n iii   ',
     &     'n iv    ','n v     ','n vi    ','n vii   '/
      data kinam(17),kinam(18),kinam(19),kinam(20),kinam(21),
     &     kinam(22),kinam(23),kinam(24)/'o i     ','o ii    ',
     &     'o iii   ','o iv    ','o v     ','o vi    ',
     &     'o vii   ','o viii  '/
      data kinam(25),kinam(26),kinam(27),kinam(28),kinam(29),
     &     kinam(30),kinam(31),kinam(32),kinam(33),kinam(34)
     &     /'ne i    ','ne ii   ','ne iii  ','ne iv   ',
     &     'ne v    ','ne vi   ','ne vii  ','ne viii ',
     &     'ne ix   ','ne x    '/
      data kinam(35),kinam(36),kinam(37),kinam(38),kinam(39),
     &     kinam(40),kinam(41),kinam(42),kinam(43),kinam(44),
     &     kinam(45),kinam(46)/'mg i    ','mg ii   ','mg iii  ',
     &     'mg iv   ','mg v    ','mg vi   ','mg vii  ',
     &     'mg viii ','mg ix   ','mg x    ','mg xi   ',
     &     'mg xii  '/
      data kinam(47),kinam(48),kinam(49),kinam(50),kinam(51),
     &     kinam(52),kinam(53),kinam(54),kinam(55),kinam(56),
     &     kinam(57),kinam(58),kinam(59),kinam(60)/'si i    ',
     &     'si ii   ','si iii  ','si iv   ','si v    ',
     &     'si vi   ','si vii  ','si viii ','si ix   ',
     &     'si x    ','si xi   ','si xii  ','si xiii ',
     &     'si xiv  '/
      data kinam(61),kinam(62),kinam(63),kinam(64),kinam(65),
     &     kinam(66),kinam(67),kinam(68),kinam(69),kinam(70),
     &     kinam(71),kinam(72),kinam(73),kinam(74),kinam(75),
     &     kinam(76)/'s i     ','s ii    ','s iii   ','s iv    ',
     &     's v     ','s vi    ','s vii   ','s viii  ',
     &     's ix    ','s x     ','s xi    ','s xii   ',
     &     's xiii  ','s xiv   ','s xv    ','s xvi   '/
      data kinam(77),kinam(78),kinam(79),kinam(80),kinam(81),
     &     kinam(82),kinam(83),kinam(84),kinam(85),kinam(86),
     &     kinam(87),kinam(88),kinam(89),kinam(90),kinam(91),
     &     kinam(92),kinam(93),kinam(94)/'ar i    ','ar ii   ',
     &     'ar iii  ','ar iv   ','ar v    ','ar vi   ',
     &     'ar vii  ','ar viii ','ar ix   ','ar x    ',
     &     'ar xi   ','ar xii  ','ar xiii ','ar xiv  ',
     &     'ar xv   ','ar xvi  ','ar xvii ','ar xviii'/
      data kinam(95),kinam(96),kinam(97),kinam(98),kinam(99),
     &     kinam(100),kinam(101),kinam(102),kinam(103),
     &     kinam(104),kinam(105),kinam(106),kinam(107),
     &     kinam(108),kinam(109),kinam(110),kinam(111),
     &     kinam(112),kinam(113),kinam(114)/'ca i    ',
     &     'ca ii   ','ca iii  ','ca iv   ','ca v    ',
     &     'ca vi   ','ca vii  ','ca viii ','ca ix   ',
     &     'ca x    ','ca xi   ','ca xii  ','ca xiii ',
     &     'ca xiv  ','ca xv   ','ca xvi  ','ca xvii ',
     &     'ca xviii','ca xix  ','ca xx   '/
      data kinam(115),kinam(116),kinam(117),kinam(118),
     &     kinam(119),kinam(120),kinam(121),kinam(122),
     &     kinam(123),kinam(124),kinam(125),kinam(126),
     &     kinam(127),kinam(128),kinam(129),kinam(130),
     &     kinam(131),kinam(132),kinam(133),kinam(134),
     &     kinam(135),kinam(136),kinam(137),kinam(138),
     &     kinam(139),kinam(140)/'fe i    ','fe ii   ',
     &     'fe iii  ','fe iv   ','fe v    ','fe vi   ',
     &     'fe vii  ','fe viii ','fe ix   ','fe x    ',
     &     'fe xi   ','fe xii  ','fe xiii ','fe xiv  ',
     &     'fe xv   ','fe xvi  ','fe xvii ','fe xviii',
     &     'fe xix  ','fe xx   ','fe xxi  ','fe xxii ',
     &     'fe xxiii','fe xxiv ','fe xxv  ','fe xxvi '/
      data kinam(141),kinam(142),kinam(143),kinam(144),
     &     kinam(145),kinam(146),kinam(147),kinam(148),
     &     kinam(149),kinam(150),kinam(151),kinam(152),
     &     kinam(153),kinam(154),kinam(155),kinam(156),
     &     kinam(157),kinam(158),kinam(159),kinam(160),
     &     kinam(161),kinam(162),kinam(163),kinam(164),
     &     kinam(165),kinam(166),kinam(167),kinam(168),
     &     kinam(169)/'ni i    ','ni ii   ','ni iii  ',
     &     'ni iv   ','ni v    ','ni vi   ','ni vii  ',
     &     'ni viii ','ni ix   ','ni x    ','ni xi   ',
     &     'ni xii  ','ni xiii ','ni xiv  ','ni xv   ',
     &     'ni xvi  ','ni xvii ','ni xviii','ni xix  ',
     &     'ni xx   ','ni xxi  ','ni xxii ','ni xxiii',
     &     'ni xxiv ','ni xxv  ','ni xxvi ','ni xxvii',
     &     'nixxviii','        '/
 
c      data sigth/6.65e-25/
      data sigth/1.e-34/
      data ergsev/1.602197e-12/
c
c
      lprisv=lpri
c      lpri=0
      if (lpri.ge.1) write (6,*)'in heatt'
c
      lskp=1
      if ((lffst.eq.1).and.(numcon.gt.1000)) lskp=10
c
      do 100 kl = 1,ncn
         opakc(kl) = xnx*sigth
 100  continue
c
c
      if ( lpri.gt.2 ) write (6,99001) delr
c
      if ( lcdd.eq.0 ) xpx = p/(1.4e-12*t*(1.+xee))
      xnx = xee*xpx
c
      r19 = r*(1.e-19)
      fpr2 = 12.56*r19*r19
      sum1 = 0.
      tmp1 = 0.
      tmp2 = 0.
      sum2 = 0.
      etotc = 0.
      etotc1 = 0.
      etotc2 = 0.
      etotc3 = 0.
      nlev=10
c      klry=nbinc2(13.6,lskp)
      klry=340
      if ( lichk(1).eq.1 ) then
            do 120 kl = 1,nlev
               klp=nprn(kl)
               if (klp.gt.6) go to 120
               abund = xel(1)*xihh(kl)*xpx
               do 110 jk = 1,numcon,lskp
                  optmp = abund*skh2(jk,klp)
                  opakc(jk) = opakc(jk) + optmp
                  tmp1o = tmp1
                  tmp1 = bremsa(jk)*optmp
                  if ( jk.ge.2 ) sum1 = sum1 + (tmp1+tmp1o)
     &                    *(epi(jk)-epi(jk-lskp))*ergsev/2.
                  if ((jk.eq.klry).and.(lpri.gt.2))
     $                write (6,*)kl,jk,epi(jk),abund,
     $               xihh(kl),xpx,bremsa(jk),optmp,opakc(jk),tmp1
 110           continue
 120        continue
            htmp(1) = sum1
      endif
      htsum = 0.
      do 200 kl = 1,nni
         if (kl.ne.1) then
            htmp(kl) = 0.
            piht(kl) = 0.
            if ( lichk(kl).eq.1 ) then
               abund = xeln(kl)*xpx*xiin(kl)
               if ( abund.gt.1.e-34 ) then
                  sum1 = 0.
                  do 125 jk = 1,numcon,lskp
                     optmp = abund*skhc(jk,kl)
                     opakc(jk) = opakc(jk) + optmp
                     tmp1o = tmp1
                     tmp1 = bremsa(jk)*optmp
                     if ( jk.ge.2 ) sum1 = sum1 + (tmp1+tmp1o)
     &                    *(epi(jk)-epi(jk-lskp))*ergsev/2.
                     if ((jk.eq.klry).and.(lpri.gt.2)) 
     $                   write (6,*)kl,jk,epi(jk),abund,
     $                   xiin(kl),xpx,bremsa(jk),optmp,opakc(jk),tmp1
 125              continue
                  htmp(kl) = sum1
                  htsum = htsum + htmp(kl)
                  piht(kl) = htmp(kl)/abund - eth(kl)*pirt(kl)*ergsev
               endif
            endif
         endif
 200  continue
      tmp = 1.
c     if (lthin.ne.1) sum1=0.
      sum1 = 0.
      zrtmp2=0.
      do 300 kl = 1,numcon,lskp
            zrems(kl) = zremso(kl)
            optpp = opakc(kl)
            optp2 = amax1(1.e-34,optpp-xnx*sigth)
c
c           transfer
            deltau = optpp*delr
               tmp = expo(-deltau)
               fac = amax1(0.,(1.-tmp))/amax1(optpp,1.e-34)
               if ((deltau.le.1.e-4).or.(lthin.ge.1)) fac = delr
               zrtpp =(rccems(kl)+brcems(kl)+fline(kl))
     &                 *fac*fpr2/2.
               if (lnoinwd.eq.1) zrtpp=zrtpp*2.
               fwdexp=expo(-dpthc(kl))
               bakexp=expo(-dpthb(kl))               
               if (lthin.ge.1) fwdexp=1.
               if (lthin.ge.1) bakexp=1.
               if (lnoinwd.ne.1)
     $           zremsb(kl) = zrmsbo(kl) + zrtpp*fwdexp
               if (lthin.ge.1) tmp=1.
               zrtpo = zremso(kl)*tmp
               zrems(kl) = zrtpo +zrtpp
               zrems(kl) = amax1(zrems(kl),1.e-28)
c              special statement for compton reflection problem
               if (lnoinwd.ne.1)
     $           zrems(kl) = zremso(kl) + zrtpp*bakexp+
     $                 cocems(kl)*fac*fpr2/2.
c               if (lnoinwd.ne.1)
c     $           zrems(kl) = zremso(kl) + zrtpp*bakexp
               if ((lpri.ge.3).and.(kl.eq.klry)) 
     $             write (6,*)kl,epi(kl),zrtpp,fwdexp,delr,zrmsbo(kl),
     $                zremso(kl),deltau,tmp,fac,zrems(kl),zremsb(kl)
c
            tmp1o = tmp1
            tmp1 = bremsa(kl)*optp2
            if ( kl.ge.2 ) sum1 = sum1 + (tmp1+tmp1o)
     &                *(epi(kl)-epi(kl-lskp))*ergsev/2.
            zrtmp2o=zrtmp2
            tmpe=expo(-dpthc(kl))
            if (lthin.eq.2) tmpe=1.
            if (kl.ge.lskp+1) tmpe2=expo(-dpthc(kl-lskp))
            if (lthin.eq.2) tmpe2=1.
            zrtmp2=zrems(kl)+zremsb(kl)+zremsz(kl)*tmpe
c            emnint=100.
c            emxint=1.e+4
            emnint=epi(1)
            emxint=epi(numcon)
            if ((epi(kl).lt.emnint).or.(epi(kl).gt.emxint)) go to 300
            if (kl.ge.lskp+1)  etotc = etotc + 
     &           (zrtmp2+zrtmp2o)*(epi(kl)-epi(kl-lskp))/2.
            if (kl.ge.lskp+1)  etotc1 = etotc1 + 
     &           (zrems(kl)+zrems(kl-lskp))*(epi(kl)-epi(kl-lskp))/2.
            if (kl.ge.lskp+1)  etotc2 = etotc2 + 
     &           (zremsb(kl)+zremsb(kl-lskp))*(epi(kl)-epi(kl-lskp))/2.
            if (kl.ge.lskp+1)  etotc3 = etotc3 + 
     &           (zremsz(kl)*tmpe+zremsz(kl-lskp)*tmpe2)
     $              *(epi(kl)-epi(kl-lskp))/2.
            etotco=etotc
            if ( lpri.gt.2 ) write (6,99004) kl,epi(kl),bremsa(kl),
     &                              optp2,etotc,tmp1,sum1,
     &                              deltau,tmp,zrtpo
 300  continue
c
      httot = sum1
c     httot=htsum
      if ( lpri.gt.2 ) write (6,99005) httot
      etotc = etotc*ergsev
      etotc2 = etotc2*ergsev
      etotc3 = etotc3*ergsev
      etotc1 = etotc1*ergsev
c
      if ( lrc.eq.0 ) then
         ekt = t*(0.861707)
         htcmp = cmp1*xee*ergsev*xpx
         clcmp = ekt*cmp2*xee*ergsev*xpx
      else
         call comp2
         htcmp = cohc*xee*ergsev*xpx
         clcmp = 0.
      endif
      enz2 = (xel(1)*xii(2)+xel(2)*(amax1(0.,xii(4)+4.*xii(5))))*xnx
      clbr = brcl*enz2*xpx
      httot = htcmp + httot
      cltot = clbr + clcmp
      if ( lpri.gt.2 ) write (6,99006) htcmp,clcmp,cmp1,cmp2
      if ( lpri.gt.2 ) write (6,99007) clbr,brcl,xpx,enz2,xel(1)
     &                                ,xii(2),xel(2)
c
c     heating - cooling calculation
c
      recj=0.
      do 3011 kl=1+lskp,numcon,lskp         
         recj=recj+(rccems(kl)+rccems(kl-lskp))
     $       *(epi(kl)-epi(kl-lskp))/2.
     $                *ergsev
 3011    continue
      if (lpri.gt.2) write (6,*)'recombination cooling:',recj
c
c
      etotl = 0.
      etotl1 = 0.
      etotl2 = 0.
      tmp = 1.
      tmpb = 1.
      r19 = r/1.e+19
      do 500 kl = 1,nni
         cltmp2(kl) = 0.
         cecl(kl) = 0.
 500  continue
      fpr2dr = 12.56*r19*r19*delr
      do 600 jkk = 1,nlsvn
         jk = nlsv(jkk)
         if ( (jk.ge.1) .and. (jk.le.nnnl) ) then
            ni1 = nilin(jk)
            nitmp = ni1
            if ( (nitmp.gt.0) .and. (nitmp.le.nni) ) then
               if ( lichk(ni1).eq.1 ) then
                  if ( (elin(jk).gt.0.1) .and. (elin(jk).le.1.0e+9) )
     &                 then
                     tmp = trnsb(jk)
                     if (lnoinwd.eq.1) tmp=0.
                     nb1 = nblin(jk)
                     elmtmp=(flem(jk)+rcem(jk)+ceem(jk)+diem(jk))*fpr2dr
                     escfac=fesc(jk)
                     if ( (nitmp.eq.1) .or. (nitmp.eq.3) )
     $                 escfac=fesc(jk)/(1.e-34+fesc(jk)+fescb(jk))
                     elum(jk) = oelum(jk) +  elmtmp*escfac*tmp
                     tmpb = trnsl(jk)
                     if (lnoinwd.eq.1) tmpb=1.
                     escfac=fescb(jk)
                     if ( (nitmp.eq.1) .or. (nitmp.eq.3) )
     $                 escfac=fescb(jk)/(1.e-34+fesc(jk)+fescb(jk))
                     elumb(jk) = oelmb(jk) + elmtmp*escfac*tmpb
                     etmpp=(12398.54)/elin(jk)
                     if ((etmpp.lt.emnint).or.(etmpp.gt.emxint)) 
     $                            go to 3089
                     etotl = etotl + (elum(jk)+elumb(jk))
     &                       *ergsev*(12398.54)/elin(jk)
                     etotl1 = etotl1 + elum(jk)
     &                       *ergsev*(12398.54)/elin(jk)
                     etotl2 = etotl2 + elumb(jk)
     &                       *ergsev*(12398.54)/elin(jk)
 3089                continue
                     ener = ergsev*(12398.54)/elin(jk)
                     cttmp=(rcem(jk)+ceem(jk))*ener*(fesc(jk)+fescb(jk))
c                     cttmp=ceem(jk)*ener*(fesc(jk)+fescb(jk))
c                    NB emissivities for H and He II already have escape 
c                          probability built in.
                     if ( (nitmp.eq.1) .or. (nitmp.eq.3) )
     &                    cttmp =(rcem(jk)+ceem(jk))*ener
                     cltmp2(nitmp) = cltmp2(nitmp) + cttmp
                     cltot = cltot + cttmp
                     if ( lpri.gt.2 ) write (6,*) jk,elin(jk),
     &                    fesc(jk),fescb(jk),tmp,tmpb,
     $                    elum(jk),elumb(jk),rcem(jk),ceem(jk),
     &                    diem(jk),nb1,dpthc(nb1),dpthb(nb1),
     &                    cltot
                     enum = ceem(jk)*fesc(jk)*ener
                     denom = xeln(nitmp)*xiin(nitmp)*xpx*xnx
                     if ( lpri.gt.2 ) write (6,*) enum,denom
                     cecltp = enum/amax1(1.e-28,denom)
                     cecl(nitmp) = cecl(nitmp) + cecltp
                     if ( lpri.gt.2 ) write (6,*) cecltp,cecl(nitmp)
                  endif
               endif
            endif
         endif
 600  continue
      cltmp = cltot - clbr
      if ( lpri.gt.2 ) write (6,99012) cltmp
c
      do 709 ll=1,13
         hth(ll)=0.
         clh(ll)=0.
 709     continue
      do 700 jk = 1,nni
         cecl(jk) = cltmp2(jk)
         htt(jk) = htmp(jk)
         cll(jk) = cltmp2(jk)+rccl(jk)
         neion=netmp(jk)
         hth(neion)=hth(neion)+htt(jk)
         clh(neion)=clh(neion)+cll(jk)
         hmc = htt(jk) - cll(jk)
         if ( lpri.gt.2 ) write (6,99013) jk,kinam(jk),htmp(jk),
     &                           cltmp2(jk),cltmpp,hmc
 700  continue
      if ( lpri.gt.2 ) then
         write (6,99014)
         do 750 lk = 1,nni
            write (6,99015) lk,piht(lk),cicl(lk),aicl(lk),
     &                      rrcl(lk),dicl(lk),tbht(lk),hxh(1,lk),
     &                      hxh(2,lk),hexh(1,lk),cecl(lk)
 750     continue
      endif
c
c
c      cll(1) =  cltmp2(1)+recj
      cltot = cltot + recj
c
      httot = httot/xpx/xpx
      cltot = cltot/xpx/xpx
c
      hmctot = (httot-cltot)/((abs(httot)+abs(cltot))/2.+1.e-34)
      if (lpri.gt.2) 
     $ write (6,*)'httot,cltot,hmctot',httot,cltot,hmctot
c
      httot = httot*xpx*xpx
      cltot = cltot*xpx*xpx
c
c
      lpri=lprisv
c
      return
99001 format (' ',' delr=',e12.4)
c        write(6,9821)kl,eth(kl),xiin(kl),xeln(kl)
99002 format (' ',' in opcmp ',i4,3e12.4)
c            write (6,9962)kl,epi(kl),rccems(kl),cocems(kl),brcems(kl),
c     $             deltau,fac,fpr2,zrtpp,zremsb(kl),zrems(kl)
99003 format (' ',i4,10e12.4)
99004 format (' ',' in heatt',i4,9e12.4)
99005 format (' ',' photoionization heating=',e12.4)
99006 format (' ',' compton heating, cooling=',4e12.4)
99007 format (' ',' brems cooling=',7e12.4)
99008 format (' ',' in heatt',i4,5e12.4)
99009 format (' ',' recombination cooling=',e12.4)
c        write (6,9981)jk,elin(jk),rcem(jk),ceem(jk),fesc(jk),fpr2dr,
c     $   tmp,tmpb,elum(jk),elumb(jk)
99010 format (' ',i4,9e12.4)
99011 format (' ',i4,6e12.4,i4,3e12.4)
99012 format (' ',' line cooling=',e12.4)
99013 format (' ',i4,1x,a8,5e12.4)
99014 format (' ',
     &' ion stage,pi heat,ci cool,ai cool,rr cool,di cool,tb heat,h cx h
     &eat,cool,he cx heat,ce cool ')
99015 format (' ',i4,10e12.4)
99016 format (' ',' h, he continuum cooling ',e12.4)
      end
      subroutine heatto
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /linsel/ nlsv(nnnl),nlsvn
      common /prs   / p,p0
      common /radius/ delr,r,rl,rstp,rdel,radexp,rscale,rsave
      common /heato / httoto,cltoto,hmctoto
      common /temp  / t,to
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /phrate/ pirt(nni)
      common /abel  / xel(nl),xeln(nni),xelln(nnnl)
      common /phheat/ piht(nni)
      common /abh   / xihh(11),xihho(11),bbrt(11),enrt(11)
      common /flemis/ flem(nnnl)
      common /ffesc / fesc(nnnl)
      common /ffescb/ fescb(nnnl)
      common /dirate/ dirt(nni)
      common /cicool/ cicl(nni)
      common /aicool/ aicl(nni)
      common /cirate/ cirt(nni)
      common /tbheat/ tbht(nni)
      common /diemis/ diem(nnnl)
      common /rrcool/ rrcl(nni)
      common /rrrate/ rrrt(nni)
      common /airate/ airt(nni)
      common /ceemis/ ceem(nnnl)
      common /rcemis/ rcem(nnnl)
      common /cdpth / dpthc(ncn)
      common /bdpth / dpthb(ncn)
      common /lindat/ elin(nnnl),blin(nnnl), 
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &      flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
      common /ethrsh/ eth(nni)
      common /dicool/ dicl(nni)
      common /brcool/ brcl
      common /llumin/ elum(nnnl),oelum(nnnl)
      common /llumnb/ elumb(nnnl),oelmb(nnnl)
      common /coheat/ cmp1,cmp2,cohc
      common /pcoolo / cllo(nni),clbro,clcmpo
      common /trans / trnsl(nnnl),trnsb(nnnl)
      common /hcxht / hxh(2,nni),hexh(2,nni)
      common /pheato / htto(nni),htcmpo
      common /cecool/ cecl(nni)
      common /spectc/ bremsa(ncn),brems(ncn),zrems(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /spctcb/ zremsb(ncn),zrmsbo(ncn),bremsb(ncn),
     &                brmsab(ncn)
      common /enerc / epi(ncn),dele(ncn),numcon
      common /copak / opakc(ncn),opakco(ncn)
      common /phsgcs/ skhc(ncn,nni)
      common /phsgc2/ skh2(ncn,6)
      common /cemis / rccems(ncn),cocems(ncn),dicems(ncn),
     &                brcems(ncn)
      common /spectl/ fline(ncn)
      common /icc   / lichk(nni),lipin
c
      dimension htmp(nni),cltmp1(nni),cltmp2(nni)
      character*8 kinam(169)
      character*72 ktitle
      dimension ethh(6)
      dimension nell(nni),nprn(10)
c
      data nell/1,1,2,1,2,3,4,5,6,1,2,3,4,5,
     &     6,7,1,2,3,4,5,6,7,8,1,2,3,4,5,
     &     6,7,8,9,10,1,2,3,4,5,6,7,8,9,10,
     &     11,12,1,2,3,4,5,6,7,8,9,10,11,12,
     &     13,14,1,2,3,4,5,6,7,8,9,10,11,12,
     &     13,14,15,16,1,2,3,4,5,6,7,8,9,10,
     &     11,12,13,14,15,16,17,18,1,2,3,4,5,
     &     6,7,8,9,10,11,12,13,14,15,16,17,18,
     &     19,20,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,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/
      data ethh/13.598,3.400,1.511,.8499,.5439,.3777/
      data kinam(1)/'h i     '/
      data kinam(2),kinam(3)/'he i    ','he ii   '/
      data kinam(4),kinam(5),kinam(6),kinam(7),kinam(8),
     &     kinam(9)/'c i     ','c ii    ','c iii   ','c iv    ',
     &     'c v     ','c vi    '/
      data kinam(10),kinam(11),kinam(12),kinam(13),kinam(14),
     &     kinam(15),kinam(16)/'n i     ','n ii    ','n iii   ',
     &     'n iv    ','n v     ','n vi    ','n vii   '/
      data kinam(17),kinam(18),kinam(19),kinam(20),kinam(21),
     &     kinam(22),kinam(23),kinam(24)/'o i     ','o ii    ',
     &     'o iii   ','o iv    ','o v     ','o vi    ',
     &     'o vii   ','o viii  '/
      data kinam(25),kinam(26),kinam(27),kinam(28),kinam(29),
     &     kinam(30),kinam(31),kinam(32),kinam(33),kinam(34)
     &     /'ne i    ','ne ii   ','ne iii  ','ne iv   ',
     &     'ne v    ','ne vi   ','ne vii  ','ne viii ',
     &     'ne ix   ','ne x    '/
      data kinam(35),kinam(36),kinam(37),kinam(38),kinam(39),
     &     kinam(40),kinam(41),kinam(42),kinam(43),kinam(44),
     &     kinam(45),kinam(46)/'mg i    ','mg ii   ','mg iii  ',
     &     'mg iv   ','mg v    ','mg vi   ','mg vii  ',
     &     'mg viii ','mg ix   ','mg x    ','mg xi   ',
     &     'mg xii  '/
      data kinam(47),kinam(48),kinam(49),kinam(50),kinam(51),
     &     kinam(52),kinam(53),kinam(54),kinam(55),kinam(56),
     &     kinam(57),kinam(58),kinam(59),kinam(60)/'si i    ',
     &     'si ii   ','si iii  ','si iv   ','si v    ',
     &     'si vi   ','si vii  ','si viii ','si ix   ',
     &     'si x    ','si xi   ','si xii  ','si xiii ',
     &     'si xiv  '/
      data kinam(61),kinam(62),kinam(63),kinam(64),kinam(65),
     &     kinam(66),kinam(67),kinam(68),kinam(69),kinam(70),
     &     kinam(71),kinam(72),kinam(73),kinam(74),kinam(75),
     &     kinam(76)/'s i     ','s ii    ','s iii   ','s iv    ',
     &     's v     ','s vi    ','s vii   ','s viii  ',
     &     's ix    ','s x     ','s xi    ','s xii   ',
     &     's xiii  ','s xiv   ','s xv    ','s xvi   '/
      data kinam(77),kinam(78),kinam(79),kinam(80),kinam(81),
     &     kinam(82),kinam(83),kinam(84),kinam(85),kinam(86),
     &     kinam(87),kinam(88),kinam(89),kinam(90),kinam(91),
     &     kinam(92),kinam(93),kinam(94)/'ar i    ','ar ii   ',
     &     'ar iii  ','ar iv   ','ar v    ','ar vi   ',
     &     'ar vii  ','ar viii ','ar ix   ','ar x    ',
     &     'ar xi   ','ar xii  ','ar xiii ','ar xiv  ',
     &     'ar xv   ','ar xvi  ','ar xvii ','ar xviii'/
      data kinam(95),kinam(96),kinam(97),kinam(98),kinam(99),
     &     kinam(100),kinam(101),kinam(102),kinam(103),
     &     kinam(104),kinam(105),kinam(106),kinam(107),
     &     kinam(108),kinam(109),kinam(110),kinam(111),
     &     kinam(112),kinam(113),kinam(114)/'ca i    ',
     &     'ca ii   ','ca iii  ','ca iv   ','ca v    ',
     &     'ca vi   ','ca vii  ','ca viii ','ca ix   ',
     &     'ca x    ','ca xi   ','ca xii  ','ca xiii ',
     &     'ca xiv  ','ca xv   ','ca xvi  ','ca xvii ',
     &     'ca xviii','ca xix  ','ca xx   '/
      data kinam(115),kinam(116),kinam(117),kinam(118),
     &     kinam(119),kinam(120),kinam(121),kinam(122),
     &     kinam(123),kinam(124),kinam(125),kinam(126),
     &     kinam(127),kinam(128),kinam(129),kinam(130),
     &     kinam(131),kinam(132),kinam(133),kinam(134),
     &     kinam(135),kinam(136),kinam(137),kinam(138),
     &     kinam(139),kinam(140)/'fe i    ','fe ii   ',
     &     'fe iii  ','fe iv   ','fe v    ','fe vi   ',
     &     'fe vii  ','fe viii ','fe ix   ','fe x    ',
     &     'fe xi   ','fe xii  ','fe xiii ','fe xiv  ',
     &     'fe xv   ','fe xvi  ','fe xvii ','fe xviii',
     &     'fe xix  ','fe xx   ','fe xxi  ','fe xxii ',
     &     'fe xxiii','fe xxiv ','fe xxv  ','fe xxvi '/
      data kinam(141),kinam(142),kinam(143),kinam(144),
     &     kinam(145),kinam(146),kinam(147),kinam(148),
     &     kinam(149),kinam(150),kinam(151),kinam(152),
     &     kinam(153),kinam(154),kinam(155),kinam(156),
     &     kinam(157),kinam(158),kinam(159),kinam(160),
     &     kinam(161),kinam(162),kinam(163),kinam(164),
     &     kinam(165),kinam(166),kinam(167),kinam(nni),
     &     kinam(169)/'ni i    ','ni ii   ','ni iii  ',
     &     'ni iv   ','ni v    ','ni vi   ','ni vii  ',
     &     'ni viii ','ni ix   ','ni x    ','ni xi   ',
     &     'ni xii  ','ni xiii ','ni xiv  ','ni xv   ',
     &     'ni xvi  ','ni xvii ','ni xviii','ni xix  ',
     &     'ni xx   ','ni xxi  ','ni xxii ','ni xxiii',
     &     'ni xxiv ','ni xxv  ','ni xxvi ','ni xxvii',
     &     'nixxviii','        '/
 
c      data sigth/6.65e-25/
      data sigth/1.e-34/
      data ergsev/1.602197e-12/
      data nprn/1,2*2,3,4,5,6,8,16,65/
c
c
      if (lpri.ge.1) write (6,*)'in heatto'
c
c      lpri=1
c
      if ( lpri.gt.2 ) write (6,99001) delr
c
      if ( lcdd.eq.0 ) xpx = p/(1.4e-12*t*(1.+xee))
      xnx = xee*xpx
c
      r19 = r*(1.e-19)
      fpr2 = 12.56*r19*r19
      sum1 = 0.
      tmp1 = 0.
      tmp2 = 0.
      sum2 = 0.
c      etotc = 0.
      if ( lichk(1).eq.1 ) then
            do 120 kl = 1,10
               kkl=nprn(kl)
               if (kkl.gt.6) go to 120
               abund = xel(1)*xihh(kl)*xpx
               do 110 jk = 1,numcon
                  optmp = abund*skh2(jk,kkl)
                  tmp1o = tmp1
                  tmp1 = bremsa(jk)*optmp*(epi(jk)-ethh(kkl))/epi(jk)
                  if ( jk.ge.2 ) sum1 = sum1 + (tmp1+tmp1o)
     &                                  *(epi(jk)-epi(jk-1))*ergsev/2.
 110           continue
 120        continue
            htmp(1) = sum1
      endif
      htsum = 0.
      do 200 kl = 1,nni
         if (kl.ne.1) then
            htmp(kl) = 0.
            piht(kl) = 0.
            if ( lichk(kl).eq.1 ) then
               abund = xeln(kl)*xpx*xiin(kl)
               if ( abund.gt.1.e-34 ) then
                  sum1 = 0.
                  do 125 jk = 1,numcon
                     optmp = abund*skhc(jk,kl)
                     tmp1o = tmp1
                     tmp1 = bremsa(jk)*optmp*(epi(jk)-eth(kl))/epi(jk)
                     if ( jk.ge.2 ) sum1 = sum1 + (tmp1+tmp1o)
     &                    *(epi(jk)-epi(jk-1))*ergsev/2.
 125              continue
                  htmp(kl) = sum1
                  htsum = htsum + htmp(kl)
                  piht(kl) = htmp(kl)/abund - eth(kl)*pirt(kl)*ergsev
               endif
            endif
         endif
 200  continue
      tmp = 1.
      sum1 = 0.
      do 300 kl = 1,numcon
         if ( zrems(kl).gt.1.e-34 ) then
            optpp = opakc(kl)
            optp2 = amax1(1.e-34,optpp-xnx*sigth)
c
c           transfer
            deltau = optpp*delr
            if ( deltau.gt.1.e-20 ) then
               tmp = expo(-deltau)
               fac = amax1(0.,(1.-tmp))/amax1(optpp,1.e-34)
               if ( deltau.le.1.e-4 ) fac = delr
               zrtpp = (rccems(kl)+cocems(kl)+brcems(kl)+fline(kl))
     &                 *fac*fpr2/2.
               zrtpo = zremso(kl)*tmp
            endif
c
            tmp1o = tmp1
            tmp1 = bremsa(kl)*optp2
            if ( kl.ge.2 ) sum1 = sum1 + (tmp1+tmp1o)
     &                            *(epi(kl)-epi(kl-1))*ergsev/2.
            if ( lpri.gt.2 ) write (6,99004) kl,epi(kl),zremso(kl),
     &                              optp2,etotc,tmp1,sum1,
     &                              deltau,tmp,zrtpo
         endif
 300  continue
c
      httoto=htsum
      if ( lpri.gt.2 ) write (6,99005) httoto
c
      htcmp = cmp1*xee*ergsev*xpx
      clcmp = ekt*cmp2*xee*ergsev*xpx
      httoto = htcmp + httoto
      enz2 = (xel(1)*xii(2)+xel(2)*(amax1(0.,xii(4)+4.*xii(5))))*xnx
      clbr = brcl*enz2*xpx
      cltoto = clbr + clcmp
      ekt=(0.861707)*t
      if ( lpri.gt.2 ) write (6,99006) htcmp,clcmp
      if ( lpri.gt.2 ) write (6,99007) clbr,brcl,xpx,enz2,xel(1)
     &                                ,xii(2),xel(2)
c
c     heating - cooling calculation
c
c
      recj = 0.
      hfrac = 1.
      llthn=0
      do 400 jk = 1,nni
         cltmp1(jk) = 0.
         rrcl(jk) = 0.
         abund = xeln(jk)*xiip(jk)*xpx*xnx
         abund2 = xeln(jk)*xiin(jk)*xpx*xnx
         if ( abund.gt.1.e-34 ) then
            if ( .not.((llthn.ne.1) .and. ((jk.eq.1) .or. (jk.eq.3))) )
     &           then
               tmpp = (abund*(rrrt(jk)+dirt(jk))*ekt
     &                +abund2*(cirt(jk)+airt(jk))*eth(jk))*ergsev
               if ( lpri.gt.2 ) write (6,99008) jk,xeln(jk),xiip(jk)
     &                                ,rrrt(jk),tmpp,recj
               cltmp1(jk) = tmpp
               rrcl(jk) = tmpp/abund - eth(jk)*ergsev*rrrt(jk)
               recj = recj + tmpp
            endif
         endif
 400  continue
      if ( lpri.gt.2 ) write (6,99009) recj
c
      etotl = 0.
      tmp = 1.
      tmpb = 1.
      r19 = r/1.e+19
      do 500 kl = 1,nni
         cltmp2(kl) = 0.
         cecl(kl) = 0.
 500  continue
      fpr2dr = 12.56*r19*r19*delr
      do 600 jkk = 1,nlsvn
         jk = nlsv(jkk)
         if ( (jk.ge.1) .and. (jk.le.nnnl) ) then
            ni1 = nilin(jk)
            nitmp = ni1
            if ( (nitmp.gt.0) .and. (nitmp.le.nni) ) then
               if ( lichk(ni1).eq.1 ) then
                  if ( (elin(jk).gt.0.1) .and. (elin(jk).le.1.0e+9) )
     &                 then
                     tmp = trnsb(jk)
                     nb1 = nblin(jk)
                     tmpb = trnsl(jk)
                     ener = ergsev*(12398.54)/elin(jk)
                     cttmp = ceem(jk)*ener*(fesc(jk)+fescb(jk))
                     cltmp2(nitmp) = cltmp2(nitmp) + cttmp
                     cltoto = cltoto + cttmp
                     if ( lpri.gt.2 ) write (6,99011) jk,elin(jk),
     &                    fesc(jk),fescb(jk),rcem(jk),ceem(jk),
     &                    diem(jk),nb1,dpthc(nb1),dpthb(nb1),
     &                    cltoto
                     enum = ceem(jk)*fesc(jk)*ener
                     denom = xeln(nitmp)*xiin(nitmp)*xpx*xnx
                     if ( lpri.gt.2 ) write (6,*) enum,denom
                     cecltp = enum/amax1(1.e-28,denom)
                     cecl(nitmp) = cecl(nitmp) + cecltp
                     if ( lpri.gt.2 ) write (6,*) cecltp,cecl(nitmp)
                  endif
               endif
            endif
         endif
 600  continue
      cltmp = cltoto - clbr
      if ( lpri.gt.2 ) write (6,99012) cltmp
c      rectot = rectto + (clbr+recj)*r19*r19*(12.56)*delr
c
      do 700 jk = 1,nni
         cltmpp = cltmp1(jk) + cltmp2(jk)
         htto(jk) = htmp(jk)
         cllo(jk) = cltmpp
         hmc = htto(jk) - cllo(jk)
         if ( lpri.gt.2 ) write (6,99013) jk,kinam(jk),htmp(jk),
     &                           cltmp1(jk),cltmp2(jk),cltmpp,hmc
 700  continue
      if ( lpri.gt.2 ) then
         write (6,99014)
         do 750 lk = 1,nni
            write (6,99015) lk,piht(lk),cicl(lk),aicl(lk),
     &                      rrcl(lk),dicl(lk),tbht(lk),hxh(1,lk),
     &                      hxh(2,lk),hexh(1,lk),cecl(lk)
 750     continue
      endif
c
c
      recjo = recj
      if ( llthn.eq.0 ) then
         call heatho
         clhhe = recj - recjo
         cltmp1(1) = clhhe
         if ( lpri.gt.2 ) write (6,99016) clhhe
      endif
      cllo(1) = cltmp1(1) + cltmp2(1)
      cltoto = cltoto + recj
c
      httoto = httoto/xpx/xpx
      cltoto = cltoto/xpx/xpx
c
      hmctoto = (httoto-cltoto)/((abs(httoto)+abs(cltoto))/2.+1.e-34)
c
      httoto = httoto*xpx*xpx
      cltoto = cltoto*xpx*xpx
c
c
c
      return
99001 format (' ',' delr=',e12.4)
c        write(6,9821)kl,eth(kl),xiin(kl),xeln(kl)
99002 format (' ',' in opcmp ',i4,3e12.4)
c            write (6,9962)kl,epi(kl),rccems(kl),cocems(kl),brcems(kl),
c     $             deltau,fac,fpr2,zrtpp,zremsb(kl),zrems(kl)
99003 format (' ',i4,10e12.4)
99004 format (' ',' in heatto',i4,9e12.4)
99005 format (' ',' photoionization heating=',e12.4)
99006 format (' ',' compton heating, cooling=',2e12.4)
99007 format (' ',' brems cooling=',7e12.4)
99008 format (' ',' in heatto',i4,5e12.4)
99009 format (' ',' recombination cooling=',e12.4)
c        write (6,9981)jk,elin(jk),rcem(jk),ceem(jk),fesc(jk),fpr2dr,
c     $   tmp,tmpb,elum(jk),elumb(jk)
99010 format (' ',i4,9e12.4)
99011 format (' ',i4,6e12.4,i4,3e12.4)
99012 format (' ',' line cooling=',e12.4)
99013 format (' ',i4,1x,a8,5e12.4)
99014 format (' ',
     &' ion stage,pi heat,ci cool,ai cool,rr cool,di cool,tb heat,h cx h
     &eat,cool,he cx heat,ce cool ')
99015 format (' ',i4,10e12.4)
99016 format (' ',' h, he continuum cooling ',e12.4)
      end
      subroutine hecor(emtmp)
c
c
c
c     this routine calculates intensities for helium like ions
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /temp  / t,to
      common /abhe  / xihhe(3),xihheo(3)
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /rrrate/ rrrt(nni)
      common /abel  / xeh(nl),xeln(nni),xelln(nnnl)
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /ffesc / fesc(nnnl)
      common /ffescb/ fescb(nnnl)
      common /ceemis/ ceem(nnnl)
      common /rcemis/ rcem(nnnl)
      common /tau0ln/ tau0(nnnl)
      common /tau1ln/ tau1(nnnl)
      common /linsel/ nlsv(nnnl),nlsvn
      common /lindat/ elin(nnnl),blin(nnnl), 
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &      flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
      dimension alph1sv(3),ta1(3),emtmp(100)
c
c     these are ground state recomb rates from Osterbrock
      data alph1sv/2.23e-13,1.59e-13,1.14e-13/,ta1/0.5,1.,2./
      data eps/1.e-10/
c
      if (lpri.ge.1) write (6,*)'in hecor'
c
      ekt = (0.861707)*t
c
      if ( lichk(2).ne.1 ) return
c
c     first, correct the total rec rate
      if (lbcase.ne.1) go to 9002
      lind=3
      if (t.lt.ta1(2)) lind=2
      egam=alog10(alph1sv(lind)/alph1sv(lind-1))
     $      /(alog10(ta1(lind)/ta1(lind-1))+1.e-34)
      finterp=(t/ta1(lind))**egam
      alph1=alph1sv(lind)*finterp
      alph1=amax1(alph1sv(3),alph1)
      alph1=min(alph1sv(1),alph1)
c      rrrt(2)=amax1(rrrt(2)/10.,rrrt(2)-alph1)
      if (lpri.gt.2) write (6,*)'correcting He 0 for case B',
     $   alph1,rrrt(2)
 9002 continue
c
c
c      he i level populations
      n591 = nlin(1)+3
      n5876 = nlin(1)+7
      n10830 = nlin(1)+6
      ccc = 8.63e-8
      sqt = sqrt(t)
      ekt = (0.861707)*t
      c21 = ccc*((0.0736)/3.)/sqt
      c2s = ccc*((2.52)/3.)*expo(-(0.7962)/ekt)/sqt
      c23 = ccc*((29.5)/3.)*expo(-(1.144)/ekt)/sqt
      c32 = ccc*((29.5)/9.)/sqt
      c12 = ccc*((0.0736)/1.)*expo(-(19.82)/ekt)/sqt
      c13 = ccc*((0.0213)/1.)*expo(-(20.96)/ekt)/sqt
      c31 = ccc*((0.0213)/9.)/sqt
      c3s = ccc*((1.66)/9.+((4.05)/9.)*expo(-(0.2639)/ekt))/sqt
      alph2 = rrrt(2)*(0.75)*(0.25)
      alph3 = rrrt(2)*(0.75)*(0.75)
c     alphu=rrrt(2)*(0.75)*(0.625)
c      alphu = (1.95e-14)*t**(-0.7146) where did this come from?
      alphu = (4.96e-14)*t**(-1.071)
      a32 = 1.022e+7
      a31 = 1.76e+2
      a21 = 1.13e-4
      c1u = 0.
      c3u = ccc*((50.)/9.)*expo(-(2.110)/ekt)/sqt
      cu3 = ccc*((50.)/15.)/sqt
      c2u = ccc*((1.98)/3.)*expo(-(3.255)/ekt)/sqt
      cu2 = ccc*((1.98)/15.)/sqt
      pescu3=0.
      pscu3b=1.
      fesc32=0.
      fsc32b=1.
      fesc31=0.
      fsc31b=1.
      if (lnoinwd.eq.1) go to 3381
      pescu3 = pescc(tau0(n5876),0.)
      pscu3b = pescc(tau1(n5876),0.)
      fesc32 = pescc(tau0(n10830),0.)*3.
      fsc32b = pescc(tau1(n10830),0.)*3.
      fesc31 = pescc(tau0(n591),0.)
      fsc31b = pescc(tau1(n591),0.)
 3381 continue
      au3 = 1.176e+8
      fescu3 = pescu3/(pescu3+cu3*xnx/au3+pscu3b)
      fesc(n5876) = fescu3
      fscu3b = pscu3b/(pescu3+cu3*xnx/au3+pscu3b)
      fescb(n5876) = fscu3b
      fesc(n5876) = fescu3
      fescb(n5876) = fscu3b
      fesc(n591) = fesc31
      fescb(n591) = fsc31b
      fesc(n10830) = fesc32
      fescb(n10830) = fsc32b
      aa1 = xnx*(c2s+c21+c23)
      bb1 = -(xnx*c32+a32*(fesc32+fsc32b))
      cc1 = xnx*alph2*xiin(3) + xnx*c12*xiin(2)
      aa2 = -(xnx*c23)
      bb2 = xnx*(c3s+c32+c31) + a31*(fsc31b+fesc31)
     &      + a32*(fesc32+fsc32b) + xnx*c3u
      cc2 = xnx*xiin(3)*alph3 + xiin(2)*xnx*c13
      denom = bb1*aa2 - bb2*aa1
c     xx2=100.
c     xx3=100.
c     if (denom.lt.1.e-30) go to 285
      xx2 = -(cc1*bb2-cc2*bb1)/denom
      xx3 = (cc1*aa2-cc2*aa1)/denom
      xx2b = xiin(2)*(3./1.)*expo(-(19.82)/ekt)
      xx3b = xiin(2)*(9./1.)*expo(-(20.96)/ekt)
c     xx2=min(xx2,xx2b)
c     xx3=min(xx3,xx3b)
      xihhe(1) = xiin(2)
      xihhe(2) = xx2
      xihhe(3) = xx3
      rcem(n5876) = xeh(2)
     &              *xnx*xpx*(xiin(3)*alphu+xx3*c3u+xx2*c2u+xiin(2)*c1u)
      abund=xeh(2)*xnx*xpx*xiin(3)
      emtmp(n5876-nlin(1))=rcem(n5876)/(1.e-34+abund)
      term1 = xiin(3)*alphu
      term2 = xx3*c3u
      term3 = xx2*c2u
      term4 = xiin(2)*c1u
      ceem(n5876) = 0.
      rcem(n10830) = xeh(2)*xx3*a32*xpx
      emtmp(n10830-nlin(1))=rcem(n10830)/(1.e-34+abund)
      ceem(n10830) = 0.
      if ( lpri.gt.2 ) then
         write (6,99001)
         write (6,99002) c21,c2s,c23,c32,c12,c3s,c32,c31,
     &                   c3u,c23,c13,c2u,c1u
         write (6,99002) a32,a31,a21
         write (6,99002) alph2,alph3,alphu
         write (6,99002) xiin(2),xiin(3),xx2,xx3
         write (6,99003) term1,term2,term3,term4
         write (6,99003)fesc(n5876),fescb(n5876),
     $                  fesc(n10830),fescb(n10830)
         write (6,99002) rcem(n5876),rcem(n10830)
      endif
c
c
      return
99001 format (' ',' in hecor ')
99002 format (' ',10e12.4)
99003 format (' ',' term1,2,3,4 --',4e12.4)
      end
      subroutine hheem
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /abemis/ cemab(nnml)
      common /levdat/eexlv(nnml),nilev(nnml),nbcn(nnml),nbcns(nnml),
     $  nlvv(nni)
      common /prs   / p,p0
      common /temp  / t,to
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /abel  / xeh(nl),xeln(nni),xelln(nnnl)
      common /abh   / xihh(11),xihho(11),bbrt(11),enrt(11)
      common /rrcool/ rrcl(nni)
      common /rrrate/ rrrt(nni)
      common /tau0ln/ tau0(nnnl)
      common /tau1ln/ tau1(nnnl)
      common /lopak / oplin(nnnl),oplno(nnnl)
      common /ffesc / fesc(nnnl)
      common /ffescb/ fescb(nnnl)
      common /pqrtt / pqrtot
      common /phrat2/ pirt2(6)
      common /phhht2/ piht2(6)
      common /cdpth / dpthc(ncn)
      common /bdpth / dpthb(ncn)
      common /ceemis/ ceem(nnnl)
      common /rcemis/ rcem(nnnl)
      common /copak / opakc(ncn),opakco(ncn)
      common /lindat/ elin(nnnl),blin(nnnl),
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &     flin1(nnnl),flin2(nnnl),nbl(nnnl),nilin(nnnl),nlin(nni)
      common /pheat / htt(nni),htcmp
      common /pcool / cll(nni),clbr,clcmp
      common /abhe2 / xihhe(7),xihheo(7),bbrte(7),enrte(7)
      common /icc   / lichk(nni),lipin
      common /rrrthh/ rrrth(11,11)
      common /rrrthe/ rrrthe(7,7)
      common /cemis / rccems(ncn),cocems(ncn),dicems(ncn),
     &                brcems(ncn)
      common /enerc / epi(ncn),dele(ncn),numcon
      common /phsgc2/ skhc(ncn,6)
      common /rccool/ rccl(nni)
c
      character*72 ktitle
c
      dimension eee(7),rcemterm(ncn),rccemtmp(ncn)
      dimension eth(7)
      dimension gg(10),nprn(10),aa0(10,10)
c
      data nprn/1,2*2,3,4,5,6,8,15,60/
      data gg/2.,2.,6.,18.,32.,50.,72.,588.,4970.,670960./
      data aa0/0.,0.,62.57,5.574,1.279,.4123,.1644,3.079e-2,
     $              16.38e-4,38.63e-7,
     $         3*0.,0.7478,0.1812,.0593,0.02380,.4481e-2,2.396e-4,
     $              5.368e-7,
     $         3*0.,3.660,0.6603,0.1936,0.07345,1.315e-2,6.738e-4,
     $              16.10e-7,
     $         4*0.,0.8993,.2201,.07780,1.319e-2,6.474e-4,14.93e-7,
     $         5*0.,.2700,.07714,1.147e-2,5.145e-4,11.51e-7,
     $         6*0.,0.1025,1.144e-2,4.397e-4,9.415e-7,
     $         7*0.,1.392e-2,3.976e-4,8.022e-7,
     $         8*0.,16.74e-4,24.42e-7,
     $         9*0.,49.22e-7,
     $             10*0./
      data cc1/1.e-06/,cc2/1.602196e-18/
      data ethh/13.598/
      data eee/0.,10.2,12.09,12.75,13.06,13.22,13.599/
      data cc/8.626e-08/,ergsev/1.602197e-12/
      data ccee/1.986e-08/
      data c1/1.3e-06/,c2/2.08e-18/
c     data c4/5.957e-52/,c5/3.718e-40/
      data ccs/5.465e-09/
      data etkh/13.598/
      data crit/0.5/,lmx/5/
      data eth/0.,10.2,12.09,12.75,13.06,13.22,13.598/
      data ccc/2.395e-15/
c
      if (lpri.ge.1) write (6,*)'in hheem'
c
      lprisv=lpri
c      lpri=3
c
      lskp=1
      if ((lffst.eq.1).and.(numcon.gt.1000)) lskp=10
c
      do 101 ll=1,nlin(1)
          rcem(ll)=0.
          ceem(ll)=0.
 101      continue
c
c     calculate emissivities
      ekt = 0.861707*t
      ll = 0
      kkl=0
      nlevp=11
c      nlevp=4
      do 521 ll=1,ncn
         rccemtmp(ll)=0.
 521     continue
      sumtot=0.
      rcemhbeta=0.
      nlev=nlevp-1
      fudge=amax1(1.,alog(0.861707*t/13.6))
      rrrtsum=0.
      do 52 mk = 1,nlev
c
c              first, continuum
               abund=xnx*xpx*xihh(nlevp)*xeh(1)
               ethcon=13.6/float(nprn(mk)**2)
c               old norm
               emtot=abund*rrrth(nlevp,mk)
     $               *(ethcon+ekt/fudge)*ergsev
               mkk=mk
               cemab(mkk)=emtot
               ibin=nbinc2(ethcon,lskp)
               rrrtsum=rrrtsum+rrrth(nlevp,mk)
               if (lpri.gt.2)
     $          write (6,*)'ethcon,ibin:',mk,ethcon,ibin
               rcemsum=0.
               mm=ibin-lskp
               rcemterm(mm)=0.
 3011             mm=mm+lskp
                  exptmp=-(epi(mm)-epi(ibin))/ekt
                  rcemterm(mm)=expo(exptmp)
c                 old norm
                  if (mm.gt.lskp) rcemint=
     $             (rcemterm(mm)+rcemterm(mm-lskp))
     $                    *(epi(mm)-epi(mm-lskp))/2.
                  rcemsum=rcemsum+rcemint
                  if (lpri.gt.2) write (6,*)'first loop:',mm,epi(mm),
     $                 rcemterm(mm),rcemint,rcemsum
                  if ((rcemint/(rcemsum+1.e-34).gt.1.e-6)
     $                .and.(mm.lt.(numcon-lskp))) go to 3011
               rcemsum=rcemsum*ergsev
c               write (6,*)'rcemsum=',rcemsum
               mmmx=mm
               sumchk=0.
               tscle=((1.e+20)/amax1(1.e-1,xpx))
               do 3012 mm=ibin,mmmx,lskp
                 rcemterm(mm)=rcemterm(mm)*emtot/(rcemsum+1.e-36)
                 rccemtmp(mm)=rccemtmp(mm)+rcemterm(mm)
                 if (mm.gt.lskp)
     $            sumchk=sumchk+(rcemterm(mm)+rcemterm(mm-lskp))
     $               *tscle*(epi(mm)-epi(mm-lskp))*ergsev/2.
                 if (lpri.gt.2) write (6,*)mm,epi(mm),rcemterm(mm),
     $                  sumchk
 3012            continue
               sumchk=sumchk/tscle
               sumtot=sumtot+sumchk
               if (lpri.gt.2) write (6,*)'continuum:',
     $                   mk,abund,rrrth(nlevp,mk),emtot,sumchk,sumtot
               do 552 mk2=1,nlev
                   if (mk2.le.mk) go to 552
                   if (aa0(mk2,mk).le.1.e-34) go to 552
                   kkl=kkl+1
                   ceem(kkl)=0.
                   rcem(kkl)=rcem(kkl)+
     $                  xihh(mk2)*xpx*xeh(1)*rrrth(mk2,mk)
                   if (lpri.gt.2) write (6,99001)mk,mk2,kkl,
     $                elin(kkl),xihh(mk2),rrrth(mk2,mk),rcem(kkl)
 552               continue
 52             continue
 60            continue
      em2ph=xihh(2)*rrrth(2,1)*xpx*xeh(1)*ergsev*(10.2)
      nbmx=nbinc(10.2)+1
      nbmx=max0(nbmx,2)
      nbmx=min0(nbmx,numcon)
      rcemsum=0.
      if (lpri.gt.2) write (6,*)'2 photon:',em2ph,xihh(2),rrrth(2,1)
      rcemterm(1)=0.
      do 298 ll=1+lskp,nbmx,lskp
         rcemterm(ll)=epi(ll)*amax1(0.,(epi(nbmx)-epi(ll)))
         if (ll.le.1) go to 298
         rcemsum=rcemsum+(rcemterm(ll)+rcemterm(ll-lskp))
     $                   *(epi(ll)-epi(ll-lskp))/2.
 298     continue
      do 297 ll=1,nbmx,lskp
         rcemterm(ll)=rcemterm(ll)*em2ph/(1.e-34+rcemsum)/ergsev
         rccemtmp(ll)=rccemtmp(ll)+rcemterm(ll)
         if (lpri.gt.2) write (6,*)'2 photon:',ll,epi(ll),rcemterm(ll)
 297     continue
      sumtot=0.
      do 2294 ll=1+lskp,numcon,lskp
         sumtot=sumtot+(rccemtmp(ll)+rccemtmp(ll-lskp))
     $       *(epi(ll)-epi(ll-lskp))*ergsev/2.
 2294    continue
      sumtto=sumtot
      if (lpri.gt.2) write (6,*)'total H continua:',sumtot
      do 5522 kl=1,nlin(1)
         sumtot=sumtot+rcem(kl)*(12398.54/elin(kl))*ergsev
 5522    continue
      sumtmp=sumtot-sumtto
      if (lpri.gt.2) write (6,*)'total H lines:',sumtmp,sumtot
      sumcor=abund*rrrtsum*ergsev*(13.6+0.8617*t/fudge)
      cfac=sumcor/(1.e-34+sumtot)
      if (lpri.gt.2) write (6,*)'renormalizing H emiss:',cfac,
     $       sumcor,rrrtsum
c      cfac=1.
      do 295 mm=1,nlin(1)
         rcem(mm)=rcem(mm)*cfac
 295     continue
      do 294 ll=1,numcon,lskp
         rccemtmp(ll)=rccemtmp(ll)*cfac
         rccems(ll)=rccems(ll)+rccemtmp(ll)
         if (lpri.gt.2) write (6,*)ll,epi(ll),rccemtmp(ll),rccems(ll)
 294     continue
      sumtot=0.
      do 2296 ll=1+lskp,numcon,lskp
         sumtot=sumtot+(rccemtmp(ll)+rccemtmp(ll-lskp))
     $       *(epi(ll)-epi(ll-lskp))*ergsev/2.
 2296    continue
      rccl(1)=sumtot
c
c
c     calculate emissivities for He II
      ekt = 0.861707*t
      fac = xiin(3) + xiip(3)
      ll = nlin(1) + nlin(2)
      nlevphe=7
      rccl(3)=0.
      fudge=amax1(1.,alog(ekt/54.4))
      do 200 jk = 1,6
c
c              first, continuum
               abund=xnx*xpx*xihhe(7)*xeh(2)
               mk=jk
               ethcon=54.4/float(mk)**2
               emtot=abund*rrrthe(nlevphe,mk)
     $               *(ethcon+ekt/fudge)*ergsev
               mkk=jk+nlvv(1)+nlvv(2)
               cemab(mkk)=emtot
               ibin=nbinc2(ethcon,lskp)
               rcemsum=0.
               mm=ibin-lskp
               rcemterm(mm)=0.
 4011             mm=mm+lskp
                  exptmp=-(epi(mm)-epi(ibin))/ekt
                  rcemterm(mm)=expo(exptmp)
c     $                 *skhc(mm,nprn(mk))*epi(mm)**3
                  if (mm.gt.lskp)
     $             rcemint=
     $             (rcemterm(mm)+rcemterm(mm-lskp))
     $                    *(epi(mm)-epi(mm-lskp))/2.
                  rcemsum=rcemsum+rcemint
                  if ((rcemint/(rcemsum+1.e-34).gt.1.e-6)
     $                .and.(mm.lt.(numcon-lskp))) go to 4011
               rcemsum=rcemsum*ergsev
               mmmx=mm
               sumchk=0.
               do 4012 mm=ibin,mmmx,lskp
                 rcemterm(mm)=rcemterm(mm)*emtot
     $                        /(1.e-36+rcemsum)
                 rccems(mm)=rccems(mm)+rcemterm(mm)
                 if (mm.gt.lskp)
     $            sumchk=sumchk+(rcemterm(mm)+rcemterm(mm-lskp))
     $                   *(epi(mm)-epi(mm-lskp))*ergsev/2.
               if (lpri.gt.2) write (6,*)mm,epi(mm),rcemterm(mm),sumchk
 4012            continue
               if (lpri.gt.2) write (6,*)'continuum:',
     $                   mk,abund,rrrthe(nlevphe,mk),emtot,sumchk
               rccl(3)=rccl(3)+sumchk
               if (jk.eq.6) go to 200
c
c
c        now lines
         jkp1 = jk + 1
         do 150 kl = jkp1,6
c
            ll = ll + 1
            rcem(ll) = 0.
            ceem(ll) = 0.
c            if ( lichk(3).eq.1 ) then
               rcem(ll) = xihhe(kl)*xpx*xeh(2)
     &                    *fac*rrrthe(kl,jk)
               if ( lpri.gt.2 ) write (6,*) 'he ii:',
     $                kl,jk,ll,elin(ll),
     $                              xihhe(kl)
     &                                 ,rrrthe(kl,jk),rcem(ll),
     &                                 xiin(3),ceem(ll)
c            endif
 150     continue
 200  continue
c
      lpri=lprisv
c
      return
99001 format (' ',' in hheem ',3i4,5e12.4)
      end
      subroutine hheemn
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /prs   / p,p0
      common /temp  / t,to
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /abel  / xeh(nl),xeln(nni),xelln(nnnl)
      common /abh   / xihh(11),xihho(11),bbrt(11),enrt(11)
      common /rrcool/ rrcl(nni)
      common /rrrate/ rrrt(nni)
      common /tau0ln/ tau0(nnnl)
      common /tau1ln/ tau1(nnnl)
      common /lopak / oplin(nnnl),oplno(nnnl)
      common /ffesc / fesc(nnnl)
      common /ffescb/ fescb(nnnl)
      common /pqrtt / pqrtot
      common /phrat2/ pirt2(6)
      common /phhht2/ piht2(6)
      common /cdpth / dpthc(ncn)
      common /bdpth / dpthb(ncn)
      common /ceemis/ ceem(nnnl)
      common /rcemis/ rcem(nnnl)
      common /copak / opakc(ncn),opakco(ncn)
      common /lindat/ elin(nnnl),blin(nnnl),
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &     flin1(nnnl),flin2(nnnl),nbl(nnnl),nilin(nnnl),nlin(nni)
      common /pheat / htt(nni),htcmp
      common /pcool / cll(nni),clbr,clcmp
      common /abhe2 / xihhe(7),xihheo(7),bbrte(7),enrte(7)
      common /icc   / lichk(nni),lipin
      common /rrrthh/ rrrth(11,11)
      common /rrrthe/ rrrthe(7,7)
      common /cemis / rccems(ncn),cocems(ncn),dicems(ncn),
     &                brcems(ncn)
      common /enerc / epi(ncn),dele(ncn),numcon
      common /phsgc2/ skhc(ncn,6)
c
      character*72 ktitle
c
      dimension eee(7),rcemterm(ncn),rccemtmp(ncn)
      dimension eth(7)
      dimension gg(10),nprn(10),aa0(10,10)
c
      data nprn/1,2*2,3,4,5,6,8,15,60/
      data gg/2.,2.,6.,18.,32.,50.,72.,588.,4970.,670960./
      data aa0/0.,0.,62.57,5.574,1.279,.4123,.1644,3.079e-2,
     $              16.38e-4,38.63e-7,
     $         3*0.,0.7478,0.1812,.0593,0.02380,.4481e-2,2.396e-4,
     $              5.368e-7,
     $         3*0.,3.660,0.6603,0.1936,0.07345,1.315e-2,6.738e-4,
     $              16.10e-7,
     $         4*0.,0.8993,.2201,.07780,1.319e-2,6.474e-4,14.93e-7,
     $         5*0.,.2700,.07714,1.147e-2,5.145e-4,11.51e-7,
     $         6*0.,0.1025,1.144e-2,4.397e-4,9.415e-7,
     $         7*0.,1.392e-2,3.976e-4,8.022e-7,
     $         8*0.,16.74e-4,24.42e-7,
     $         9*0.,49.22e-7,
     $             10*0./
      data cc1/1.e-06/,cc2/1.602196e-18/
      data ethh/13.598/
      data eee/0.,10.2,12.09,12.75,13.06,13.22,13.599/
      data cc/8.626e-08/,ergsev/1.602197e-12/
      data ccee/1.986e-08/
      data c1/1.3e-06/,c2/2.08e-18/
c     data c4/5.957e-52/,c5/3.718e-40/
      data ccs/5.465e-09/
      data etkh/13.598/
      data crit/0.5/,lmx/5/
      data eth/0.,10.2,12.09,12.75,13.06,13.22,13.598/
      data ccc/2.395e-15/
c
      lprisv=lpri
c      lpri=1
c
      do 101 ll=1,nlin(1)
          rcem(ll)=0.
          ceem(ll)=0.
 101      continue
c
c     calculate emissivities
      ekt = 0.861707*t
      ll = 0
      kkl=0
      nlevp=11
c      nlevp=4
      do 521 ll=1,ncn
         rccemtmp(ll)=0.
 521     continue
      sumtot=0.
      rcemhbeta=0.
      nlev=nlevp-1
      rrrtsum=0.
      do 52 mk = 1,nlev
c
c              first, continuum
               abund=xnx*xpx*xihh(nlevp)
               ethcon=13.6/float(nprn(mk)**2)
c               old norm
               emtot=abund*rrrth(nlevp,mk)
     $               *(ethcon+ekt)*ergsev
               ibin=nbinc(ethcon)+1
               rrrtsum=rrrtsum+rrrth(nlevp,mk)
c               write (6,*)'ethcon,ibin:',mk,ethcon,ibin
               rcemsum=0.
               mm=ibin-1
               rcemterm(mm)=0.
 3011             mm=mm+1
                  exptmp=-(epi(mm)-epi(ibin))/ekt
                  rcemterm(mm)=expo(exptmp)
c                 old norm
                  rcemint=
     $             (rcemterm(mm)+rcemterm(mm-1))
     $                    *(epi(mm)-epi(mm-1))/2.
                  rcemsum=rcemsum+rcemint
c                  if (lpri.gt.2) write (6,*)'first loop:',mm,epi(mm),
c     $                 rcemterm(mm),rcemint,rcemsum
                  if ((rcemint/(rcemsum+1.e-34).gt.1.e-6)
     $                .and.(mm.lt.numcon)) go to 3011
               rcemsum=rcemsum*ergsev
               mmmx=mm
               sumchk=0.
               do 3012 mm=ibin,mmmx
                 rcemterm(mm)=rcemterm(mm)*emtot/rcemsum
                 rccemtmp(mm)=rccemtmp(mm)+rcemterm(mm)
                 sumchk=sumchk+(rcemterm(mm)+rcemterm(mm-1))
     $                   *(epi(mm)-epi(mm-1))*ergsev/2.
                 if (lpri.gt.2) write (6,*)mm,epi(mm),rcemterm(mm),
     $                  sumchk
 3012            continue
               sumtot=sumtot+sumchk
               if (lpri.gt.2) write (6,*)'continuum:',
     $                   mk,abund,rrrth(nlevp,mk),emtot,sumchk,sumtot
               do 552 mk2=1,nlev
                   if (mk2.le.mk) go to 552
                   if (aa0(mk2,mk).le.1.e-34) go to 552
                   kkl=kkl+1
                   ceem(kkl)=0.
                   rcem(kkl)=rcem(kkl)+
     $                  xihh(mk2)*xpx*xeh(1)*rrrth(mk2,mk)
     $                      /(fesc(kkl)+fescb(kkl)+1.e-34)
                   if (lpri.gt.2) write (6,99001)mk,mk2,kkl,
     $                elin(kkl),xihh(mk2),rrrth(mk2,mk),rcem(kkl)
 552               continue
 52             continue
 60            continue
      em2ph=xihh(2)*rrrth(2,1)*xpx*xeh(1)*ergsev*(10.2)
      nbmx=nbinc(10.2)+1
      nbmx=max0(nbmx,2)
      nbmx=min0(nbmx,numcon)
      rcemsum=0.
      if (lpri.gt.2) write (6,*)'2 photon:',em2ph,xihh(2),rrrth(2,1)
      rcemterm(1)=0.
      do 298 ll=1,nbmx
         rcemterm(ll)=epi(ll)*amax1(0.,(epi(nbmx)-epi(ll)))
         if (ll.le.1) go to 298
         rcemsum=rcemsum+(rcemterm(ll)+rcemterm(ll-1))
     $                   *(epi(ll)-epi(ll-1))/2.
 298     continue
      do 297 ll=1,nbmx
         rcemterm(ll)=rcemterm(ll)*em2ph/(1.e-34+rcemsum)/ergsev
         rccemtmp(ll)=rccemtmp(ll)+rcemterm(ll)
         if (lpri.gt.2) write (6,*)'2 photon:',ll,epi(ll),rcemterm(ll)
 297     continue
      sumtot=0.
      do 2294 ll=2,numcon
         sumtot=sumtot+(rccemtmp(ll)+rccemtmp(ll-1))
     $       *(epi(ll)-epi(ll-1))*ergsev/2.
 2294    continue
      sumtto=sumtot
      if (lpri.gt.2) write (6,*)'total H continua:',sumtot
      do 5522 kl=1,nlin(1)
         sumtot=sumtot+rcem(kl)*(12398.54/elin(kl))*ergsev
 5522    continue
      sumtmp=sumtot-sumtto
      if (lpri.gt.2) write (6,*)'total H lines:',sumtmp,sumtot
      sumcor=rrrtsum*ergsev*(13.6+0.8617*t)
      cfac=sumcor/(1.e-34+sumtot)
      if (lpri.gt.2) write (6,*)'renormalizing H emiss:',cfac
c      cfac=1.
c      do 295 mm=1,nlin(1)
c         rcem(mm)=rcem(mm)*cfac
c 295     continue
      do 294 ll=1,numcon
c         rccemtmp(ll)=rccemtmp(ll)*cfac
         rccems(ll)=rccems(ll)+rccemtmp(ll)
         if (lpri.gt.2) write (6,*)ll,epi(ll),rccemtmp(ll),rccems(ll)
 294     continue
c
c
c     calculate emissivities for He II
      ekt = 0.861707*t
      fac = xiin(3) + xiip(3)
      ll = nlin(1) + nlin(2)
      nlevphe=7
      rrrtsum=0.
      sumchk=0.
      do 200 jk = 1,6
c
c              first, continuum
               abund=xnx*xpx*xihhe(7)*xeh(2)
               mk=jk
               ethcon=54.4/float(mk)**2
               emtot=abund*rrrthe(nlevphe,mk)
     $               *(ethcon+ekt)*ergsev
               rrrtsum=rrrtsum+rrrthe(nlevphe,mk)
               ibin=nbinc(ethcon)+1
               rcemsum=0.
               mm=ibin-1
               rcemterm(mm)=0.
 4011             mm=mm+1
                  exptmp=-(epi(mm)-epi(ibin))/ekt
                  rcemterm(mm)=expo(exptmp)
c     $                 *skhc(mm,nprn(mk))*epi(mm)**3
                  rcemint=
     $             (rcemterm(mm)+rcemterm(mm-1))
     $                    *(epi(mm)-epi(mm-1))/2.
                  rcemsum=rcemsum+rcemint
                  if ((rcemint/(rcemsum+1.e-34).gt.1.e-6)
     $                .and.(mm.lt.numcon)) go to 4011
               rcemsum=rcemsum*ergsev
               mmmx=mm
               do 4012 mm=ibin,mmmx
                 rcemterm(mm)=rcemterm(mm)*emtot/rcemsum
                 sumchk=sumchk+(rcemterm(mm)+rcemterm(mm-1))
     $                   *(epi(mm)-epi(mm-1))*ergsev/2.
                 if (lpri.gt.2) write (6,*)mm,epi(mm),rcemterm(mm),
     $                                       sumchk
 4012            continue
               if (lpri.gt.2) write (6,*)'continuum:',
     $                   mk,abund,rrrthe(nlevphe,mk),emtot,sumchk
               if (jk.eq.6) go to 200
c
c
c        now lines
         jkp1 = jk + 1
         do 150 kl = jkp1,6
c
               ll = ll + 1
               rcem(ll) = 0.
               ceem(ll) = 0.
               rcem(ll) = xihhe(kl)*xpx*xeh(2)
     &                    *fac*rrrthe(kl,jk)
     $                      /(fesc(ll)+fescb(ll)+1.e-34)
               sumchk=sumchk
     $           +rcem(ll)*(12398.54)*ergsev/(1.e-34+elin(ll))
               if ( lpri.gt.2 ) write (6,*) 'he ii:',
     $                kl,jk,ll,elin(ll),
     $                              xihhe(kl)
     &                                 ,rrrthe(kl,jk),rcem(ll),
     &                                 xiin(3),ceem(ll)
 150     continue
 200  continue
c
      rrcor=abund*rrrtsum*(54.4+(0.861707)*t)*ergsev
     $      /(1.e-34+sumchk)
      if (lpri.gt.2) write (6,*)'correcting He II emiss:',
     $  rrrtsum,sumchk,rrcor
      rrcor=amax1(rrcor,1.)
c      rrcor=0.
      if (rrcor.lt.1.01) go to 4016
      do 4013 mm=1,numcon
         rccems(mm)=rccems(mm)+rcemterm(mm)*rrcor
 4013    continue
      ll1=nlin(1)+nlin(2)+1
      ll2=nlin(1)+nlin(2)+nlin(3)
      do 4014 ll=ll1,ll2
         rcem(ll)=rcem(ll)*rrcor
 4014    continue
 4016 continue
c
      lpri=lprisv
c
      return
99001 format (' ',' in hheem ',3i4,5e12.4)
      end
      subroutine hlike(sk,et,nz)
c
c
c
c
c     this routine computes hydrogen like photoionization cross section
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /enerc / epi(ncn),dele(ncn),numcon
c
      character*72 ktitle
c
      dimension sk(ncn,nz),et(nz)
c
      data crit/1.e-04/
c
      zz = float(nz)
      do 100 i = 1,numcon
         sk(i,nz) = fh2lke(zz,epi(i),et(nz))
 100  continue
c
c
      return
c      write (6,9901)i,et(nz),epi(i),zz
99001 format (' ',' in hlike ',i4,3e12.4)
      end
      subroutine hunt(xx,n,x,jlo,lpri)
c
      external bigdat,newdat,rr3,nfllns
c
      integer inc,jhi,jlo,jm,lpri,n
      real x,xx
c
      dimension xx(n)
      logical ascnd
c
      ascnd = xx(n).gt.xx(1)
c      lpri=1
      if ( lpri.gt.2 ) write (6,*) 'in hunt'
      if ( jlo.le.0 .or. jlo.gt.n ) then
         jlo = 0
         jhi = n + 1
         if ( lpri.gt.2 ) write (6,*) 'initializing',jlo,jhi
         goto 200
      endif
      inc = 1
      if ( x.ge.xx(jlo) .eqv. ascnd ) then
 50      if ( .true. ) then
            jhi = jlo + inc
            if ( jhi.gt.n ) then
               jhi = n+1
c            if ( lpri.gt.2 ) write (6,*) 'hunt up ',jlo,jhi,
c     &                              xx(jlo),xx(jhi)
            elseif ( x.ge.xx(jhi) .eqv. ascnd ) then
               jlo = jhi
               inc = inc + inc
               if ( lpri.gt.2 ) write (6,*) 'double the increment',inc
               goto 50
            endif
         endif
      else
         jhi = jlo
 100     if ( .true. ) then
            jlo = jhi - inc
c            if ( lpri.gt.2 ) write (6,*) 'hunt down ',jlo,jhi,
c     &                              xx(jlo),xx(jhi)
            if ( jlo.lt.1 ) then
               jlo = 0
            elseif ( x.lt.xx(jlo) .eqv. ascnd ) then
               jhi = jlo
               inc = inc + inc
               if ( lpri.gt.2 ) write (6,*) 'double the increment',inc
               goto 100
            endif
         endif
      endif
 200  if ( .true. ) then
         if ( jhi-jlo.eq.1 ) return
         jm = (jhi+jlo)/2
         if ( lpri.gt.2 ) write (6,*) 'bisection phase',jlo,jhi,
     &                                jm,xx(jm)
         if ( x.gt.xx(jm) .eqv. ascnd ) then
            jlo = jm
         else
            jhi = jm
         endif
         goto 200
c
      endif
c
      end
      subroutine ichk
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /linsel/ nlsv(nnnl),nlsvn
      common /abel  / xeh(nl),xeln(nni),xelln(nnnl)
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /lindat/ elin(nnnl),blin(nnnl), 
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &      flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
      dimension nnz(13)
c
      data eps/1.e-6/
      data nnz/1,2,6,7,8,10,12,14,16,18,20,26,
     &     28/
 
c
      if (lpri.ge.1) write (6,*)'in ichk'
c
      jkk = 0
      if ( lpri.gt.2 ) write (6,99001) lipin
      do 100 kl = 1,nel
         nlim = nnz(kl)
         do 50 jk = 1,nlim
            jkk = jkk + 1
            lichk(jkk) = 1
            if ( (xiin(jkk).le.eps) .and. (lipin.ne.1) .and. 
     &           (xiip(jkk).le.eps) ) then
               lichk(jkk) = 0
            endif
            if ( lpri.gt.2 ) write (6,99002) kl,jk,jkk,xiin(jkk),
     &                              xiip(jkk),lichk(jkk)
 50      continue
 100  continue
c
      return
99001 format (' ',' in ichk',i4)
99002 format (' ',3i4,2e12.4,i4)
      end
      subroutine init1
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /scfac / betsce,gamsce,betscp,gamscp
      common /timesv  / ttrnfr,tesc,tphot,taug,tsolve,temop,
     &                ntold
      common /enerc / epi(ncn),dele(ncn),numcon
      common /linsel/ nlsv(nnnl),nlsvn
      common /levdat/eexlv(nnml),nilev(nnml),nbcn(nnml),nbcns(nnml),
     $   nlvv(nni)
      common /agdata/ amkc(6,6),amkn(7,7),amko(8,8),amkne(10,10),
     &                amkmg(12,12),amlsmg(10,10),amlpmg(8,8),
     &                amksi(14,14),amlssi(12,12),amlpsi(10,10),
     &                amks(16,16),amlss(14,14),amlps(12,12),
     &                amkfe(26,26),amlsfe(24,24),amlpfe(22,22)
      common /abel  / xel(nl),xeln(nni),xelln(nnnl)
      common /lindat/ elin(nnnl),blin(nnnl), 
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &      flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
      common /fe2dat/ gglfe(10),ggufe(6),eelfe(10),eeufe(6),
     &                bbfe(10,6),elamfe(60),nblfe2(60),ffe(10,6),
     &                gfe(10,6)
      common /spectc/ bremsa(ncn),brems(ncn),zrems(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /tmper/ ntmper,ntmpermx
      common /ethrsh/ eth(nni)
c
      character*72 ktitle
c
      dimension nikey(13),nnz(13)
      dimension nfeln(26)
c
      data ergsev/1.602197e-12/
      data nfeln/0,1162,1178,1193,1208,1223,1238,1253,
     &     1272,1287,1302,1317,1332,1347,1362,1377,
     &     1386,1401,1416,1431,1446,1462,1477,0,1504,
     &     1517/
      data ccee/12398.54/,eps/1.e-8/
      data nikey/1,3,9,16,24,34,46,60,76,94,114,
     &     140,168/
      data nnz/1,2,6,7,8,10,12,14,16,18,20,26,
     &     28/
c
      if (lpri.ge.1) write (6,*)'in init1'
c
      do 100 ll = 1,numcon
         zrems(ll) = 0.
         zremso(ll) = 0.
 100  continue
c
c
      jltmp = numcon - 1
      do 200 jl = 1,jltmp
         dele(jl) = epi(jl+1) - epi(jl)
 200  continue
c
c
c     bin the lines and continua.
      kk = 0.
      kk2 = 0.
      do 300 j = 1,nni
c
c        first lines
         nlim = nlin(j)
         do 251 k = 1,nlim
            kk = kk + 1
            if ( elin(kk).lt.0.1 ) go to 251
            ener = ccee/elin(kk)
            nblin(kk) = nbinc(ener)
            if ((j.eq.1).or.(j.eq.3)) go to 251
            kk2=kk2+1
            etmp=eth(j)-ener
            nbcns(kk2)=nbinc2(etmp,10)
            nbcn(kk2)=nbinc2(etmp,1)
            eexlv(kk2)=ener
            nilev(kk2)=j
 251        continue
c
         if ((j.eq.1).or.(j.eq.3)) go to 3001
c
         kk2=kk2+1
         etmp=eth(j)
         eexlv(kk2)=0.
         nbcns(kk2)=nbinc2(etmp,10)
         nbcn(kk2)=nbinc2(etmp,1)
         nilev(kk2)=j
         nlvv(j)=nlim+1
         go to 300
c
c        special case for h and he ii
 3001    continue
         nlim=10
         if (j.eq.3) nlim=6
         do 252 k = 1,nlim
            etmp=eth(j)/float(k*k)
            kk2=kk2+1
            nbcns(kk2)=nbinc2(etmp,10)
            nbcn(kk2)=nbinc2(etmp,1)
            eexlv(kk2)=etmp
            nilev(kk2)=j
 252        continue
         nlvv(j)=nlim
c
 300     continue
c
c     bin fe2 lines
      do 400 ll = 1,60
         nblfe2(ll) = ncn
         if ( (elamfe(ll).le.9999.) .and. (elamfe(ll).ge.1.) ) then
            ener = ccee/elamfe(ll)
            nblfe2(ll) = nbinc(ener)
         endif
 400  continue
c
c     put in iron k fluorescence.
      do 500 ik =2, 24
         amkfe(ik-1,ik) = 0.34
         if ( ik.eq.24 ) amkfe(ik-1,ik) = 0.75
         if ( ik.eq.23 ) amkfe(ik-1,ik) = 0.1
         iktmp = ik -1
c         do 450 jk = iktmp,26
c            amkfe(ik,jk) = amkfe(ik,jk)*(1.-amkfe(ik,ik))
c 450     continue
 500  continue
c
c     put in oxygen k fluorescence.
      do ik =2, 6
         amko(ik-1,ik) = 0.0094
         enddo
c
c     put in neon k fluorescence.
      do ik =2, 8
         amkne(ik-1,ik) = 0.0182
         enddo
c
c     put in magnesium k fluorescence.
      do ik =2, 10
         amkmg(ik-1,ik) = 0.0336
         enddo
c
c     put in silicon k fluorescence.
      do ik =2, 12
         amksi(ik-1,ik) = 0.042
         enddo
c
c     put in sulfur k fluorescence.
      do ik =2, 14
         amks(ik-1,ik) = 0.0774
         enddo
c
c
c     put in iron l fluorescence.
      amlsfe(1,1) = 2.7e-4
      amlsfe(2,2) = 2.9e-4
      amlsfe(3,3) = 3.7e-4
      amlsfe(4,4) = 4.0e-4
      amlsfe(5,5) = 1.1e-3
      amlsfe(6,6) = 1.5e-3
      amlsfe(7,7) = 1.e-2
      amlsfe(8,8) = 1.1e-2
      amlsfe(9,9) = 1.5e-2
      amlsfe(10,10) = 1.5e-2
      amlsfe(11,11) = 1.4e-2
      amlsfe(12,12) = 1.3e-2
      amlsfe(13,13) = 1.2e-2
      amlsfe(14,14) = 9.1e-3
      amlsfe(15,15) = 1.0e-3
      amlpfe(1,1) = 6.e-4
      amlpfe(2,2) = 7.e-4
      amlpfe(3,3) = 8.e-4
      amlpfe(4,4) = 2.3e-3
      amlpfe(5,5) = 3.3e-3
      amlpfe(6,6) = 4.5e-3
      amlpfe(7,7) = 3.5e-3
      amlpfe(8,8) = 1.9e-3
      amlpfe(9,9) = 8.8e-4
      amlpfe(10,10) = 1.2e-3
      amlpfe(11,11) = 1.7e-3
      amlpfe(12,12) = 2.6e-3
      amlpfe(13,13) = 4.6e-3
      amlpfe(14,14) = 1.4e-2
      amlpfe(15,15) = 1.5e-2
c
      ntmper=0
      ntmpermx=10
c
      return
c     write (6,9923)j,k,kk,elin(kk),ener,nblin(kk),nbcn(kk)
99001 format (' ',' line bin data ',3i4,2e12.4,2i4)
      end
      subroutine init2
c
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /scfac / betsce,gamsce,betscp,gamscp
      common /timesv  / ttrnfr,tesc,tphot,taug,tsolve,temop,
     &                ntold
      common /agdata/ amkc(6,6),amkn(7,7),amko(8,8),amkne(10,10),
     &                amkmg(12,12),amlsmg(10,10),amlpmg(8,8),
     &                amksi(14,14),amlssi(12,12),amlpsi(10,10),
     &                amks(16,16),amlss(14,14),amlps(12,12),
     &                amkfe(26,26),amlsfe(24,24),amlpfe(22,22)
      common /radius/ delr,r,rl,rstp,rdel,radexp,rscale,rsave
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /trans / trnsl(nnnl),trnsb(nnnl)
      common /fstar / fstar(ncn),dilfac,rstar
      common /linsel/ nlsv(nnnl),nlsvn
      common /spectl/ fline(ncn)
      common /spctcb/ zremsb(ncn),zrmsbo(ncn),bremsb(ncn),
     &                brmsab(ncn)
      common /spectc/ bremsa(ncn),brems(ncn),zrems(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /ethrsh/ eth(nni)
      common /enerc / epi(ncn),dele(ncn),numcon
      common /abh   / xihh(11),xihho(11),bbrt(11),enrt(11)
      common /abhe  / xihhe(3),xihheo(3)
      common /abhe2 / xihe2(7),xihe2o(7),bbrthe(7),enrthe(7)
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /abel  / xel(nl),xeln(nni),xelln(nnnl)
      common /lindat/ elin(nnnl),blin(nnnl), 
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &      flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
      common /fe2dat/ gglfe(10),ggufe(6),eelfe(10),eeufe(6),
     &                bbfe(10,6),elamfe(60),nblfe2(60),ffe(10,6),
     &                gfe(10,6)
      common /fe2emm/ emfe2(10,6),xxlfe2(10)
      common /fe2lum/ elmfe2(10,6),oemfe2(10,6),t0fe2(10,6),
     &                t1fe2(10,6),elmf2b(10,6),oemf2b(10,6)
      common /numit / lnerrs,lnerrd,ntmpit,nelit,ntotit,
     &                npttit,nstpnm
      common /pcool / cll(170)
      common /pheat / htt(169)
      common /phheat/ piht(nni)
      common /phrate/ pirt(nni)
      common /pqrtt / pqrtot
      common /pqrate/ piqt(nni)
      common /cecool/ cecl(nni)
      common /cicool/ cicl(nni)
      common /cirate/ cirt(nni)
      common /dirate/ dirt(nni)
      common /rrrate/ rrrt(nni)
      common /airate/ airt(nni)
      common /tbrate/ tbrt(nni)
      common /aicool/ aicl(nni)
      common /tbheat/ tbht(nni)
      common /rrcool/ rrcl(nni)
      common /dicool/ dicl(nni)
      common /coheat/ cmp1,cmp2,cohc
      common /brcool/ brcl
      common /heat  / httot,cltot,hmctot
      common /hcxrt / hxr(2,nni),hexr(2,nni)
      common /hcxht / hxh(2,nni),hexh(2,nni)
      common /radp  / pradl,pradc,pradt
      common /copak / opakc(ncn),opakco(ncn)
      common /cdpth / dpthc(ncn)
      common /bdpth / dpthb(ncn)
      common /etot  / etotc,etotco,etotl,etotlo
     $               ,etotc1,etotc2,etotc3,etotl1,etotl2
      common /llumin/ elum(nnnl),oelum(nnnl)
      common /llumnb/ elumb(nnnl),oelmb(nnnl)
      common /lopak / oplin(nnnl),oplno(nnnl)
      common /grcrte/ grcrt(nni)
      common /ceemis/ ceem(nnnl)
      common /cxemis/ cxem(nnnl)
      common /diemis/ diem(nnnl)
      common /rcemis/ rcem(nnnl)
      common /flemis/ flem(nnnl)
      common /hrcrte/ hrcrt(20,28),hrcrtt(28)
      common /swdata/ stwtrt(nni)
      common /he2bow/ fbow1,fbow2,bem304,be3003,bem374,be4641
      common /ffcomp/ fcomp(nnnl)
      common /ffbbs / fbbs(nnnl)
      common /ffthrm/ ftherm(nnnl)
      common /ffsplt/ fsplit(nnnl)
      common /ffesc / fesc(nnnl)
      common /ffescb/ fescb(nnnl)
      common /tau0ln/ tau0(nnnl)
      common /tau1ln/ tau1(nnnl)
      common /cemis / rccems(ncn),cocems(ncn),dicems(ncn),
     &                brcems(ncn)
      common /abo1  / xio1(4),xio1o(4)
      common /xcol  / xcc(183)
      common /dpttau/ tauth
      common /rrrthe/ rrrthe(7,7)
      common /ccrthe/ cirthhe(7,7)
      common /rrrthh/ rrrth(11,11)
      common /ccrthh/ cirthh(11,11)
c
      character*72 ktitle
c
      dimension nikey(13),nnz(13)
      dimension nfeln(26),t1sv(8)
c
      data t1sv/2.5,1.1,6*1.01/
      data ergsev/1.602197e-12/
      data nfeln/0,1162,1178,1193,1208,1223,1238,1253,
     &     1272,1287,1302,1317,1332,1347,1362,1377,
     &     1386,1401,1416,1431,1446,1462,1477,0,1504,
     &     1517/
      data ccee/12398.54/,eps/1.e-8/
      data nikey/1,3,9,16,24,34,46,60,76,94,114,
     &     140,168/
      data nnz/1,2,6,7,8,10,12,14,16,18,20,26,
     &     28/
c
      if (lpri.ge.1) write (6,*)'in init2'
c
      ilim2 = 0
      kkk = 0
      do 100 jk = 1,nel
         ilim1 = ilim2 + 1
         ilim2 = ilim1 + nnz(jk) - 1
         do 50 kl = ilim1,ilim2
            xeln(kl) = xel(jk)
            nalim = nlin(kl)
            do 20 kkl = 1,nalim
               kkk = kkk + 1
               xelln(kkk) = xeln(kl)
               nlsv(kkk) = kkk
 20         continue
 50      continue
 100  continue
      nlsvn = kkk
c
c
      tauth = 0.
      ttrnfr = 0.
      tesc = 0.
      tphot = 0.
      taug = 0.
      tsolve = 0.
      temop = 0.
      ntold = 0
      ntotit = 0
      fbow1 = 0.
      fbow2 = 0.
      bem304 = 0.
      be3003 = 0.
      bem374 = 0.
      be4641 = 0.
      cmp1 = 0.
      cmp2 = 0.
      cmp3 = 0.
      cohc = 0.
      brcl = 0.
      httot = 0.
      cltot = 0.
      hmctot = 0.
      do 200 ll = 1,nni+1
         htt(ll) = 0.
 200  continue
      do 300 ll = 1,nni+2
         cll(ll) = 0.
 300  continue
      rl = 0.
      xnxo=0.
      xpxo=0.
      xnx = xee*xpx
      delr = 0.
      zeta = 0.
      ntmpit = 0.
      nelit = 0.
      npttit = 0.
      pradl = 0.
      pradc = 0.
      pradt = 0.
      dilfac = 0.
      rstar = 0.
c
      do 400 ml = 1,ncn
         fline(ml) = 0.
         fstar(ml) = 0.
c         zremsb(ml) = 0.
c         zrmsbo(ml) = 0.
         bremsb(ml) = 0.
         brmsab(ml) = 0.
         brems(ml) = 0.
         bremsa(ml) = 0.
c         zrems(ml) = 0.
c         zremso(ml) = 0.
         rccems(ml) = 0.
         cocems(ml) = 0.
         dicems(ml) = 0.
         brcems(ml) = 0.
         opakc(ml) = 0.
         opakco(ml) = 0.
         dpthb(ml) = 1.e+10
         dpthc(ml) = 0.
         if (lnoinwd.eq.1) dpthb(ml)=0.
c         if (lnoinwd.eq.1) dpthc(ml)=1.e+10
 400  continue
c
      do 500 ml = 1,nni
         xiin(ml) = 0.
         xiip(ml) = 0.
         grcrt(ml) = 0.
         piht(ml) = 0.
         piqt(ml) = 0.
         cecl(ml) = 0.
         cicl(ml) = 0.
         cirt(ml) = 0.
         dirt(ml) = 0.
         rrrt(ml) = 0.
         airt(ml) = 0.
         tbrt(ml) = 0.
         aicl(ml) = 0.
         tbht(ml) = 0.
         rrcl(ml) = 0.
         dicl(ml) = 0.
         hxr(1,ml) = 0.
         hxr(2,ml) = 0.
         hxh(1,ml) = 0.
         hxh(2,ml) = 0.
         hexr(1,ml) = 0.
         hexr(2,ml) = 0.
         hexh(1,ml) = 0.
         hexh(2,ml) = 0.
         pirt(ml) = 0.
 500  continue
c
      do 600 ml = 1,nnnl
         xiln(ml) = 0.
         xilp(ml) = 0.
         oplin(ml) = 0.
         oplno(ml) = 0.
         ceem(ml) = 0.
         cxem(ml) = 0.
         rcem(ml) = 0.
         diem(ml) = 0.
         flem(ml) = 0.
c         elum(ml) = 0.
c         oelum(ml) = 0.
c         elumb(ml) = 0.
c         oelmb(ml) = 0.
         tau0(ml) = 0.
         tau1(ml) = 1.e+10
c         if (lnoinwd.eq.1) tau0(ml)=1.e+10
         if (lnoinwd.eq.1) tau1(ml)=0.
         if ((lbcase.eq.1).and.(ml.le.8).and.(lnoinwd.eq.1))
     $       tau1(ml)=1.e+6
c         if ((lbcase.eq.1).and.(ml.le.(nlin(1)+nlin(2)+5))
c     $      .and.(ml.ge.(nlin(1)+nlin(2)+1)).and.(lnoinwd.eq.1))
c     $       tau1(ml)=1.e+6
         fcomp(ml) = 0.
         fbbs(ml) = 0.
         ftherm(ml) = 0.
         fsplit(ml) = 0.
         fesc(ml) = 0.
         fescb(ml) = 0.
         trnsl(ml) = 1.
         trnsb(ml) = 0.
 600  continue
c
c
      do 700 ml = 1,11
         do 702 ml2=1,11
           rrrth(ml,ml2)=0.
           cirthh(ml,ml2)=0.
 702       continue
         xihh(ml) = 0.
         bbrt(ml) = 0.
         enrt(ml) = 0.
         xihho(ml) = 0.
 700  continue
c
      do 701 ml=1,7
         do 703 ml2=1,7
           rrrthe(ml,ml2)=0.
           cirthhe(ml,ml2)=0.
 703       continue
         xihe2(ml)=0.
         xihe2o(ml)=0.
         bbrthe(ml)=0.
         enrthe(ml)=0.
 701     continue
c
      do 800 ml = 1,3
         xihhe(ml) = 0.
         xihheo(ml) = 0.
 800  continue
c
      do 900 ml = 1,4
         xio1(ml) = 0.
         xio1o(ml) = 0.
 900  continue
c
      do 1000 ml = 1,nnip
         xii(ml) = 0.
         xiio(ml) = 0.
         xcc(ml) = 0.
 1000 continue
      xcc(182) = 0.
      xcc(183) = 0.
c
c
      do 1100 kl = 1,10
         xxlfe2(kl) = 0.
         do 1050 ll = 1,6
            elmfe2(kl,ll) = 0.
            oemfe2(kl,ll) = 0.
            elmf2b(kl,ll) = 0.
            oemf2b(kl,ll) = 0.
            emfe2(kl,ll) = 0.
            t1fe2(kl,ll) = 1.e+10
            t0fe2(kl,ll) = 0.
 1050    continue
 1100 continue
 
      betsce = 0.
      gamsce = 0.
      betscp = 0.
      gamscp = 0.
c
c
c
      return
      end
      subroutine init3
c
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /scfac / betsce,gamsce,betscp,gamscp
      common /timesv  / ttrnfr,tesc,tphot,taug,tsolve,temop,
     &                ntold
      common /agdata/ amkc(6,6),amkn(7,7),amko(8,8),amkne(10,10),
     &                amkmg(12,12),amlsmg(10,10),amlpmg(8,8),
     &                amksi(14,14),amlssi(12,12),amlpsi(10,10),
     &                amks(16,16),amlss(14,14),amlps(12,12),
     &                amkfe(26,26),amlsfe(24,24),amlpfe(22,22)
      common /radius/ delr,r,rl,rstp,rdel,radexp,rscale,rsave
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /trans / trnsl(nnnl),trnsb(nnnl)
      common /fstar / fstar(ncn),dilfac,rstar
      common /linsel/ nlsv(nnnl),nlsvn
      common /spectl/ fline(ncn)
      common /spctcb/ zremsb(ncn),zrmsbo(ncn),bremsb(ncn),
     &                brmsab(ncn)
      common /spectc/ bremsa(ncn),brems(ncn),zrems(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /ethrsh/ eth(nni)
      common /enerc / epi(ncn),dele(ncn),numcon
      common /abh   / xihh(11),xihho(11),bbrt(11),enrt(11)
      common /abhe  / xihhe(3),xihheo(3)
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /abel  / xel(nl),xeln(nni),xelln(nnnl)
      common /lindat/ elin(nnnl),blin(nnnl), 
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &      flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
      common /fe2dat/ gglfe(10),ggufe(6),eelfe(10),eeufe(6),
     &                bbfe(10,6),elamfe(60),nblfe2(60),ffe(10,6),
     &                gfe(10,6)
      common /fe2emm/ emfe2(10,6),xxlfe2(10)
      common /fe2lum/ elmfe2(10,6),oemfe2(10,6),t0fe2(10,6),
     &                t1fe2(10,6),elmf2b(10,6),oemf2b(10,6)
      common /numit / lnerrs,lnerrd,ntmpit,nelit,ntotit,
     &                npttit,nstpnm
      common /pcool / cll(170)
      common /pheat / htt(169)
      common /phheat/ piht(nni)
      common /phrate/ pirt(nni)
      common /pqrtt / pqrtot
      common /pqrate/ piqt(nni)
      common /cecool/ cecl(nni)
      common /cicool/ cicl(nni)
      common /cirate/ cirt(nni)
      common /dirate/ dirt(nni)
      common /rrrate/ rrrt(nni)
      common /airate/ airt(nni)
      common /tbrate/ tbrt(nni)
      common /aicool/ aicl(nni)
      common /tbheat/ tbht(nni)
      common /rrcool/ rrcl(nni)
      common /dicool/ dicl(nni)
      common /coheat/ cmp1,cmp2,cohc
      common /brcool/ brcl
      common /heat  / httot,cltot,hmctot
      common /hcxrt / hxr(2,nni),hexr(2,nni)
      common /hcxht / hxh(2,nni),hexh(2,nni)
      common /radp  / pradl,pradc,pradt
      common /copak / opakc(ncn),opakco(ncn)
      common /cdpth / dpthc(ncn)
      common /bdpth / dpthb(ncn)
      common /etot  / etotc,etotco,etotl,etotlo
     $               ,etotc1,etotc2,etotc3,etotl1,etotl2
      common /llumin/ elum(nnnl),oelum(nnnl)
      common /llumnb/ elumb(nnnl),oelmb(nnnl)
      common /lopak / oplin(nnnl),oplno(nnnl)
      common /grcrte/ grcrt(nni)
      common /ceemis/ ceem(nnnl)
      common /cxemis/ cxem(nnnl)
      common /diemis/ diem(nnnl)
      common /rcemis/ rcem(nnnl)
      common /flemis/ flem(nnnl)
      common /hrcrte/ hrcrt(20,28),hrcrtt(28)
      common /swdata/ stwtrt(nni)
      common /he2bow/ fbow1,fbow2,bem304,be3003,bem374,be4641
      common /ffcomp/ fcomp(nnnl)
      common /ffbbs / fbbs(nnnl)
      common /ffthrm/ ftherm(nnnl)
      common /ffsplt/ fsplit(nnnl)
      common /ffesc / fesc(nnnl)
      common /ffescb/ fescb(nnnl)
      common /tau0ln/ tau0(nnnl)
      common /tau1ln/ tau1(nnnl)
      common /cemis / rccems(ncn),cocems(ncn),dicems(ncn),
     &                brcems(ncn)
      common /abo1  / xio1(4),xio1o(4)
      common /xcol  / xcc(183)
      common /dpttau/ tauth
c
      character*72 ktitle
c
      if (lpri.ge.1) write (6,*)'in init3'
c
c
      do 400 ml = 1,ncn
         fline(ml) = 0.
         fstar(ml) = 0.
         zremsb(ml) = 0.
         zrmsbo(ml) = 0.
         bremsb(ml) = 0.
         brmsab(ml) = 0.
         brems(ml) = 0.
         bremsa(ml) = 0.
         zrems(ml) = 0.
         zremso(ml) = 0.
         rccems(ml) = 0.
         cocems(ml) = 0.
         dicems(ml) = 0.
         brcems(ml) = 0.
         opakc(ml) = 0.
         opakco(ml) = 0.
         dpthb(ml) = 1.e+10
         dpthc(ml) = 0.
 400  continue
c
      do 600 ml = 1,nnnl
         xiln(ml) = 0.
         xilp(ml) = 0.
         oplin(ml) = 0.
         oplno(ml) = 0.
         ceem(ml) = 0.
         cxem(ml) = 0.
         rcem(ml) = 0.
         diem(ml) = 0.
         flem(ml) = 0.
         elum(ml) = 0.
         oelum(ml) = 0.
         elumb(ml) = 0.
         oelmb(ml) = 0.
         tau0(ml) = 0.
         tau1(ml) = 1.e+10
c         if (lnoinwd.eq.1) tau0(ml)=1.e+10
         if (lnoinwd.eq.1) tau1(ml)=0.
         if ((lbcase.eq.1).and.(ml.le.8).and.(lnoinwd.eq.1))
     $       tau1(ml)=1.e+6
c         if ((lbcase.eq.1).and.(ml.le.(nlin(1)+nlin(2)+5))
c     $      .and.(ml.ge.(nlin(1)+nlin(2)+1)).and.(lnoinwd.eq.1))
c     $       tau1(ml)=1.e+6
         fcomp(ml) = 0.
         fbbs(ml) = 0.
         ftherm(ml) = 0.
         fsplit(ml) = 0.
         fesc(ml) = 0.
         fescb(ml) = 0.
         trnsl(ml) = 1.
         trnsb(ml) = 0.
 600  continue
c
c
      return
      end
      subroutine ioneqm(linc,z,a,s,s2,n,m,l,lpri)
c
      external bigdat,newdat,rr3,nfllns
c
      real a,delt,eps,pg,pl,q,s,s2,sumg,suml,tst,z
      integer i,j,jk,jmax,k,l,linc,ll,lpri,m,mmn,
     &        mmx,n
c
c
c
c     solves a system of ionization equations, attempting
c     to avoid overflow problems.
c
c
c
      dimension z(m),a(m),s(n),q(29),linc(m)
c
      data eps/1.e-6/
      data delt/1.e-28/
c
      if (lpri.gt.2) write (6,*)'in ioneqm'
c
c     initialize
      do 100 jk = 1,n
         s(jk) = 0.
 100  continue
c
      if ( lpri.gt.2 ) write (6,99001)
c
c     form naive ratio
      do 200 j = 1,m
         q(j) = a(j)/(z(j)+delt)
 200  continue
c
c     step thru and search for max. q value
      jk = l
 300  jk = jk + 1
      if ( (jk.lt.n) .and. (q(jk-1).lt.1.) ) goto 300
      jmax = jk
c
      if ( lpri.gt.2 ) write (6,99002) n,m,l,jmax
c
c     step forwards
      suml = 0.
      if ( jmax.ne.n ) then
         pl = 1.
         mmx = jmax - 1
 350     mmx = mmx + 1
         pl = pl/q(mmx)
         suml = suml + pl
         tst = pl/(suml+1.e-20)
         if ( lpri.gt.2 ) write (6,99003) mmx,q(mmx),suml,pl
         if ( (tst.gt.eps) .and. (mmx.lt.m) ) goto 350
      endif
c
c     step backwards
      sumg = 0.
      if ( jmax.ne.l ) then
         pg = 1.
         mmn = jmax
 400     mmn = mmn - 1
         pg = pg*q(mmn)
         sumg = sumg + pg
         tst = pg/(sumg+1.e-20)
         if ( lpri.gt.2 ) write (6,99004) mmn,q(mmn),sumg,pg
         if ( (tst.gt.eps) .and. (mmn.gt.l) ) goto 400
      endif
c
c
      s(jmax) = 1./(1.+suml+sumg)
      if ( jmax.ne.n ) then
         do 450 j = jmax,mmx
            s(j+1) = s(j)/q(j)
 450     continue
      endif
c
      if ( jmax.ne.l ) then
         k = jmax - mmn
         do 500 i = 1,k
            j = jmax - i
            s(j) = s(j+1)*q(j)
 500     continue
      endif
c
      if ( lpri.gt.2 ) write (6,99005) (ll,q(ll),s(ll),ll=l,n)
c
c
      return
99001 format (' ',' in ioneqm ')
99002 format (' ',' n,m,l,jmax --',4i4)
99003 format (' ','in greater than loop, j,q,sum,p --',i4,3e12.4)
99004 format (' ','in less than loop, j,q,sum,p --',i4,3e12.4)
99005 format (' ',i4,2e12.4)
      end
      subroutine ispcbp(tp1,tp2,ebb,xnorm)
c
c
c
c
c     this subroutine generates the initial spectrum.
c     broken power law
c     brems stores the flux to be used
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /spectc/ bremsa(ncn),brems(ncn),zrems(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /enerc / epi(ncn),dele(ncn),numcon
c
      character*72 ktitle
c
      dimension zrms1(ncn)
c
      data eps/1.e-34/
      data ergsev/1.602197e-12/
c
      if (lpri.ge.1) write (6,*)'in ispcbp'
c
      alph1 = tp1
      alph2 = tp2
      enux = ebb*1.e+3
      sum1 = 0.
      zrms1(1) = epi(1)**(-alph1)
      eee = epi(1)
      enul = 13.6
      enuxx = 1.36e+4
      if (lpri.gt.2)
     $  write (6,*)'in ispcbp',tp1,tp2,ebb,alph1,alph2,enux
      do 100 jk = 2,numcon
         eeel = eee
         eee = epi(jk)
         if ( epi(jk).gt.enux ) then
            zrms1(jk) = zrms1(jk-1)*(eeel/eee)**alph2
         else
            zrms1(jk) = zrms1(jk-1)*(eeel/eee)**alph1
         endif
         if ( (eee.ge.enul) .and. (eee.le.enuxx) ) then
            sum1 = sum1 + (zrms1(jk)+zrms1(jk-1))*(eee-eeel)/2.
         endif
 100  continue
c
      const = xnorm/(sum1*ergsev)
      do 200 jk = 1,numcon
         zremsz(jk) = zremsz(jk) + zrms1(jk)*const
 200  continue
c
c
      return
      end
      subroutine ispcg2
c
c
c
c
c
c     this subroutine calculates number luminosity
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /radius/ delr,r,rl,rstp,rdel,radexp,rscale,rsave
      common /spectc/ bremsa(ncn),brems(ncn),zrems(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /enerc / epi(ncn),dele(ncn),numcon
      common /fstar / fstar(ncn),dilfac,rstar
c
      character*72 ktitle
c
      data ergsev/1.602197e-12/
c
      if (lpri.ge.1) write (6,*)'in ispec2'
c
      sum2 = 0.
      do 100 jk = 1,numcon
         if ( epi(jk).ge.13.6 ) then
            sum2 = sum2+(zremsz(jk)/epi(jk)+zremsz(jk-1)/epi(jk-1))
     &             *(epi(jk)-epi(jk-1))/2.
         endif
c         write (6,*)jk,epi(jk),zremsz(jk),sum2
 100  continue
      enlum = sum2
c
c
      return
      end
      subroutine ispcss(dotmm,rin,rout,emm,alph)
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /spectc/ bremsa(ncn),brems(ncn),zrems(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /enerc / epi(ncn),dele(ncn),numcon
c
      character*72 ktitle
c
      dimension zremsi(ncn),zrmstp(ncn),zrmspo(ncn)
c
c
      do 100 kl = 1,numcon
         zremsi(kl) = 0.
 100  continue
c
      dotm = dotmm
      gam = 0.
      ttd0 = 0.
      dotmc = (3.e-8)*emm
      rrg = (3.e+5)*emm
      eml = emm
      dotml = dotm/dotmc
      rr0 = 3.*rrg
c     rri=2.*rrg*(3.e+2)
c      rri=rr0
      rri = rin
c      ttd0=(elum*ffd0/(12.56*rr0*rr0*(5.67e-5)))**(0.25)
c      rr1=3.*rrg*(4.e+4)*yy(3)
      rr1 = rout
      amu = 1.66e-24
      ekk = 1.38e-16
      bb = 7.56464e-15
      ccc = 2.998e+10
      if ( lpri.gt.2 ) print 99001,emm,alph,xlum,dotm,dotmc,
     &                       dotml,rrg,rr0,rr1,ttd0
      nstp = 100
      del = (rr1/rri)**(1./float(nstp))
      quan1l = -1.
      rrr = rri*1.001
      rrrl = rrr
      ergsev = 1.602197e-12
      quan2l = -1.
      llab = -1
      llbc = 1
c
c
c      step through radii
      do 400 jk = 1,nstp
c
c
c     evaluate non-dimensional quantities
         rrl = rrr/rr0
         brack = 1. - 1./sqrt(rrl)
c     brack=1.
c
c     find region
         lreg = 0
         quant1 = rrl/brack**(16./21.) - 150.*(alph*eml)**(2./21.)
     &            *dotml**(16./21.)
         quant2 = rrl - (6.3e+3)*dotml**(2./3.)*brack**(2./3.)
         quant2 = -quant2
         tst1 = quant1*quan1l
         tst2 = quant2*quan2l
         if ( (jk.gt.1) .and. (tst1.lt.0.) ) llab = -llab
         if ( (jk.gt.1) .and. (tst2.lt.0.) ) llbc = -llbc
         quan1l = quant1
         quan2l = quant2
         if ( llbc.lt.0 ) then
c
c      in region c
c
            tt = 8.6e7*(dotml*brack)**(0.3)
     &           /((alph*eml)**(0.2)*rrl**(0.75))
            ttx = ttd0*rrl**(gam/4.-0.5)
            tt = amax1(tt,ttx)
            zz0 = 6.1e3*(dotml*brack)**(0.15)*eml**(0.9)*rrl**(1.125)
            enn = 3.e+25*(dotml*brack)**(0.55)
     &            /((alph*eml)**(0.7)*rrl**(15./8.))
            taust = 3.4e+2*(dotml*brack*eml)**(0.2)/alph**(0.8)
            rho = enn*amu
            prad = bb*tt**4
            pgas = enn*ekk*tt
c     if (prad.gt.pgas) go to 13
            vsqg = ekk*tt/amu
c      vsqr=eps/(3.*rho)
            sigff = 0.11*tt**(-3.5)*enn
            sigt = 0.4
c     if (sigt.gt.sigff) go to  12
c
            lreg = 3
         elseif ( llab.lt.0 ) then
c
c      in region b
c
            tt = 3.1e+8*(dotml*brack)**(0.4)
     &           /((alph*eml)**(0.2)*rrl**(0.9))
            ttx = ttd0*rrl**(gam/4.-0.5)
            tt = amax1(tt,ttx)
            zz0 = 1.2e+4*(dotml*brack)**(0.2)*eml**(0.9)*rrl**(1.05)
     &            /alph**(0.2)
            enn = 4.2e+24*(dotml*brack)**(0.4)
     &            /((alph*eml)**(0.7)*rrl**(1.65))
            taust = 1.e+2*(dotml*brack)**(0.9)*eml**(0.2)*rrl**(0.15)
     &              /alph**(0.8)
            sigff = 0.11*tt**(-3.5)*enn
            sigt = 0.4
            rho = enn*amu
            prad = bb*tt**4
            pgas = enn*ekk*tt
c     if (pgas.gt.prad) go to 11
c     if (sigt.gt.sigff) go to 13
            vsqg = ekk*tt/amu
c      vsqr=eps/(3.*rho)
c
            lreg = 2
         else
c
c      in region a
c
            ttx = ttd0*rrl**(gam/4.-0.5)
            tt = 2.3e+7*(alph*eml)**(-1./4.)*rrl**(-3./8.)
            tt = amax1(tt,ttx)
            taust = 8.4e-5*alph**(-17./16.)*eml**(-1./16.)*dotml**(-2)
     &              *rrl**(-93./32.)*brack**(-2)
            ener = 2.1e+15/(alph*eml*rrl**1.5)
            enn = 4.3e+17*rrl**1.5/(alph*dotml**2*eml*brack**2)
            zz0 = 3.2e+6*eml*dotml*brack
            rho = enn*amu
            prad = bb*tt**4
            pgas = enn*ekk*tt
c     if (pgas.gt.prad) go to 11
            vsqg = ekk*tt/amu
c      vsqr=eps/(3.*rho)
            sigff = 0.11*tt**(-3.5)*enn
            sigt = 0.4
c     if (sigff.gt.sigt) go to 12
c
            lreg = 1
         endif
c
c
c
         if ( lpri.ge.3 ) then
            print 99002,jk,rrr,rrl
            print 99003,quant1,quan1l,quant2,quan2l,llbc,
     &            llab,lreg
            print 99004,tt,ttx,zz0,enn,taust,rho,ener
            print 99005,prad,pgas,sigt,sigff
         endif
c
c      now calculate radiation spectrum
c      find region
         tst = 800.*alph**(4./57.)*dotml**(37./57.)/(eml**(46./57.))
c     if (rrl.lt.tst) go to 4
c      lreg=3
         if ( lreg.ne.1 ) then
            if ( lreg.eq.2 ) then
c
c      in the intermediate region
               tst2 = 25.*alph**(2./9.)*dotml**(2./3.)
               if ( rrl.ge.tst2 ) then
                  region = 2.
                  tts = 1.e+8*((dotml*brack)**28.*alph)**(1./75.)
     &                  /(eml**(19./75.)*rrl**(141./150.))
                  tts = amax1(tts,ttx)
                  ektt = tts*(0.8617)/1.e+4
                  do 105 kl = 1,numcon
                     xx = epi(kl)/ektt
                     expx = exp(-xx)
                     denom = 1. - expx
                     if ( xx.le.1.e-4 ) denom = amax1(xx,1.e-34)
                     zrmstp(kl) = xx**2*expx/denom**(0.33333)
 105              continue
                  qq = 1.8e-4*sqrt(enn)*tts**(2.25)
                  goto 200
               endif
            else
               if ( lreg.eq.3 ) then
               endif
c
c      for outer planck region
               region = 3.
               tts = 3.e+7*((dotml*brack)/(eml*rrl**3))**(1./4.)
               tts = amax1(tts,ttx)
               ektt = tts*(0.8617)*(1.e-4)
               do 110 kl = 1,numcon
                  xx = epi(kl)/ektt
                  zrmstp(kl) = xx**3*exp(-xx)/(1.-exp(-xx))
 110           continue
               qq = (ccc*bb*tts**4)/4.
               goto 200
            endif
         endif
c
c      in the inner region
         region = 1.
         tts = 5.e+8*((dotml*brack)**(0.2)/(eml**(0.2)*rrl**(1.5)))
         tts = amax1(tts,ttx)
         ektt = tts*(0.8617)/1.e+4
         do 150 kl = 1,numcon
            xx = epi(kl)/ektt
            zrmstp(kl) = xx**3*exp(-xx)
 150     continue
         qq = 4.4e19*dotml*brack/(eml*rrl**3)
c
 200     qq = dotm*emm*brack/(rrr/1.02e+17)**3
         sgt4 = (5.65e-5)*ttx**4
         qq = amax1(qq,sgt4)
         tmpo = zrmstp(1)
         enero = epi(1)
         sum = 0.
         do 250 kl = 2,numcon
            ener = epi(kl)
            tmp = zrmstp(kl)
            sum = sum + (tmp+tmpo)*(ener-enero)/2.
            enero = ener
            tmpo = tmp
 250     continue
         const = qq/amax1(1.e-34,(sum*ergsev))
         do 300 kl = 1,numcon
            zrmstp(kl) = zrmstp(kl)*const
            ytmpp = (zrmstp(kl)+zrmspo(kl))*3.14*rrr*(rrr-rrrl)
            zremsi(kl) = zremsi(kl) + ytmpp
            zrmspo(kl) = zrmstp(kl)
            elam = 12398.54/amax1(epi(kl),1.e-34)
 300     continue
c
c
         if ( lpri.ge.3 ) then
            print 99006,region,tts,qq
            print 99007,(ll,epi(ll),zrmstp(ll),zrmspo(ll),zrems(ll),
     &            ll=1,numcon,10)
            print 99008
         endif
c
         rrrl = rrr
         rrr = rrr*del
c
 400  continue
c
      sum = 0.
      tmp = zremsi(1)
      ener = epi(1)
      do 500 kl = 2,numcon
         tmpo = tmp
         enero = ener
         tmp = zremsi(kl)
         ener = epi(kl)
         sum = sum + (tmp+tmpo)*(ener-enero)/2.
 500  continue
      sum = sum*ergsev
      if ( lpri.gt.2 ) print 99009,sum
      sigsm = 0.
      if ( lpri.gt.2 ) print 99010
      do 600 kl = 1,numcon
         zremsz(kl) = zremsz(kl)+zremsi(kl)/amax1(1.e-34,(sum*xlum))
 600  continue
c
c
      return
99001 format (' ','funk2 parameters ',6e12.4)
99002 format (' ',' step number and radius ',i4,2e12.4)
99003 format (' ',' the region variables ',4e12.4,3i4)
99004 format (' ',' disk properties ',7e12.4)
99005 format (' ',' pressures and opacities ',4e12.4)
99006 format (' ',' spectrum quantities ',3e12.4)
c     print 9909,(ll,epi(ll),zrmspo(ll),ll=1,numcon)
c     print 9909,(ll,epi(ll),zrems(ll),ll=1,numcon)
99007 format (' ',' the spectrum ',i4,4e12.4)
99008 format (' ')
99009 format (' ',' normalization ',e12.4)
99010 format (' ',' the total spectrum ')
c
      end
      subroutine ispec
c
c
c
c
c
c     this subroutine generates the initial spectrum.
c      optically thin bremsstrahlung spectrum
c     brems stores the flux to be used
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /spectc/ bremsa(ncn),brems(ncn),zrems(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /enerc / epi(ncn),dele(ncn),numcon
c
      character*72 ktitle
c
      data ergsev/1.602197e-12/
c
      dimension zremsi(ncn)
c
      lprisv=lpri
      lpri=0
      if (lpri.ge.1) write (6,*)'in ispec'
      znx = ecut
      del = 1.
      q = 7.49e+08*del*xlum/tp
      xkt = 1.16e-03/tp
      sum = 0.
      if ( lpri.gt.2 ) write (6,*) 'in ispec',tp,xlum,q,xkt
      do 100 i = 1,numcon
         tempp = epi(i)*xkt
         zremsi(i) = 0.
         if ( tempp.le.50. ) then
            zremsi(i) = q
            if ( tempp.ge.1.e-2 ) then
               zremsi(i) = q*expo(-tempp)
            endif
         endif
         if ( lpri.gt.2 ) write (6,*) i,epi(i),zremsi(i)
         if ( (epi(i).ge.13.6) .and. (epi(i).le.1.36e+4) .and. (i.gt.1)
     &        ) then
            sum = sum + (zremsi(i)+zremsi(i-1))*(epi(i)-epi(i-1))/2.
         endif
 100  continue
c
      const = xlum/sum/ergsev
      do 200 i = 1,numcon
         zremsz(i) = zremsz(i) + zremsi(i)*const
         if ( lpri.gt.2 ) write (6,*) i,epi(i),zremsi(i),const,
     &                                zremsz(i)
 200  continue
      lpri=lprisv
c
      return
      end
      subroutine ispec4
c
c
c
c
c     this subroutine generates the initial spectrum.
c     brems stores the flux to be used
c     single power law spectrum
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /spectc/ bremsa(ncn),brems(ncn),zrems(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /enerc / epi(ncn),dele(ncn),numcon
      common /fstar / fstar(ncn),dilfac,rstar
c
      character*72 ktitle
c
      dimension zremsi(ncn)
c
      data eps/1.e-4/
      data ergsev/1.602197e-12/
c
      if (lpri.ge.1) write (6,*)'in ispec4'
      sum = 0.
      enuh = 13.6
      do 100 jk = 1,numcon
         zremsi(jk) = 0.
         if ( epi(jk).ge.ecut ) then
            zremsi(jk) = 1./epi(jk)**tp
            if ( (epi(jk).ge.13.6) .and. (epi(jk).le.1.36e+4) .and. 
     &           (jk.ne.1) ) then
               sum = sum + (zremsi(jk)+zremsi(jk-1))*(epi(jk)-epi(jk-1))
     &               /2.
            endif
         endif
 100  continue
      sum = sum*ergsev
      const = xlum/sum
      do 200 jk = 1,numcon
         zremsz(jk) = zremsz(jk) + zremsi(jk)*const
 200  continue
c
c
      return
      end
      subroutine ispec5(epi1,epi2)
c
c     this routine does a cutoff power law
c
c
c
c     this subroutine generates the initial spectrum.
c     brems stores the flux to be used
c     single power law spectrum
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /spectc/ bremsa(ncn),brems(ncn),zrems(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /enerc / epi(ncn),dele(ncn),numcon
      common /fstar / fstar(ncn),dilfac,rstar
c
      character*72 ktitle
c
      dimension zremsi(ncn)
c
      data eps/1.e-4/
      data ergsev/1.602197e-12/
c
c      write (6,*)'in ispec5:',tp,epi1,epi2,ecut,xlum
      sum = 0.
      enuh = 13.6
      do 100 jk = 1,numcon
         zremsi(jk) = 0.
         if ( epi(jk).ge.ecut ) then
            zremsi(jk) = 1./epi(jk)**tp
            if (epi(jk).gt.epi1) 
     $         zremsi(jk)=zremsi(jk)*expo(-(epi(jk)-epi1)/epi2)
            if ( (epi(jk).ge.13.6) .and. (epi(jk).le.1.36e+4) .and. 
     &           (jk.ne.1) ) then
               sum = sum + (zremsi(jk)+zremsi(jk-1))*(epi(jk)-epi(jk-1))
     &               /2.
            endif
         endif
 100  continue
      sum = sum*ergsev
      const = xlum/sum
      do 200 jk = 1,numcon
         zremsz(jk) = zremsz(jk) + zremsi(jk)*const
 200  continue
c
c
      return
      end
      subroutine ispec9(tauth)
c
c
c      this routine calculates input spectra,
c      including comptonization by low temperature electrons
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /radius/ delr,r,rl,rstp,rdel,radexp,rscale,rsave
      common /enerc / epi(ncn),dele(ncn),numcon
      common /cemis / rccems(ncn),cocems(ncn),dicems(ncn),
     &                brcems(ncn)
      common /spectc/ bremsa(ncn),brems(ncn),zrems1(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /copak / opakc(ncn),opakco(ncn)
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
c
      character*72 ktitle
c
      dimension zrmstp(ncn),zrmspo(ncn),zremsi(ncn)
c
      data ergsev/1.602197e-12/
      data emc2/5.11e+5/
      data sigth/6.65e-25/
c
      if ( tauth.le.0.1 ) return
c
c      lpri=2
c
      if ( lpri.gt.2 ) write (6,99001) tauth
      sum = 0.
      zrmstp(1) = zremsz(1)
      zremsi(1) = 0.
      do 100 kl = 2,numcon
         zrmstp(kl) = zremsz(kl)
         zremsi(kl) = 0.
         sum = sum + (zrmstp(kl)+zrmstp(kl-1))*(epi(kl)-epi(kl-1))/2.
 100  continue
      sum = sum*ergsev
c
      lprio = lpri
      eps = 1.e-5
c
c     compton setup
      call cmpstp(tauth)
c
c     step through energies
      do 300 kl = 2,numcon - 1
c
         if ( (zrmstp(kl).gt.eps) .and. (epi(kl).ge.100.) ) then
c
c           the green's function
            call cmpztn(zrmspo,kl,tauth)
c
c           step through final energies
            if (epi(kl).lt.10000.) go to 221
            do 220 lm = 1,kl
c
               if ((zrmspo(lm).gt.1.e-30)
     $              .and.(epi(lm).ge.100.)) then
                  elam0 = emc2/epi(kl)
                  elam = emc2/epi(lm)
                  delam = elam - elam0
                  cc1 = 1.e-5
                  wabs = 1.
                  zremsi(lm)=zremsi(lm) + wabs*zrmspo(lm)*zrmstp(kl)
     &                        *(emc2/epi(kl-1)-emc2/epi(kl+1))/2.
                  endif
 220           continue
            go to 300
c
 221        continue
            zremsi(kl)=zrmspo(kl)*zrmstp(kl)
     &               *(emc2/epi(kl-1)-emc2/epi(kl+1))/2.
c
         endif
c
 300  continue
c
      lpri = lprio
c
c     renormalize
c      lpri=1
      sum = 0.
      sum2 = 0.
      do 400 kl = 2,numcon
         if ( (epi(kl).gt.13.6) .and. (epi(kl).lt.1.36e+4) ) then
            sum = sum + (zremsi(kl)+zremsi(kl-1))*(epi(kl)-epi(kl-1))/2.
            sum2 = sum2 + (zrmstp(kl)+zrmstp(kl-1))*(epi(kl)-epi(kl-1))
     &             /2.
         endif
 400  continue
c
c     the normalization should give an emissivity
      sum = sum*ergsev
      sum2 = sum2*ergsev
      q1 = delr
      optpp = xpx*sigth
      deltau = optpp*delr
      tmp = expo(-deltau)
      fac = amax1(0.,(1.-tmp))/amax1(optpp,1.e-34)
      if ( deltau.le.1.e-4 ) fac = delr
c      q1=delr/amax1(1.-tmp,1.e-34)
      q1 = fac
      q1 = delr
      r19 = r*(1.e-19)
      fpr2 = 12.568*r19*r19
      cfac = sum2/sum/amax1(1.e-34,q1)/fpr2
      cfac = 1./amax1(1.e-34,q1)/fpr2
c      write (6,*) ' cfac=',sum,sum2,cfac,xlum
      do 500 kl = 1,numcon
         if ( (zrmstp(kl).gt.eps) .and. (epi(kl).ge.1.) ) then
c        zrmstp(kl)=zrmstp(kl)*xlum/sum2
            cocems(kl) = zremsi(kl)*cfac
            elam = emc2/epi(kl)
            ekev = epi(kl)*1.e-3
            zr1 = zrmstp(kl)*ekev
            zr2 = zrems1(kl)*ekev
         endif
 500  continue
c
c
      return
99001 format (' ',' compton depth=',e12.4)
c         if (lpri.gt.2) write (6,9905)kl,epi(kl),zrmstp(kl)
99002 format (' ',i4,2e12.4)
c            wabs=expo(cc1*(0.25*elam0**4-0.25*elam**4))
c            if (kl.eq.298)
c     $        write (6,9921)lm,delam,zrmspo(lm)
99003 format (' ',i4,2e12.4)
c            write (6,9981)kl,lm,zrmspo(lm),zrmstp(kl),zrems(lm)
99004 format (' ',' in ispec9 ',2i4,3e12.4)
c         if ((zrems(kl).gt.1.e-30))
c     $    write (6,9901)kl,ekev,zr1,zr2
99005 format (' ',i4,3e12.4)
c     write (6,9902)sum2,sum
99006 format (' ','in ispec9. incident and comptonized normalizations',
     &        2e12.4)
      end
      subroutine ispecg(eptmp,zrtmp,nret)
c
c
c
c
c     this subroutine generates the initial spectrum.
c     brems stores the flux to be used
c     generic renormalization
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /radius/ delr,r,rl,rstp,rdel,radexp,rscale,rsave
      common /spectc/ bremsa(ncn),brems(ncn),zrems(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /enerc / epi(ncn),dele(ncn),numcon
      common /fstar / fstar(ncn),dilfac,rstar
c
      character*72 ktitle
c
      dimension zremsi(ncn),eptmp(ncn),zrtmp(ncn)
c
      data eps/1.e-4/
      data ergsev/1.602197e-12/
c
c        interpolate onto standard grid
c
c        spline interpolation
c      yp2 = 1.e+30
c      yp1 = 1.e+30
c      call spline(eptmp,zrtmp,nret,yp1,yp2,y2)
c         write (6,*)(mm,eptmp(mm),zrtmp(mm),y2(mm),mm=1,nret)
c      khi = nret
c      klo = 1
c      ncall = 0
c      do 100 kl = 1,numcon
c            write (6,*)'x=',kl,epi(kl)
c         x = epi(kl)
c         call splint(eptmp,zrtmp,y2,nret,x,y,klo,khi,ncall)
c         zremsi(kl) = y
c 100  continue
c
c        linear interpolation in log
 200  jlo = 0
      if (lpri.ge.1) write (6,*)'in ispecg:',nret
      if ( lpri.gt.2 ) write (6,*) (ll,eptmp(ll),zrtmp(ll),ll=1,nret)
      do 300 kl = 1,numcon
         x = epi(kl)
         zremsi(kl) = 0.
         epmx = amax1(eptmp(1),eptmp(nret))
         epmn = min(eptmp(1),eptmp(nret))
         if ( lpri.gt.2 ) write (6,*) kl,x,epmx,epmn
         if ( (x.le.epmx) .and. (x.ge.epmn) ) then
            call hunt(eptmp,nret,x,jlo,lpri)
c            jlo=min0(jlo,nret-1)
            jlo = max0(jlo,1)
            zr1 = alog10(amax1(zrtmp(jlo+1),1.e-34))
            zr2 = alog10(amax1(zrtmp(jlo),1.e-34))
c            zr1=zrtmp(jlo+1)
c            zr2=zrtmp(jlo)
            ep1 = alog10(amax1(eptmp(jlo+1),1.e-34))
            ep2 = alog10(amax1(eptmp(jlo),1.e-34))
            alx = alog10(x)
            alx = amax1(alx,ep2)
            alx = min(alx,ep1)
            aly = (zr1-zr2)*(alx-ep2)/(ep1-ep2+1.e-34) + zr2
            y = 10.**aly
            zremsi(kl) = y
            if ( lpri.gt.2 ) write (6,*) kl,x,jlo,zr1,zr2,
     &                              ep1,ep2,y
         endif
 300  continue
c
      sum = 0.
      enuh = 13.6
      tmp = zremsi(1)
      if ( lpri.gt.2 ) write (6,*) ' in ispecg'
      do 400 jk = 2,numcon
         tmpo = tmp
         tmp = zremsi(jk)
         if ( lpri.gt.2 ) write (6,*) jk,epi(jk),tmp,tmpo,sum
         if ( (epi(jk).ge.13.6) .and. (epi(jk).le.1.36e+4) ) then
            sum = sum + (tmp+tmpo)*(epi(jk)-epi(jk-1))/2.
         endif
 400  continue
      sum = sum*ergsev
      const = xlum/sum
      do 500 jk = 1,numcon
         if ( lpri.gt.2 ) write (6,*) jk,epi(jk),zrems(jk),
     &                                zremsi(jk)
         zremsz(jk) = zremsz(jk) + zremsi(jk)*const
 500  continue
c
c
      return
      end
      subroutine ispecgg
c
c
c
c     this subroutine generates the initial spectrum.
c     brems stores the flux to be used
c     generic renormalization
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /radius/ delr,r,rl,rstp,rdel,radexp,rscale,rsave
      common /spectc/ bremsa(ncn),brems(ncn),zrems(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /enerc / epi(ncn),dele(ncn),numcon
      common /fstar / fstar(ncn),dilfac,rstar
c
      character*72 ktitle
c
c
      data eps/1.e-4/
      data ergsev/1.602197e-12/
c
c
      sum = 0.
      enuh = 13.6
      tmp = zremsz(1)
      if ( lpri.ge.1 ) write (6,*) ' in ispecg'
      do 100 jk = 2,numcon
         tmpo = tmp
         tmp = zremsz(jk)
         if ( lpri.gt.2 ) write (6,*) jk,epi(jk),tmp,tmpo,sum
         if ( (epi(jk).ge.13.6) .and. (epi(jk).le.1.36e+4) ) then
            sum = sum + (tmp+tmpo)*(epi(jk)-epi(jk-1))/2.
         endif
 100  continue
      sum = sum*ergsev
      const = xlum/sum
      do 200 jk = 1,numcon
         zremsz(jk) = zremsz(jk)*const
 200  continue
c
c
      return
      end
      subroutine istruc
c
c
c
c     this routine solves for ionization = recombination.
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /temp  / t,to
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /abel  / xel(nl),xeln(nni),xelln(nnnl)
      common /phrate/ pirt(nni)
      common /dirate/ dirt(nni)
      common /rrrate/ rrrt(nni)
      common /airate/ airt(nni)
      common /cirate/ cirt(nni)
      common /hcxrt / hxr(2,nni),hexr(2,nni)
      common /tbrate/ tbrt(nni)
      common /pqrtt / pqrtot
      common /prs   / p,p0
      common /lindat/ elin(nnnl),blin(nnnl), 
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &      flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
      dimension zeff(28),alpha(28),xitp(29)
      dimension nlow(13),linc(28)
      dimension ni1(13),ni2(13)
c
      data ni1/1,2,4,10,17,25,35,47,61,77,95,115,
     &     141/
      data ni2/1,3,9,16,24,34,46,60,76,94,114,
     &     140,168/
      data nlow/1,1,2,1,1,1,2,2,2,3,2,2,1/
      data ergsev/1.602192e-12/
c
c
       lprisv=lpri
       lpri=0
c
      if ( lcdd.eq.0 ) xpx = p/(1.4e-12*t*(1.+xee))
      xnx = xpx*xee
c
c
c     ionization = recombination calculation.
c
      xh1 = xel(1)*xii(1)*xpx
      xh2 = xel(1)*xii(2)*xpx
      xhe1 = xel(2)*xii(3)*xpx
      xhe2 = xel(2)*xii(4)*xpx
c     if (xii(3).le.1.e-2) xhe1=0.
c     if (xii(4).le.1.e-2) xhe2=0.
c     if (xii(1).le.1.e-2) xh1=0.
c
      if ( lpri.ge.1 ) write (6,*) 'in istruc',xnx,xh1,xhe1
      nellow = 1
      if (t.lt.10.) nellow = 2
      do 200 jk = nellow,nel
         ilim1 = ni1(jk)
         ilim2 = ni2(jk)
         nnz = ilim2 - ilim1 + 1
         do 50 kl = ilim1,ilim2
            lk = kl - ilim1 + 1
            linc(lk) = lichk(kl)
            alpha(lk) = (rrrt(kl)+dirt(kl)+tbrt(kl)*xnx)*xnx + hxr(1,kl)
     &                  *xh1 + hexr(1,kl)*xhe1
            zeff(lk) = pirt(kl) + xnx*(cirt(kl)+airt(kl)) + hxr(2,kl)
     &                 *xh2 + hexr(2,kl)*xhe2
            if ( lpri.gt.2 ) write (6,99001) lk,kl,rrrt(kl),
     &                              dirt(kl),tbrt(kl),hxr(1,kl),
     &                              hexr(1,kl),alpha(lk),pirt(kl),
     &                              cirt(kl),airt(kl),zeff(lk)
 50      continue
c     ill=nlow(jk)
         ill = 1
         nnzp1 = nnz + 1
         call ioneqm(linc,zeff,alpha,xitp,xii2,nnzp1,nnz,ill,lpri)
         ilim2p = ilim2 + 1
         do 100 kl = ilim1,ilim2p
            lk = kl + jk - 1
            ll = kl - ilim1 + 1
            xii(lk) = xitp(ll)
 100     continue
 200  continue
c
      kkk = 0
      do 300 jk = 1,nel
         ilim1 = ni1(jk)
         ilim2 = ni2(jk)
         do 250 kl = ilim1,ilim2
            ll = kl + jk - 1
            xiin(kl) = xii(ll)
            xiip(kl) = xii(ll+1)
            do 220 kkl = 1,nlin(kl)
               kkk = kkk + 1
               xilp(kkk) = xiip(kl)
               xiln(kkk) = xiin(kl)
 220        continue
 250     continue
 300  continue
c
      lpri=lprisv
c
      return
99001 format (' ',2i4,10e12.4)
      end
      subroutine leqt2f(a,m,n,np,b,idgt,wkarea,ier,lpri)
c
      implicit real*8(a-h,o-z)
c
      real*8 a,ao,aoo,b,bo,d,wkarea
      integer idgt,ier,indx,jk,kl,lpri,m,n,np
c
c
      dimension a(np,np),b(np)
      dimension wkarea(1)
      dimension indx(100)
      dimension ao(100,100),bo(100),aoo(100,100)
c
c     np had better be 6
c
      do 100 jk = 1,n
         bo(jk) = b(jk)
         do 50 kl = 1,n
            if ( lpri.gt.2 ) write (6,99001) jk,kl,a(jk,kl)
            aoo(jk,kl) = a(jk,kl)
            ao(jk,kl) = a(jk,kl)
 50      continue
 100  continue
c
      npp=100
      call ludcmp(aoo,d,n,npp,indx)
      call lubksb(aoo,b,n,npp,indx)
      call mprove(ao,aoo,bo,b,n,npp,indx)
c
      return
99001 format (' ',' in leqt2f ',2i4,e12.4)
      end
      subroutine lescpe
c
c
c
c     this routine does the line work
c
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /radius/ delr,r,rl,rstp,rdel,radexp,rscale,rsave
      common /spectl/ fline(ncn)
      common /temp  / t,to
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /copak / opakc(ncn),opakco(ncn)
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /enerc / epi(ncn),dele(ncn),numcon
      common /lopak / oplin(nnnl),oplno(nnnl)
      common /he2bow/ fbow1,fbow2,bem304,be3003,bem374,be4651
      common /cdpth / dpthc(ncn)
      common /bdpth / dpthb(ncn)
      common /tau0ln/ tau0(nnnl)
      common /tau1ln/ tau1(nnnl)
      common /ffbbs / fbbs(nnnl)
      common /ffthrm/ ftherm(nnnl)
      common /ffesc / fesc(nnnl)
      common /ffescb/ fescb(nnnl)
      common /ffsplt/ fsplit(nnnl)
      common /ffcomp/ fcomp(nnnl)
      common /radp  / pradl,pradc,pradt
      common /ceemis/ ceem(nnnl)
      common /linsel/ nlsv(nnnl),nlsvn
      common /lindat/ elin(nnnl),blin(nnnl),
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &      flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
      common /rcemis/ rcem(nnnl)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
      dimension pbbs(nnnl),ptherm(nnnl),psplit(nnnl)
      dimension pcomp(nnnl),pesc(nnnl)
      dimension nikey(13)
      dimension pescb(nnnl)
      dimension aa(13)
c
      data ergsev/1.602197e-12/
      data ehh/6.6262e-27/,ccc/2.998e+10/
      data eclam/12398.54/
      data crit/1.e-20/
      data sigth/6.65e-25/
      data pp/0.47047/,a1/0.3480242/,a2/ - 0.0958798/,
     &     a3/0.7478556/
      data stwrt/2.5/
      data nikey/1,3,9,16,24,34,46,60,76,94,114,
     &     140,168/,nhalph/3/,nlalph/1/
      data aa/1.,4.,12.,14.,16.,20.,24.,28.,32.,36.,
     &     40.,56.,58./
      data sqpi/1.772/
      data n1304/244/,n2796/526/,n10830/22/
c
      if (lpri.ge.1) write (6,*)'in lescpe'
c
      econst = ergsev*eclam
      lprof = 0
      opcomp = xnx*sigth
      sqt = sqrt(t)
c
      lprisv=lpri
c      lpri=2
c
      if (lthin.eq.0) go to 1001
c
      do 100 jlk = 1,nlsvn
         j = nlsv(jlk)
         if ( (j.gt.0) .and. (j.le.nnnl) ) then
            pesc(j) = 1.0
            pescb(j) = 0.
            if (lnoinwd.eq.1) pesc(j)=1.e-10
            if (lnoinwd.eq.1) pescb(j)=1.
            psplit(j) = 0.
            ptherm(j) = xnx*sxlin(j)
c    $       /sqt
c    $       *(1.+stwrt*expo(-eclam/(0.8617*t*(elin(j)+crit))))
            pbbs(j) = 0.
            pcomp(j) = 0.
         endif
 100  continue
c
      go to 1050
c
 1001 continue
c
      if (lpri.gt.2) write (6,*)'in lescpe'
c
c
c     get continuous opacities.
      do 200 jlk = 1,nlsvn
         j = nlsv(jlk)
         jli = nilin(j)
         if ( (j.gt.0) .and. (j.le.nnnl) ) then
            if (lpri.gt.2) write (6,*)j,jli,nni,elin(j)
            if ( (jli.le.nni) .and. (jli.gt.0) ) then
               if ( lichk(jli).eq.1 ) then
                  ptherm(j) = xnx*sxlin(j)
c    $             *(1.+stwrt*expo(-eclam/(0.8617*t*(elin(j)+crit))))
c    $             /sqt
                  pesc(j) = 1.
                  pescb(j) = 0.
                  if (lnoinwd.eq.1) pesc(j)=1.e-10
                  if (lnoinwd.eq.1) pescb(j)=1.
                  pbbs(j) = 0.
c                 psplit(j)=cvmgp((1.-blin(j)),0.,(flin2(j)-crit))
                  psplit(j) = 0.
                  pcomp(j) = 0.
                  if ( flin2(j).gt.(0.01) ) then
                     oplc = opakc(nblin(j))
                     oplin(j) = amax1(oplin(j),(1.e-13)*(oplc+opcomp))
                     if ( lpri.gt.2 ) write (6,99001) j,elin(j),
     &                    nblin(j),oplin(j),oplc,opcomp
                     beta = (oplc+opcomp)/(oplc+opcomp+oplin(j))
                     gamma = sqrt(-1.772*alog(beta))
                     tt = 1./(1.+pp*gamma)
                     if ( lpri.gt.2 ) write (6,99002) j,elin(j),t,
     &                    sxlin(j)
                     pbbs(j) = ((beta*2.*gamma+beta**(+2.772)/(tt*(a1+tt
     &                         *(a2+tt*a3))))*oplc/(oplc+opcomp))
                     if ( lpri.gt.2 ) write (6,99003) j,elin(j),
     &                    beta,gamma,tt
                  endif
               endif
            endif
         endif
c        pcomp(j)=((beta*2.*gamma+beta**(+2.772)
c    $    /(tt*(a1+tt*(a2+tt*a3))))
c    $    *opcomp/(oplc+opcomp))
 200  continue
c
c
c     compute escape probability.
      sqpi = 1.772
      jll = 0
      jlk = 0
      nimxo = 0
      do 300 jl = 1,nel
         nimx = nikey(jl)
         nimax = nimx - nimxo
         nimxo = nimx
         aaj = aa(jl)
         do 250 kl = 1,nimax
            jll = jll + 1
            nlmax = nlin(jll)
            do 220 kkl = 1,nlmax
               jlk = jlk + 1
               pesc(jlk) = 1.
               if (lnoinwd.eq.1) pesc(jlk)=1.e-10
               if (lnoinwd.eq.1) pescb(jlk)=1.
               if ( lichk(jll).eq.1 ) then
                  j = nlsv(jlk)
                  if ( (j.gt.0) .and. (j.le.nnnl) ) then
                     if ( (elin(j).gt.0.1) .and. (elin(j).le.9.e+4) )
     &                    then
                        aaaa = 0.
                        if ( sxlin(j).gt.1.e-20 ) then
                           aaa = (8.626e-8)*cslin(j)/(sxlin(j)+1.e-34)
                           vtherm = 1.289e+06*sqt/(sqrt(aaj)+1.e-34)
                           delnud = vtherm/(elin(j)*1.e-8)
                           aaaa = aaa/(delnud*12.56+1.e-34)
                        endif
                        pesc(j) = pescc(tau0(j),aaaa)
                        if (lnoinwd.eq.1) pesc(j)=1.e-10
                        pescb(j) = pescc(tau1(j),aaaa)
                        if ( lpri.gt.2 ) write (6,99004) j,elin(j),
     &                       tau0(j),tau1(j),aaaa,pesc(j),
     &                       pescb(j)
                     endif
                  endif
               endif
 220        continue
 250     continue
 300  continue
      do 400 jk = 6,15
         if ( tau0(jk).ge.3.e+3 ) then
            pesc(jk) = 1./sqrt(4.e+4*(tau0(jk)+2.5e-5))
           if (lnoinwd.ne.1) pesc(jk)=pesc(jk)/2.
         endif
         if (lnoinwd.eq.1) pesc(jk)=1.e-10
         if ( tau1(jk).ge.3.e+3 ) then
            pescb(jk) = 1./sqrt(4.e+4*(tau1(jk)+2.2e-5))
           if (lnoinwd.ne.1) pescb(jk)=pescb(jk)/2.
         endif
 400  continue
      jstart = nlin(1) + nlin(2) + 6
      jend = jstart + 9
      do 500 jk = jstart,jend
         if ( tau0(jk).ge.3.e+3 ) then
            pesc(jk) = 1./sqrt(4.e+4*(tau0(jk)+2.5e-5))
            if (lnoinwd.ne.1) pesc(jk)=pesc(jk)/2.
         endif
         if (lnoinwd.eq.1) pesc(jk)=1.e-10
         if ( tau1(jk).ge.3.e+3 ) then
            pescb(jk) = 1./sqrt(4.e+4*(tau1(jk)+2.2e-5))
            if (lnoinwd.ne.1) pescb(jk)=pescb(jk)/2.
         endif
 500  continue
c
 1050 continue
c
c     compute fractions
      do 600 jlk = 1,nlsvn
         j = nlsv(jlk)
         if ( (j.gt.0) .and. (j.le.nnnl) ) then
            fescb(j) = pescb(j)
     &                 /(psplit(j)+pesc(j)+ptherm(j)+pbbs(j)+pcomp(j)
     &                 +pescb(j))
            fesc(j) = pesc(j)
     &                /(psplit(j)+pesc(j)+ptherm(j)+pbbs(j)+pcomp(j)
     &                +pescb(j))
            ftherm(j) = ptherm(j)
     &                  /(psplit(j)+pesc(j)+ptherm(j)+pbbs(j)+pcomp(j)
     &                  +pescb(j))
            fbbs(j) = pbbs(j)
     &                /(psplit(j)+pesc(j)+ptherm(j)+pbbs(j)+pcomp(j)
     &                +pescb(j))
            fcomp(j) = pcomp(j)
     &                 /(psplit(j)+pesc(j)+ptherm(j)+pbbs(j)+pcomp(j)
     &                 +pescb(j))
            fsplit(j) = psplit(j)
     &                  /(psplit(j)+pesc(j)+ptherm(j)+pbbs(j)+pcomp(j)
     &                  +pescb(j))
            if ( lpri.gt.2 ) write (6,99005) j,elin(j),pbbs(j),
     &                              pesc(j),pescb(j),ptherm(j),
     &                              psplit(j),pcomp(j)
         endif
 600  continue
c
c
         jend = nlin(1) + nlin(2) + nlin(3)
         do 650 j = 1,jend
            if ( (j.le.nlin(1)) .or. (j.ge.(nlin(2)+nlin(1))) ) then
               fesc(j) = pesc(j)*(1.-fbbs(j))
               fescb(j) = pescb(j)*(1.-fbbs(j))
               ftherm(j) = 0.
               fbbs(j) = 0.
               fcomp(j) = 0.
               fsplit(j) = 0.
               if (lpri.gt.2) write (6,*)'h, he II lines:',j,elin(j),
     $           pesc(j),fesc(j),pescb(j),fescb(j)
            endif
 650     continue
c
c         goto 800
c
c         do 700 jk = 1,nlsvn
c            j = nlsv(jk)
c            nb1 = nblin(j) + 1
c            tmpf = 5.*dpthc(nb1)**(0.75)
c            tmpb = 5.*dpthb(nb1)**(0.75)
c            fesc(j) = fesc(j)*expo(-tmpf)
c            fescb(j) = fescb(j)*expo(-tmpb)
c            if ( lpri.gt.2 ) write (6,99006) j,tmpf,tmpb,fesc(j),
c     &                              fescb(j)
c 700     continue
c
c
c
c
      lpri=lprisv
c
c
 800  return
99001 format (' ',' in lescpe ',i4,e12.4,i4,3e12.4)
99002 format (' ',' in lescpe',i4,3e12.4)
99003 format (' ',' in lescpe ',i4,3e12.4)
99004 format (' ',' in lescpe ',i4,6e12.4)
99005 format (' ',' in lescpe ',i4,7e12.4)
99006 format (' ',i4,4e12.4)
      end
      subroutine lopcmp
c
c
c
c     this routine computes line opacities.
c
c
c
      external bigdat,newdat,rr3,nfllns
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /abel  / xel(nl),xeln(nni),xelln(nnnl)
      common /abhe  / xihhe(3),xihheo(3)
      common /abion / xii(nnip),xiin(nni),xiip(nni),xiln(nnnl),
     &                xilp(nnnl),xiio(nnip)
      common /temp  / t,to
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /linsel/ nlsv(nnnl),nlsvn
      common /lindat/ elin(nnnl),blin(nnnl),
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &      flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
      common /lopak / oplin(nnnl),oplno(nnnl)
      common /abh   / xihh(11),xihho(11),bbrt(11),enrt(11)
      common /abo1  / xio1(4),xio1o(4)
      common /abhe2 / xihe(7),xiheo(7),bbrte(7),enrte(7)
      common /icc   / lichk(nni),lipin
c
      character*72 ktitle
c
      dimension aa(13),nikey(13)
c
      data aa/1.,4.,12.,14.,16.,20.,24.,28.,32.,36.,
     &     40.,56.,58./
      data nikey/1,3,9,16,24,34,46,60,76,94,114,
     &     140,168/
      data cc1/1.289e+06/,cc2/2.655e-02/
      data crit/1.e-08/
c
      if (lpri.ge.1) write (6,*)'in lopcmp'
c
      vtherm = cc1*sqrt(t)
      cc3 = cc2*1.e-8/(vtherm)
      cc3 = cc3/1.772
c
c     compute escape probability.
      sqpi = 1.772
      jll = 0
      jlk = 0
      nimxo = 0
      do 100 jl = 1,nel
         xeltp = xel(jl)
         nimx = nikey(jl)
         nimax = nimx - nimxo
         nimxo = nimx
         aaj = aa(jl)
         do 50 kl = 1,nimax
            jll = jll + 1
            xiltp = xiin(jll)
            nlmax = nlin(jll)
            do 20 kkl = 1,nlmax
               jlk = jlk + 1
               j = nlsv(jlk)
               oplin(j) = 0.
               if ( lichk(jll).eq.1 ) then
                  if ( (j.gt.0) .and. (j.le.nnnl) ) then
                     if ( (elin(j).gt.0.1) .and. (elin(j).le.9.e+4) )
     &                    then
                        oplin(j) = flin2(j)*cc3*elin(j)*sqrt(aaj)
     &                             *xiltp*xeltp*xpx
                     endif
                  endif
               endif
 20         continue
 50      continue
 100  continue
c
c
      ll = 0
      do 200 jk = 1,9
         jkp1 = jk + 1
         abund = xihh(jk)*xel(1)*xpx
         do 150 kl = jkp1,10
            if ((kl.eq.2).and.(jk.eq.1)) go to 150
            ll=ll+1
            oplin(ll) = 0.
            if ( lichk(1).eq.1 ) then
               oplin(ll) = flin2(ll)*cc3*elin(ll)*abund
            endif
 150     continue
 200  continue
c
      ll = nlin(1) + nlin(2)
      do 300 jk = 1,5
         jkp1 = jk + 1
         abund = xihe(jk)*xel(2)*xpx
         do 250 kl = jkp1,6
            ll = ll + 1
            oplin(ll) = 0.
            if ( lichk(3).eq.1 ) then
               oplin(ll) = flin2(ll)*cc3*elin(ll)*abund
            endif
 250     continue
 300  continue
c
c       return
c
      n10830 = 21
      n5876 = 22
      abund = xihhe(2)*xel(2)*xpx
      oplin(n10830) = flin2(n10830)*cc3*elin(n10830)*abund*(1.414)
      abund = xihhe(3)*xel(2)*xpx
      oplin(n5876) = flin2(n5876)*cc3*elin(n5876)*abund*(1.414)
c
      n8447 = 210
      n11287 = 211
      n1304 = 200
      n1027 = 197
      abund = xio1(1)*xel(5)*xpx
      oplin(n1027) = flin2(n1027)*cc3*elin(n1027)*abund*4.
      oplin(n1304) = flin2(n1304)*cc3*elin(n1304)*abund*4.
      abund = xio1(3)*xel(5)*xpx
      oplin(n11287) = flin2(n11287)*cc3*elin(n11287)*abund*4.
      abund = xio1(4)*xel(5)*xpx
      oplin(n8447) = flin2(n8447)*cc3*elin(n8447)*abund*4.
c
      return
c     write (6,9982)(xio1(ll),ll=1,4),xel(5),xpx,oplin(n11287),oplin(n84
99001 format (' ',' in lopcmp',8e12.4)
      end
      subroutine lubksb(a,b,n,np,indx)
c
      implicit real*8(a-h,o-z)
c
      real*8 a,b,sum
      integer i,ii,indx,j,ll,n,np
c
      dimension a(np,np),indx(n),b(n)
      ii = 0
      do 100 i = 1,n
         ll = indx(i)
         sum = b(ll)
         b(ll) = b(i)
         if ( ii.ne.0 ) then
            do 20 j = ii,i - 1
               sum = sum - a(i,j)*b(j)
 20         continue
         elseif ( sum.ne.0. ) then
            ii = i
         endif
         b(i) = sum
 100  continue
      do 200 i = n,1,-1
         sum = b(i)
         if ( i.lt.n ) then
            do 120 j = i + 1,n
               sum = sum - a(i,j)*b(j)
 120        continue
         endif
         b(i) = sum/a(i,i)
 200  continue
      return
      end
      subroutine ludcmp(a,d,n,np,indx)
c
      implicit real*8(a-h,o-z)
c
      real*8 a,aamax,d,dum,sum,tiny,vv
      integer i,imax,indx,j,k,n,nmax,np
c
      parameter (nmax=100,tiny=1.0e-20)
c
      dimension a(np,np),indx(n),vv(nmax)
c
      d = 1.
      do 100 i = 1,n
         aamax = 0.
         do 50 j = 1,n
            if ( abs(a(i,j)).gt.aamax ) aamax = abs(a(i,j))
 50      continue
         if ( aamax.eq.0. ) then
            aamax = 1.e-20
         endif
c       stop
         vv(i) = 1./aamax
 100  continue
      do 200 j = 1,n
         if ( j.gt.1 ) then
            do 120 i = 1,j - 1
               sum = a(i,j)
               if ( i.gt.1 ) then
                  do 105 k = 1,i - 1
                     sum = sum - a(i,k)*a(k,j)
 105              continue
                  a(i,j) = sum
               endif
 120        continue
         endif
         aamax = 0.
         do 150 i = j,n
            sum = a(i,j)
            if ( j.gt.1 ) then
               do 130 k = 1,j - 1
                  sum = sum - a(i,k)*a(k,j)
 130           continue
               a(i,j) = sum
            endif
            dum = vv(i)*abs(sum)
            if ( dum.ge.aamax ) then
               imax = i
               aamax = dum
            endif
 150     continue
         if ( j.ne.imax ) then
            do 160 k = 1,n
               dum = a(imax,k)
               a(imax,k) = a(j,k)
               a(j,k) = dum
 160        continue
            d = -d
            vv(imax) = vv(j)
         endif
         indx(j) = imax
         if ( j.ne.n ) then
            if ( a(j,j).eq.0. ) a(j,j) = tiny
            dum = 1./a(j,j)
            do 180 i = j + 1,n
               a(i,j) = a(i,j)*dum
 180        continue
         endif
 200  continue
      if ( a(n,n).eq.0. ) a(n,n) = tiny
      return
c         write (6,9901)i,j,a(i,j)
99001 format (' ',' in ludcmp ',2i4,e12.4)
c       write (6,9342
99002 format (' ','singular matrix.')
      end
      subroutine makatable
c
      integer*2 bperno,line,lone
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel,na,
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /mtpass/ tgran
      common /linsel/ nlsv(nnnl),nlsvn
      common /llumnb/elum(nnnl),oelum(nnnl)
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /sigh/ zeta
      common /nmrc/ numrec,nstart
      common /spectc/bremsa(ncn),brems(ncn),zrems(ncn),zremso(ncn),
     $   zremsz(ncn)
      common /enerc/epi(ncn),dele(ncn),numcon
      common /cemis/ rccems(ncn),cocems(ncn),dicems(ncn),brcems(ncn)
      common /rcemis/ rcem(nnnl)
      common /xcol  / xcc(183)
      common /lindat/
     $  elin(nnnl),blin(nnnl),sxlin(nnnl),eex(nnnl),
     $  cslin(nnnl),flin1(nnnl),flin2(nnnl),
     $  nblin(nnnl),nilin(nnnl),nlin(nni)
c
       dimension ztsv(200),xpsv(200),jkptr(200,200)
c
       character*72 ktitle
c

      logical ifl
c
c      from ian george
c Record Definitions for Binary File
c - Record 1 ............................................ Header record
	character*4  machine		! Machine type (`Sun' or `Vax')
	integer*4  check_i		! Check Integer = 123456
	real*4  check_r			! Check real = 1.23456e+07	
	integer*4  N	
c                    ! No. bytes per record = MAX(S*M+4*P,NP*4+42)
	integer*2  M			! No. bytes per spectral bin 
	integer*4  S			! No. spectral bins
	integer*4  P			! No. model parameters
	character*12 model_name		! Model name
	real*4  e_start		
c                   ! Start energy for tabulated model (keV)
	real*4  e_stop   		! End energy for tabulated model (keV)
	integer*4  H		
c                ! Additional header records (above P+2) in file
	logical*4  z_flag	
c                 ! Flag for including redshift as a parameter

c - Records 2 --> (P+1) ................................. Parameter records
c
        parameter (IP_max=1,NP_max=200)
c
	character*12 p_name(IP_max)	! Parameter name
	real*4  p_initial(IP_max)	! Initial value of the parameter
	real*4  p_minh(IP_max)		! Hard minimum of the parameter
	real*4  p_mins(IP_max)		! Soft minimum of the parameter
	real*4  p_maxs(IP_max)		! Soft maximum of the parameter
	real*4  p_maxh(IP_max)		! Hard maximum of the parameter
	real*4  p_delta(IP_max)		! Delta value of the parameter
	integer*2  NP(IP_max)		! Number of parameter values
	integer*2  Interp_mode(IP_max)	! Interpolation scheme (0=linear,1=log)
	real*4  p_val(IP_max,NP_max)	
c                   ! Array of parameter values for this parameter

c - Record (P+2) ..............................Model Spectral Energy record
c	Note: Any set of energy bins can be used and XSPEC will 
c	      interpolate the model spectra onto the appropriate 
c	      energy bins for the detectors in use.

c - Records (P+3) --> (P+2+H) ................... Free Records for the User

c - Records (P+3+H) --> (P+2+H+NP(1)*NP(2)*NP(3)...NP(P)) .................
c			............ Records containing the Grid of Spectra 
c 	Note: As with standard models, the spectra must be in terms of 
c		FLUX PER BIN    (not Flux per keV)
c	real*4  Gd_pt(Gd_max)	
c               ! Values of all parmeters at each grid point
c		! .... This is actually the same as the P_VAL array above
c	real*4  Flx(Gd_max) 		! Flux at each grid point
	
c Defaults for Binary File
	data machine/'SUN'/		!
	data check_i /123456/		!
	data check_r /1.23456e+07/	!
	data M /4/			! Necessary {XSPEC FIXED} at present
	data z_flag/.false./
c
c     read through the records and sort and find xi and column values
c
c      lpri=1
c
      rewind(30)
      nsv1=0
      nsv2=0
      epss=0.001
      if (lpri.gt.2)
     $  write (6,*)'in wrttab: numrec=',numrec
      do 101 jk=1,numrec
c
         call unsavo(30)
         xpxtp=alog10(amax1(xcc(183),1.e-34))
c         xpxtp=float(int(xpxtp+0.5))
c         zeta=float(int(zeta+0.5))
         if (lpri.gt.2)
     $    write (6,*)'sorting xi and N values',jk,zeta,xpxtp
c
c        file away the values
         ll=0
 103        ll=ll+1
            if (ll.gt.nsv1) go to 102
            if (abs(zeta-ztsv(ll)).lt.tgran) go to 104
            go to 103
 102     continue
         nsv1=nsv1+1
         ztsv(nsv1)=zeta
 104     continue
         ll1=ll
c
         ll=0
 203     ll=ll+1
            if (ll.gt.nsv2) go to 202
            if (abs(xpxtp-xpsv(ll)).lt.tgran) go to 204
            go to 203
 202     continue
         nsv2=nsv2+1
         xpsv(nsv2)=xpxtp
 204     continue
         ll2=ll
         ll2=1
         nsv2=1
         xpsv(nsv2)=xpxtp
c
         jkptr(ll1,ll2)=jk
c
 101     continue
c
       if (lpri.eq.0) go to 3096
       write (6,*)'nsv1=',nsv1
       write (6,9901)(ztsv(ll),ll=1,nsv1)
       write (6,*)'nsv2=',nsv2
       write (6,9901)(xpsv(ll),ll=1,nsv2)
3096   continue
c
c     sort the values
      lchng1=0
      ltry=0
      nsv1m=nsv1-1
      ltrymx=3*nsv1
 110     ltry=ltry+1
         do 111 ll=1,nsv1m
            if (ztsv(ll+1).gt.ztsv(ll)) go to 111
            lchng1=1
            zttmp=ztsv(ll+1)
            ztsv(ll+1)=ztsv(ll)
            ztsv(ll)=zttmp
            do 8111 ml=1,nsv2
               jktmp=jkptr(ll+1,ml)
               jkptr(ll+1,ml)=jkptr(ll,ml)
               jkptr(ll,ml)=jktmp
 8111          continue
 111        continue
         if ((ltry.le.ltrymx).and.(lchng1.ne.0)) go to 110
c
      lchng1=0
      ltry=0
      if (nsv2.le.1) go to 2118
      nsv2m=nsv2-1
      ltrymx=3*nsv2
 210     ltry=ltry+1
         do 211 ll=1,nsv2m
            if (xpsv(ll+1).gt.xpsv(ll)) go to 211
            lchng1=1
            xptmp=xpsv(ll+1)
            xpsv(ll+1)=xpsv(ll)
            xpsv(ll)=xptmp
            do 8211 ml=1,nsv1
               jktmp=jkptr(ml,ll+1)
               jkptr(ml,ll+1)=jkptr(ml,ll)
               jkptr(ml,ll)=jktmp
 8211          continue
 211        continue
         if ((ltry.le.ltrymx).and.(lchng1.ne.0)) go to 210
 2118    continue
c
       if (lpri.eq.0) go to 3097
       write (6,*)'nsv1=',nsv1
       write (6,9901)(ztsv(ll),ll=1,nsv1)
 9901 format (1h ,10e12.4)
       write (6,*)'nsv2=',nsv2
       write (6,9901)(xpsv(ll),ll=1,nsv2)
3097   continue
c
      rewind(30)  
c
c
      lun=54
      ist=nbinc(100.)
      ind=nbinc(4.e+4)
      is=ind-ist+1
      ip=1
      nxcol=0
      nzet=nsv1
      np1=nzet
      np2=nxcol
      m=4
      nbytes=max0(is*m+4*ip,np1*4+42,np2*4+42)
      nbytes2=nbytes
c     statement from ian george, corrects for decstation
c      nbytes2=nbytes/4
      open (54,file='atablexstar.out',form='unformatted',
     $     access='direct',recl=nbytes2,status='unknown')
c
c     write header record
      ichkk=123456
      ifl=.false.
      rchk=1.23456e+07
      istm=ist+1
      indm=ind+1
      emin=epi(istm)*1.e-3
      emax=epi(indm)*1.e-3
      ih=0
      bperno=4
      n=nbytes
      m=bperno
      s=is
      p=ip
      e_start=emin
      e_stop=emax
      h=ih
      z_flag=ifl
      model_name='slab test   '
      write (lun, rec=1) machine,check_i,check_r,n,m,s,p,model_name,
     :		e_start,e_stop,h,z_flag
c      write (6,*)'header parameters'
c      write (6,*) machine,check_i,check_r,n,m,s,p,model_name,
c     :		e_start,e_stop,h,z_flag
c
c     write out parameter record for ionization parameter
      zetamx=ztsv(nzet)
      zetamn=ztsv(1)
      zetai=(zetamx+zetamn)/2.
      delzt=(zetamx-zetamn)/float(nzet)
      xone=1.
      line=1
      lone=1
      lzero=0
c
c     write out parameter record for column density
      xone=1.
      line=1
      lone=1
c
c
c     set up for writing
      P=1
      p_name(1)='log(xi)    '
      p_initial(1)=zetai
      p_minh(1)=zetamn
      p_mins(1)=zetamn
      p_maxs(1)=zetamx
      p_maxh(1)=zetamx
      p_delta(1)=delzt
      np(1)=nzet
      interp_mode(1)=0
      do 1011 kl=1,nzet
 1011    p_val(1,kl)=ztsv(kl)
c
c ... Parameter Records
	do irec = 2, P+1
	   jj = irec-1
c	   write(*,*) '     rec  ', irec, ' parameter', jj
	   write(lun, rec=irec) p_name(jj),p_initial(jj),p_minh(jj),
     :		p_mins(jj), p_maxs(jj), p_maxh(jj), p_delta(jj),
     :		np(jj), interp_mode(jj), (p_val(jj,ii),ii=1,np(jj))
	enddo

c ... Energy Records
c
c     write out energies
      write (lun,rec=3) (epi(jj)/1000.,jj=istm,indm)
c
      jkl=0
      jk2=1
      do 1 jk1=1,nsv1
c
            jkl=jkl+1
            jk=jkptr(jk1,jk2)
c            write (6,*)'jk1,jk2,jk=',jk1,jk2,jk
            if (jk.le.0) go to 1
            rewind(30)
            do 3 jkk=1,jk
               call unsavo(30)
 3             continue
c
c
      lprii=0
c      if ((jk1.eq.nsv1).and.(jk2.eq.nsv2)) lprii=1
      do 4501 ll=1,nlsvn
        kk=ll
        nbbt=nblin(kk)
        if ((nbbt.eq.numcon).or.(nbbt.eq.1)) go to 4501
        delte=epi(nbbt+1)-epi(nbbt-1)
        rccems(nbbt)=rccems(nbbt)+rcem(kk)*epi(nbbt)/delte
        if (lprii.eq.1) 
     $    write (6,*)ll,elin(ll),
     $     nbbt,epi(nbbt),delte,rcem(kk),zrems(nbbt)
4501    continue
c     distance corresponds to 10 Kpc, including 10**38 scaling
c      dist=10.*(3.e+2)
c      fpr2=12.56*dist*dist
      do 4502 ml=1,numcon
         bremsa(ml)=rccems(ml)/xpx/xpx
4502     continue
c     renormalize to 2.4e-11 erg cm**-2 s**-1 over 2 - 10 KeV
      sum=0.
      epii=epi(1)
      do 4503 ml=1,numcon
         epiio=epii
         epii=epi(ml)
         if ((epii.lt.2000.).or.(epii.gt.10000.)) go to 4503
         sum=sum+(bremsa(ml)+bremsa(ml-1))*(epii-epiio)/2.
 4503    continue
      ergsev=1.602197e-12
      const=(2.4e-11)/sum/ergsev
      const=1.e+14
      nmcnm=numcon-1
      do 4505 ml=1,nmcnm
         delte=epi(ml+1)-epi(ml)
         bremsa(ml)=bremsa(ml)*const*delte/epi(ml)
c         bremsa(ml)=0.
c         if ((epi(ml).le.1100.).and.(epi(ml).ge.900.))
c     $        bremsa(ml)=1.
         if (lprii.eq.1) write (6,*)ml,epi(ml),zrems(ml),bremsa(ml)
 4505    continue
      
c
      xpxtp=alog10(amax1(xpx,1.e-34))
c
c     write out model fluxes
      if (lpri.gt.2) write (6,*)ztsv(jk1),xpsv(jk2),zeta,xpxtp
      write (lun,rec=3+jkl) 
     $    ztsv(jk1),(bremsa(jj),jj=ist,ind)
c
 2    continue
 1    continue
c
c
      return
      end
      subroutine makatablen
c
c
      parameter (ncn=5000,nnnl=3900,nnml=4100,nl=13,nni=168,nnip=nni+nl)
c
      common tp,xlum,enlum,ecut,vturb,lpri,lwri,llte,
     &   lfast,lcdd,lrc,lfix,lthin,lbcase,nel2,na2, 
     &   nnnl2,nni2,nnip2,lnoinwd,lffst,ktitle
      common /mtpass/ tgran
      common /lindat/ elin(nnnl),blin(nnnl), 
     &                sxlin(nnnl),eex(nnnl),cslin(nnnl),
     &      flin1(nnnl),flin2(nnnl),nblin(nnnl),nilin(nnnl),nlin(nni)
      common /nmrc/ numrec,nstart                                       
      common /radius/delr,r,rl,rmax,rdel,radexp,rscale,rsave
      common /epden /xee,xpx,xnx,xpxo,xnxo,xpxsave,colsave
      common /linsel/ nlsv(nnnl),nlsvn
      common /spctcb/ zremsb(ncn),zrmsbo(ncn),bremsb(ncn),
     &                brmsab(ncn)
      common /spectc/ bremsa(ncn),brems(ncn),zrems(ncn),
     &                zremso(ncn),zremsz(ncn)
      common /ethrsh/ eth(nni)