      subroutine func2a(jkk,kl,ilimh,lpriz,lun11,lfpi,vturbi,
     $       t,trad,r,xee,xpx,xh1,xh0,
     $       epi,ncn2,bremsa,bremsint,
     $       idat1,rdat1,kdat1,nptrs,np2,
     $       npar,npnxt,npfi,npfirst,
     $       nplin,nplini,nlsvn,npcon,npconi,npilev,npilevi,
     $       npconi2,ncsvn,rates,vsav,idrates,
     $       rlev,ilev,
     $          nlpt,iltp,nlev,klev,ajis,cjis,ipmat,ipsv)
c
c     this routine calculates rates affecting level populations
c     author: T. Kallman
c
      implicit none
c
      include './PARAM'
c
      integer nptmpdim
      parameter (nptmpdim=200000)
c
c     master data
c     global xstar data
c     master data
      integer idat1(nidat1)
      real rdat1(nrdat1)
      integer nptrs(nptt,ndat2)
      character*1 kdat1(nkdat1)
c     pointers to master data
      integer npar(ndat2),npnxt(ndat2),
     $      npfirst(ntyp)
      integer npfi(ntyp,nni)
c     pointers to line data
      integer nplin(nnnl),nplini(ndat2)
c     pointers to line data
      integer npcon(nnml),npconi2(ndat2),npconi(ndat2)
      integer npilev(nd,nni),npilevi(nnml)
c     energy bins
      real epi(ncn)
c     continuum flux
      real bremsa(ncn),bremsint(ncn)
c     continuum emissivities
      real rccemis(2,ncn)
      real fline(ncn),flinel(ncn)
c     continuum opacities
      real opakc(ncn),opakscatt(ncn)
c     element abundances
c     the saved rates
      real rates(4,ndat2)
      integer idrates(2,ndat2)
      real vsav(4,ndat2)
c     state variables
      real r,t,xpx
c     heating-cooling variables
c     input parameters
      real trad
      real vturbi,xee
      integer ncn2,lpri,lun11,lfpi,np2
      integer nlsvn,ncsvn
      real rlev(10,nd)
      integer ilev(10,nd),nlpt(nd),iltp(nd)
      character*1 kdat(nptmpdim),klev(100,nd)
      character*48 kdesc2
      real rdat(nptmpdim)
      integer idat(nptmpdim)
      real tsq,ans1,ans2,xh1,xh0
      real abund1,abund2,ptmp1,ptmp2,ans3,ans4,opakb1
      integer idest1,idest2,idest3,idest4
c     continuum optical depths
      integer ipsv(31)
c
      character*1 kblnk
c
      real ajis(nds,nds),cjis(nds,nds)
      integer mltype,ml,mllz,nlev,ipmat,
     $  ltyp,lrtyp,lcon,nrdt,nidt,nkdt,mlrdesc,llo,lup,
     $  lforce,jkk,lpriu,kl,ilimh,lpriz,mlm
      integer jkk2,idesti,jkinit,iptmp,jktmp,mn,mmn,mlpar
c
      data kblnk/' '/
c
c      if (lpri.ne.0)
c     $  write (lun11,*)'in func2a, inputs:',t,
c     $         xee,xpx,xnx
c      if (lpri.ne.0) write (lun11,*)'in func2a:',ndo,ipsv
c

      mltype=1
      ml=npfi(mltype,jkk)
      if (ml.le.0) return
      mllz=npar(ml)
      mlm=mllz-1
      call dread(ltyp,lrtyp,lcon,
     $   nrdt,rdat,nidt,idat,nkdt,kdat,mlm,
     $   idat1,rdat1,kdat1,nptrs,0,lun11)
      jkk2=idat(nidt)
      lpri=lpriz
      tsq=sqrt(t)
      if (kl.gt.0) then
        jkinit=jkk-kl+1
        do jktmp=jkinit,jkk-2
          iptmp=ipsv(kl-(jkk-jktmp))
