module broadm
   ! Module to provide broadr for NJOY2016
   use locale
   implicit none
   private
   public broadr

   ! global variables for broadr
   integer::nunr,intunr,nsig0,ncyc
   real(kr)::e1,eumax
   real(kr)::alpha,tempk,tempef,errthn,errmax,errint,thnmax
   integer::klow,khigh,mlow,mhigh,nlow,nhigh,n2in,&
     n2out,n2left,mpage,nreac,ntx
   real(kr)::f(5),aa,x,y,oy,xx,yy ! variables for funk
   real(kr)::h(5),alast,s1,s2 ! variables for hunk

   integer,parameter::ntt=160
   integer,parameter::nbuf=1000
   real(kr),dimension(ntt)::qmtr,emtr

contains

   subroutine broadr
   !-------------------------------------------------------------------
   !
   ! Doppler broaden and thin neutron point cross sections
   !
   ! A modified version of the kernel broadening method developed
   ! for SIGMA1 (D.E.Cullen, LLNL) is used.  Cross sections for low
   ! threshold reactions are unionized on the grid of the total
   ! cross section, then broadened and thinned in parallel.
   ! High threshold reactions are not broadened.  the total and
   ! nonelastic are reconstructed to equal the sum of parts.
   !
   ! The output energy grid for broadened cross sections is
   ! constructed adaptively (as in reconr) so that the results
   ! represent the true function within the given tolerance.
   ! Energy values are either removed from the original grid, or
   ! new values are added between the original points.  Thus, a
   ! given energy range can have more or fewer points than the
   ! original energy grid.
   !
   ! For high temperatures and low energies where the original
   ! SIGMA1 breaks down, a new direct expansion of the Doppler
   ! integral is used.
   !
   ! If the temperature is close to 293.6 K (.0253 eV), broadr
   ! computes and displays thermal cross sections, Maxwellian
   ! integrals (one-group thermal cross sections), g-factors,
   ! integral ratios (eta, alpha), the K1 integral and the
   ! corresponding 1/v-equivalent, and resonance integrals.
   !
   ! The results are written out in pendf format with each
   ! temperature represented as a different MAT.  Dictionaries
   ! are corrected to reflect the effects of thinning.
   !
   !---input specifications (free format)---------------------------
   !
   ! card 1
   !    nendf    input endf tape (for thermal nubar only)
   !    nin      input pendf tape
   !    nout     output pendf tape
   ! card 2
   !    mat1     material to broadened and thinned
   !    ntemp2   number of final temperatures (default=1)
   !    istart   restart (0 no, 1 yes, default 0)
   !    istrap   bootstrap (0 no, 1 yes, default 0
   !    temp1    starting temperature from nin (default=0K)
   ! card 3
   !    errthn   fractional tolerance for thinning
   !    thnmax   max.energy for broadening and thinning
   !             (default = 0, but see comments below)
   !    errmax   fractional tolerance used when integral criterion
   !             is satisfied (same usage as in reconr)
   !             (errmax.ge.errthn, default=10*errthn)
   !    errint   parameter to control integral thinning
   !             (usage as in reconr) (default=errthn/20000)
   !             set very small to turn off integral thinning.
   !      (A good choice for the convergence parameters
   !       errthn, errmax, and errint is the same set of
   !       values used in reconr)
   ! card 4
   !    temp2    final temperatures (deg Kelvin)
   ! card 5
   !    mat1     next MAT number to be processed with these
   !             parameters.  Terminate with mat1=0.
   !
   !---input options------------------------------------------------
   !
   ! The output tape will contain the ntemp2 final temperatures
   ! specified.  It is necessary to have temp1.le.temp2(1).
   ! if temp2.eq.temp1, the data will be thinned only.
   !
   ! restart    Continue broadening an existing pendf tape.  All
   !            temperatures are copied through temp1.  Additional
   !            final temperatures are added by starting with the
   !            data at temp1.
   !
   ! bootstrap  If bootstrap is not requested, each final tempera-
   !            ture is generated by broadening directly from
   !            temp1 to temp2.  If bootstrap is requested, each
   !            final temperature is broadened from the preceding
   !            temperature.  This option is faster due to the
   !            thinning in the previous step.  However, errors
   !            accumulate.
   !
   ! thnmax     A possible upper limit for broadening and thinning.
   !            Beginning with NJOY2012.75, if the default thnmax
   !            value is used (default thnmax = 0):
   !            - (i) and there is a resolved resonance region we
   !              Doppler broaden to the top of that region.  any
   !              threshold reactions below this upper limit are also
   !              broadened, but any non-zero cross section for energies
   !              below the reaction threshold are zeroed.
   !            - (ii) and there is no resolved resonance region but
   !              there is an unresolved resonance region we Doppler
   !              broaden to the beginning of the urr.
   !            - (iii) and there are no resolved or unresolved
   !              resonance parameters, we broaden to the lessor of
   !              6.5 MeV or the first threshold energy.
   !
   !            As before, a negative value for thnmax forces the
   !            Doppler broadening upper limit to be abs(thnmax)
   !            irrespective of the other conditions.
   !
   !            Caution:  The magnitude of thnmax must be chosen to
   !            keep the number of broadenable reactions less than or
   !            equal to the maximum of ntt (160).
   !
   !-------------------------------------------------------------------
   use mainio  ! provides nsysi,nsyso,nsyse
   use util    ! provides openz,timer,error,mess,repoz,closz,loada,finda
   use endf    ! provides endf routines and variables
   use physics ! provides bk,pi
   ! internals
   integer::nwscr,nscr1,iold,inew,nendf,nin,nout,no
   integer::namax,istart,istrap,nb,nw,lnu,nwt,i,l1,iflag
   integer::mat1,ntemp2,idis,idnx,mt4br,kt,k,isave,it
   integer::ndim,nset,j,nxc,mf,mt,jjj,nwunr,nx,ncds
   integer::mt4i,llf,llc,ir,ip,ireac,nbo,nwo,nnn,j1
   integer::mt103,mt104,mt105,mt106,mt107,mpmin,mpmax
   integer::mdmin,mdmax,mtmin,mtmax,m3min,m3max,m4min,m4max
   integer::lrf,lrp,lru
   integer::loop
   integer::n,npp,itmp
   real(kr)::time,temp1,diff,test,thnmx,emin,temp,awr,enext
   real(kr)::sig,en,sun,tempin,break,enow,eone,tev,picon
   real(kr)::fint,cint,alint,etint,v1int,ssf,slf,ssc,slc
   real(kr)::elast,flast,fnul,sf,sc,ss,fnu,xnext,eresh
   real(kr)::ftev,ctev,fnow,ee
   real(kr)::tt(ntt+1)
   real(kr)::emax
   integer::mtr(ntt),mti(ntt)
   integer,dimension(:),allocatable::nppmt
   real(kr),dimension(:),allocatable::bufo,bufn
   real(kr),dimension(:),allocatable::scr
   real(kr),dimension(:),allocatable::nutot
   real(kr),dimension(:),allocatable::unr
   real(kr),dimension(:),allocatable::b
   real(kr),dimension(:),allocatable::e
   real(kr),dimension(:),allocatable::temp2
   real(kr),dimension(:,:),allocatable::s
   real(kr),parameter::therm=.0253e0_kr
   real(kr),parameter::fact=.99999e0_kr
   real(kr),parameter::onemev=1.e6_kr
   real(kr),parameter::e6pt5=6.5e6_kr
   real(kr),parameter::tbreak=0.5e0_kr
   real(kr),parameter::big=9.e9_kr
   real(kr),parameter::step=1.01e0_kr
   real(kr),parameter::zero=0

   namax=15000000
   nwscr=2500
   nunr=0

   !--initialize and assign i/o units.
   nscr1=10
   iold=12
   inew=13
   call openz(-iold,1)
   call openz(-inew,1)

   !--read and display user input.
   call timer(time)
   write(nsyso,'(/&
     &'' broadr...doppler broadening of endf data'',&
     &28x,f8.1,''s'')') time
   write(nsyse,'(/'' broadr...'',59x,f8.1,''s'')') time
   read(nsysi,*) nendf,nin,nout
   if (nin.lt.0.and.nout.gt.0)&
      call error('broadr','nin and nout must be same mode.',' ')
   if (nin.gt.0.and.nout.lt.0)&
      call error('broadr','nin and nout must be same mode.',' ')
   if (nin.lt.0.and.nout.le.0) nscr1=-nscr1
   call openz(nin,0)
   call openz(nendf,0)
   call openz(nout,1)
   call openz(nscr1,1)
   istart=0
   istrap=0
   temp1=0
   ntemp2=1
   read(nsysi,*) mat1,ntemp2,istart,istrap,temp1
   thnmx=e6pt5
   errmax=0
   errint=0
   read(nsysi,*) errthn,thnmx,errmax,errint
   if (errmax.eq.zero) errmax=10*errthn
   if (errint.eq.zero) errint=errthn/20000
   allocate(temp2(ntemp2))
   read(nsysi,*) (temp2(i),i=1,ntemp2)
   thnmx=sigfig(thnmx,7,0)
   write(nsyso,'(/&
     &'' unit for input endf tape ............. '',i10/&
     &'' unit for input pendf tape ............ '',i10/&
     &'' unit for output pendf tape ........... '',i10/&
     &'' material to be processed ............. '',i10/&
     &'' number of final temperatures ......... '',i10/&
     &'' restart (0 no, 1 yes) ................ '',i10/&
     &'' bootstrap (0 no, 1 yes) .............. '',i10/&
     &'' starting material temperature ........ '',f10.1,''k''/&
     &'' thinning tolerance ................... '',f10.3/&
     &'' max. energy .......................... '',1p,e10.3/&
     &'' errmax for thinning .................. '',1p,e10.3/&
     &'' errint for thinning .................. '',1p,e10.3)')&
     nendf,nin,nout,mat1,ntemp2,istart,istrap,&
     temp1,errthn,thnmx,errmax,errint
   write(nsyso,'(&
     &'' final temperatures ................... '',1p,e10.3/&
     &(40x,e10.3))') (temp2(i),i=1,ntemp2)

   !--allocate storage.
   allocate(scr(nwscr))
   allocate(bufo(nbuf))
   allocate(bufn(nbuf))

   loop=0
  110 continue
   !--search input endf tape for some parameters ...
   !  - maximum file energy, emax.
   !  - total nu-bar (mf1/mt452).
   !  - resonance flag, lru (from mf2/mt151).
   call repoz(nendf)
   call tpidio(nendf,0,0,scr,nb,nw)
   call findf(mat1,1,0,nendf)
   !--read input file emax and make sure thnmx is legal
   emax=20.e6_kr !assumed maximum energy
   call contio(nendf,0,0,scr,nb,nw) !first record
   lrp=l1h
   call contio(nendf,0,0,scr,nb,nw) !second record
   if (n1h.eq.0.and.n2h.ne.0) then
      call contio(nendf,0,0,scr,nb,nw)
      if (c2h.gt.zero) emax=c2h
   endif
   if (abs(thnmx).gt.emax) then
       thnmx=0.9999_kr*emax
       call mess('broadr','reset thnmx to just less than input file''s emax','')
   endif
   !--jump to the end of mf1/mt451
   call tosend(nendf,0,0,scr)
   !--read input file nu-bar, if present
   lnu=0
  101 continue
   call contio(nendf,0,0,scr,nb,nw)
   if (mfh.ne.1) go to 107
   if (mth.ne.452) go to 106
   lnu=l2h
   if (lnu.eq.2) go to 103
   call listio(nendf,0,0,scr,nb,nw)
   nw=6+n1h
   allocate(nutot(nw))
   do i=1,nw
      nutot(i)=scr(i)
   enddo
   go to 107
  103 continue
   call tab1io(nendf,0,0,scr,nb,nw)
   nwt=6+2*n1h+2*n2h
   allocate(nutot(nwt))
   l1=1
  104 continue
   do i=1,nw
      nutot(l1+i-1)=scr(i)
   enddo
   if (nb.eq.0) go to 107
   l1=l1+nw
   call moreio(nendf,0,0,nutot(l1),nb,nw)
   go to 104
  106 continue
   call tosend(nendf,0,0,scr)
   go to 101
  107 continue
   !--read the (lru) resonance flag
   lrf=0
   npp=0
   if (lrp.eq.0) then
      lru=0
   else
      if (mfh.le.1) then
         if (mfh.eq. 1) call tofend(nendf,0,0,scr)
         call contio(nendf,0,0,scr,nb,nw)
      endif
      if (mfh.eq.2) then
         call contio(nendf,0,0,scr,nb,nw)
         call contio(nendf,0,0,scr,nb,nw)
         lru=l1h
         lrf=l2h
         !--make a list of the lrf7 mt's
         if (lru.eq.1.and.lrf.eq.7) then
            call contio(nendf,0,0,scr,nb,nw)
            call listio(nendf,0,0,scr,nb,nw)
            npp=l1h
            if (allocated(nppmt)) deallocate(nppmt)
            allocate(nppmt(npp))
            do i=1,npp
               nppmt(i)=nint(scr(16+12*(i-1)))
            enddo
            !--sort the nppmt list into ascending order
            if (npp.ge.2) then
               do i=1,npp-1
                  do j=i+1,npp
                     if (nppmt(j).lt.nppmt(i)) then
                        itmp=nppmt(i)
                        nppmt(i)=nppmt(j)
                        nppmt(j)=itmp
                     endif
                  enddo
               enddo
            endif
         endif
      endif
   endif

   !--search for desired mat1 at temp1 on input tape.
   !--if restart is requested, copy all t.le.temp1 to output tape.
   if (loop.eq.0) then
      nsh=0
      call repoz(nin)
      call repoz(nout)
      call tpidio(nin,nout,0,scr,nb,nw)
   endif
  115 continue
   call contio(nin,0,0,scr,nb,nw)
   if (math.eq.-1) go to 120
   if (math.eq.mat1) go to 130
   call tomend(nin,0,0,scr)
   go to 115
  120 continue
   call mess('broadr','desired mat and temp not on tape',' ')
   go to 400
  130 continue
   no=0
   nsc=0
   thnmax=thnmx
   eresh=thnmax
   emin=1
   if (thnmax.lt.zero) emin=-thnmax
   call repoz(nscr1)
   if (istart.eq.1) no=nout
   call contio(0,no,nscr1,scr,nb,nw)
   nx=n2h
   call contio(nin,0,0,scr,nb,nw)
   if (n1h.ne.0) then
      iverf=4
   else if (n2h.eq.0) then
      iverf=5
   else
      iverf=6
   endif
   write(nsyso,'(/'' files are in endf-'',i1,'' format'')') iverf
   call skiprz(nin,-1)
   if (iverf.ge.5) call contio(nin,no,nscr1,scr,nb,nw)
   if (iverf.ge.6) call contio(nin,no,nscr1,scr,nb,nw)
   call hdatio(nin,no,nscr1,scr,nb,nw)
   temp=scr(1)
   if (iverf.ne.4) nx=n2h
   if (no.ne.0) write(nsyso,'(/&
     &'' output '',1p,e12.4,''k from restart'')') temp
   do while (nb.ne.0)
      call moreio(nin,no,nscr1,scr,nb,nw)
   enddo
   call dictio(nin,no,nscr1,scr,nb,nx)
   nwunr=1
   do i=1,nx,6
      mf=nint(scr(i+2))
      mt=nint(scr(i+3))
      ncds=nint(scr(i+4))
      if (mf.eq.2.and.mt.eq.152) then
         nwunr=6*ncds
      endif
   enddo
   call tofend(nin,no,nscr1,scr)
   if (allocated(unr)) deallocate(unr)
   allocate(unr(nwunr))
   call contio(nin,no,nscr1,scr,nb,nw)
   if (mfh.eq.2) then
      call contio(nin,no,nscr1,scr,nb,nw)
      call contio(nin,no,nscr1,scr,nb,nw)
      eresh=c2h
      call tosend(nin,no,nscr1,scr)
      call contio(nin,no,nscr1,scr,nb,nw)
      if (mfh.ne.0) then
         if (mth.eq.152) call stounx(nin,no,nscr1,unr,thnmax)
         call tofend(nin,no,nscr1,scr)
      endif
      call contio(nin,no,nscr1,scr,nb,nw)
   endif
   call tomend(nin,no,nscr1,scr)
   diff=abs(temp-temp1)
   test=1+temp1/1000
   if (diff.gt.test) go to 115

   if (lrp.eq.0) then
      write(nsyso,'(/'' non-resonance nuclide, input pendf limit'',5x,&
                   &''= '',1pe14.5,'' eV.'')')eresh
   elseif (lrp.eq.1.and.lru.eq.1) then
      write(nsyso,'(/'' resolved resonance range upper limit'',9x,&
                   &''= '',1pe14.5,'' eV.'')')eresh
   elseif (lrp.eq.1.and.lru.eq.2) then
      write(nsyso,'(/'' unresolved resonance range lower limit'',7x,&
                   &''= '',1pe14.5,'' eV.'')')eresh
   endif
   if (eresh.gt.e6pt5) then
      eresh=e6pt5
      write(nsyso,'('' - reset to '',1pe14.5,'' eV.'')')e6pt5
   endif
   if (thnmx.eq.0) then
      thnmax=eresh
   elseif (thnmx.gt.0) then
      thnmax=min(thnmx,eresh)
   endif
   if (lrp.eq.1) emin=eresh

   !--copy low threshold reactions from nscr1 to
   !--scratch storage using the grid of mt1.
   call repoz(nscr1)
   call tofend(nscr1,0,0,scr)
   call contio(nscr1,0,0,scr,nb,nw)
   call contio(nscr1,0,0,scr,nb,nw)
   call contio(nscr1,0,0,scr,nb,nw)
   if (c2h.lt.thnmax) thnmax=c2h
   call tofend(nscr1,0,0,scr)
   call contio(nscr1,0,0,scr,nb,nw)
   awr=c2h
   enow=0
   call gety1(enow,enext,idis,sig,nscr1,scr)
   nreac=0
   ntx=1
   n2in=0
   idnx=0
   mt4br=0
   mt103=0
   mt104=0
   mt105=0
   mt106=0
   mt107=0
   if (iverf.ge.6) then
       mpmin=600
       mpmax=649
       mdmin=650
       mdmax=699
       mtmin=700
       mtmax=749
       m3min=750
       m3max=799
       m4min=800
       m4max=849
   else
       mpmin=700
       mpmax=718
       mdmin=720
       mdmax=738
       mtmin=740
       mtmax=758
       m3min=760
       m3max=768
       m4min=780
       m4max=798
   endif
   enow=enext
   do while (enext.lt.big)
      n2in=n2in+1
      if (idnx.gt.0.and.enext*fact.gt.enow) enext=enext*fact
      enow=enext
      call gety1(enow,enext,idis,sig,nscr1,scr)
      call getunx(mth,enow,en,sun,unr)
      if (en.gt.zero) sig=sig-sun
      tt(1)=enow
      kt=n2in
      if (enext.ge.big) kt=-kt
      call loada(kt,tt,ntx,iold,bufo,nbuf)
      if (idis.gt.0) idnx=1-idnx
      if (idis.eq.0) idnx=0
   enddo
   call tosend(nscr1,0,0,scr)
   n=1
  160 continue
   call contio(nscr1,0,0,scr,nb,nw)
   if (mfh.eq.0) go to 190
   if (iverf.lt.6) then
      if (mth.gt.150) go to 165
   else
      if (mth.gt.200.and.mth.lt.600) go to 165
      if (mth.gt.850) go to 165
   endif
   if (mth.eq.3) go to 165
   if (mth.eq.4) go to 165
   if (mth.ge.46.and.mth.le.49) go to 165
   if (mth.eq.19) go to 165
   enow=0
   call gety1(enow,enext,idis,sig,nscr1,scr)
   if (mth.eq.18) go to 170
   if (allocated(nppmt)) then
      if (n.le.npp) then
        if(mth.eq.nppmt(n)) then
           n=n+1
           go to 170
        endif
      endif
   endif
   if (enext.le.emin) go to 170
   if (lrp.eq.1.and.enext.lt.eresh) go to 170
   if (lrp.eq.0) then
      if (fact*enext.lt.thnmax) thnmax=fact*enext
   endif
  165 continue
   call tosend(nscr1,0,0,scr)
   go to 160
  170 continue
   nreac=nreac+1
   if (nreac.ge.ntt)&
      call error('broadr','too many low-threshold reactions.',' ')
   ntx=nreac+1
   mtr(nreac)=mth
   if (mth.ge.51.and.mth.le.91) mt4br=1
   if (mth.eq.103) mt103=1
   if (mth.eq.104) mt104=1
   if (mth.eq.105) mt105=1
   if (mth.eq.106) mt106=1
   if (mth.eq.107) mt107=1
   mti(nreac)=0
   kt=1
   k=0
   do while (kt.gt.0)
      k=k+1
      call finda(k,tt,nreac,iold,bufo,nbuf)
      enow=tt(1)
      call gety1(enow,enext,idis,sig,nscr1,scr)
      call getunx(mth,enow,en,sun,unr)
      if (en.gt.zero) sig=sig-sun
      tt(1+nreac)=sig
      kt=k
      if (k.eq.n2in) kt=-k
      call loada(kt,tt,ntx,inew,bufn,nbuf)
   enddo
   call tosend(nscr1,0,0,scr)
   isave=iold
   iold=inew
   inew=isave
   go to 160
  190 continue
   if (thnmax.eq.zero.and.thnmx.eq.0) thnmax=e6pt5
   if (allocated(nppmt)) deallocate(nppmt)
   if (thnmax.lt.zero) thnmax=-thnmax
   write(nsyso,'(/&
     &'' final maximum energy for broadening/thinning = '',1pe14.5,&
     &'' eV'')')thnmax
   tempin=temp1
   if (nreac.gt.0) go to 200
   call mess('broadr','no broadenable reactions',' ')
   it=0
  195 continue
   it=it+1
   tempk=temp2(it)
   write(nsyso,'('' copied mat'',i4,'' from'',1p,e12.4,&
     &'' to'',e12.4,'' k'')') mat1,tempin,tempk
   go to 215

   !--assign storage for paging cross sections.
  200 continue
   nw=npage+50
   allocate(b(nw))
   mpage=namax/(4*(nreac+1))
   ndim=3*mpage
   allocate(e(ndim))
   allocate(s(nreac,ndim))

   !--get q-values and lab system threshold energy
   !  for the mt's to be broadened.
   call repoz(nscr1)
   do i=1,nreac
      call findf(mat1,3,mtr(i),nscr1)
      call contio(nscr1,0,0,scr,nb,nw)
      call contio(nscr1,0,0,scr,nb,nw)
      qmtr(i)=scr(2)
      if (qmtr(i).eq.0) then
         emtr(i)=0
      else
         emtr(i)=-qmtr(i)*(awr+1)/awr
      endif
   enddo

   !--doppler broaden and thin these reactions.
   it=0
   tempin=temp1
  210 continue
   it=it+1
   tempk=temp2(it)
   tempef=tempk-tempin
   if (tempef.gt.zero) alpha=awr/(bk*tempef)
   call timer(time)
   write(nsyso,'(69x,f8.1,''s'')') time
   break=9999
   if (ntemp2.gt.1.and.tempk.lt.break) then
      write(nsyse,'(f11.1,'' deg'',54x,f8.1,''s'')') tempk,time
   else if (ntemp2.gt.1) then
      write(nsyse,'(1p,e11.3,'' deg ('',e9.3,'' eV)'',39x,&
        &0p,f8.1,''s'')') tempk,bk*tempk,time
   endif
   call bfile3(iold,inew,bufo,bufn,e,s,nreac)
   write(nsyso,'(/'' broadened mat'',i4,'' from'',1p,e12.4,&
     &'' to'',e12.4,'' k''/9x,''points in='',i7,&
     &''  points out='',i7/9x,''mt'',16i4,(/11x,16i4))')&
     mat1,tempin,tempk,n2in,n2out,(mtr(i),i=1,nreac)
   nset=0
   j=0
   do while (nset.lt.nreac)
      j=j+1
      call finda(j,tt,ntx,inew,bufn,nbuf)
      nset=0
      do k=1,nreac
         if (j.eq.1) mti(k)=0
         if (mti(k).eq.0.and.tt(1+k).gt.zero) mti(k)=j
         if (mti(k).gt.0) nset=nset+1
      enddo
   enddo

   !--correct dictionary to reflect thinning.
  215 continue
   call repoz(nscr1)
   call contio(nscr1,nout,0,scr,nb,nw)
   nxc=n2h
   if (iverf.ge.5) call contio(nscr1,nout,0,scr,nb,nw)
   if (iverf.eq.6) call contio(nscr1,nout,0,scr,nb,nw)
   call hdatio(nscr1,0,0,scr,nb,nw)
   if (iverf.ne.4) nxc=n2h
   scr(1)=tempk
   call hdatio(0,nout,0,scr,nb,nw)
   do while (nb.ne.0)
      call moreio(nscr1,nout,0,scr,nb,nw)
   enddo
   nw=nxc
   if (nxc*6.gt.nwscr) call error('broadr','storage exceeded.',' ')
   call dictio(nscr1,0,0,scr,nb,nw)
   if (nreac.ne.0) then
      do i=1,nw,6
         mf=nint(scr(i+2))
         if (mf.eq.3) then
            mt=nint(scr(i+3))
            if (mt.eq.1.or.mt.eq.3.or.mt.eq.19) then
               scr(i+4)=3+int((n2out+2)/3)
            endif
            if (mt.eq.4.and.mt4br.ne.0) then
               do j=1,nreac
                  jjj=mti(j)
                  if (jjj.gt.1) jjj=jjj-1
                  if (mtr(j).eq.51) mt4i=jjj
               enddo
               scr(i+4)=3+int((n2out-mt4i+3)/3)
            endif
            do j=1,nreac
               jjj=mti(j)
               if (jjj.gt.1) jjj=jjj-1
               if (mt.eq.mtr(j)) scr(i+4)=3+int((n2out-jjj+3)/3)
            enddo
         endif
      enddo
   endif
   nw=nxc
   call dictio(0,nout,0,scr,nb,nw)
   call tofend(nscr1,nout,0,scr)

   !--write out thermal quantities if t is close to 293.6 Kelvin.
   eone=tbreak
   tev=tempk*bk
   if (abs(tev-therm).gt.therm/1000) go to 240
   write(nsyso,'(/''    thermal quantities at'',f6.1,'' K ='',&
     &f7.4,'' eV''/&
     &''    -----------------------------------------'')')&
     tempk,tev
   picon=2/sqrt(pi)
   llf=0
   llc=0
   sc=0
   sf=0
   do j=1,nreac
      if (mtr(j).eq.18) llf=j+1
      if (mtr(j).eq.102) llc=j+1
   enddo
   fint=0
   cint=0
   alint=0
   etint=0
   v1int=0
   ssf=0
   slf=0
   ssc=0
   slc=0
   elast=0
   flast=0
   fnul=0
   j=0
  220 continue
   j=j+1
   call finda(j,tt,ntx,inew,bufn,nbuf)
  225 continue
   enow=tt(1)
   if (enow.gt.step*elast.and.elast.gt.zero) then
      enow=step*elast
      if (llf.gt.0) sf=slf+(tt(llf)-slf)*(enow-elast)/(tt(1)-elast)
      if (llc.gt.0) sc=slc+(tt(llc)-slc)*(enow-elast)/(tt(1)-elast)
   else
      if (llf.gt.0) sf=tt(llf)
      if (llc.gt.0) sc=tt(llc)
   endif
   ! thermal cross sections at 0.0253 eV
   ctev=0
   if (elast.lt.therm.and.enow.ge.therm) then
      if (llf.gt.0) then
         ss=slf+(therm-elast)*(sf-slf)/(enow-elast)
         write(nsyso,'(&
           &''           thermal fission xsec:'',1p,e12.4)') ss
         if (lnu.eq.1) then
            fnu=nutot(7)
         else
            ir=1
            ip=2
            call terpa(fnu,therm,xnext,idis,nutot,ip,ir)
         endif
         write(nsyso,'(&
           &''          thermal fission nubar:'',1p,e12.4)') fnu
      endif
      if (llc.gt.0) then
         ss=slc+(therm-elast)*(sc-slc)/(enow-elast)
         write(nsyso,'(&
           &''           thermal capture xsec:'',1p,e12.4)') ss
      endif
   endif
   ! thermal cross sections at tev
   ctev=zero
   if (elast.lt.tev.and.enow.ge.tev) then
      if (llf.gt.0) then
         ss=slf+(tev-elast)*(sf-slf)/(enow-elast)
         ftev=ss
         if (lnu.eq.1) then
            fnu=nutot(7)
         else
            ir=1
            ip=2
            call terpa(fnu,tev,xnext,idis,nutot,ip,ir)
         endif
      endif
      if (llc.gt.0) then
         ss=slc+(tev-elast)*(sc-slc)/(enow-elast)
         ctev=ss
      endif
   endif
   ! fission nubar at this energy
   fnu=0
   if (llf.gt.0) then
      if (lnu.eq.1) then
         fnu=nutot(7)
      else
         ir=1
         ip=2
         call terpa(fnu,enow,xnext,idis,nutot,ip,ir)
      endif
   endif
   ! thermal integrals
   break=1
   if (enow.lt.break) then
      fnow=enow*exp(-enow/tev)
      if (llc.gt.0) then
         if (j.gt.1) then
            cint=cint+(fnow*sc+flast*slc)*(enow-elast)/2
         endif
      endif
      if (llf.gt.0) then
         if (j.gt.1) then
            fint=fint+(fnow*sf+flast*slf)*(enow-elast)/2
            if (sf.gt.zero.and.slf.gt.zero)&
              alint=alint+(fnow*sc/sf+flast*slc/slf)&
              *(enow-elast)/2
            if ((slf+slc).ne.0.and.(sf+sc).ne.0)&
              etint=etint+(fnow*fnu*sf/(sf+sc)&
              +flast*fnul*slf/(slf+slc))*(enow-elast)/2
            v1int=v1int+(fnow*(fnu*sf-sf-sc)&
              +flast*(fnul*slf-slf-slc))*(enow-elast)/2
         endif
      endif
      flast=fnow
   endif
   ! resonance integrals
   if (elast.lt.eone.and.enow.ge.eone) then
      if (llf.gt.0) then
         ss=slf+(eone-elast)*(sf-slf)/(enow-elast)
         ssf=(sf/enow+ss/elast)*(enow-eone)/2
      endif
      if (llc.gt.0) then
         ss=slc+(eone-elast)*(sc-slc)/(enow-elast)
         ssc=(sc/enow+ss/elast)*(enow-eone)/2
      endif
   endif
   if (elast.ge.eone) then
      if (llf.gt.0) ssf=ssf+(sf/enow+slf/elast)*(enow-elast)/2
      if (llc.gt.0) ssc=ssc+(sc/enow+slc/elast)*(enow-elast)/2
   endif
   ! continue the energy loop
   elast=enow
   fnul=fnu
   if (llf.gt.0) slf=sf
   if (llc.gt.0) slc=sc
   if (enow.lt.tt(1)) go to 225
   if (j.ge.n2out) go to 230
   go to 220
   ! print out the results
  230 continue
   cint=cint/tev**2
   write(nsyso,'(&
     &''       thermal capture integral:'',1p,e12.4)') cint
   if (ctev.ne.zero) write(nsyso,'(&
     &''       thermal capture g-factor:'',1p,e12.4)')&
     picon*cint/ctev
   write(nsyso,'(&
     &''     capture resonance integral:'',1p,e12.4)') ssc
   if (llf.gt.0) then
      fint=fint/tev**2
      alint=alint/tev**2
      etint=etint/tev**2
      v1int=v1int/tev**2
      write(nsyso,'(&
        &''       thermal fission integral:'',1p,e12.4)') fint
      if (ftev.ne.zero) write(nsyso,'(&
        &''       thermal fission g-factor:'',1p,e12.4)')&
        picon*fint/ftev
      write(nsyso,'(&
        &''         thermal alpha integral:'',1p,e12.4)') alint
      write(nsyso,'(&
        &''           thermal eta integral:'',1p,e12.4)') etint
      write(nsyso,'(&
        &''            thermal k1 integral:'',1p,e12.4)') v1int
      write(nsyso,'(&
        &''                  equivalent k1:'',1p,e12.4)')&
      picon*v1int
      write(nsyso,'(&
        &''     fission resonance integral:'',1p,e12.4)') ssf
   endif
   write(nsyso,&
     '(''    -----------------------------------------'')')
  240 continue

   !--output the broadened cross sections in endf format.
  245 continue
   call contio(nscr1,nout,0,scr,nb,nw)
   if (mfh.eq.0) go to 320
   if (mfh.eq.3) go to 250
   if (mfh.eq.2.and.mth.eq.152) go to 247
   call tosend(nscr1,nout,0,scr)
   call contio(nscr1,nout,0,scr,nb,nw)
   if (mfh.eq.0) go to 245
   ! update unresolved temperature
  247 continue
   call listio(nscr1,0,0,scr,nb,nw)
   scr(1)=tempk
   call listio(0,nout,0,scr,nb,nw)
   call tofend(nscr1,nout,0,scr)
   go to 245
  250 continue
   ireac=0
   if (nreac.eq.0) go to 260
   if (mth.eq.1) go to 275
   if (mth.eq.3) go to 275
   if (mth.eq.4.and.mt4br.eq.1) go to 275
   if (mth.ge.46.and.mth.le.49) go to 275
   if (mth.eq.19) go to 275
   do i=1,nreac
      if (mth.eq.mtr(i)) ireac=i
   enddo
  260 continue
   if (ireac.gt.0) go to 275
   ! this section wasnt broadened or thinned.
   ! copy it to output.
   call tab1io(nscr1,0,0,scr,nb,nw)
   nbo=nb
   nwo=nw
   call tab1io(0,nout,0,scr,nbo,nwo)
   do while (nb.ne.0)
      call moreio(nscr1,nout,0,scr,nb,nw)
   enddo
   go to 310
   ! this section was broadened and thinned.
   ! construct a new tab1 structure for the reaction.
   ! use the original total cross section above thnmax.
   ! use the original non-elastic cross section above thnmax.
  275 continue
   ee=0
   call gety1(ee,enext,idis,sig,nscr1,b)
   jjj=1
   do j=1,nreac
      if (mth.eq.mtr(j)) jjj=mti(j)
      if (mth.eq.4.and.mtr(j).eq.51) jjj=mti(j)
      if (mth.eq.4.and.jjj.eq.1.and.mtr(j).eq.91) jjj=mti(j)
   enddo
   if (jjj.gt.1) jjj=jjj-1
   nnn=n2out-jjj+1
   scr(1)=c1h
   scr(2)=c2h
   scr(3)=l1h
   scr(4)=l2h
   scr(5)=1
   scr(6)=nnn
   scr(7)=nnn
   scr(8)=2
   k=8
   j1=npage/2
   j=0
  305 continue
   j=j+1
   call finda(j,tt,ntx,inew,bufn,nbuf)
   if (j.lt.jjj) go to 305
   k=k+1
   scr(k)=tt(1)
   k=k+1
   if (ireac.ne.0) then
      scr(k)=tt(1+ireac)
      call getunx(mth,scr(k-1),en,sun,unr)
      if (en.gt.zero) scr(k)=scr(k)+sun
   else
      if (tt(1).gt.thnmax) then
         call gety1(tt(1),enext,idis,scr(k),nscr1,b)
      else
         scr(k)=0
         do i=1,nreac
            iflag=0
            if (mth.eq.3) then
              if (mtr(i).eq.2) iflag=1
            endif
            if (mth.eq.4) then
              if(mtr(i).lt.51.or.mtr(i).gt.91) iflag=1
            endif
            if (mth.eq.19) then
              if (mtr(i).ne.18) iflag=1
            endif
            if (mth.ge.46.and.mth.le.49) then
              if (mtr(i).ne.mth-40) iflag=1
            endif
            if (mth.ge.201) iflag=1
            ! Don't include partial xs if its sum is already available
            if (mt103.eq.1) then
              if (mtr(i).ge.mpmin.and.mtr(i).le.mpmax) iflag=1
            endif
            if (mt104.eq.1) then
              if (mtr(i).ge.mdmin.and.mtr(i).le.mdmax) iflag=1
            endif
            if (mt105.eq.1) then
              if (mtr(i).ge.mtmin.and.mtr(i).le.mtmax) iflag=1
            endif
            if (mt106.eq.1) then
              if (mtr(i).ge.m3min.and.mtr(i).le.m3max) iflag=1
            endif
            if (mt107.eq.1) then
              if (mtr(i).ge.m4min.and.mtr(i).le.m4max) iflag=1
            endif
            if (iflag.eq.0) scr(k)=scr(k)+tt(1+i)
         enddo
         call getunx(1,tt(1),en,sun,unr)
         if (en.gt.zero) scr(k)=scr(k)+sun
      endif
   endif
   scr(k)=sigfig(scr(k),7,0)
   if (j-jjj+1.gt.j1) go to 300
   if (j-jjj+1.lt.j1.and.j.ne.n2out) go to 305
   nw=k
   call tab1io(0,nout,0,scr,nb,nw)
   k=0
   if (j.lt.n2out) go to 305
   go to 310
  300 continue
   if (k.ne.npage.and.j.ne.n2out) go to 305
   nw=k
   call moreio(0,nout,0,scr,nb,nw)
   k=0
   if (j.lt.n2out) go to 305
  310 continue
   call tosend(nscr1,0,0,scr)
   call asend(nout,0)
   go to 245
  320 continue
   call tomend(nscr1,nout,0,scr)

   !--loop over requested final temperatures.  if bootstrap was
   !--requested, interchange the old and new scratch units.
   if (it.eq.ntemp2) go to 400
   if (istrap.ne.0) then
      isave=iold
      iold=inew
      inew=isave
      n2in=n2out
      tempin=tempk
   endif
   if (nreac.eq.0) go to 195
   go to 210

   !--loop over desired materials.
  400 continue
   read(nsysi,*) mat1
   if (mat1.eq.0) go to 410
   if (nreac.gt.0) then
      deallocate(b)
      deallocate(e)
      deallocate(s)
   endif
   if (nwunr.gt.0) deallocate(unr)
   if (lnu.gt.0) deallocate(nutot)
   if (allocated(nutot)) deallocate(nutot)
   loop=loop+1
   go to 110

   !--broadr is finished
  410 continue
   deallocate(temp2)
   call atend(nout,0)
   call repoz(nout)
   call repoz(nin)
   call closz(nin)
   call closz(nendf)
   call closz(nout)
   call closz(-iold)
   call closz(-inew)
   call closz(nscr1)
   call timer(time)
   write(nsyso,'(69x,f8.1,''s''/&
     &1x,7(''**********''),''*******'')') time
   return
   end subroutine broadr

   subroutine stounx(nin,nout,nscr,unr,thnmax)
   !-------------------------------------------------------------------
   ! Store unresolved cross sections from MF2/MT152 (if present)
   ! for later retrieval using getunx.  The energy range is chosen
   ! for retrieval in the region of resolved-unresolved overlap only.
   !-------------------------------------------------------------------
   use util ! provides mess
   use endf ! provides endf routines and variables
   ! externals
   integer::nin,nout,nscr
   real(kr)::thnmax,unr(*)
   ! internals
   integer::l,nx,k,j,np,nb,nw,i
   real(kr)::e
   real(kr),parameter::zero=0

   !--read in the data
   nunr=0
   intunr=n2h
   l=1
   call listio(nin,0,0,unr(l),nb,nw)
   nx=nint(unr(l+2))
   nsig0=nint(unr(l+3))
   ncyc=1+nx*nsig0
   nunr=n2h
   do while (nb.ne.0)
      l=l+nw
      call moreio(nin,0,0,unr(l),nb,nw)
   enddo

   !--squeeze out sigmazero data if present
   if (nsig0.gt.1) then
      call mess('stounx','sigma zero data removed from unresolved',&
        &'regenerate it if needed.')
      l=8
      k=l+nsig0-1
      do i=1,nunr
         unr(l)=unr(k)
         l=l+1
         k=k+nsig0
         do j=1,nx
            unr(l)=unr(k)
            l=l+1
            k=k+nsig0
         enddo
      enddo
      nsig0=1
      ncyc=1+nx*nsig0
      np=6+nsig0+nunr*(1+nx)
      unr(4)=nsig0
      unr(6)=np
   endif

   !--write mt152 to output files
   l=1
   call listio(0,nout,nscr,unr(l),nb,nw)
   do while (nb.ne.0)
      l=l+nw
      call moreio(0,nout,nscr,unr(l),nb,nw)
   enddo
   l=7+nsig0
   do i=1,nunr
      e=unr(l)
      if (i.eq.1) e1=abs(e)
      if (i.eq.1.or.e.lt.zero) eumax=abs(e)
      if (e.lt.zero) unr(l)=-e
      l=l+ncyc
   enddo
   if (thnmax.gt.0.and.eumax.lt.thnmax) thnmax=eumax
   if (eumax.gt.e1) return

   !--no overlap.  unresolved not needed.
   nunr=0
   return
   end subroutine stounx

   subroutine getunx(mt,e,enext,sun,unr)
   !-------------------------------------------------------------------
   ! Retrieve infinitely dilute unresolved cross section from MT152
   ! data (if present).  enext=-1 means that there is no unresolved
   ! data at this energy.
   !-------------------------------------------------------------------
   use endf ! provides terp1
   ! externals
   integer::mt,i
   real(kr)::e,enext,sun,unr(*)
   ! internals
   integer::ix,ibase,lim,loc,loc1
   real(kr),parameter::up=1.00001e0_kr

   enext=-1
   sun=0
   if (nunr.eq.0) return
   if (e.lt.e1) return
   if (e.gt.eumax) return
   ix=0
   if (mt.eq.1) ix=1
   if (mt.eq.2) ix=2
   if (mt.eq.18.or.mt.eq.19) ix=3
   if (mt.eq.102) ix=4
   if (ix.eq.0) return
   ibase=7+nsig0
   lim=nunr-1
   do i=1,lim
      loc=ibase+(i-1)*ncyc
      loc1=loc+ncyc
      if (e.ge.unr(loc).and.e.lt.unr(loc1))&
         call terp1(unr(loc),unr(loc+ix),unr(loc1),unr(loc1+ix),&
           e,sun,intunr)
   enddo
   if (sun.eq.0) then
      sun=unr(loc1+ix)
      enext=eumax*up
   else
      enext=unr(loc1+1)
   endif
   return
   end subroutine getunx

   subroutine bfile3(iold,inew,bufo,bufn,e,s,nx)
   !-------------------------------------------------------------------
   ! This routine manages the paging of cross section data.  At
   ! any time, there are three pages of data in memory.  Doppler
   ! broadening or thinning is performed for energies on the
   ! middle page.  When the range of energies on this page is
   ! exceeded, The top two pages are moved down, and new data
   ! is read into the top page.  This process continues until
   ! the energy thnmax is reached.  The rest of the data are
   ! simply copied.
   !-------------------------------------------------------------------
   use util ! provides finda
   ! externals
   integer::iold,inew,nx
   real(kr)::bufo(*),bufn(*),e(*),s(nx,*)
   ! internals
   integer::nj,l,k,i,nw,kk
   real(kr)::tt(ntt+1)
   real(kr),parameter::zero=0

   !--set broadening indices to middle page
   n2left=n2in
   nlow=mpage+1
   nhigh=2*mpage
   if (n2left.lt.mpage) nhigh=nlow+n2left-1
   ! set index to loaded points at beginning of middle page
   klow=nlow
   ! set indices to load middle and last pages
   mlow=nlow
   mhigh=3*mpage
   ! set output index for first point
   nj=0
   l=0

   !--load desired points
  110 continue
   if (n2left.lt.mhigh-mlow+1) mhigh=mlow+n2left-1
   do k=mlow,mhigh
      l=l+1
      call finda(l,tt,ntx,iold,bufo,nbuf)
      e(k)=tt(1)
      do i=1,nreac
         s(i,k)=tt(i+1)
      enddo
   enddo
   ! set index to loaded points to last point loaded
   khigh=mhigh
   ! calculate no. of points left to read
   n2left=n2left-(mhigh-mlow+1)

   !--broaden or thin points in middle page
  120 continue
   if (tempef.gt.zero) then
      call broadn(nj,inew,bufn,e,s,nreac)
   else
      call thinb(nj,inew,bufn,e,s,nreac)
   endif

   !--has last point been broadened or thinned.
   if (nj.lt.0) go to 150

   !--shift remaining unbroadened points one page forward
   nw=khigh-nlow+1
   kk=nw
   do k=1,nw
      e(k)=e(nlow+k-1)
      do i=1,nreac
         s(i,k)=s(i,nlow+k-1)
      enddo
   enddo
   ! set index to loaded points to beginning of table
   klow=1
   ! set index to next available location for loading
   mlow=kk+1

   ! are there any more points to read
   if (n2left.gt.0) go to 110
   ! no.  set index to last loaded point
   khigh=kk
   ! set index to broaden all remaining points
   nhigh=khigh
   mhigh=khigh
   go to 120

   !--finished...entire table broadened
  150 continue
   n2out=-nj
   return
   end subroutine bfile3

   subroutine broadn(j,inew,bufn,e,s,nx)
   !-------------------------------------------------------------------
   ! Given a cross section that is described by a table of
   ! x/s vs. e and linear-linear interpolation between points,
   ! this routine will exactly doppler broaden the cross
   ! section for the range of energies on the middle page.
   ! Paging parameters:
   !  klow  =index to first point loaded in core.
   !  khigh =index to last point loaded in core.
   !  nlow  =index to first point to broaden.
   !  nhigh =index to last point to broaden.
   !  mlow  =index to first point just loaded.
   !  mhigh =index to last point just loaded.
   !  e     =table of energies corresponding to s.
   !  s     =table of cross sections at initial temperature.
   !  alpha =doppler width (awr/(bk*tempef))
   ! On entry, the points just loaded (mlow to mhigh) are converted
   ! to velocity-like terms.  An iterative method is then used to
   ! compute the broadened cross sections for the range of energies
   ! in the middle page (nlow to nhigh) using the original data
   ! from all pages (klow to khigh).  As each new energy and set of
   ! broadened cross sections is found, it is written to scratch
   ! storage (j,inew,bufn).  After energy has reached thnmax,
   ! the rest of the current page is copied to scratch storage.
   ! The routine will broaden and thin up to ntt reactions
   ! simultaneously on a unionized and linearized grid which
   ! will represent the broadened function to the specified accuracy.
   ! In any given energy range, this grid may be finer or coarser
   ! than the original grid.  The final grid will usually have
   ! fewer points than the input grid due to the smoothing effect
   ! of Doppler broadening.  However, in some cases, points will
   ! be added to regions near sharp breaks or discontinuities,
   ! and the final grid may have more points than the input grid.
   !-------------------------------------------------------------------
   use util ! provides sigfig,loada
   ! externals
   integer::j,inew,nx
   real(kr)::bufn(*),e(*),s(nx,*)
   ! internals
   integer::n,k,klast,i,is,km,ndig
   real(kr)::et,dn,test,em,xm,dx,errt,errm,f,dy,est,si,xt,stot
   real(kr)::tt1old
   integer,parameter::nstack=12
   integer::ks(nstack),js(nstack)
   real(kr)::es(nstack),ss(ntt,nstack)
   real(kr)::tt(ntt+1),sn(ntt),dl(ntt)
   integer::nmax=10
   real(kr),parameter::therm=.0253e0_kr
   real(kr),parameter::one=1.e0_kr
   real(kr),parameter::estp=4.1e0_kr
   real(kr),parameter::half=.5e0_kr
   real(kr),parameter::small=1.e-9_kr
   real(kr),parameter::step=2.01e0_kr
   real(kr),parameter::rmax=3.0e0_kr
   real(kr),parameter::errmin=1.e-15_kr
   real(kr),parameter::trange=.4999e0_kr
   real(kr),parameter::ssmall=1.e-6_kr
   real(kr),parameter::tenth=1.e-1_kr
   real(kr),parameter::zero=0
   save ks,es,js,ss,tt,sn,dl

   !--convert energies just loaded to velocity-like terms
   if (mhigh.ge.mlow) then
      do n=mlow,mhigh
         e(n)=sqrt(alpha*e(n))
      enddo
   endif
   k=nlow
   klast=nlow-1

   !--set up first node in stack
   tt1old=zero
   if (klow.eq.1) go to 110
   klast=k
   ks(2)=k
   et=e(k)**2/alpha
   es(2)=sigfig(et,7,0)
   xt=sqrt(alpha*es(2))
   do i=1,nreac
      dn=s(i,k+1)-s(i,k)
      if (abs(dn).lt.abs(s(i,k))/1000) dn=0
      dl(i)=1
      if (dn.lt.zero) dl(i)=-1
   enddo
   call bsigma(k,xt,ss(1,2),e,s,nx)
   js(2)=0
   do i=1,nreac
      if (abs(ss(i,2)-s(i,k)).gt.errthn*s(i,k)) js(2)=1
   enddo
   k=k+1
   go to 120
  110 continue
   if (es(1).gt.thnmax) go to 190

   !--locate next node for stack
  120 continue
   et=e(k)**2/alpha
   if (et.ge.thnmax) go to 130
   if (k.ge.nhigh) go to 130
   test=sigfig(et,7,0)
   if (abs(es(2)-test).lt.small*test) go to 126
   if (k.gt.klast+nmax) go to 130
   if (et.gt.step*es(2)) go to 130
   test=sigfig(et,3,0)
   if (abs(et-test).lt.small*test) go to 130
   if (abs(et-therm).lt.small*therm) go to 130
   do 125 i=1,nreac
   dn=s(i,k+1)-s(i,k)
   if (abs(dn).lt.abs(s(i,k))/1000) dn=0
   if (dn.ge.zero) then
      dn=1
   else
      dn=-1
   endif
   if (dn.ne.dl(i)) go to 130
  125 continue
  126 continue
   k=k+1
   go to 120
  130 continue
   es(1)=sigfig(et,7,0)
   xt=sqrt(alpha*es(1))
   call bsigma(k,xt,ss(1,1),e,s,nx)
   ks(1)=k
   js(1)=0
   do i=1,nreac
      if (abs(ss(i,1)-s(i,k)).gt.errthn*s(i,k)) js(1)=1
   enddo

   !--add points between nodes if needed
   is=2
  140 continue
   if (is.ge.nstack) go to 150
   if (ks(is-1).eq.ks(is)+1) then
     if (js(is-1).eq.0) then
       if(js(is).eq.0) go to 150
     endif
   endif
   ! compare true function to linear approximation
   em=half*(es(is-1)+es(is))
   ndig=9
   if (em.gt.tenth.and.em.lt.one) ndig=8
   if (em.gt.sigfig(es(is),7,+1)) then
     if(em.lt.sigfig(es(is-1),7,-1)) then
       em=sigfig(em,7,0)
     endif
   else
      em=sigfig(em,ndig,0)
   endif
   km=0
   if (em.lt.sigfig(es(is),ndig,+1).or.&
     em.gt.sigfig(es(is-1),ndig,-1)) go to 150
   errt=errthn
   if (es(is-1).lt.trange) errt=errt/5
   errm=errmax
   if (es(is-1).lt.trange) errm=errm/5
   xm=sqrt(alpha*em)
   call bsigma(klast,xm,sn,e,s,nx)
   dx=es(is-1)-es(is)
   f=(em-es(is))/dx
   test=one-one/100
   if (f.gt.test) go to 170
   stot=zero
   do i=1,nreac
      stot=stot+sn(i)
   enddo
   do 145 i=1,nreac
   if (stot.lt. errmin) go to 145
   if (abs(sn(i)/stot).lt.ssmall) go to 145
   if (ss(i,is-1).gt.rmax*ss(i,is)) go to 170
   if (ss(i,is-1).lt.ss(i,is)/rmax) go to 170
   si=f*ss(i,is-1)+(1-f)*ss(i,is)
   dy=abs(sn(i)-si)
   if (dy.le.errt*abs(sn(i))+errmin) go to 145
   if (dy.gt.errm*abs(sn(i))+errmin) go to 170
   if (dy*dx/2.gt.errint*em) go to 170
  145 continue
   ! don't allow a big increase in the step size
   ! it may be a misconvergence
   est=estp*(es(is)-tt(1))
   if (j.gt.3.and.dx.gt.est) go to 170
   ! converged. store top point of stack.
  150 Continue
   tt(1)=es(is)
   do i=1,nreac
      if (tt(1).gt.emtr(i).and.tt1old.ge.emtr(i)) then
         tt(1+i)=ss(i,is)
      else
         tt(1+i)=0
      endif
   enddo
   tt1old=tt(1)
   j=j+1
   call loada(j,tt,ntx,inew,bufn,nbuf)
   is=is-1
   if (is.gt.1) go to 140
   ! stack exhausted.  get new node.
   es(2)=es(1)
   ks(2)=ks(1)
   js(2)=js(1)
   do i=1,nreac
      ss(i,2)=ss(i,1)
      dn=s(i,k+1)-s(i,k)
      if (abs(dn).lt.abs(s(i,k))/1000) dn=0
      if (dn.ge.zero) then
         dl(i)=1
      else
         dl(i)=-1
      endif
   enddo
   if (k.ge.nhigh) go to 180
   if (es(1).gt.thnmax) go to 190
   klast=k
   k=k+1
   go to 120
   ! not converged.  add midpoint to stack and continue.
  170 continue
   is=is+1
   es(is)=es(is-1)
   es(is-1)=em
   ks(is)=ks(is-1)
   ks(is-1)=km
   js(is)=js(is-1)
   js(is-1)=0
   if (km.eq.0) js(is-1)=1
   do i=1,nreac
      ss(i,is)=ss(i,is-1)
      ss(i,is-1)=sn(i)
      if (km.ne.0) then
         if (abs(sn(i)-s(i,km)).gt.errthn*s(i,km)+errmin) js(is-1)=1
      endif
   enddo
   go to 140
   ! finished with this page.
  180 continue
   ks(2)=nlow-1
   if (nhigh.lt.khigh) return
   ! copy energies above thnmax to output
   ! flag last point with minus.
  190 continue
   j=j+1
   et=e(k)**2/alpha
   tt(1)=et
   do i=1,nreac
      tt(1+i)=s(i,k)
   enddo
   if (k.eq.nhigh.and.khigh.eq.nhigh) j=-j
   call loada(j,tt,ntx,inew,bufn,nbuf)
   k=k+1
   if (k.le.nhigh) go to 190
   ks(2)=nlow-1
   return
   end subroutine broadn

   subroutine bsigma(kn,en,sn,e,s,nx)
   !-------------------------------------------------------------------
   ! Given tables of energies (e) and cross sections (s) with linear
   ! interpolation between points, this routine will exactly Doppler
   ! broaden the cross sections for an energy (en) in the middle
   ! page of the table.  If there is not sufficient data in the
   ! side pages to perform the doppler integral, an error message
   ! will be issued, and the calculation should be redone with a
   ! smaller temperature change.
   !-------------------------------------------------------------------
   use util ! provides mess
   use physics ! get global physics constants
   ! externals
   integer::kn,nx
   real(kr)::en
   real(kr)::sn(nx),e(*),s(nx,*)
   ! internals
   integer::khm1,i,k,ll,l
   real(kr)::aamin,denom,slope,factor,xp,xm
   real(kr)::sbt(ntt)
   character(60)::strng
   real(kr),dimension(5),parameter::fzero=(/0.5e0_kr,&
     1.e0_kr/(2.e0_kr*sqrt(pi)),0.25e0_kr,&
     1.e0_kr/(2.e0_kr*sqrt(pi)),0.375e0_kr/)
   real(kr),parameter::one=1.e0_kr
   real(kr),parameter::two=2.e0_kr
   real(kr),parameter::atop=4.e0_kr
   real(kr),parameter::sigmin=1.e-15_kr
   aamin=atop
   aa=0

   !--initialize integral
   khm1=khigh-1
   do i=1,nreac
      sbt(i)=0
   enddo

   !--search for panel containing en
   k=kn
   if (e(k+1).ge.e(k)) then
      do while (en.ge.e(k+1))
         k=k+1
      enddo
   endif

   !--compute desired cross sections
   y=en
   oy=-one/y
   yy=y*y
   ! initialize f functions to zero distance values
   do ll=1,5
      f(ll)=fzero(ll)
   enddo
   alast=0

   !--loop over intervals below current point
   l=k+1
   do 150 ll=klow,k
   l=l-1
   x=e(l)
   xp=e(l+1)
   xx=xp*xp
   if (xx.le.x*x) go to 150
   aa=y-x
   call hunky
   denom=one/(xx-x*x)
   do i=1,nreac
      slope=(s(i,l+1)-s(i,l))*denom
      sbt(i)=sbt(i)+s(i,l+1)*s1+slope*s2
   enddo
   if (aa.gt.atop) go to 170
  150 continue
   if (aa.lt.aamin.and.nlow.ne.klow) aamin=aa
   ! continue cross sections as 1/v to x=0.
   x=0
   xx=0
   aa=y
   call hunky
   do i=1,nreac
      sbt(i)=sbt(i)-s(i,klow)*e(klow)*(oy**2*h(2)+oy*h(1))
   enddo

   !--reinitialize f functions to zero distance values
  170 continue
   do ll=1,5
      f(ll)=fzero(ll)
   enddo
   alast=0
   ! reverse sign of 1/y to use same s1 and s2 functions
   oy=-oy
   ! no intervals above the last point
   if (k.eq.khigh) go to 200

   !--loop over intervals above current one
   do 190 l=k,khm1
   x=e(l+1)
   xm=e(l)
   xx=xm*xm
   if (xx.ge.x*x) go to 190
   aa=x-y
   call hunky
   denom=one/(x*x-xx)
   do i=1,nreac
      slope=(s(i,l+1)-s(i,l))*denom
      sbt(i)=sbt(i)+s(i,l)*s1+slope*s2
   enddo
   if (aa.gt.atop) go to 210
  190 continue
   if (aa.lt.aamin.and.nhigh.ne.khigh) aamin=aa
   ! continue cross sections as constant to x=infinity
  200 continue
   factor=(f(3)*oy+two*f(2))*oy+f(1)
   do i=1,nreac
      sbt(i)=sbt(i)+s(i,khigh)*factor
   enddo

   !--add low energy term, if applicable
  210 continue
   y=-y
   aa=-y
   if (aa.gt.atop) go to 230
   ! extend cross section to x=0.0 as 1/v.
   call funky
   alast=aa
   oy=-oy
   aa=e(klow)-y
   xx=0
   call hunky
   do i=1,nreac
      sbt(i)=sbt(i)-s(i,klow)*e(klow)*(oy**2*h(2)+oy*h(1))
   enddo
   if (aa.gt.atop) go to 230
   ! loop over other intervals
   do 220 l=klow,khm1
   x=e(l+1)
   aa=x-y
   xx=e(l)**2
   if (xx.eq.x*x) go to 220
   call hunky
   denom=one/(x*x-xx)
   do i=1,nreac
      slope=(s(i,l+1)-s(i,l))*denom
      sbt(i)=sbt(i)-s(i,l)*s1-slope*s2
   enddo
   if (aa.gt.atop) go to 230
  220 continue
   ! extend cross section to x=infinity as constant
   factor=(f(3)*oy+two*f(2))*oy+f(1)
   do i=1,nreac
      sbt(i)=sbt(i)-s(i,khigh)*factor
   enddo

   !--return broadened values
  230 continue
   do i=1,nreac
      if (sbt(i).lt.sigmin) sbt(i)=0
      sn(i)=sbt(i)
   enddo

   !--print truncation warning
   if (aamin.lt.atop) then
      write(strng,'(''broadening truncated at a='',f3.1)') aamin
      call mess('bsigma',strng,' ')
   endif
   return
   end subroutine bsigma

   subroutine thinb(j,inew,bufn,e,s,nx)
   !-------------------------------------------------------------------
   ! Given a set of nx cross sections versus energy (e and s)
   ! and linear-linear interpolation between points, this
   ! routine will remove all extraneous points that lie within a
   ! given accuracy of the function based upon interpolation
   ! from surrounding points.  Since all reactions are
   ! thinned simultaneously, the union grid is preserved.
   !-------------------------------------------------------------------
   use util ! provides loada
   ! externals
   integer::j,inew,nx
   real(kr)::e(*),s(nx,*),bufn(*)
   ! internals
   integer::nmin,ilow,i,n,nm1,k
   real(kr)::denom,slope,sp
   real(kr)::tt(ntt+1)
   real(kr),parameter::stpmax=1.24e0_kr
   real(kr),parameter::eps=1.e-5_kr
   real(kr),parameter::zero=0
   nmin=nlow+2
   ilow=nlow+1

   !--keep first point
   if (klow.ne.1) then
      j=j+1
      tt(1)=e(nlow)
      do i=1,nreac
         tt(1+i)=s(i,nlow)
      enddo
      call loada(j,tt,ntx,inew,bufn,nbuf)
   endif

   !--loop over all other points
   do 150 n=nmin,nhigh
   ! define index to last candidate for thinning
   nm1=n-1
   denom=e(n)-tt(1)
   if (denom.eq.zero) go to 150
   denom=1/denom
   do 130 i=1,nreac
   slope=(s(i,n)-tt(1+i))*denom
   ! test allowable error at all intervening points
   do 120 k=ilow,nm1
   if (e(k).ge.stpmax*tt(1)) go to 140
   sp=tt(1+i)+slope*(e(k)-tt(1))
   if (abs(sp-s(i,k)).gt.errthn*s(i,k)) go to 140
   if (e(k)*(1.+eps).gt.thnmax) go to 140
  120 continue
  130 continue
   ! all intervening points can be thinned
   ! extend interval to thin by one more point
   go to 150
   ! at least one point in interval fails test
   ! save last point within the interval
  140 continue
   j=j+1
   tt(1)=e(nm1)
   do i=1,nreac
      tt(1+i)=s(i,nm1)
   enddo
   if (tt(1)*(1.+eps).ge.thnmax) go to 180
   call loada(j,tt,ntx,inew,bufn,nbuf)
   ! reset lower limit of interval that can be thinned
   ilow=n
  150 continue

   !--finished with this page.
   return

   !--copy energies above thnmax to scratch storage.
  160 continue
   j=j+1
   tt(1)=e(nm1)
   do i=1,nreac
      tt(i+1)=s(i,nm1)
   enddo
  180 continue
   if (nm1.eq.nhigh.and.khigh.eq.nhigh) j=-j
   call loada(j,tt,ntx,inew,bufn,nbuf)
   nm1=nm1+1
   if (nm1.le.nhigh) go to 160
   return
   end subroutine thinb

   subroutine hunky
   !-------------------------------------------------------------------
   ! This routine is designed to define functions that appear
   ! in Doppler broadening calculations.
   !  h(n,a)=integral (b to a) z**n*exp(-z*z)*dz/sqrt(pi)
   !  for n=0 to 4
   ! These h(n,a,b) functions are defined as the difference
   ! between f(n,a) functions (see routine funky).
   !  h(n,a,b)=f(n,a)-f(n,b)
   ! unless this expression losses significance in which case
   ! hnabb is calculated by a Taylor expansion of the defining
   ! integral.
   !-------------------------------------------------------------------
   ! internals
   integer::k,n
   real(kr),parameter::small=1.e-12_kr
   real(kr),parameter::toler=1.e-5_kr
   real(kr),parameter::two=2.e0_kr
   real(kr),parameter::four=4.e0_kr
   real(kr),parameter::six=6.e0_kr

   ! initialize h functions to current f functions
   do k=1,5
      h(k)=f(k)
   enddo
   ! compute new f functions
   call funky
   ! subtract new f functions to obtain integral over interval
   do k=1,5
      h(k)=h(k)-f(k)
      if (abs(h(k)).le.small*abs(f(k))) h(k) = 0.0_kr
      if (abs(h(k)).le.toler*abs(f(k)).and.aa.ne.alast) then
         n=k-1
         h(k)=hnabb(n,alast,aa)
      endif
   enddo
   alast=aa
   ! compute contributions from two integral terms
   s1=(h(3)*oy+two*h(2))*oy+h(1)
   s2=((h(5)+(six*yy-xx)*h(3))*oy+(four*h(4)&
     +(four*yy-two*xx)*h(2)))*oy+(yy-xx)*h(1)
   return
   end subroutine hunky

   subroutine funky
   !-------------------------------------------------------------------
   ! This routine is designed to define functions that appear
   ! in Doppler broadening calculations:
   !  f(n,a)=integral(a to infinity) z**n*exp(-z*z)*dz/sqrt(pi)
   !  for n=0 to 4
   ! The resulting expression is analytic.
   !-------------------------------------------------------------------
   use mathm   ! provides erfc
   use physics ! provides pi
   ! internals
   real(kr)::resqpi,a,asq,expo
   real(kr),parameter::half=0.5e0_kr
   real(kr),parameter::two=2.e0_kr
   real(kr),parameter::three=3.e0_kr
   real(kr),parameter::alim=10.e0_kr

   resqpi=1/sqrt(pi)
   a=aa
   asq=a*a
   expo=0
   if (a.lt.alim) expo=exp(-asq)
   f(1)=0
   if (a.lt.alim) f(1)=half*erfc(a)
   expo=expo*resqpi
   f(2)=half*expo
   expo=expo*a
   f(3)=half*(f(1)+expo)
   expo=expo*a
   f(4)=half*(two*f(2)+expo)
   expo=expo*a
   f(5)=half*(three*f(3)+expo)
   return
   end subroutine funky

   real(kr) function hnabb(n,aa,bb)
   !-------------------------------------------------------------------
   ! For b.ge.a, calculates hn(a,b) by a direct taylor series
   ! expansion of the defining integral.  This is appropriate
   ! for b-a small.
   !-------------------------------------------------------------------
   use physics ! provides pi
   ! externals
   integer::n
   real(kr)::aa,bb
   ! internals
   integer::mflag,k,kd,kstar,j,kk,jalpha,m,kdstar
   real(kr)::sign,a,b,h,x,xx,asq,con,xk,s,fact,qmn,beta,xn1,xn2,test
   real(kr)::resqpi,term
   real(kr)::cm(50),cmstar(50)
   real(kr),parameter::aerr=1.e30_kr
   real(kr),parameter::rerr=1.e-8_kr
   real(kr),dimension(5),parameter::pow2=(/1.4142135623731e0_kr,&
     2.0e0_kr,2.8284271247462e0_kr,4.0e0_kr,5.6568542494924e0_kr/)
   real(kr),parameter::explim=100.e0_kr
   real(kr),parameter::zero=0

   resqpi=1/sqrt(pi)

   !--transform limits so that b ge a
   !--select relative sign of result
   sign=1
   if (bb.lt.aa) then
      a=abs(bb)
      b=abs(aa)
      sign=-sign
   else
      a=abs(aa)
      b=abs(bb)
   endif
   if (bb.lt.zero) then
     if (mod(n,2).ne.0) sign=-sign
   endif
   h=(b-a)*pow2(1)
   x=pow2(1)*a
   xx=x*x
   asq=a*a
   con=0
   if (asq.lt.explim) con=exp(-asq)*resqpi/pow2(n+1)
   mflag=0
   k=n
   kd=0
   cm(1)=1
   xk=1
   if (k.ne.0) then
      xk=x**k
   endif
   s=h*xk
   fact=h
   do 130 m=2,50
   fact=fact*h/m
   kstar=k
   kdstar=kd+1
   do j=1,kdstar
      cmstar(j)=cm(j)
   enddo
   k=n-m+1
   if (k.lt.0) then
      kk=mod(k,2)
      k=0
      if (kk.ne.0) k=1
   endif
   kd=(n+m-1-k)/2
   cm(kd+1)=-cmstar(kdstar)
   qmn=cm(kd+1)
   if (kd.ne.0) then
      do j=1,kd
         jalpha=(2*j+k-1-kstar)/2
         beta=0
         if (jalpha.ne.0) then
            beta=cmstar(jalpha)
         endif
         cm(j)=(2*j+k-1)*cmstar(jalpha+1)-beta
      enddo
      do j=1,kd
         qmn=qmn*xx+cm(kd+1-j)
      enddo
   endif
   xk=1
   if (k.ne.0) then
      xk=x**k
   endif
   term=fact*xk*qmn
   s=s+term
   xn1=n+1
   xn2=abs(h*x)
   if (m.lt.max(xn1,xn2)) go to 130
   test=aerr+rerr*abs(s)
   if (abs(term).gt.test) go to 200
   if (mflag.eq.1) go to 210
   mflag=1
   go to 130
  200 continue
   mflag=0
  130 continue
  210 continue
   hnabb=con*s*sign
   return
   end function hnabb

end module broadm