c          if (lpri.ne.0) write (lun11,*)'iptmp=',jktmp,jkk,kl,iptmp
          if (iptmp.ge.0) then
            ml=npfi(mltype,jktmp)
            mlrdesc=mltype
            if (ml.ne.0) then
              mllz=npar(ml)
              mlpar=npar(ml)
c             step thru records of this type
              do while ((ml.ne.0).and.(mlpar.eq.mllz))
                if (nptrs(3,ml).eq.mlrdesc) then
                  mlm=ml-1
                  call dread(ltyp,lrtyp,lcon,
     $              nrdt,rdat,nidt,idat,nkdt,kdat,mlm,
     $              idat1,rdat1,kdat1,nptrs,0,lun11)
c                 this is a cheat.  should creat new rate type
c                       for Auger, and one for total pi rate.
                  idesti=idat(nidt-2)
                  if ((nidt.ge.5).and.(ltyp.ne.53)
     $                .and.(idesti.eq.jkk2)) then
c                     calculate rates
                      lpriu=lpri
                      lforce=1
                      abund1=0.
                      abund2=0.
                      ptmp1=0.
                      ptmp2=0.
                      call ucalc(ltyp,lrtyp,ml,lcon,jkk,vturbi,
     $                  nrdt,rdat,nidt,idat,nkdt,kdat,ans1,ans2,
     $                  ans3,ans4,idest1,idest2,idest3,idest4,
     $                  abund1,abund2,ptmp1,ptmp2,xpx,opakb1,
     $                  opakc,opakscatt,rccemis,fline,lpriu,kdesc2,
     $                  r,t,trad,tsq,xee,xh1,xh0,
     $                  epi,ncn2,bremsa,bremsint,
     $                  rlev,ilev,nlpt,iltp,nlev,klev,lfpi,lun11,
     $                  idat1,rdat1,kdat1,nptrs,np2,
     $                  npar,npnxt,npfi,npfirst,
     $                  nplin,nplini,nlsvn,npcon,npconi,npilev,npilevi,
     $                  npconi2,ncsvn,rates,vsav,idrates,lforce)
                      llo=idest1+iptmp
                      lup=idest2+ipmat
                      if (kl.eq.ilimh) lup=min(nlev+ipmat,lup)
c                     this is a cheat because I may have erred in the indexing
                      idest3=max(1,idat(nidt-3)-1)
                      if ((idest3.ge.1).and.
     $                  (llo.ne.0).and.(llo.le.nd).and.
     $                  (lup.ne.0).and.(lup.le.nd)) then
c                       ajis(llo,lup)=ajis(llo,lup)+airtmp*ptmp
                        ajis(llo,llo)=ajis(llo,llo)-ans1
c                       ajis(lup,lup)=ajis(lup,lup)-airtmp*ptmp
                        ajis(lup,llo)=ajis(lup,llo)+ans1
                        cjis(llo,lup)=cjis(llo,lup)-ans3*xpx
                        if (lpri.ge.1) then
                          do mn=nkdt+1,20
                            kdat(mn)=kblnk
                            enddo
                          write (lun11,9001)jkk,lrtyp,ltyp,idest1,
     $                    idest2,llo,lup,ml,ans1,ans2,ajis(llo,lup),
     $                    ajis(lup,llo),ajis(llo,llo),ajis(lup,lup),
     $                    (kdat(mmn),mmn=1,20)
 9001                     format (1x,8i6,' auger',6(1pe10.3),20a1)
                          endif
                        endif
                      endif
                  ml=npnxt(ml)
                  if (ml.ne.0) mlpar=npar(ml)
                  endif
                enddo
              endif
            endif
          enddo
        endif
c        if (lpri.ne.0)
c     $            write (lun11,*)'rrrtt=',rrrtot,rrrtot2
c
      return
      end
