c123456789*123456789*123456789*123456789*123456789*123456789*123456789*12
c   Version 2 December 2002
c   For info please contact Dave Poston (505)-667-4336 - poston@lanl.gov
c   or  Holly Trellue (505)-665-9539 - trellue@lanl.gov
c
c...MONTEB call a variety of subroutines based on call line ARG
c
      common /mbinp/nmat,mt(49),voli(49),pow,qu235,days,nouter,ninner,
     & npre,nrst,frimp,nauto(49),ntot(49),nkeff,mbxs,nisn(999,49),
     & nisnr(999,49)
      common /mbinp2/niso(999,49),nisor(999,49),title,olib,locale,posit,
     &     tmpfile,machin,CALC
      character niso*10,nisor*6,title*72,olib*10,locale*72,posit*1,
     &      arg*6,machin*4,tmpfile*10,CALC*6
c
c...Read in command line argument getarg for sun, igetarg for HP
c
       m = iargc()
c    for non-VMS and non-HP systems:
       if (m.eq.1) call getarg(1,arg)
c  Note:  for a UNIX HP system, uncomment the line above
c      and comment out the next one (i.e. put a 'c' at the beginning of 
c      each of these lines).
!        if (m.eq.1) call igetarg(1, arg, 6)
c  Note:  for a VMS system, uncomment the following 3 lines and comment 
c     out the two above.
c        character arg*8
c        ilib=LIB$GET_FOREIGN(arg)
c        read*, arg
      write(6,'("  Monteb option ", a6, "selected")')arg
c
c...Read in input file into common block data from standard input (initial
c... read (with arg = a) is different than preceding ones b/c nauto
c... has not yet been defined.
c
      if (arg(1:1).eq.'a'.or.arg.eq.'wparam') then
        call readc
      else
        call readco
      endif
c
c...Set temporary file directory name (system-dependent)
c
      if (machin(1:3).eq.'VMS') then
        tmpfile = '[.tmpfile]'
      else
        tmpfile = './tmpfile/'
      endif
c
c...execute based on arg
c
      if (arg(1:1).eq.'1'.or.arg.eq.'pcard ')  call pcard 
      if (arg(1:1).eq.'2'.or.arg.eq.'wtall2')  call wtal2
      if (arg(1:1).eq.'3'.or.arg.eq.'wtally')  call wtally
      if (arg(1:1).eq.'4'.or.arg.eq.'worcom')  call worcom
      if (arg(1:1).eq.'5'.or.arg.eq.'worinp')  call worinp
      if (arg(1:2).eq.'6b'.or.arg.eq.'worxsb')  then 
         posit = 'b'
         call worxs
      elseif (arg(1:2).eq.'6m'.or.arg.eq.'worxsm') then
         posit = 'm'
         call worxs
      elseif (arg(1:2).eq.'6e'.or.arg.eq.'worxse') then
         posit = 'e'
         call worxs
      endif
      if (arg(1:2).eq.'7b'.or.arg.eq.'wmcinb') then
         posit = 'b'
         call wmcinp
      elseif (arg(1:2).eq.'7m'.or.arg.eq.'wmcinm') then
         posit = 'm'
         call wmcinp
      elseif (arg(1:2).eq.'7e'.or.arg.eq.'wmcine') then
         posit = 'e'
         call wmcinp
      endif
      if (arg(1:2).eq.'8b'.or.arg.eq.'gramsb') then
         posit = 'b'
         call grams
      elseif (arg(1:2).eq.'8e'.or.arg.eq.'gramse') then
         posit = 'e'
         call grams
      endif
c
      if (arg(1:1).eq.'9'.or.arg.eq.'wmbinp') then
        nrst=nrst+1
        call wmbinp
      end if
      if (arg(1:1).eq.'0'.or.arg.eq.'rmhalf') call rmhalf
      if (arg(1:1).eq.'b'.or.arg.eq.'discre') call discr
      if (arg(1:1).eq.'c'.or.arg.eq.'region') call region
      if (arg(1:1).eq.'d'.or.arg.eq.'discre') call dremo
      if (arg(1:1).eq.'e'.or.arg.eq.'natele') call natele
      if (arg(1:1).eq.'i'.or.arg.eq.'isogas') call isogas
      if (arg(1:1).eq.'z'.or.arg.eq.'burnca') call burnca
c
c...Write variables 'params' to be read by shell and make more detailed
c... user's input file
c
      if (arg.eq.'a'.or.arg.eq.'wparams')  then
         call wparam
         call wmbinp
      endif
c
      end
c
c23456789*123456789*123456789*123456789*123456789*123456789*123456789*12
c
c...WPARAMS writes scratch file containing variables to be read by
c...shell with the AWK command
c
      subroutine wparam 
      common /mbinp/nmat,mt(49),voli(49),pow,qu235,days,nouter,ninner,
     & npre,nrst,frimp,nauto(49),ntot(49),nkeff,mbxs,nisn(999,49),
     & nisnr(999,49)
      common /mbinp2/niso(999,49),nisor(999,49),title,olib,locale,posit,
     &     tmpfile,machin,CALC
      character niso*10,nisor*6,title*72,olib*10,locale*72,posit*1,
     & machin*4,tmpfile*10,filen*10,CALC*6
c
      filen = 'params.dat'
      open (11,file=filen,status='unknown')
      write (11,902) nouter
      write (11,903) npre
      write (11,904) nrst
      write (11,905) nkeff
      write (11,906) nmat
      write (11,907) olib(1:6)
      close (11)
c
  902 format (i4,'  nout')
  903 format (i4,'  npre')
  904 format (i4,'  nrst')
  905 format (i4,'  nkeff')
  906 format (i4,'  nmat')
  907 format (1x,a6,'  olib')
      return
      end
c
c23456789*123456789*123456789*123456789*123456789*123456789*123456789*12
c
c...READC reads in common block data from input file without ntot 
c    (initial)
c
      subroutine readc
      common /mbinp/nmat,mt(49),voli(49),pow,qu235,days,nouter,ninner,
     & npre,nrst,frimp,nauto(49),ntot(49),nkeff,mbxs,nisn(999,49),
     & nisnr(999,49)
      common /mbinp2/niso(999,49),nisor(999,49),title,olib,locale,posit,
     &     tmpfile,machin,CALC
      character niso*10,nisor*6,title*72,olib*10,locale*72,posit*1,
     &      machin*4,nisor5*5,met*1,tmpfile*10,char4*4,CALC*6
c
c...Read mburn input file, read twice to get niso & nisn, have to
c...read as real variable first and then convert to integer so that it
c...works both on Sun and HP.
c
      open (11,file='mb.inp',status='old')
      read (11,'(a72)') title
      read (11,'(a4)') machin 
      read (11,'(a6)') CALC 
      write(*,888) CALC
 888  format(a6)
      read (11,*) nmat
      do 20 j=1,nmat
   20 read (11,*) mt(j)
      do 30 j=1,nmat 
   30 read (11,*) voli(j)
      read (11,*) pow
      read (11,*) qu235
      read (11,*) days
      read (11,*) nouter
      read (11,*) ninner
      read (11,*) npre
      read (11,*) nrst
      read (11,'(a10)') olib
      read (11,'(a72)') locale
      read (11,*) frimp
      read (11,*) nkeff
      do 60 j=1,nmat
      read (11,*) nauto(j)
      ntot(j) = nauto(j)
      do 60 i=1,ntot(j)
      read (11,'(a10)') niso(i,j)
      backspace (11)
      read (11,'(f6.1)',err=999,end=999) x
   60 nisn(i,j)=x
      mbxs = 0
      read (11,'(a4)',end=70) char4
      if (char4.eq.'MBXS') then
        mbxs = 1
      endif 
   70 close (11)
c
c...Assign origin iso names
c
      do 10 j=1,nmat
      do 10 i=1,ntot(j)
      nisor5=niso(i,j)
      met='0'
      if (nisor5.eq.'95242') met='1'
   10 nisor(i,j)=nisor5//met
c
      do 15 j=1,nmat
      do 15 i=1,ntot(j)
      nisnr(i,j)=nisn(i,j)*10
      if (nisnr(i,j).eq.952420) nisnr(i,j)=nisnr(i,j)+1
   15 continue
      goto 998
c
  999 write (6,*) '***** MB ERROR: Problem with monteburns input file'     
      stop 
  998 return
      end
c
c23456789*123456789*123456789*123456789*123456789*123456789*123456789*12
c
c...READCOM reads in common block data from input file with ntot
c
      subroutine readco
      common /mbinp/nmat,mt(49),voli(49),pow,qu235,days,nouter,ninner,
     & npre,nrst,frimp,nauto(49),ntot(49),nkeff,mbxs,nisn(999,49),
     & nisnr(999,49)
      common /mbinp2/niso(999,49),nisor(999,49),title,olib,locale,posit,
     &     tmpfile,machin,CALC
      character niso*10,nisor*6,title*72,olib*10,locale*72,posit*1,
     &      machin*4,nisor5*5,met*1,tmpfile*10,CALC*6
c
c...Read mburn input file, read twice to get niso & nisn, have to 
c...read as real variable first and then convert to integer so that it
c...works both on Sun and HP.
c
      open (11,file='mb.inp',status='old')
      read (11,'(a72)') title
      read (11,'(a4)') machin
      read (11,'(a6)') CALC 
c      write(*,888) CALC
c 888  format(a6)
      read (11,*) nmat
      do 20 j=1,nmat
   20 read (11,*) mt(j)
      do 30 j=1,nmat
   30 read (11,*) voli(j)
      read (11,*) pow
      read (11,*) qu235
      read (11,*) days
      read (11,*) nouter
      read (11,*) ninner
      read (11,*) npre
      read (11,*) nrst
      read (11,'(a10)') olib
      read (11,'(a72)') locale
      read (11,*) frimp
      read (11,*) nkeff
      do 60 j=1,nmat
      read (11,*) nauto(j)
      read (11,*) ntot(j)
      do 60 i=1,ntot(j)
      read (11,'(a10)') niso(i,j)
      backspace (11)
      read (11,'(f6.1)') x
   60 nisn(i,j)=x
      read (11,*) mbxs
      close (11)
c
c...Assign origin iso names
c
      do 10 j=1,nmat
      do 10 i=1,ntot(j)
      nisor5=niso(i,j)
      met='0'
      if (nisor5.eq.'95242') met='1'
   10 nisor(i,j)=nisor5//met
c
      do 15 j=1,nmat
      do 15 i=1,ntot(j)
      nisnr(i,j)=nisn(i,j)*10
      if (nisnr(i,j).eq.952420) nisnr(i,j)=nisnr(i,j)+1
   15 continue
c
      return
      end
c
c23456789*123456789*123456789*123456789*123456789*123456789*123456789*12
c
c...PCARD checks mcnp input file for print card, and alters or adds one
c...(only run once at beginning of monteburns)
c
      subroutine pcard
      common /mbinp/nmat,mt(49),voli(49),pow,qu235,days,nouter,ninner,
     & npre,nrst,frimp,nauto(49),ntot(49),nkeff,mbxs,nisn(999,49),
     & nisnr(999,49)
      common /mbinp2/niso(999,49),nisor(999,49),title,olib,locale,posit,
     &     tmpfile,machin,CALC
      character niso*10,nisor*6,title*72,olib*10,locale*72,posit*1,
     &          ju5*5,ju80*80,m(30)*1,file1t*22,file2t*22,tmpfile*10,
     &          file3t*22,file4a*22,file4b*22,file5t*22,file5x*22,
     &          file7t*22,file8t*22,fname*22,fil12t*22,fil12a*22,
     &          fil14t*22,fil15t*22,fil16t*22,fil17t*22,machin*4,
     &          filen*19,fil18t*22,CALC*6
      integer first
c
c...  Used to keep track if materials have been processed yet or 
c...    not (blank lines following materials are removed)
c
      iflag = 0
      k = 0
      if (machin(1:3).ne.'VMS') then
        open (12,file='mbmc',status='unknown')
        nphys = 0
c
   10   k=k+1
        read (5,'(a5)',end=15) ju5
        if (ju5.eq.'print'.or.ju5.eq.'PRINT') ni=k
        if (ju5.eq.'phys:') then
          nphys = 1
        endif
        goto 10
   15   rewind (5)
c
c  Portray if HTAPE run is needed or not (0 = no, 1 = yes)
c 
        if (olib(1:6).eq.'CINDER') then
          open (7,file=tmpfile//'htape.tmp',status='unknown')
          write (7,'(i4)') nphys 
          close (7)
        endif
c
   20   do 25 n=1,k-1
        read (5,'(a80)') ju80
c
        if (n.ne.ni) then
          if (ju80(1:20).ne.'                    ') then
            write (12,'(a80)') ju80
          else
            if (nn.ne.2) then
              nn = nn + 1
              write (12,'(a80)') ju80
            endif
          endif
        else
          write (12,'(a8)') 'print 40'
        end if
   25 continue
      if (ni.eq.0) write (12,'(a8)') 'print 40'
      if (olib(1:6).eq.'CINDER'.and.nphys.eq.1) then
        write (12,'(a5)') 'histp' 
      endif
c
c...  Obtain initial file for VMS system
c
      elseif (machin(1:3).eq.'VMS') then
        open (12,file='mbmc.dat',status='unknown')
c
   30   k=k+1
        read (55,'(a5)',end=32) ju5
        if (ju5.eq.'print'.or.ju5.eq.'PRINT') ni=k
        goto 30
   32   rewind (55)
   34   do 38 n=1,k-1
        read (55,'(a80)') ju80
        if (n.ne.ni) then
c          if (ju80(1:20).ne.'                    ') then
            write (12,'(a80)') ju80
c          endif
        else
          write (12,'(a8)') 'print 40'
        end if
   38   continue
        if (ni.eq.0) write (12,'(a8)') 'print 40'
      endif
c
      close (12)
c
c...Remove mt card and write mbmc.skl
c
      if (machin(1:3).ne.'VMS') then
        open (11,file='mbmc',status='unknown')
      elseif (machin(1:3).eq.'VMS') then
        open (11,file='mbmc.dat',status='unknown')
      endif
      open (12,file='mbmc.skl',status='unknown')
c
      n = 0
      first = 0
   40 read (11,'(30a1)',end=50) (m(i),i=1,30)
      ifd = 0
      nogo=0
      do 45 i=1,30
   45 if (m(i).ne.' ') nogo=1
c
      if (nogo.eq.0.and.iflag.eq.1) goto 40 
      if ((m(1).eq.'m'.or.m(1).eq.'M').and.first.ne.0) then
        if (m(2).eq.'x'.or.m(2).eq.'X') goto 80     
        iflag = 1 
        do 47 i=6,2,-1
         if (m(i).eq.' ') ii=i
   47   continue
        matr=0
        do 48 i=2,ii-1
   48   matr=matr+(ichar(m(i))-48)*10**(ii-1-i)
c
c... Identify if MCNP material is one of the user requested materials
c
        do 49 j=1,nmat
   49     if (matr.eq.abs(mt(j))) ifd=1
   80 end if
      first = 1
c
c... Print lines excluding user-specified material identifiers to skeleton
c...       removing blank lines as you go (except for first two, which 
c...       separate cell cards from surface cards and surface cards from
c...       material cards)
c
      if (ifd.eq.0) then
        backspace(11)
        read (11,'(a80)') ju80
        write (12,'(a80)') ju80
        goto 40
      else
c
c... If MCNP material is equal to user specified one, then print material
c... identification cards to appropriate output file.
c
c       if (iflag.eq.1) then
        do 52 j=1,nmat
        if (matr.eq.abs(mt(j))) then
          if (j.lt.10) then
            fname = tmpfile//'mat_'//char(j+48)//'.inp'
          elseif (j.ge.10) then
            j1 = j/10
            j2 = j - j1*10
            fname = tmpfile//'mat_'//char(j1+48)//char(j2+48)//'.inp'
          endif
          open (13,file=fname,status='unknown')
          n = n + 1
        endif
   52   continue
       endif
       backspace(11)
       read (11,'(a80)') ju80
       write (13,'(a80)') ju80
   51  read (11,'(20a1)',end=50) (m(i),i=1,20) 
       nomat=0
       nomat2=0
       do 53 i=1,5
   53     if (m(i).ne.' ') nomat=1
       do 54 i=1,20
   54     if (m(i).ne.' ') nomat2=1
       if (nomat.eq.1.or.nomat2.eq.0) then
          backspace (11)
          goto 40
       else
          backspace (11)
          read (11,'(a80)') ju80
          write (13,'(a80)') ju80
          goto 51
       endif
c      end if
c      goto 40
c
   50 close(12)
      close (11)
c
c... Create output files and label them.  "mb11t.out" does not depend on the
c... material, the others do.  mb13t.out contains only beginning of step
c
        if (frimp.lt.0.) frimp = abs(frimp)
        filen = tmpfile//'mb11t.out'
        open (14,file=filen,status='unknown')
        write (14,'(a72)') title
        write (14,961) pow,days,nouter,ninner,npre,frimp
        write (14,'(a33)') 'Monteburns MCNP k-eff Versus Time'
        write (14,'(a34,a30)') '        days    k-eff     rel err ',
     &                   '    nu       avQfis      k-inf'
        close (14)
c
        filen = tmpfile//'mb13t.out'
        open (14,file=filen,status='unknown')
        write (14,'(/,a34,a8)') 'Monteburns MCNP k-eff at Beginning',
     &     ' of Step'
        write (14,'(a34,a6)') '        days    k-eff     rel err ',
     &                 '    nu'
        close (14)
c
c... Create file names
c
        do 70 j=1,nmat
        if (j.lt.10) then
          file1t = tmpfile//'mb1t_'//char(j+48)//'.out'
          file2t = tmpfile//'mb2t_'//char(j+48)//'.out'
          file3t = tmpfile//'mb3t_'//char(j+48)//'.out'
          file4a = tmpfile//'mb4a_'//char(j+48)//'.out'
          file4b = tmpfile//'mb4b_'//char(j+48)//'.out'
          file5t = tmpfile//'mb5t_'//char(j+48)//'.out'
          file5x = tmpfile//'mb5tx_'//char(j+48)//'.out'
          file7t = tmpfile//'mb7t_'//char(j+48)//'.out'
          file8t = tmpfile//'mb8t_'//char(j+48)//'.out'
          fil12t = tmpfile//'mb12t_'//char(j+48)//'.out'
          fil12a = tmpfile//'mb12a_'//char(j+48)//'.out'
          fil14t = tmpfile//'mb14t_'//char(j+48)//'.out'
          fil15t = tmpfile//'mb15t_'//char(j+48)//'.out'
          fil16t = tmpfile//'mb16t_'//char(j+48)//'.out'
          fil17t = tmpfile//'mb17t_'//char(j+48)//'.out'
          fil18t = tmpfile//'mb18t_'//char(j+48)//'.out'
        elseif (j.ge.10) then
          j1 = j/10
          j2 = j - j1*10
          file1t = tmpfile//'mb1t_'//char(j1+48)//
     &                               char(j2+48)//'.out'
          file2t = tmpfile//'mb2t_'//char(j1+48)//
     &                               char(j2+48)//'.out'
          file3t = tmpfile//'mb3t_'//char(j1+48)//
     &                               char(j2+48)//'.out'
          file4a = tmpfile//'mb4a_'//char(j1+48)//
     &                               char(j2+48)//'.out'
          file4b = tmpfile//'mb4b_'//char(j1+48)//
     &                               char(j2+48)//'.out'
          file5t = tmpfile//'mb5t_'//char(j1+48)//
     &                               char(j2+48)//'.out'
          file5x = tmpfile//'mb5tx_'//char(j1+48)//
     &                               char(j2+48)//'.out'
          file7t = tmpfile//'mb7t_'//char(j1+48)//
     &                               char(j2+48)//'.out'
          file8t = tmpfile//'mb8t_'//char(j1+48)//
     &                               char(j2+48)//'.out'
          fil12t = tmpfile//'mb12t_'//char(j1+48)//
     &                               char(j2+48)//'.out'
          fil12a = tmpfile//'mb12a_'//char(j1+48)//
     &                               char(j2+48)//'.out'
          fil14t = tmpfile//'mb14t_'//char(j1+48)//
     &                               char(j2+48)//'.out'
          fil15t = tmpfile//'mb15t_'//char(j1+48)//
     &                               char(j2+48)//'.out'
          fil16t = tmpfile//'mb16t_'//char(j1+48)//
     &                               char(j2+48)//'.out'
          fil17t = tmpfile//'mb17t_'//char(j1+48)//
     &                               char(j2+48)//'.out'
          fil18t = tmpfile//'mb18t_'//char(j1+48)//
     &                               char(j2+48)//'.out'
        endif
c
        filen = tmpfile//'mb1.txt'
        open (14,file=tmpfile//'mb1.txt',status='unknown')
        write (14,'(/,a29)') 'Monteburns Transport History '
        close (14)
        open (14,file=file1t,status='unknown')
        write (14,'(/,a29,a12,i3,22x,a14,32x,a20)')
     &   'Monteburns Transport History ',
     &   'for material',j,'total material','for actinide    '
        write (14,'(a25,a60,a58,a17)') '      Qfis     Flux      ',
     &   'SigmaF    Power    Pow.Den.     Burnup   n,gamma   n,fission',
     &   ' fis/cap   n2n        eta      n,gamma   n,fission fis/cap',
     &   '   n2n        eta'
        write (14,'(a25,a60,a58,a11)') '     (MeV)   (n/cm^2-s)  ',
     &   '(1/cm)    (MW)     (W/cc)      (GWd/MTU) (barns)   (barns)  ',
     &   '           (barns)             (barns)   (barns)          ',
     &   '   (barns) '
        close (14)
        filen = tmpfile//'mb2.txt'
        open (14,file=filen,status='unknown')
        write (14,'(/,a41)') 'Monteburns 1-group n,gamma Cross Sections'
        close (14)
        open (14,file=file2t,status='unknown')
        write (14,'(/,a33,a21,i3)')
     &   'Monteburns 1-group n,gamma Cross ',
     &   'Sections for material',j
        write (14,'(3x,a9,250(1x,a9))') (niso(i,j),i=1,nauto(j))
        close (14)
        filen = tmpfile//'mb3.txt'
        open (14,file=filen,status='unknown')
        write (14,'(/,a41)') 'Monteburns 1-group Fission Cross Sections'
        close (14)
        open (14,file=file3t,status='unknown')
        write (14,'(/,a33,a21,i3)')
     &   'Monteburns 1-group Fission Cross ',
     &   'Sections for material',j
        write (14,'(3x,a9,250(1x,a9))') (niso(i,j),i=1,nauto(j))
        close (14)
        filen = tmpfile//'mb4a.txt'
        open (14,file=filen,status='unknown')
        write (14,'(/,a72)') title
        write (14,961) pow,days,nouter,ninner,npre,frimp
        write (14,'(a43)') 'Monteburns Spectrum for Each Predictor Step'
        close (14)
        open (14,file=file4a,status='unknown')
        write (14,'(/,a29,a27,i3)')
     &     'Monteburns Spectrum for Each ',
     &     'Predictor Step for material',j
        write (14,'(a5,a58)') '     ',
     &   '   <.1eV      <1eV    <100eV   <100keV     <1MeV    <20MeV'
        close (14)
        filen = tmpfile//'mb4b.txt'
        open (14,file=filen,status='unknown')
        write (14,'(/,a28)') 'Monteburns Grams at Midpoint'
        close (14)
        open (14,file=file4b,status='unknown')
        write (14,'(/,a28,a13,i3)')
     &   'Monteburns Grams at Midpoint',
     &   ' for material',j
        write (14,'(a40)') '1st row is actual, 2nd row was predicted'
        write (14,'(3x,a9,250(1x,a9))')(niso(i,j),i=1,nauto(j)),
     &   'actinide'
        close (14)
        filen = tmpfile//'mb5.txt'
        open (14,file=filen,status='unknown')
        write (14,'(/,a44)')
     &   'Monteburns Grams of Material at End of Steps'
        close (14)
        filen = tmpfile//'mb12.txt'
        open (14,file=filen,status='unknown')
        write (14,'(/,a50)')
     &   'Monteburns Grams of Material at Beginning of Steps'
        close (14)
        open (14,file=file5t,status='unknown')
        write (14,'(/,a44,a13,i3)')
     &   'Monteburns Grams of Material at End of Steps',
     &   ' for material',j
        write (14,'(3x,a9,250(1x,a9))')(niso(i,j),i=1,nauto(j)),
     &   'actinide'
        close (14)
        open (14,file=fil12t,status='unknown')
        write (14,'(/,a47,a13,i3)')
     &   'Monteburns Grams of Material at Begin. of Steps',
     &   ' for material',j
        write (14,'(3x,a9,250(1x,a9))')(niso(i,j),i=1,nauto(j)),
     &   'actinide'
        close (14)
        open (14,file=file5x,status='unknown')
        write (14,'(/,a44,a13,i3)')
     &   'Monteburns Grams of Material at End of Steps',
     &   ' for material',j
        write (14,'(3x,a9,250(1x,a9))')(niso(i,j),i=1,nauto(j)),
     &   'actinide'
        close (14)
        open (14,file=fil12a,status='unknown')
        write (14,'(/,a47,a13,i3)')
     &   'Monteburns Grams of Material at Begin. of Steps',
     &   ' for material',j
        write (14,'(3x,a9,250(1x,a9))')(niso(i,j),i=1,nauto(j)),
     &   'actinide'
        close (14)
        filen = tmpfile//'mb14.txt'
        open (14,file=filen,status='unknown')
        write (14,'(/,a52)')
     &   'Monteburns Activity (Ci) of Material at End of Steps'
        close (14)
        open (14,file=fil14t,status='unknown')
        write (14,'(/,a39,i3)')
     &   'Monteburns Activities (Ci) for material',j
        write (14,'(3x,a9,250(1x,a9))')(niso(i,j),i=1,nauto(j)),
     &   'actinide','total    '
        close (14)
        filen = tmpfile//'mb15.txt'
        open (14,file=filen,status='unknown')
        write (14,'(/,a51)')
     &   'Monteburns Heatload (W) of Material at End of Steps'
        close (14)
        open (14,file=fil15t,status='unknown')
        write (14,'(/,a37,i3)')
     &   'Monteburns Heatloads (W) for material',j
        write (14,'(3x,a9,250(1x,a9))')(niso(i,j),i=1,nauto(j)),
     &   'actinide','total    '
        close (14)
        filen = tmpfile//'mb16.txt'
        open (14,file=filen,status='unknown')
        write (14,'(/,a60,a8)')
     &   'Monteburns Inhalation Toxicity (m^3 air) of Material at End ',
     &   'of Steps'
        close (14)
        open (14,file=fil16t,status='unknown')
        write (14,'(/,a55,i3)')
     &   'Monteburns Inhalation Toxicities (m^3 air) for material',j
        write (14,'(3x,a9,250(1x,a9))')(niso(i,j),i=1,nauto(j)),
     &   'actinide'
        close (14)
        filen = tmpfile//'mb17.txt'
        open (14,file=filen,status='unknown')
        write (14,'(/,a61,a9)')
     &   'Monteburns Ingestion Toxicity (m^3 water) of Material at End',
     &   ' of Steps'
        close (14)
        open (14,file=fil17t,status='unknown')
        write (14,'(/,a57,i3)')
     &   'Monteburns Ingestion Toxicities (m^3 water) for material',j
        write (14,'(3x,a9,250(1x,a9))')(niso(i,j),i=1,nauto(j)),
     &   'actinide'
        close (14)
        filen = tmpfile//'mb18.txt'
        open (14,file=filen,status='unknown')
        write (14,'(/,a52)')
     &   'Fractional Error for Isotopic Compositions'
        close (14)
        open (14,file=fil18t,status='unknown')
        write (14,'(/,a39,i3)')
     &   'Fractional Error for material',j
        write (14,'(3x,a9,250(1x,a9))')(niso(i,j),i=1,nauto(j))
        close (14)
        filen = tmpfile//'mb7.txt'
        open (14,file=filen,status='unknown')
        write (14,'(/,a30,a34,i3)') 'Fractional Importance of Radio'
     &     ,'nuclides Sent From ORIGEN2 to MCNP'
        close (14)
        open (14,file=file7t,status='unknown')
        write (14,'(/,a57,/,a20,i3)')
     &     'Fractional Importance of Radionuclides Sent From ORIGEN2 ',
     &     'to MCNP for material',j
        write (14,'(/,a5,a55,a7)') 'step#',
     &     '       isotope grams     mass fra  atom fra  capture   ',
     &     'fission'
        close (14)
        filen = tmpfile//'mb8.txt'
        open (14,file=filen,status='unknown')
        write (14,'(/,a29,a6,i3)') 'Monteburns Fission-to-Capture',
     &     ' Ratio'
        close (14)
        open (14,file=file8t,status='unknown')
        write (14,'(/,a29,a19,i3)') 'Monteburns Fission-to-Capture',
     &   ' Ratio for material',j
        write (14,'(3x,a9,250(1x,a9))')(niso(i,j),i=1,nauto(j))
        close (14)
  961   format (/'Total Power (MW) =',1pe10.2,'   Days =',1pe10.2,/
     &   '# outer steps =',i3,',  # inner steps =',i3,
     &   ',  # predictor steps =',i2,/
     &   'Importance Fraction = ',0pf6.4/)
   70   continue
c
      return
      end
c
c23456789*123456789*123456789*123456789*123456789*123456789*123456789*12
c
c...WTALLY2 writes the tally cards to tal2.inp which is appended
c...to mcnp input file, and creates new mbmc file that does not
c...include tallied materials (run only once at beginning of monteburns)
c
      subroutine wtal2
      common /mbinp/nmat,mt(49),voli(49),pow,qu235,days,nouter,ninner,
     & npre,nrst,frimp,nauto(49),ntot(49),nkeff,mbxs,nisn(999,49),
     & nisnr(999,49)
      common /mbinp2/niso(999,49),nisor(999,49),title,olib,locale,posit,
     &     tmpfile,machin,CALC
      character niso*10,nisor*6,title*72,olib*10,locale*72,posit*1,
     &      machin*4,ju6*6,tcell(999,49)*6,ncell*6,file6t*22,file2*22,
     &      tmpfile*10,filen*18,CALC*6
      dimension vol(49),ntc(49)
c
c...Determine cells to tally
c
      do 12 j=1,nmat
        ntc(j)=0
        vol(j)=0.0
   12 continue
c
      if (machin(1:3).ne.'VMS') then
        open (55,file='mbmco',status='old')
      elseif (machin(1:3).eq.'VMS') then
        open (55,file='mbmco.dat',status='old')
      endif
   40 read (55,'(a6)') ju6
      if (ju6.ne.'1cells') goto 40
c
      read (55,'(///)')
   50 read (55,'(i6,a6,i5,1x,1p3e12.5)') n,ncell,nmt,aden,gden,vol1
      do 55 j=1,nmat
      if (nmt.eq.abs(mt(j))) then 
        ntc(j)=ntc(j)+1
        tcell(ntc(j),j)=ncell
        vol(j)=vol(j)+vol1
        write(*,*)'VOLUME',j,vol1,vol(j)
      end if
   55 continue
      if (n.ne.0) goto 50
c
c...Write tally2 file
c
      do 100 j=1,nmat
c
c   For CINDER 90, also write 'inthe..' files for HTAPE
c
       if (olib(1:6).eq.'CINDER') then
         if (j.eq.1) then
           open (7,file='inthe08',status='unknown')
           write (7,'(a35,a19)') 'HTAPE int deck: residual mass edits',
     &         ' for CINDER90 input'
           open (8,file='inthe14',status='unknown')
           write (8,'(a35,a19)') 'HTAPE int deck: residual mass edits',
     &         ' for CINDER90 input'
           open (9,file='inthe15',status='unknown')
           write (9,'(a35,a19)') 'HTAPE int deck: residual mass edits',
     &         ' for CINDER90 input'
         elseif (j.eq.27) then
           close (7)
           close (8)
           close (9)
           open (7,file='inthe08a',status='unknown')
           write (7,'(a36,a19)') 'HTAPE int deck2: residual mass edits',
     &         ' for CINDER90 input'
           open (8,file='inthe14a',status='unknown')
           write (8,'(a36,a19)') 'HTAPE int deck2: residual mass edits',
     &         ' for CINDER90 input'
           open (9,file='inthe15a',status='unknown')
           write (9,'(a36,a19)') 'HTAPE int deck2: residual mass edits',
     &         ' for CINDER90 input'
         endif 
         write (7,'(a6,i2,a10,i2)') 'MB mat',j,' MCNP mat ',abs(mt(j))
         write (8,'(a6,i2,a10,i2)') 'MB mat',j,' MCNP mat ',abs(mt(j))
         write (9,'(a6,i2,a10,i2)') 'MB mat',j,' MCNP mat ',abs(mt(j))
         write (7,'(a10,i4,a6)') '108,,,,,  ',ntc(j),',,,,1/'
         write (8,'(a10,i4,a6)') '114,,,,,  ',ntc(j),',,,,1/'
         write (9,'(a10,i4,a6)') '115,,,,,  ',ntc(j),',,,,1/'
         do 70 i=1,ntc(j)/8
         write (7,932) (tcell(k,j),k=(i-1)*8+1,i*8)
         write (8,932) (tcell(k,j),k=(i-1)*8+1,i*8)
   70    write (9,932) (tcell(k,j),k=(i-1)*8+1,i*8)
         if ((ntc(j) - (ntc(j)/8)*8).eq.0) then
           backspace (7)
           backspace (8)
           backspace (9)
           write (7,933) (tcell(k,j),k=(ntc(j)/8)*8-7,ntc(j))
           write (8,933) (tcell(k,j),k=(ntc(j)/8)*8-7,ntc(j))
           write (9,933) (tcell(k,j),k=(ntc(j)/8)*8-7,ntc(j))
         elseif ((ntc(j) - (ntc(j)/8)*8).eq.7) then
           write (7,934) (tcell(k,j),k=(ntc(j)/8)*8+1,ntc(j))
           write (8,934) (tcell(k,j),k=(ntc(j)/8)*8+1,ntc(j))
           write (9,934) (tcell(k,j),k=(ntc(j)/8)*8+1,ntc(j))
         elseif ((ntc(j) - (ntc(j)/8)*8).eq.6) then
           write (7,935) (tcell(k,j),k=(ntc(j)/8)*8+1,ntc(j))
           write (8,935) (tcell(k,j),k=(ntc(j)/8)*8+1,ntc(j))
           write (9,935) (tcell(k,j),k=(ntc(j)/8)*8+1,ntc(j))
         elseif ((ntc(j) - (ntc(j)/8)*8).eq.5) then
           write (7,936) (tcell(k,j),k=(ntc(j)/8)*8+1,ntc(j))
           write (8,936) (tcell(k,j),k=(ntc(j)/8)*8+1,ntc(j))
           write (9,936) (tcell(k,j),k=(ntc(j)/8)*8+1,ntc(j))
         elseif ((ntc(j) - (ntc(j)/8)*8).eq.4) then
           write (7,937) (tcell(k,j),k=(ntc(j)/8)*8+1,ntc(j))
           write (8,937) (tcell(k,j),k=(ntc(j)/8)*8+1,ntc(j))
           write (9,937) (tcell(k,j),k=(ntc(j)/8)*8+1,ntc(j))
         elseif ((ntc(j) - (ntc(j)/8)*8).eq.3) then
           write (7,938) (tcell(k,j),k=(ntc(j)/8)*8+1,ntc(j))
           write (8,938) (tcell(k,j),k=(ntc(j)/8)*8+1,ntc(j))
           write (9,938) (tcell(k,j),k=(ntc(j)/8)*8+1,ntc(j))
         elseif ((ntc(j) - (ntc(j)/8)*8).eq.2) then
           write (7,939) (tcell(k,j),k=(ntc(j)/8)*8+1,ntc(j))
           write (8,939) (tcell(k,j),k=(ntc(j)/8)*8+1,ntc(j))
           write (9,939) (tcell(k,j),k=(ntc(j)/8)*8+1,ntc(j))
         elseif ((ntc(j) - (ntc(j)/8)*8).eq.1) then
           write (7,940) (tcell(k,j),k=(ntc(j)/8)*8+1,ntc(j))
           write (8,940) (tcell(k,j),k=(ntc(j)/8)*8+1,ntc(j))
           write (9,940) (tcell(k,j),k=(ntc(j)/8)*8+1,ntc(j))
         endif
  932    format (7x,8(a6,1x))
  933    format (7x,8(a6,1x),'/ ')
  934    format (7x,7(a6,1x),'/ ')
  935    format (7x,6(a6,1x),'/ ')
  936    format (7x,5(a6,1x),'/ ')
  937    format (7x,4(a6,1x),'/ ')
  938    format (7x,3(a6,1x),'/ ')
  939    format (7x,2(a6,1x),'/ ')
  940    format (7x,a6,1x,'/ ')
         if (j.ne.nmat) write (7,*)
         if (j.ne.nmat) write (8,*)
         if (j.ne.nmat) write (9,*)
      endif
c
      if (j.lt.10) then
        file2  = tmpfile//'tal2_'//char(j+48)//'.inp'
        file6t = tmpfile//'mb6t_'//char(j+48)//'.out'
      elseif (j.ge.10) then
        j1 = j/10
        j2 = j - j1*10
        file2  = tmpfile//'tal2_'//char(j1+48)//char(j2+48)//'.inp'
        file6t = tmpfile//'mb6t_'//char(j1+48)//char(j2+48)//'.out'
      endif
      if (voli(j).ne.0.) vol(j)=voli(j)
      if (vol(j).eq.0) then
        write (6,*) '***** MB ERROR: No tally volume'
        stop
      end if  
      open (11,file=file2,status='unknown')
      if (j.eq.1.and.olib(1:6).eq.'CINDER') then
        write (11,910)
  910   format ('e0       5.00000e-9 1.00000e-8 1.50000e-8 2.00000e-8',/
     &  '      2.50000e-8 3.00000e-8 3.50000e-8 4.20000e-8 5.00000e-8',/
     &  '      5.80000e-8 6.70000e-8 8.00000e-8 1.00000e-7 1.52000e-7',/
     &  '      2.51000e-7 4.14000e-7 6.83000e-7 1.12500e-6 1.85500e-6',/
     &  '      3.05900e-6 5.04300e-6 8.31500e-6 1.37100e-5 2.26000e-5',/
     &  '      3.72700e-5 6.14400e-5 1.01300e-4 1.67000e-4 2.75400e-4',/
     &  '      4.54000e-4 7.48500e-4 1.23400e-3 2.03500e-3 2.40400e-3',/
     &  '      2.84000e-3 3.35500e-3 5.53100e-3 9.11900e-3 1.50300e-2',/
     &  '      1.98900e-2 2.55400e-2 4.08700e-2 6.73800e-2 1.11100e-1',/
     &  '      1.83200e-1 3.02000e-1 3.88700e-1 4.97900e-1 6.39279e-1',/
     &  '      8.20850e-1 1.10803e+0 1.35335e+0 1.73774e+0 2.23130e+0',/
     &  '      2.86505e+0 3.67879e+0 4.96585e+0 6.06500e+0 1.00000e+1',/
     &  '      1.49182e+1 1.69046e+1 2.00000e+1 2.50000e+1'/
     &  'fq0  e f')
      endif
c
c...Write energy tallies (tally numbers range from 14 to 494)
c... (1 to 49 represents material number)
c
      write (11,911) (10+j)
  911 format ('c'/'f',i2,'4:n  (')
      do 80 i=1,ntc(j)
   80 write (11,912) tcell(i,j)
  912 format (7x,a6,' ')
      write (11,913)
  913 format (14x,')')
      if (olib(1:6).eq.'CINDER') then
        write (11,916) (10+j),(10+j),vol(j)
      else 
        write (11,915) (10+j),(10+j),vol(j),(10+j)
      endif
  915 format ('fc',i2,'4  MonteBurns Energy Spectrum Tallies'/
     &  'sd',i2,'4  ',1pe12.5/
     &  'e',i2,'4    1.0e-7 1.0e-6 1.0e-4 1.0e-1 1.0 20.0')        
  916 format ('fc',i2,'4  MonteBurns Energy Spectrum Tallies'/
     &  'sd',i2,'4  ',1pe12.5)

c...Write header for xs tallies
c
        write (11,911) (50+j)
        do 90 i=1,ntc(j)
   90   write (11,922) tcell(i,j)
  922   format (7x,a6,' ')
        write (11,923)
  923   format (14x,')')
        write (11,924) (50+j),(50+j),vol(j),(50+j)
  924   format ('fc',i2,'4  MonteBurns Cross Section Tallies'/
     &  'sd',i2,'4  ',1pe12.5/'fm',i2,'4   (1)')
c
      filen = tmpfile//'mb6.txt'
      open (14,file=filen,status='unknown')
      write (14,'(/,a24)') 'Monteburns Flux Spectrum'
      close (14)
      open (14,file=file6t,status='unknown')
      write (14,'(/,a25,a12,i3)') 'Monteburns Flux Spectrum ',
     & 'for material',j
      write (14,'(a63)') 
     & '        <.1eV      <1eV    <100eV   <100keV     <1MeV    <20MeV'
      close (14)
  100 continue
      close (7)
      close (8)
      close (9)
      close (11)
c
      return  
      end   
c
c23456789*123456789*123456789*123456789*123456789*123456789*123456789*12
c
c...WTALLY writes the tally cards to tal1.inp and tal3.inp which 
c...are appended to mcnp input file
c
      subroutine wtally
      common /mbinp/nmat,mt(49),voli(49),pow,qu235,days,nouter,ninner,
     & npre,nrst,frimp,nauto(49),ntot(49),nkeff,mbxs,nisn(999,49),
     & nisnr(999,49)
      common /mbinp2/niso(999,49),nisor(999,49),title,olib,locale,posit,
     &     tmpfile,machin,CALC
      character niso*10,nisor*6,title*72,olib*10,locale*72,posit*1,
     &      machin*4,file1*22,file3*22,tmpfile*10,CALC*6
c
c...Write tally files 1 and 3
c
      ii = 100
      ij = 9900
      do 100 j=1,nmat
      iflag = 0
      if (j.lt.10) then
        file1 = tmpfile//'tal1_'//char(j+48)//'.inp'
        file3 = tmpfile//'tal3_'//char(j+48)//'.inp'
      elseif (j.ge.10) then
        j1 = j/10
        j2 = j - j1*10
        file1 = tmpfile//'tal1_'//char(j1+48)//char(j2+48)//'.inp'
        file3 = tmpfile//'tal3_'//char(j1+48)//char(j2+48)//'.inp' 
      endif
      open (11,file=file1,status='unknown')
      open (12,file=file3,status='unknown')
      do 90 i=1,ntot(j)
      ii=ii+1
      if (ii.gt.999) then
       write (11,902) ii,niso(i,j)
      else
       write (11,901) ii,niso(i,j)
      endif
  901 format ('m',i3,4x,a10,'   1.0')
  902 format ('m',i4,4x,a10,'   1.0')
c
c   Equate (n,t) reaction to (n,alpha) for Lithium-6
c   All others are true (n,alpha) cross sections
c
      if (nisn(i,j).eq.3006.or.nisn(i,j).eq.3007) then
        write (12,920) ii
      elseif (nisn(i,j).lt.89000) then
        write (12,921) ii
      elseif (nisn(i,j).ge.89000) then
        iflag = 1
        write (12,922) ii
      endif
   90 continue
      ij = ij + 1 
      if (iflag.eq.1) write (12,923) ij
      write (12,923) abs(mt(j))
      close (11)
  100 continue
c
c       -2 is the total capture cross section
c       16 is (n,2n) cross section
c       105 is (n,t) cross section
c       107 is (n,alpha) cross section
c       103 is (n,p) cross section (for activation products)
c       17 is (n,3n) cross section
c       -6 is the total fission cross section (for actinides)
c       452 is nu bar - only used for verification purposes
c
  920 format (8x,'(1 ',i4,' (102)  (16)  (105) (103))')
  921 format (8x,'(1 ',i4,' (102)  (16)  (107) (103))')
  922 format (8x,'(1 ',i4,' (102)  (16)  (17)  (-6))')
  923 format (8x,'(1 ',i4,' (-2)  (16)  (17) (-6))')
c
      return  
      end   
c
c23456789*123456789*123456789*123456789*123456789*123456789*123456789*12
c
c...WORCOMP writes composition input file for origen TAPE7, which is
c...read by origen as TAPE4.  Units are g-atoms (grams / atomic mass)
c...(one time execute at beginning of monteburns)
c
      subroutine worcom
c      
      common /mbinp/nmat,mt(49),voli(49),pow,qu235,days,nouter,ninner,
     & npre,nrst,frimp,nauto(49),ntot(49),nkeff,mbxs,nisn(999,49),
     & nisnr(999,49)
      common /mbinp2/niso(999,49),nisor(999,49),title,olib,locale,posit,
     &     tmpfile,machin,CALC
      character niso*10,nisor*6,title*72,olib*10,locale*72,posit*1,
     &      machin*4,fmcnp*22,nmcnp*20,ju30*30,vers*2,tmpfile*10,
     &      ju6*6,ju10*10,met*1,fname*12,fnat*22,filen*17,ninat*10,
     &      filem*12,CALC*6
      real atomfr(20,33),gmat(999,49,20),f(999,49),gden(49),vol(49),
     & aix(999,49,20),aden(49),aa(999,49),fn(999)
      integer ij(49),nelem(34),nisop(33),nisot(20,33),nc(99),nuc(999,49)
     & ,naix(999,49,20),iflag(999,49),ik(999,49),totk
c
      if (machin(1:3).ne.'VMS') then
        open (55,file='mbmco',status='old')
      elseif (machin(1:3).eq.'VMS') then
        open (55,file='mbmco.dat',status='old')
      endif
      read (55,'(a30)') ju30
      if (ju30(19:20).eq.'4b') vers = '4b'
      if (ju30(19:20).eq.'4c') vers = '4c'
      if (ju30(6:6).eq.'x'.and.ju30(19:19).eq.'2') vers = 'x5'
      if (ju30(19:20).eq.'4a') vers = '4a' 
      ifra = 0
   10 read (55,'(32x,a10)') ju10
      if (ifra.eq.0) then
        if (ju10.ne.'atom fract') goto 10
      else 
        if (ju10.ne.'mass fract') goto 10
      endif
c
c...Read mass fractions for material
c      
      ifd = 0
      read (55,*)
   20 if (ifra.eq.0) then 
        read (55,'(a10)') ju10
        if (ju10.eq.' associate') then
          goto 20
        elseif (ju10.eq.'1material ') then
          ifra = 1
          goto 10
        else
          backspace (55)
        endif 
      endif
      if (vers.eq.'4a') then
c
c...  The next line is for MCNP4A
c
        read (55,'(i6,5x,4(6x,i5,2x,f8.5))')
     &  mtn,(nc(i),fn(i),i=1,4)
      elseif (vers(1:1).eq.'x') then
c
c...  The next line is for MCNPX, Vers.2.1.5
c
        read (55,'(i6,5x,4(6x,i5,2x,1pe17.11))')
     &  mtn,(nc(i),fn(i),i=1,4)
      else
c
c...  The next line is for MCNP4B or 4C
c
        read (55,'(i6,5x,4(6x,i5,2x,1pe11.5))')
     &  mtn,(nc(i),fn(i),i=1,4)
      endif
      ii = 0
      im = 0 
      do 25 j=1,nmat
      if (mtn.eq.abs(mt(j))) then
        do 22 i=1,4
        nuc(i,j) = nc(i)
        if (ifra.eq.0) then
          aa(i,j) = fn(i)
        else
          f(i,j) = fn(i)    
        endif
   22   continue
        nmt = j
        im = 1
        ifd = ifd + 1
      endif
   25 continue
      if (im.eq.0) goto 20
c
   30 ii=ii+4
      read (55,'(a6,26x,a10)') ju6,ju10
      if (ju10.eq.'mass fract') then
         write (6,*) 'not all mats have atom fract.'
         stop
c         backspace (55)
c         ifra = 1
c         goto 10
      elseif (ju6.eq.'1cells') then
c         ii=ii-4
c         ij(nmt) = ii
         write (6,*) 'not all mats have mass fract.'
         stop
c         goto 42
      else
         backspace (55)
      endif         
c
c...  The next line is for MCNP4A
c
      if (ifra.eq.0) then
        read (55,'(a10)') ju10
        if (ju10.eq.' associate') then
          goto 20
        elseif (ju10.eq.'1material ') then
          ifra = 1
          goto 10
        else
          backspace (55)
        endif
      endif
      if (vers.eq.'4a') then
        read (55,'(i6,5x,4(6x,i5,2x,f8.5))')
     &  mtn,(nuc(i,nmt),f(i,nmt),i=1+ii,4+ii)
      elseif (vers.eq.'x5') then
c
c...  The next line is for MCNPX, Vers.2.1.5
c
        read (55,'(i6,5x,4(6x,i5,2x,1pe17.11))')
     &  mtn,(nuc(i,nmt),f(i,nmt),i=1+ii,4+ii)
c
c...  The next line is for MCNP4B and 4C
c
      else
        read (55,'(i6,5x,4(6x,i5,2x,1pe11.5))')
     &  mtn,(nuc(i,nmt),f(i,nmt),i=1+ii,4+ii)
      endif
      if (ifra.eq.0) then
        do i=1+ii,4+ii 
          aa(i,nmt) = f(i,nmt)
        enddo
      endif
      if (mtn.gt.0.and.mtn.ne.abs(mt(nmt))) ii=ii-4
      if (mtn.eq.0.and.nuc(4+ii,nmt).ne.0) goto 30
      ij(nmt) = ii
      if (ifd.ne.nmat) then
       backspace(55) 
       goto 20 
      endif 
      if (ifra.eq.0) then
        ifra = 1
        goto 10
      endif
c 
c...Determine gram density and volume of cells (for now just 1)
c
   40 read (55,'(a6)') ju6
      if (ju6.ne.'1cells') goto 40
c
   42 read (55,'(///)')
   50 read (55,'(2i6,i5,1x,1p3e12.5)') n,ncell,nmt,aden1,gden1,vol1
      do 51 j=1,nmat
      if (nmt.eq.abs(mt(j))) then 
        vol(j)=vol(j)+vol1
        gden(j)=gden1
        aden(j)=aden1
      end if
   51 continue
      if (n.ne.0) goto 50
c
c...Make sure isos have been read correctly, erase spurios readings
c
      if (olib(1:6).eq.'CINDER') then
        open (7,file='material',status='unknown')      
        write (7,'(a72)') title
      endif
        k = 1
        filen = tmpfile//'natelem'
        open (16,file=filen,status='unknown')
        read (16,*)
        read (16,*)
  104   read (16,*,end=103) nelem(k)
        read (16,*) nisop(k)
        do 105 n=1,nisop(k)
  105    read (16,'(i5,3x,f10.5)',err=105,end=103)
     &        nisot(n,k),atomfr(n,k)
        k = k + 1
        goto 104
  103   close (16)
        totk = k - 1
c
      do 80 j=1,nmat 
        nisos = 4+ij(j)
        do 110 i=1,4+ij(j)
          iflag(i,j) = 0
          nz=nuc(i,j)/1000
          na=nuc(i,j)-1000*(nuc(i,j)/1000)
          if (na.eq.0.and.nz.eq.0) then
            nisos = nisos - 1
          elseif (na.eq.0) then
            iflag(i,j) = 1
            do 106 k=1,totk
              if (nelem(k).eq.nuc(i,j)/1000) then
                nisos = nisos + nisop(k) - 1
                ik(i,j) = k
              endif
  106       continue           
          endif 
  110   continue
c
c   Write CINDER 90 'material' file
c
        if (olib(1:6).eq.'CINDER') then
          write (7,'(a3,i3,i4,f10.8)') 'mat',abs(mt(j)),nisos,aden(j)
        endif
        do 120 i=1,4+ij(j)
          mety = 0
          if (nuc(i,j).eq.95242) mety = 1
          nz=nuc(i,j)/1000
          na=nuc(i,j)-1000*(nuc(i,j)/1000)
        if (olib(1:6).eq.'CINDER') then
          if (na.eq.0.and.nz.eq.0) then
          elseif (na.eq.0) then
            do 100 n=1,nisop(ik(i,j)) 
              na = nisot(n,ik(i,j)) - 1000*(nisot(n,ik(i,j))/1000)
              isoname = na*10000 + nz*10 + mety
              write (7,922) isoname,aa(i,j)*atomfr(n,ik(i,j))
  922         format (i7,2x,f11.8)
  100       continue
          else
            isoname = na*10000 + nz*10 + mety 
            write (7,922) isoname,aa(i,j)
          endif
        endif
  120   continue
      do 52 i=1,4+ij(j)
      nogo=0
      if (nuc(i,j).lt.1000) nogo=1
      if (nogo.eq.1) nuc(i,j)=0
   52 continue
c
c...Write grams of material to TAPE7 (origen comp file) or mnat.tmp
c...if a natural iso appears in mcnp input file
c
      if (voli(j).ne.0.) vol(j)=voli(j)
      voli(j) = vol(j)
      call wmbinp
c
      if (j.lt.10) then
        fnat = tmpfile//'mnat_'//char(j+48)//'.tmp'
        fname = 'TAPE7_'//char(j+48)//'.OUT'
      elseif (j.ge.10) then
        j1 = j/10
        j2 = j - j1*10
        fnat = tmpfile//'mnat_'//char(j1+48)//char(j2+48)//'.tmp'
        fname = 'TAPE7_'//char(j1+48)//char(j2+48)//'.OUT'
      endif
      open (12,file=fnat,status='unknown')
      if (mbxs.eq.1) then
        if (nrst.lt.10) then
          filem = 'mbxs_'//char(nrst+48)//'.inp'
        elseif (nrst.lt.100) then
          i1 = nrst/10
          i2 = nrst - i1*10
          filem = 'mbxs_'//char(i1+48)//char(i2+48)//'.inp'
        else
          i1 = nrst/100
          i2 = (nrst - i1*100)/10
          i3 = nrst - i2*10 - i1*100
          filem = 'mbxs_'//char(i1+48)//char(i2+48)//
     &                     char(i3+48)//'.inp'
        endif
      else
          filem = 'mbxs.inp'
      endif
      do 58 i=1,4+ij(j)
      if (nuc(i,j)-1000*(nuc(i,j)/1000).eq.0.and.nuc(i,j).gt.0) then
       open (13,file=filem,status='unknown')
        ifd=0
   55   read (13,'(i5)',end=57) nixs
        if (nixs.eq.nuc(i,j)) ifd=1
        if (ifd.eq.0) goto 55
        backspace (13)
        read (13,'(a10)') ninat
        write (12,'(i2,4x,a10)') nelem(ik(i,j)),ninat
   57   if (ifd.eq.0) write (6,*)
     &  '***** MB WARNING: Natural iso xs not found ',nuc(i,j)
        close (13)
      elseif (nuc(i,j).ne.0) then
       if (j.lt.10) then
        fmcnp = tmpfile//'mcnp_'//char(j+48)//'.inp'
       elseif (j.ge.10) then
        j1 = j/10
        j2 = j - j1*10
        fmcnp = tmpfile//'mcnp_'//char(j1+48)//char(j2+48)//'.inp'
       endif
       open (17,file=fmcnp,status='unknown')
       open (13,file=filem,status='unknown')
       ifd=0
   66  read (13,'(i5)',end=67) nixs
       if (nixs.eq.nuc(i,j)) ifd=1
       if (ifd.eq.0) goto 66 
       backspace (13)
       read (13,'(a10)') nmcnp
       write (17,'(a5,2x,a10)') nmcnp(1:5),nmcnp
   67  if (ifd.eq.0) write (6,*)
     &  '***** MB WARNING: Iso xs not found ',nuc(i,j)
       close (13)                                              
      end if
   58 continue
      close (12)
      close (17)
      if (olib(1:6).ne.'CINDER') then
      open (11,file=fname,status='unknown')
c
c...Write non-actinides to TAPE7, sort numerically for xs file read
c
      do 65 k=1,4+ij(j)
      nmin=99999
      ni=0
      do 60 i=1,4+ij(j)
      a=float(nuc(i,j))-float(1000*(nuc(i,j)/1000))
      if (nuc(i,j).lt.83000.and.nuc(i,j).gt.1000) then 
        if (nuc(i,j).lt.nmin) then
          nmin=nuc(i,j)
          if (iflag(i,j).ne.1) then
             ai=a
          else
             do 59 n=1,nisop(ik(i,j))
             naix(i,j,n)=nisot(n,ik(i,j)) - 
     &                   1000*(nisot(n,ik(i,j))/1000)
   59        aix(i,j,n) = float(nisot(n,ik(i,j)))
     &           - float(1000*(nisot(n,ik(i,j))/1000))    
          endif
          ni=i
        end if
      end if
   60 continue
      if (ni.gt.0) then
        kxs=1
        met='0'
        if (iflag(ni,j).eq.1) then
          do 62 n=1,nisop(ik(ni,j))
          gmat(ni,j,n) = f(ni,j)*gden(j)*vol(j)/aix(ni,j,n)
      write(*,*)'GMAT1',ni,j,n,gmat(ni,j,n),f(ni,j),gden(j),vol(j),
     &aix(ni,j,n),ik(ni,j),nisop(ik(ni,j))
          gmat(ni,j,n) = gmat(ni,j,n)*atomfr(n,ik(ni,j))
      write(*,*)'GMAT2',ni,j,n,gmat(ni,j,n),atomfr(n,ik(ni,j))
          if (naix(ni,j,n).lt.10) then
            write (11,912) kxs,nelem(ik(ni,j)),naix(ni,j,n),met,
     &           gmat(ni,j,n)
          elseif (naix(ni,j,n).lt.100) then
            write (11,913) kxs,nelem(ik(ni,j)),naix(ni,j,n),met,
     &           gmat(ni,j,n)
          else
            write (11,914) kxs,nelem(ik(ni,j)),naix(ni,j,n),met,
     &           gmat(ni,j,n)
          endif
   62     continue
        else
          gma=f(ni,j)*gden(j)*vol(j)/ai
          write(*,*)'GMA1',gma,f(ni,j),gden(j),vol(j),ai
          write (11,911) kxs,nuc(ni,j),met,gma
        endif  
        nuc(ni,j)=0
       end if
   65 continue
c
c...Write actinides to TAPE7, sort numerically for xs file read
c
      do 75 k=1,4+ij(j)
      nmin=99999
      ni=0
      do 70 i=1,4+ij(j)
      a=float(nuc(i,j))-float(1000*(nuc(i,j)/1000))
      if (nuc(i,j).ge.83000.and.a.gt.0.) then 
        if (nuc(i,j).lt.nmin) then
          nmin=nuc(i,j)
          if (iflag(i,j).ne.1) then
             ai=a
          else
             do 69 n=1,nisop(ik(i,j))
             naix(i,j,n)=nisot(n,ik(i,j)) - 
     &                    1000*(nisot(n,ik(i,j))/1000)
   69        aix(i,j,n) = float(nisot(n,ik(i,j)))
     &           - float(1000*(nisot(n,ik(i,j))/1000))   
          endif
          ni=i
        end if
      end if
   70 continue
      if (ni.gt.0) then
        kxs=2
        met='0'
        if (nuc(ni,j).eq.95242) met='1'
        if (iflag(ni,j).eq.1) then
          do 72 n=1,nisop(ik(ni,j))
          gmat(ni,j,n) = f(ni,j)*gden(j)*vol(j)/aix(ni,j,n)
          gmat(ni,j,n) = gmat(ni,j,n)*atomfr(n,ik(ni,j))
          if (naix(ni,j,n).lt.10) then
            write (11,912) kxs,nelem(ik(ni,j)),naix(ni,j,n),met,
     &           gmat(ni,j,n)
          elseif (naix(ni,j,n).lt.100) then
            write (11,913) kxs,nelem(ik(ni,j)),naix(ni,j,n),met,
     &           gmat(ni,j,n)
          else
            write (11,914) kxs,nelem(ik(ni,j)),naix(ni,j,n),met,
     &           gmat(ni,j,n)
          endif
   72     continue
        else
          gma=f(ni,j)*gden(j)*vol(j)/ai
          write(*,*)'GMA2',gma,f(ni,j),gden(j),vol(j),ai
          write (11,911) kxs,nuc(ni,j),met,gma
        endif          
        nuc(ni,j)=0
       end if
   75 continue
      write (11,'(a12)') '0  0  0  0'
      close (11)
  911 format (i4,i6,a1,1pe12.4,
     & '      0  0.0000E+00      0  0.0000E+00      0  0.0000E+00')
  912 format (i4,i3,'00',i1,a1,1pe12.4,
     & '      0  0.0000E+00      0  0.0000E+00      0  0.0000E+00')
  913 format (i4,i3,'0',i2,a1,1pe12.4,
     & '      0  0.0000E+00      0  0.0000E+00      0  0.0000E+00')
  914 format (i4,i3,i3,a1,1pe12.4,
     & '      0  0.0000E+00      0  0.0000E+00      0  0.0000E+00')
      endif
   80 continue
      if (olib(1:6).eq.'CINDER') then
        close (7)
      endif
c
      return
      end
c
c23456789*123456789*123456789*123456789*123456789*123456789*123456789*12
c
c...WORINP writes the origen input files.
c...put GTO 9 card 1/2 way for predictor step.
c...Do not write over restart files
c
      subroutine worinp
c
      common /mbinp/nmat,mt(49),voli(49),pow,qu235,days,nouter,ninner,
     & npre,nrst,frimp,nauto(49),ntot(49),nkeff,mbxs,nisn(999,49),
     & nisnr(999,49)
      common /mbinp2/niso(999,49),nisor(999,49),title,olib,locale,posit,
     &     tmpfile,machin,CALC
      character niso*10,nisor*6,title*72,olib*10,locale*72,posit*1,
     &       machin*4,libnam*80,xslib*14,lib(99)*10,decayl*80,CALC*6,
     &       ju3*3,fname*22,flname*22,file9t*22,dec80*80,lib2(99)*10
     &       ,tmpfile*10,filen*21,inpfile*21,plname*22,lib3(99)*10
      integer endy,olibn,oend,caps
      dimension day(999),nfeed(999,49),gf1(999,49),gf2(999,49),
     & kfeed(10),kfeed1(10,30),kfeed2(10,30),tmst(999),mfeed(10),
     & ifeed(10,30),ffeed(10,30),tfeed(999,49),ttfeed(999,49),
     & nf(3,999,49),rf(3,999,49),pfra(999),lb(99,4),nmt(49)
c
c...Determine library of interest (to get numbers of Activation product,
c...     actinide, and fission product cross section libraries).  This
c...     may be input as an integer (20 to 66) or as a character string
c...     in all caps or one cap & then lowercase letters.  Define which
c...     library numbers are associated with each character name below.
c
      data (lb(22,ii),ii=1,4),lib(22),lib2(22),lib3(22) /204,205,206,1,
     &       'PWRU','Pwru','pwru'/
      data (lb(23,ii),ii=1,4),lib(23),lib2(23),lib3(23) /207,208,209,2,
     &       'PWRPUU','Pwrpuu','pwrpuu'/
      data (lb(24,ii),ii=1,4),lib(24),lib2(24),lib3(24) /210,211,212,3,
     &       'PWRPUPU','Pwrpupu','pwrpupu'/
      data (lb(25,ii),ii=1,4),lib(25),lib2(25),lib3(25) /213,214,215,7,
     &       'PWRDU3TH','Pwrdu3th','pwrdu3th'/
      data (lb(26,ii),ii=1,4),lib(26),lib2(26),lib3(26) /225,226,227,11,
     &       'PWRD5D33','Pwrd5d33','pwrd5d33'/
      data (lb(27,ii),ii=1,4),lib(27),lib2(27),lib3(27) /222,223,224,10,
     &       'PWRD5D35','Pwrd5d35','pwrd5d35'/
      data (lb(28,ii),ii=1,4),lib(28),lib2(28),lib3(28) /216,217,218,8,
     &       'PWRPUTH','Pwrputh','pwrputh'/
      data (lb(29,ii),ii=1,4),lib(29),lib2(29),lib3(29) /219,220,221,9,
     &       'PWRU50','Pwru50','pwru50'/
      data (lb(30,ii),ii=1,4),lib(30),lib2(30),lib3(30) /251,252,253,4,
     &       'BWRU','Bwru','bwru'/
      data (lb(31,ii),ii=1,4),lib(31),lib2(31),lib3(31) /254,255,256,5,
     &       'BWRPUU','Bwrpuu','bwrpuu'/
      data (lb(32,ii),ii=1,4),lib(32),lib2(32),lib3(32) /257,258,259,6,
     &       'BWRPUPU','Bwrpupu','bwrpupu'/
      data (lb(33,ii),ii=1,4),lib(33),lib2(33),lib3(33) /201,202,203,0,
     &       'THERMAL','Thermal','thermal'/
      data (lb(34,ii),ii=1,4),lib(34),lib2(34),lib3(34) /401,402,403,21,
     &       'CANDUNAU','Candunau','candunau'/
      data (lb(35,ii),ii=1,4),lib(35),lib2(35),lib3(35) /404,405,406,22,
     &       'CANDUSEU','Canduseu','canduseu'/
      data (lb(36,ii),ii=1,4),lib(36),lib2(36),lib3(36) /311,312,313,12,
     &       'AMOPUUUC','Amopuuuc','amopuuuc'/
      data (lb(37,ii),ii=1,4),lib(37),lib2(37),lib3(37) /314,315,316,13,
     &       'AMOPUUUA','Amopuuua','amopuuua'/
      data (lb(38,ii),ii=1,4),lib(38),lib2(38),lib3(38) /317,318,319,14,
     &       'AMOPUUUR','Amopuuur','amopuuur'/
      data (lb(39,ii),ii=1,4),lib(39),lib2(39),lib3(39) /301,302,303,18,
     &       'EMOPUUUC','Emopuuuc','emopuuuc'/
      data (lb(40,ii),ii=1,4),lib(40),lib2(40),lib3(40) /304,305,306,19,
     &       'EMOPUUUA','Emopuuua','emopuuua'/
      data (lb(41,ii),ii=1,4),lib(41),lib2(41),lib3(41) /307,308,309,20,
     &       'EMOPUUUR','Emopuuur','emopuuur'/
      data (lb(42,ii),ii=1,4),lib(42),lib2(42),lib3(42) /321,322,323,15,
     &       'AMORUUUC','Amoruuuc','amoruuuc'/
      data (lb(43,ii),ii=1,4),lib(43),lib2(43),lib3(43) /324,325,326,16,
     &       'AMORUUUA','Amoruuua','amoruuua'/
      data (lb(44,ii),ii=1,4),lib(44),lib2(44),lib3(44) /327,328,329,17,
     &       'AMORUUUR','Amoruuur','amoruuur'/
      data (lb(45,ii),ii=1,4),lib(45),lib2(45),lib3(45) /331,332,333,32,
     &       'AMOPUUTC','Amopuutc','amopuutc'/
      data (lb(46,ii),ii=1,4),lib(46),lib2(46),lib3(46) /334,335,336,33,
     &       'AMOPUUTA','Amopuuta','amopuuta'/
      data (lb(47,ii),ii=1,4),lib(47),lib2(47),lib3(47) /337,338,339,34,
     &       'AMOPUUTR','Amopuutr','amopuutr'/
      data (lb(48,ii),ii=1,4),lib(48),lib2(48),lib3(48) /341,342,343,29,
     &       'AMOPTTTC','Amoptttc','amoptttc'/
      data (lb(49,ii),ii=1,4),lib(49),lib2(49),lib3(49) /344,345,346,30,
     &       'AMOPTTTA','Amopttta','amopttta'/
      data (lb(50,ii),ii=1,4),lib(50),lib2(50),lib3(50) /347,348,349,31,
     &       'AMOPTTTR','Amoptttr','amoptttr'/
      data (lb(51,ii),ii=1,4),lib(51),lib2(51),lib3(51) /361,362,363,23,
     &       'AMOITTTC','Amoitttc','amoitttc'/
      data (lb(52,ii),ii=1,4),lib(52),lib2(52),lib3(52) /364,365,366,24,
     &       'AMOITTTA','Amoittta','amoittta'/
      data (lb(53,ii),ii=1,4),lib(53),lib2(53),lib3(53) /367,368,369,25,
     &      'AMOITTTR','Amoitttr','amoitttr'/
      data (lb(54,ii),ii=1,4),lib(54),lib2(54),lib3(54) /371,372,373,26,
     &      'AMO2TTTC','Amo2tttc','amo2tttc'/
      data (lb(55,ii),ii=1,4),lib(55),lib2(55),lib3(55) /374,375,376,27,
     &      'AMO2TTTA','Amo2ttta','amo2ttta'/
      data (lb(56,ii),ii=1,4),lib(56),lib2(56),lib3(56) /377,378,379,28,
     &      'AMO2TTTR','Amo2tttr','amo2tttr'/
      data (lb(57,ii),ii=1,4),lib(57),lib2(57),lib3(57) /351,352,353,35,
     &      'AMOXTTTC','Amoxtttc','amoxtttc'/
      data (lb(58,ii),ii=1,4),lib(58),lib2(58),lib3(58) /354,355,356,36,
     &      'AMOXTTTA','Amoxttta','amoxttta'/
      data (lb(59,ii),ii=1,4),lib(59),lib2(59),lib3(59) /357,358,359,37,
     &      'AMOXTTTR','Amoxtttr','amoxtttr'/
      data (lb(60,ii),ii=1,4),lib(60),lib2(60),lib3(60) /381,382,383,0,
     &      'FFTFC','Fftfc','fftfc'/
      data (lb(65,ii),ii=1,4),lib(65),lib2(65),lib3(65) /381,382,383,0,
     &      'ATW','Atw','atw'/ 
      data (lb(66,ii),ii=1,4),lib(66),lib2(66),lib3(66) /204,205,206,1,
     &      'PWRSPEC','Pwrspec','pwrspec'/
c
c...Add cross section values to existing TAPE9 file, which previously only
c...contained the origen2 decay library.
c
      if (olib(1:6).ne.'CINDER') then     
      open (15,file='TAPE9_0.INP',status='unknown')
      do 10 i=72,1,-1
   10   if (locale(i:i).eq.' ') endy=i-1 
c
c...Now determine which type of origen2 library files were input by the
c...   user (see first comment in this subroutine)
c
      do i=1,14
        xslib(i:i) = ' '
      enddo
      if (olib(1:1).eq.'2'.or.olib(1:1).eq.'3'.or.
     &    olib(1:1).eq.'4'.or.olib(1:1).eq.'5'.or.
     &    olib(1:1).eq.'6') then
        decayl = locale(1:endy)//'/orig21'
        if (olib(2:2).eq.' ') olibn=ichar(olib(1:1))-48
        if (olib(2:2).ne.' ') olibn=(ichar(olib(1:1))-48)*10+
     &      ichar(olib(2:2))-48
        xslib(1:4)='orig'
        xslib(5:6) = olib(1:2)
      else
	  olibn = 0
        do 20 jj=1,66 
   20      if (olib.eq.lib(jj)) olibn = jj
        if (olibn.ne.0) then 
          caps = 1 
        else
          do 21 jj=1,66 
   21        if (olib.eq.lib2(jj)) olibn = jj
          if (olibn.ne.0) then
            caps = 2 
          else
           do 22 jj=1,66
   22        if (olib.eq.lib3(jj)) olibn = jj
           if (olibn.ne.0) then
             caps = 3                                      
           else
            write (6,*) '***** MB ERROR:  Initial ORIGEN2 library ',
     &                 'was not found'
           endif
          endif
        endif
c     Remove blank lines at the end of lib
        do 30 i=10,1,-1
   30    if (olib(i:i).eq.' ') oend = i-1
	 if (caps.eq.1) then
          decayl = locale(1:endy)//'/DECAY.LIB'
          xslib = olib(1:oend)//'.LIB'
         elseif (caps.eq.2) then
          decayl = locale(1:endy)//'/Decay.lib'
          xslib = olib(1:oend)//'.lib'             
         else
          decayl = locale(1:endy)//'/decay.lib'
          xslib = olib(1:oend)//'.lib'
         endif
      endif
      do i=1,80
        libnam(i:i)=' '
      enddo
      libnam=locale(1:endy)//'/'//xslib
      open (12,file=decayl,status='old')
   40 read (12,'(a80)',end=44) dec80
      write (15,'(a80)') dec80
      goto 40 
   44 open (18,file=libnam,status='old')
   50 read (18,'(a80)',end=60) dec80
      write (15,'(a80)') dec80
      goto 50 
   60 close(12)
      close(15)
      close(18) 
      endif
c
c...Create data file from scratch ; First read feed rate data file
c
      nfd = 0
      if(days.eq.0.0) then
      nfd = 1
      open (11,file='feed',status='old')
c
c...First read the two lines of headings
c...
      read (11,*)
      read (11,*)
      do 80 i=1,nouter
        do 70 j=1,nmat
        if (j.eq.1) then
         read (11,*,err=999,end=999) tmst(i),day(i),
     &   pfra(i),nmt(1),nfeed(i,1),gf1(i,1),gf2(i,1),
     &   (nf(l,i,1),rf(l,i,1),l=1,3)
        elseif (j.ge.2) then
         read (11,*) nmt(j),
     &   nfeed(i,j),gf1(i,j),gf2(i,j),(nf(l,i,j),rf(l,i,j),
     &   l=1,3)
        endif
      ndisc = 0
      if (gf1(i,j).eq.-2.) ndisc = 1 
      if (j.lt.10) then
       if (i.lt.10) then 
        flname = tmpfile//'param_'//char(j+48)//'.'//char(i+48)
        if (j.eq.1) plname = tmpfile//'power.'//char(i+48)
       elseif (i.lt.100) then
        i1 = i/10
        i2 = i - i1*10
        flname = tmpfile//'param_'//char(j+48)//'.'
     &               //char(i1+48)//char(i2+48)
        if (j.eq.1) plname = tmpfile//'power.'
     &               //char(i1+48)//char(i2+48)
       else 
        i1 = i/100
        i2 = (i - i1*100)/10
        i3 = i - i2*10 - i1*100
        if (j.eq.1) plname = tmpfile//'power.'
     &            //char(i1+48)//char(i2+48)//char(i3+48)
        flname = tmpfile//'param_'//char(j+48)//'.'
     &            //char(i1+48)//char(i2+48)//char(i3+48)
       endif
      elseif (j.ge.10) then
       j1 = j/10
       j2 = j - j1*10
       if (i.lt.10) then
        flname = tmpfile//'param_'//char(j1+48)//char(j2+48)//'.'
     &              //char(i+48)
       elseif (i.lt.100) then
        i1 = i/10
        i2 = i - i1*10
        flname = tmpfile//'param_'//char(j1+48)//char(j2+48)//'.'
     &                //char(i1+48)//char(i2+48) 
       else
        i1 = i/100
        i2 = (i - i1*100)/10
        i3 = i - i2*10 - i1*100
        flname = tmpfile//'param_'//char(j1+48)//char(j2+48)//'.'
     &            //char(i1+48)//char(i2+48)//char(i3+48)
       endif
      endif
      open (16,file=flname,status='unknown')
      write (16,910) ndisc
  910 format (i4,' ndisc')
      close (16)
   70 if (i.gt.1.and.gf1(i,j).eq.-1.) gf1(i,j)=gf2(i-1,j)
c
c    Determine if step is irradiation or decay (MCNP runs are only 
c      done for irradiation steps)
c
      open (17,file=plname,status='unknown')
      if (pfra(i).eq.0.0) then
        npwr = 0
      else
        npwr = 1
      endif
      write (17,940) npwr
  940 format (i4,' npwr')
      close (17)
   80 days=days+day(i)
c
c   Create file to indicate that MCNP run should be performed for step 0
c
      plname = tmpfile//'power.0'
      open (17,file=plname,status='unknown')
      npwr = 1
      write (17,940) npwr
      close (17)
c
      read (11,*) nfs
      do 90 n=1,nfs
      read (11,*) mfeed(n)
      do 90 m=1,mfeed(n)
   90 read (11,*) ifeed(n,m),ffeed(n,m)
      read (11,*) nrs
      do 100 n=1,nrs
      read (11,*) kfeed(n)
      do 100 k=1,kfeed(n)
  100 read (11,*) kfeed1(n,k),kfeed2(n,k)
c
c...Rewrite mb.inp with new days (later add feed data to output)
c
      call wmbinp
      else
        do 110 i=1,nouter
  110   day(i) = days/float(nouter)
      endif
      close (11)
c
c...Write flag to file that indicates whether a feed file
c...exists or not
c
      filen = tmpfile//'params2.dat'
      open (17,file=filen,status='unknown')
      write (17,950) nfd
  950 format (i4,' nfd')
      close (17)
c
c...Write origen input file for each step and write feed data to mb9.out
c
      do 200 j=1,nmat
      if (j.lt.10) then
        file9t = tmpfile//'mb9t_'//char(j+48)//'.out'
      elseif (j.ge.10) then
        j1 = j/10
        j2 = j - j1*10 
        file9t = tmpfile//'mb9t_'//char(j1+48)//char(j2+48)//'.out'
      endif
      filen = tmpfile//'mb9.txt'
      open (14,file=filen,status='unknown')
      write (14,'(/,a21)') 'Monteburns Inventory '
      close (14)
      open (14,file=file9t,status='unknown')
      write (14,'(/,a33,a13,i3)') 
     & 'Monteburns Grams of Feed per Step',
     & ' for material',j
      write (14,'(a5,2x,a4,5x,a9,250(1x,a9))') 
     &           'mat #','days',(niso(i,j),i=1,nauto(j)),'actinide'
      do 190 i=1,nouter
      if (olib(1:6).ne.'CINDER') then
      zero= 0.0
c      if (i.le.nrst) goto 48
c      if (nrst.eq.0) goto 13
c
c...If restart read flux from old tape5 and put in new tape5 
c
       if (j.lt.10) then
        if (i.lt.10) then
          fname=tmpfile//'TAPE5_'//char(j+48)//'.IN'//char(i+48)
        elseif (i.lt.100) then
          i1 = i/10
          i2 = i - i1*10
          fname=tmpfile//'TAPE5_'//char(j+48)//'.I'
     &           //char(i1+48)//char(i2+48)
        else 
          i1 = i/100
          i2 = (i - i1*100)/10
          i3 = i - i2*10 - i1*100
          fname = tmpfile//'TAPE5_'//char(j+48)//'.'
     &            //char(i1+48)//char(i2+48)//char(i3+48)
        end if
       elseif (j.ge.10) then
        j1 = j/10
        j2 = j - j1*10
        if (i.lt.10) then
          fname=tmpfile//'TAPE5_'//char(j1+48)//char(j2+48)//'.IN'
     &             //char(i+48) 
        elseif (i.lt.100) then
          i1 = i/10
          i2 = i - i1*10     
          fname=tmpfile//'TAPE5_'//char(j1+48)//char(j2+48)//'.I'
     &           //char(i1+48)//char(i2+48)
        else
          i1 = i/100
          i2 = (i - i1*100)/10
          i3 = i - i2*10 - i1*100
          fname = tmpfile//'TAPE5_'//char(j1+48)//char(j2+48)//'.'
     &            //char(i1+48)//char(i2+48)//char(i3+48)
        endif
       endif
      if (i.eq.nrst+1.and.nrst.gt.0) then
       open (11,file=fname,status='unknown')
  120  read (11,'(a3)',end=140) ju3
       if (ju3.ne.'IRF') goto 120
       backspace (11)
       read (11,900) zero
  140  close (11)
  900  format (19x,1pe13.5)
      end if
c
  130 n=nfeed(i,j)
      dstep=day(i)/float(ninner)
      do 150 m=1,nauto(j)+1
  150 tfeed(m,j)=0.
c
      open (13,file=fname,status='unknown')
c
c...Write group info to new file, then write initial commands.
c
      write (13,921)
      do l=1,3
      nn = abs(nf(l,i,j))
      if(nf(l,i,j).le.0) then
          write (13,921)
          goto 185
      endif
      do 160 m=1,9
  160 write (13,918) m 
      do 170 m=10,14
  170 write (13,922) m 
      write (13,920) (1.0 - rf(l,i,j))
      write (13,921) 
      if(nn.gt.nrs) then
        write (6,919) i
  919   format ('***** MB ERROR:  Invalid removal group ',
     &               'entered for outer step number',i4)
        stop
      endif
      enddo
      do 180 k=1,kfeed(nn)
      do 180 m=abs(kfeed1(nn,k)),abs(kfeed2(nn,k))
  180 write (13,923) m
  185 write (13,921)
      write (13,924)
      write (13,925) 
      write (13,926) lb(olibn,1),lb(olibn,2),lb(olibn,3),lib(olibn)
      write (13,927) lb(olibn,1),lb(olibn,2),lb(olibn,3)
      write (13,928)
      write (13,929)
      write (13,930)
      write (13,931)
      write (13,932)
      write (13,933)
      write (13,934)
      write (13,935)
      write (13,905)
      kk=2
      icont=0
      if (n.gt.0.and.gf1(i,j).ne.-2) icont=1
      if (icont.eq.1) kk=10
c
c... Write various loops into origen input file
c
      do 220 k=1,kk
        write (13,901)
        if (icont.eq.1) then 
         write (13,911)
         write (13,902) ninner/10
         dburn=dstep*float(ninner/10)
        else
         write (13,902) ninner/2
         dburn=dstep*float(ninner/2)
        end if
        write (13,903) dstep,zero
        write (13,904)
        write (13,905)
c
        if (n.gt.0) then
        do 210 m=1,mfeed(n)
         nm=2
         if (ifeed(n,m).lt.89000) nm=1
         ifd6=ifeed(n,m)*10
         if (ifd6.eq.952420) ifd6=ifd6+1 
         if (gf1(i,j).ne.-2) then
            gfs=(float(k)-.5)/float(kk)*(gf2(i,j)-gf1(i,j))+gf1(i,j)
            gfeed=ffeed(n,m)*gfs*dburn
         else
            if (k.eq.1) then
              gfeed=ffeed(n,m)*gf2(i,j)*day(i)
            else
              gfeed = 0.0
            endif
         endif
         if (ifeed(n,m).ge.89000) then
           tfeed(nauto(j)+1,j)=tfeed(nauto(j)+1,j)+gfeed
         endif
         do 205 mm=1,nauto(j)
         if (ifd6.eq.nisnr(mm,j))  then
            tfeed(mm,j)=tfeed(mm,j)+gfeed
         endif
  205    continue
c
         if (icont.eq.1) write (13,913) nm,ifd6,ffeed(n,m)*gfs
  210    continue
         if (icont.eq.1) write (13,914)
        end if
c
c... Write end of run 1/2 way through for predictor step
c
        ihalf = 0
        if (k.eq.5) ihalf = 1
        if (k.eq.1.and.icont.eq.0) ihalf=1 
        if (ihalf.eq.1) then
         write (13,938)
         do l=1,3
         if (nf(l,i,j).gt.0) write (13,936)
         enddo
         write (13,937)
         write (13,939)
        end if
c
  220  continue
c
c     complete end of origen input file
c
      do l=1,3
      if(nf(l,i,j).gt.0) write (13,936)
      enddo
      write (13,937) 
c
      close (13)
      else
c
c   Create CINDER input file
c      The input "pow" from mb.inp should be in mA 
c       Approximate nu as 2.5 and spallation neutrons/proton = 30
c           and Qfis = 200 MeV/fission = 3.2e-11
c       Are my calculations correct?????
c
        if (pow.ge.0.0) then
          bmcrnt = 2.5*pow/(1.602e-19*200.0) 
        else
          bmcrnt = abs(pow)/1.60217733E-16
        endif
        if (j.lt.10) then
          if (i.lt.10) then
            inpfile = tmpfile//'input_'//char(j+48)//'.'//char(i+48)
          elseif (i.lt.100) then
            i1 = i/10
            i2 = i - i1*10       
            inpfile = tmpfile//'input_'//char(j+48)//'.'//char(i1+48)//
     &           char(i2+48)      
          endif
        elseif (j.lt.100) then
          j1 = j/10
          j2 = j - j1*10          
          if (i.lt.10) then
            inpfile = tmpfile//'input_'//char(j1+48)//char(j2+48)//
     &           '.'//char(i+48)
          elseif (i.lt.100) then
            i1 = i/10
            i2 = i - i1*10         
            inpfile = tmpfile//'input_'//char(j1+48)//char(j2+48)//
     &           '.'//char(i1+48)//char(i2+48)      
          endif
        endif
        open (7,file=inpfile,status='unknown')
        write (7,'(a72)') title
        if (i.eq.1) then
          write (7,'(1pe11.4,a1,1pe11.4,a17)') voli(j),',',bmcrnt,
     &           ',,,,,,,,,1,-1,,,/'
        else
          write (7,'(1pe11.4,a1,1pe11.4,a17)') voli(j),',',bmcrnt,
     &           ',,,,,,,,,1,1,,,/ '
        endif
        write (7,*)
        write (7,'(a6,i2)') 'MB mat',j
        write (7,'(a4,i2)') 'mat ',abs(mt(j))
        write (7,'(a6)') '1 1.E0'
        write (7,'(4x,1pe11.4,a4)') day(i)/2.0," 'd'"
      endif
      write (14,'(i3,1x,f8.2,3x,1pe9.2,250e10.2)')
     &                i,day(i),(tfeed(m,j),m=1,nauto(j)+1)
      do 188 m=1,nauto(j)+1
  188 ttfeed(m,j)=ttfeed(m,j)+tfeed(m,j)
  190 continue
      write (14,'(a3,f8.2,3x,1pe9.2,250e10.2)')
     &           'tot',days,(ttfeed(m,j),m=1,nauto(j)+1)
      write (14,'(/,a41,a13,i3)')
     & 'Monteburns Grams Produced (or Destroyed) per Step',
     & ' for material',j
      write (14,'(3x,a9,250(1x,a9))')
     &           (niso(i,j),i=1,nauto(j)),'actinide'
      close (14)
c
  901 format ('BUP')
  902 format ('DOL   1  ',i4)
  903 format ('IRF   ',1p2e13.5,'    2  3  4  1')
  904 format ('MOV   3 2 0 1.0'/'CON   1'/'BUP')
  905 format ('STP 2')
  911 format ('INP   1  0  1 -1  4  4')
  913 format (i1,i8,1pe12.4,'  0  0.0')
  914 format ('0')
  918 format (i1,t4,'1 1.0')
  920 format ('15',t4,'1 ',f7.3)
  921 format ('-1')
  922 format (i2,t4,'1 1.0')
  923 format (i2,'  15')
  924 format ('TIT     ORIGEN2 input file for monteburns')
  925 format ('LIP     0 1 0')
  926 format ('RDA *** Libs ',i3,',',i3,',',i3,' = ',a10)
  927 format ('LIB     0 1 2 3 ',3(i3,1x),'9 3 0 3 0')
  928 format ('RDA     1 Bundle of fuel',/,
     &        'RDA     Read initial comps into vector 1 from TAPE4 in ',
     &                 'gram-atoms')
  929 format ('INP     1 -2 0 -1 4 4')
  930 format ('MOV     1 2 0 1.0',/,
     &        'MOV     1 3 0 0.0',/,
     &        'MOV     1 4 0 0.0')
  931 format ('RDA ***',/,
     &        'RDA *** Set output options (print in grams)')
  932 format ('HED     1  INITIAL')
  933 format ('CUT     5  1.0-10  -1')
  934 format ('OPTA    6*8 7 8 7 19*8',/,
     &        'OPTL    6*8 7 8 7 19*8',/,
     &        'OPTF    6*8 7 8 7 19*8')
  935 format ('RDA ***',/,
     &        'RDA    Begin burn, add cards after STP 2, remove FP at',
     &                ' end of burn')
  936 format ('PRO     2  3  4  -1')
  937 format ('MOV     3  2  0  1.0',/,
     &        'OUT     4  1  1  0  ',/,
     &        'PCH     2  2  2     ',/,
     &        'RDA                 ',/,
     &        'END                 ')
  938 format ('RDA First of 1/2 way predictor cards')
  939 format ('RDA Last of 1/2 way predictor cards')
c
  200 continue
      goto 998
  999 write (6,*) '***** MB ERROR: Problem with feed input file' 
      stop
  998 return
      end
c
c23456789*123456789*123456789*123456789*123456789*123456789*123456789*12
c
c...WORXS calculates new xs from mcnp and modifies the cross
c...sections in TAPE9.  Also calculates flux and modifies TAPE5
c...for 1/2 step
c
      subroutine worxs
c
      common /mbinp/nmat,mt(49),voli(49),pow,qu235,days,nouter,ninner,
     & npre,nrst,frimp,nauto(49),ntot(49),nkeff,mbxs,nisn(999,49),
     & nisnr(999,49)
      common /mbinp2/niso(999,49),nisor(999,49),title,olib,locale,posit,
     &     tmpfile,machin,CALC
      character niso*10,nisor*6,title*72,olib*10,locale*72,posit*1,
     &          machin*4,tmpfile*10,filen*21,ju30*30,char10*10,filec*11,
     &          tal*3,nm*2,file8*22,file6*22,fname*22,fname2*23,char9*9,
     &          ju17*17,char7*7,CALC*6,
     &          tape9*12,t9tmp*15,file1*22,file2*22,file3*22,file1t*22,
     &          ju10*10,ju80*80,ju3*3,tape7*12,ju6*6,blanks*4,mtuf*20,
     &          vers*2,filednz*9,ncell*6,f2name*22,char72*724,file18*22
      dimension xs(999,5,49),eflx(7,49),day(999),nfeed(99,49),flx(49),
     &        gf1(999,49),gf2(999,49),nf(3,999,49),rf(3,999,49),
     &        nmt(49),nisq(49),gad(49),fismac(49),tmst(999),pfra(999),
     &        qfis(49),flux(49),flux2(49),fiscap(999),vol(49),pwr(49),
     &        absmac(49),frfast(49),xsg(63,999,5,49),
     &        burnup(0:999,49),fluxy(49),fluxy2(49),pwrden(49),
     &        nuc(9999),iu(9999),thalf(9999),fbx(9999),aden(49),
     &        fpec(9999),fpecx(9999),fa(9999),fit(9999),grams(9999),
     &        fsf(9999),fn(9999),qrec(9999),abund(9999),frth(49),
     &        arcg(9999),wrcg(9999),gramat(9999),grmatf(9999),
     &        act(9999),nucl(9999),atomwe(9999),nucli(9999),xsh(999,49),
     &        xsec(6,9999),nuclf(9999),cflx(63,49),nisotop(9999,49),
     &        th(9999,49),thal(9999),nj(49),nis(3400),trit(63),
     &        totaval(49),totavalact(49),tmpval(999),frerr(999,49),
     &    xsdr(999,5,49),xsecdr(6,9999),drene(197,12),
     &    fismacdr(49),absmacdr(49),ndrag(197),
     &    fisenedr(49),absenedr(49),decaydr(49),decayc(197)

      real li6(49),li7(49),mtrit6(63,49),mtrit7(63,49)
      real*8 atperbcm(3500,49)
      real number(9999),htld(9999),inha(9999),inge(9999),nperp,
     &keff,nu,macfis,macabs,macn2n,mtu(49),ratio,mfis(9999,49,63),
     &mafis(63,49),mifis(9999),numb(9999,49),halflife(9999),
     &macab,macf,kinf2,n2nmac(49),n2nmacdr(49),n2nenedr(49),
     &n2npowr,n2ntot
      integer  ihit(999,49),delay
c
c...First obtain data from feed input file
c
      write(*,888)CALC
 888  format('calc',a6)
      if (CALC.eq.'DRAGON') then
         open (66, file='energymb.dat')
         write(*,*)'reading file energymb.dat'
         do 777 i=1,197
            read(66,778)ndrag(i),decayc(i),(drene(i,k),k=1,12)
            write(*,*)i,ndrag(i),decayc(i),(drene(i,k),k=1,12)
 778        format(i10,2x,13(f11.5))
 777        continue
            endif
      filen = tmpfile//'params2.dat'
      open (17,file=filen,status='unknown')
      read (17,'(i4)') nfd
      if (nfd.eq.1) then
        open (11,file='feed',status='old')
        read (11,*)
        read (11,*)
        daynum = 0.0
        do 10 i=1,nouter
         do 5 j=1,nmat
          if (j.eq.1) then
           read (11,*) tmst(i),day(i),pfra(i),
     &      nmt(1),nfeed(i,1),gf1(i,1),gf2(i,1),
     &      (nf(l,i,1),rf(l,i,1),l=1,3)
          elseif (j.ge.2) then
           read (11,*)  
     &      nmt(j),nfeed(i,j),gf1(i,j),gf2(i,j),
     &      (nf(l,i,j),rf(l,i,j),l=1,3)
          endif
    5    continue
         if (i.eq.nrst+1) goto 15
   10    daynum = daynum + day(i)
      else
         do 12 i=1,nouter
           day(i) = days/float(nouter)
           pfra(i) = 1.0
           if (i.eq.nrst+1) goto 15
   12      daynum = daynum + day(i)
      endif
c
c...Read mass fraction section to get volume of each material 
c
      do 13 j=1,nmat
   13 vol(j) = 0.0
   15 close (11) 
      delay = 0
      if (machin(1:3).ne.'VMS') then
        open (11,file='mbmco',status='old')
      elseif (machin(1:3).eq.'VMS') then
        open (11,file='mbmco.dat',status='old')
      endif
   16 read (11,'(a30)') ju30
      if (ju30(1:5).ne.'1mcnp') goto 16
      if (ju30(19:19).eq.'5') delay = 1
      if (ju30(19:20).eq.'4b') vers = '4b'
      if (ju30(19:20).eq.'4c') vers = '4c'
      if (ju30(19:21).eq.'4c2') delay = 1
      if (ju30(19:21).eq.'4c3') delay = 1
      if (ju30(19:21).eq.'2.5') delay = 1
      if (ju30(19:21).eq.'2.4') delay = 1
      if (ju30(19:23).eq.'2.2.3') delay = 1
      if (ju30(6:6).eq.'x'.and.ju30(19:19).eq.'2') vers = 'x5'
      if (ju30(19:20).eq.'4a') vers = '4a'
  280 read (11,'(a6)') ju6
      if (ju6.ne.'1cells') goto 280
c
      read (11,'(///)')
  290 read (11,'(i6,a6,i5,1x,1p3e12.5)') n,ncell,nt,aden1,gden,vol1
      do 295 j=1,nmat
      if (nt.eq.abs(mt(j))) then
        vol(j)=vol(j)+vol1
      end if
  295 continue
      if (n.ne.0) goto 290          
c
c...Read keff and calculate nu
c
   20 read (11,'(a17)') ju17
      if (ju17.ne.' neutron creation') goto 20
c
      read (11,'(/)')
      read (11,'(31x,1pe10.4)') src
      if (pow.lt.0.0) then
        read (11,'(31x,1pe10.4)') nperp
        read (11,'(//////////)')
      else
        read (11,'(///////////)')
      endif
      read (11,'(31x,1pe10.4,54x,1pe10.4)') fsrc,floss
      write(*,*)'fsrc,floss',fsrc,floss
c
c    To account for new delayed neutron info. in output
c
      if (delay.eq.1) then
        read (11,*)
      endif
      if (vers.eq.'x5') then
        read (11,'(///////)') 
        if (delay.eq.1) then
          read (11,*)
        endif
      else 
        read (11,'(/////)')
      endif
      read (11,'(35x,1pe10.4,0p,f7.4)') fmult,err
c
c
      if (fsrc.eq.0.0.and.fmult.eq.0.0) then
         keff = 0.0
      else if (fsrc.ne.0.) then
         nu=fsrc/floss
         keff = (fmult-1.)/(fmult-1./nu)
         relerr = (fmult*(1.+err)-1.)/(fmult*(1.+err)-1./nu)
         relerr = (relerr - keff)/keff
      else
   30    read (11,'(a10)') ju10
         if (ju10.ne.' ---------') goto 30
         read (11,'(/73x,f7.5,41x,f7.5)') keff,relerr
         nu=keff*src/floss
         write(*,*)'IHRH1',nu,keff,src,floss
      endif
c
c...Read energy spectrum tallies (if tallies don't exist in mbmco,
c...then tal='yes' (used in later commands)
c
      if (posit.eq.'m') then
       do j=1,49
         li6(j) = 0.0
         li7(j) = 0.0
         mtu(j) = 0.0
         totaval(j) = 0.0
         totavalact(j) = 0.0
       enddo
      IF (olib(1:6).eq.'CINDER') THEN 
       do j=1,49
         do l=1,63
           mafis(l,j) = 0.0
           mtrit6(l,j) = 0.0
           mtrit7(l,j) = 0.0
         enddo
       enddo
c
c   Read material or DNZ file
c
         if (nrst.eq.0) then
           open (7,file='material',status='unknown')
           read (7,*)
   32      read (7,'(3x,i3,i4,f10.8)',end=33) mat,nisos,atomden
           do 36 j=1,nmat
             if (mat.eq.abs(mt(j))) then
               nj(j) = 0
               aden(j) = atomden 
               do k=1,nisos
                 read (7,940) isoname,atomfra
                 nj(j) = nj(j) + 1
                 nisotop(k,j) = (isoname-10*(isoname/10))
     &             + 10*(isoname/10000)
     &             + 10000*((isoname-10000*(isoname/10000))/10)
                 numb(nj(j),j) = atomfra*atomden*1.0e+24*voli(j) 
                 nz = (isoname-10000*(isoname/10000))/10
                 a =  float(isoname/10000)
                 if (nz.ge.90) then 
                   mtu(j) = mtu(j) + a*numb(nj(j),j)/6.022e+23 
                 endif
               enddo
  940          format (i7,2x,f11.8)
             endif
   36      continue
           goto 32
   33      close (7)
         else
          do j=1,nmat
            if (j.lt.10) then
              filednz = 'alldnz_'//char(j+48)
            else
              j1 = j/10
              j2 = j - j1*10
              filednz = 'alldnz_'//char(j1+48)//char(j2+48)
            endif
            open (unit=78,file=filednz,form='unformatted',status='old')
            read (78) mtlbname
            do 38 kb=1,2
            read (78) kbt,jnuc
   38       read (78) (atperbcm(i,j),i=1,jnuc)
            close (78)
          enddo
         endif
         icind = 0
c
c   Read CINDER library to get fission cross sections
c
         do 48 j=1,nmat
           icind = 0
           open (7,file='library',status='old')
   41      read (7,'(a10)',end=43) char10
           if (char10.ne.'__________') goto 41
           icind = icind + 1
           read (7,'(7x,i7,17x,e11.4)') isoname,halflife(icind)
           nis(icind) = (isoname - 10*(isoname/10)) + 10*(isoname/10000)
     &      + 10000*((isoname - 10000*(isoname/10000))/10)
           n = 0
           if (nrst.ge.1) then
             if (atperbcm(icind,j).gt.0.0) then
               aden(j) = aden(j) + atperbcm(icind,j)
               nj(j) = nj(j) + 1
               ident = nj(j)
               nisotop(ident,j) = nis(icind)
               numb(ident,j) = atperbcm(icind,j)*1.0e+24*voli(j)
               th(ident,j) = halflife(icind)
               totaval(j) = totaval(j) + atperbcm(icind,j)
               if (nisotop(ident,j).ge.890000) totavalact(j) =
     &           totavalact(j) + atperbcm(icind,j)
             endif
           else
             match = 0
             do n=1,nj(j)
               if (nisotop(n,j).eq.nis(icind)) then
                 ident = n
                 match = 1
                 aval = numb(n,j)/(1.0e+24*voli(j))
                 totaval(j) = totaval(j) + aval
                 if (nis(icind).ge.890000) totavalact(j) =
     &           totavalact(j) + aval
               endif
             enddo
           endif
           if ((atperbcm(icind,j).gt.0.0.and.nrst.ge.1).or.
     &             (nrst.eq.0.and.match.eq.1)) then
   42        read (7,'(12x,a10)') char10
             if (char10.eq.'__________') then
               backspace(7)
               goto 41
             endif
             if (char10(2:4).ne.'n,f') goto 42
             backspace (7)
             read (7,'(a10)') char10
             if (char10.ne.'   0, 0, 0') then
               do irep=1,6
                 read (7,'(10(1x,e11.4))') (mfis(ident,j,l),
     &                  l=10*(irep-1)+1,10*(irep-1)+10)
               enddo
               read (7,'(3(1x,e11.4))') (mfis(ident,j,l),l=61,63)
             endif
  44         if (nis(icind).eq.60030.or.nis(icind).eq.70030) then
               read (7,'(10x,i7)') nto 
               if (nto.ne.30010) goto 44
               do irep=1,6
                 read (7,'(10(1x,e11.4))') (trit(l),
     &                  l=10*(irep-1)+1,10*(irep-1)+10)
               enddo
               read (7,'(3(1x,e11.4))') (trit(l),l=61,63)
               do l=1,63
                 if (nis(icind).eq.60030) then
                   mtrit6(l,j) = trit(l)*numb(ident,j)/voli(j)
     &                     /1.0e+24
                 elseif (nis(icind).eq.70030) then
                   mtrit7(l,j) = trit(l)*numb(ident,j)/voli(j)
     &                     /1.0e+24
                 endif 
               enddo
             endif
           endif
         goto 41
   43    close (7)
   48    continue
c
         open (7,file='fluxes',status='unknown')
         nzero = 0
         ngrps = 63
         write (7,'(a72,2i4))') title,ngrps,nzero
      ENDIF
      do 68 j=1,nmat
      fismac(j) = 0.
   55 read (11,'(a10)',end=67) ju10
      if (ju10(1:6).ne.'1tally') goto 55
      tal = 'yes'
      mat = 0
      do 60 m=1,nmat
      if (m.ge.10) then
        m1 = m/10 
        m2 = m - m1*10
        m1 = m1 + 1
        nm = char(m1+48)//char(m2+48)
      elseif (m.lt.10) then
        nm = '1'//char(m+48)
      endif
      if (nm.eq.ju10(8:9)) then
       mat = m 
       goto 61
      endif
   60 continue
      if (mat.eq.0) goto 55
c
   61 read (11,'(a10)') ju10
      if (ju10.ne.'      ener') goto 61
c
      IF (olib(1:6).eq.'CINDER') then
        ctot = 0.0
        do 62 i=1,63
         read (11,'(17x,1pe11.5)') cflx(i,mat)                    
   62   ctot = ctot + cflx(i,mat)
        write (7,'(a6,i2,12x,a30,1pe11.4)') 'MB mat',j,
     &  'Integral of Rebinned flux is  ',ctot
        ik=1
   63   write (7,'(1p8e10.3)') (cflx(k,mat),k=ik,ik+7)
        if (ik.eq.49) goto 64
        ik = ik+8
        goto 63 
   64   write (7,'(1p7e10.3)') (cflx(k,mat),k=57,63)
        read (11,'(17x,1pe11.5)') flx(mat)
c
        eflx(1,mat) = cflx(1,mat) + cflx(2,mat) + cflx(3,mat)
     &   + cflx(4,mat) + cflx(5,mat)+ cflx(6,mat)+ cflx(7,mat)
     &   + cflx(8,mat) + cflx(9,mat)+ cflx(10,mat)+ cflx(11,mat)
     &   + cflx(12,mat) + cflx(13,mat)
        eflx(2,mat) = cflx(14,mat) + cflx(15,mat) + cflx(16,mat)
     &   + cflx(17,mat) + cflx(18,mat)
        eflx(3,mat) = cflx(19,mat) + cflx(20,mat) + cflx(21,mat)
     &   + cflx(22,mat) + cflx(23,mat) + cflx(24,mat)
     &   + cflx(25,mat) + cflx(26,mat) + cflx(27,mat)
        eflx(4,mat) = cflx(28,mat) + cflx(29,mat) + cflx(30,mat)
     &   + cflx(31,mat) + cflx(32,mat) + cflx(33,mat) + cflx(34,mat)
     &   + cflx(35,mat) + cflx(36,mat) + cflx(37,mat) + cflx(38,mat)
     &   + cflx(39,mat) + cflx(40,mat) + cflx(41,mat)
     &   + cflx(42,mat) + cflx(43,mat) + cflx(44,mat)
        eflx(5,mat) = cflx(45,mat) + cflx(46,mat) + cflx(47,mat)
     &   + cflx(48,mat) + cflx(49,mat) + cflx(50,mat) + cflx(51,mat)
        eflx(6,mat) = cflx(52,mat) + cflx(53,mat) + cflx(54,mat)
     &   + cflx(55,mat) + cflx(56,mat) + cflx(57,mat) + cflx(58,mat)
     &   + cflx(59,mat) + cflx(60,mat) + cflx(61,mat) + cflx(62,mat)  
     &   + cflx(63,mat)
        eflx(7,mat) = flx(mat)
      ELSE
c
c Flux read in seven groups        
c
      do 65 i=1,7
   65 read (11,'(17x,1pe11.5)') eflx(i,mat)
      ENDIF
      frfast(mat) = 0.
      frth(mat) = (eflx(1,mat)+eflx(2,mat))/eflx(7,mat)
      do 66 i=3,6
   66 frfast(mat) = frfast(mat) + eflx(i,mat)/eflx(7,mat)
c
      if (mat.lt.10) then
         file6 = tmpfile//'mb6_'//char(mat+48)//'.out'
      elseif (mat.ge.10) then
         j1 = mat/10
         j2 = mat - j1*10
         file6 = tmpfile//'mb6_'//char(j1+48)//char(j2+48)//'.out'
      endif
      open (14,file=file6,status='unknown')
      write (14,'(i3,1x,6f10.2)') nrst,
     &                  (100.*eflx(i,mat)/eflx(7,mat),i=1,6)
      close (14)      
      goto 68
   67 write (6,*) '***** MB ERROR:  Not all user-specified MCNP',
     &            ' materials were found in MCNP output file'
      stop
   68 continue
      IF (olib(1:6).eq.'CINDER') then
        close (7)
      ENDIF
c
c...Read tallies and calculate new cross sections
c
      do 86 j=1,nmat
      iflag = 0
      IF (olib(1:6).ne.'CINDER') then
   70 read (11,'(a10)') ju10
c
c search for 1tally in MCNP output
c
      if (ju10(1:6).ne.'1tally') goto 70
      mat = 0
      do 72 m=1,nmat
      if (m.ge.10) then
        m1 = m/10
        m2 = m - m1*10
        m1 = m1 + 5
        nm = char(m1+48)//char(m2+48)
      elseif (m.lt.10) then
        nm = '5'//char(m+48)
      endif
      if (nm.eq.ju10(8:9)) then
        mat = m
        goto 74 
      endif
   72 continue
      if (mat.eq.0) goto 70 
c
c search for multiplier bin in MCNP output
c
   74 read (11,'(a10)') ju10
      if (ju10.ne.' multiplie') goto 74
c
      read (11,'(17x,1pe11.5)') flx(mat)
c
      if (flx(mat).eq.0) write (6,*) '***** MB: Tally read error'
      ENDIF
c
c
c
      do 80 i=1,ntot(j)
        ihit(i,j) = 0
c
c
c
      do 80 m=1,4
   76 read (11,'(a10)') ju10
      if (ju10.ne.' multiplie') goto 76 
c
c CINDER
c
      IF (olib(1:6).eq.'CINDER') then
        if (i.eq.1.and.m.eq.1) then
   78     read (11,'(a10)') ju10
          if (ju10.ne.' multiplie') goto 78
        endif
        read (11,'(/)')
        do l=1,63
          read (11,'(17x,1pe11.5)') xsg(l,i,m,j)
        enddo
      ENDIF
c
c read rr from mcnp tally output
c
      if (m.ne.1) then
        read (11,'(17x,1pe11.5)') xs(i,m,j)
      else
        read (11,'(17x,e11.5,f7.4)') xs(i,1,j),frerr(i,j)
      endif
c
c obtain 1grp xs after dividing cross section with flux
c
      xsdr(i,m,j)=xs(i,m,j)
      xs(i,m,j)=xs(i,m,j)/flx(j)
      if (nisn(i,j).ge.89000) iflag = 1
   80 continue
c
c
c
      if  (iflag.eq.1) then
c
c
c
       do 83 m=1,4
   82   read (11,'(a10)') ju10
        if (ju10.ne.' multiplie') goto 82
c
c CINDER
c
        IF (olib(1:6).eq.'CINDER') then
          read (11,'(/)')
          do l=1,63
            read (11,'(17x,1pe11.5)') xsg(l,ntot(j)+1,m,j)
          enddo
        ENDIF
c
c for actinides in the mixture (eg m9901)
c
        read (11,'(17x,1pe11.5)') xs(ntot(j)+1,m,j)
        xsdr(ntot(j)+1,m,j)=xs(ntot(j)+1,m,j)
        xs(ntot(j)+1,m,j)=xs(ntot(j)+1,m,j)/flx(j)
   83  continue
c
      else
c
        do 81 m=1,4
        xs(ntot(j)+1,m,j)= 0.0
   81  continue
      endif
      do 86 m=1,4
   84  read (11,'(a10)') ju10
       if (ju10.ne.' multiplie') goto 84
c
c CINDER
c
       IF (olib(1:6).eq.'CINDER') then
         read (11,'(/)')
         do l=1,63
           read (11,'(17x,1pe11.5)') xsg(l,ntot(j)+2,m,j)
         enddo
       ENDIF
c
c for whole mixture (eg m1)
c
       read (11,'(17x,1pe11.5)') xs(ntot(j)+2,m,j)
       xsdr(ntot(j)+2,m,j)=xs(ntot(j)+2,m,j)
       xs(ntot(j)+2,m,j)=xs(ntot(j)+2,m,j)/flx(j)
   86 continue
      close (11)
      endif
c
c...Modify library
c
      totpwr = 0.0
      totfis = 0.0
      if (posit.eq.'m') then
      do 260 j=1,nmat
      act(nauto(j)+1) = 0.0
      htld(nauto(j)+1) = 0.0
      inha(nauto(j)+1) = 0.0
      inge(nauto(j)+1) = 0.0
      if (j.lt.10) then
        tape7 = 'TAPE7_'//char(j+48)//'.OUT'
        tape9 = 'TAPE9_'//char(j+48)//'.INP'
        t9tmp = 'TAPE9_'//char(j+48)//'.TMP'
        mtuf  = tmpfile//'mtu_'//char(j+48)//'.tmp'
        filec = 'cxupdate_'//char(j+48)       
      elseif (j.ge.10) then
        j1 = j/10
        j2 = j - j1*10      
        tape7 = 'TAPE7_'//char(j1+48)//char(j2+48)//'.OUT'
        tape9 = 'TAPE9_'//char(j1+48)//char(j2+48)//'.INP'
        t9tmp = 'TAPE9_'//char(j1+48)//char(j2+48)//'.TMP'
        mtuf  = tmpfile//'mtu_'//char(j1+48)//char(j2+48)//'.tmp'
        filec = 'cxupdate_'//char(j1+48)//char(j2+48)
      endif
      if (nrst.eq.0) open (17,file=mtuf,status='unknown')

      IF (olib(1:6).ne.'CINDER') THEN
      write (6,*) '...MB: Modifying Library for material ',j
      open (12,file=tape9,status='old')
      open (13,file=t9tmp,status='unknown')
c
c
c...  Read halflife information for each isotope from decay library
c
       l = 1
   87  read (12,913,err=87,end=90) nflag,blanks
       if (nflag.le.3) then
c
c...  write first line of decay information to modified TAPE9
c...      for each isotope (or non-isotope line in TAPE9)
c
        if (blanks.ne.'    '.and.nflag.ne.-1) then
         backspace (12)
         read (12,'(a80)') ju80
         write (13,'(a80)') ju80
         backspace(12)
   88    read (12,922,err=88)
c
c...  See ORIGEN2 manual for meaning of other variables -
c...    thalf(l) is halflife of isotope and iu(l) is units
c...    qrec(l) is "average, total, recoverable energy released by
c...      each decay event (MeV)"
c
     &      nxs,nuc(l),iu(l),thalf(l),fbx(l),fpec(l),
     &      fpecx(l),fa(l),fit(l)
   89    read (12,923,err=89)
     &      nxs,fsf(l),fn(l),qrec(l),abund(l),arcg(l),wrcg(l)
c
c...  Convert all halflife values to seconds (iu = 1)
c
         if (iu(l).eq.2) thalf(l) = thalf(l)*60.0
         if (iu(l).eq.3) thalf(l) = thalf(l)*3600.0
         if (iu(l).eq.4) thalf(l) = thalf(l)*3600.0*24.0
         if (iu(l).eq.5) thalf(l) = thalf(l)*3600.0*24.0*365.24
         if (iu(l).eq.6) thalf(l) = 0.0
         if (iu(l).eq.7) then
           thalf(l) = thalf(l)*3600.0*24.0*365.24*1.0e+3
         elseif (iu(l).eq.8) then
           thalf(l) = thalf(l)*3600.0*24.0*365.24*1.0e+6
         elseif (iu(l).eq.9) then
           thalf(l) = thalf(l)*3600.0*24.0*365.24*1.0e+9
         endif
         l = l + 1
c
c...  Print last data line read to modified TAPE9 file
c
         backspace (12)
         read (12,'(a80)') ju80
         write (13,'(a80)') ju80
         goto 87
        else
         backspace(12)
         read (12,'(a80)') ju80
         write (13,'(a80)') ju80
         goto 87
        endif
       else
        backspace (12)
        goto 90
       endif
   90 mn = 0
   91 ixs=0
      read (12,913,err=97,end=99) nflag,blanks
   92 if (nflag.gt.3.and.blanks.ne.'    ') then
        backspace(12)
c
c creates one group xsec for each element from library mentioned
c
   93   read (12,921,err=93)
     &  nxs,nnuc,xs1,xs2,xs3,xs4,xs5,xs6,xflag
        mn = mn + 1
        nucli(mn) = nnuc
        xsec(1,mn) = xs1
        xsec(2,mn) = xs2
        xsec(3,mn) = xs3
        xsec(4,mn) = xs4
        xsec(5,mn) = xs5
        xsec(6,mn) = xs6
c
c compares if the element is part of the list and updates accordingly one group xsec
c

        do 95 i=1,ntot(j)
c
        if (nisnr(i,j).eq.nnuc) then
c
c
c          if (nnuc.eq.952410.or.nnuc.eq.952430) then 
            if (ihit(i,j).eq.1) then
              xs(i,1,j) = xsh(i,j)
            else
              ihit(i,j) = 1
              xsh(i,j) = xs(i,1,j)
            endif
            ratio = xs1/(xs5+xs1)
            xs(i,5,j) = xs(i,1,j)*(1.0-ratio)
            xs(i,1,j) = xs(i,1,j)*ratio
            xsec(5,mn) = xs(i,5,j)
c          else
c            xs(i,5,j) = xs5
c          endif
         ixs=1
         write (13,921) nxs,nnuc,(xs(i,m,j),m=1,5),xs6,xflag
         xsec(1,mn) = xs(i,1,j)
         xsec(2,mn) = xs(i,2,j)
         xsec(3,mn) = xs(i,3,j)
         xsec(4,mn) = xs(i,4,j)
         xsecdr(1,mn) = xsdr(i,1,j)
         xsecdr(2,mn) = xsdr(i,2,j)
         xsecdr(3,mn) = xsdr(i,3,j)
         xsecdr(4,mn) = xsdr(i,4,j)
        end if
   95   continue
      end if
   97 if (ixs.eq.0) then
        backspace (12)
        read (12,'(a80)') ju80
        write (13,'(a80)') ju80
      end if
      goto 91
  913 format (i4,a4)
  921 format (i4,i8,1p6e10.3,f7.1)
  922 format (i4,i8,i3,4x,1p6e10.3)
  923 format (i4,15x,1p6e10.3)
c
   99 continue

      close (12)
      close (13)
c
c...Calculate the macroscopic fission cross section of the 
c...isotopes from the "number densities" multiplied by the
c...microscopic fission cross section
c
c...Read TAPE7 and TAPE9 to get density and fis xs
c
      open (16,file=tape7,status='old')
      nact = 27
c
c...Calc relative fission per nuclide
c
      fismac(j) = 0.       
      n2nmac(j) = 0.
      absmac(j) = 0.
      n = 0
      nn = 0
c
c...  Read nuclide compositions from tape7
c
  220 read (16,911,err=220,end=250) kxs,(nisq(m),gad(m),m=1,4)
      write(*,*)'KXS',kxs,(nisq(m),gad(m),m=1,4)
      do 240 m=1,4
       ixs=0
       do 235 k=1,mn
         if (nucli(k).eq.nisq(m)) then
            write(*,*)'CHK1',k,m,nucli(k),nisq(m)
           ixs=1
           xs1 = xsec(1,k)
           xs2 = xsec(2,k)
           xs4 = xsec(4,k) 
           xsdr1 = xsecdr(1,k)
           xsdr2 = xsecdr(2,k)
           xsdr4 = xsecdr(4,k) 
            write(*,*)'CHK2',xs1,xs2,xs4,xsdr1,xsdr2,xsdr4
           goto 236
         endif
  235  continue
 236   do 245 k=1,197
         if (ndrag(k).eq.nisq(m)) then
            write(*,*)'drag1',k,m,ndrag(k),nisq(m)
            drene1=drene(k,1)*decayc(k)
            drene2=drene(k,2)
            drene3=drene(k,3)
            drene4=drene(k,4)
            write(*,*)'energy',drene1,drene2,drene3,drene4
           goto 237
            endif
 245        continue

  237  if (ixs.eq.0) then
c         write (6,*) 'Warning:  Isotope',nisq(m),
c     &               ' not found in xs lib'
       else  
c
         if (voli(j).eq.0.0) voli(j) = vol(j)
         aval = gad(m)*0.6022/voli(j)
         totaval(j) = totaval(j) + aval
         if (nisq(m).ge.890000) totavalact(j) =
     &           totavalact(j) + aval
         absmac(j) = absmac(j) + aval*xs1             
         n2nmac(j) = n2nmac(j) + aval*xs2
         absmacdr(j) = absmacdr(j) + aval*xsdr1            
         n2nmacdr(j) = n2nmacdr(j) + aval*xsdr2
         absenedr(j) = absenedr(j) + aval*xsdr1*drene3          
         n2nenedr(j) = n2nenedr(j) + aval*xsdr2*drene4
         decaydr(j)=decaydr(j)+aval*drene1*1.60217653e-3
         write(*,*)'drag2',j,absmacdr(j), n2nmacdr(j),absenedr(j),
     &   n2nenedr(j),decaydr(j)
         if (kxs.eq.2) then
           fismac(j) = fismac(j) + aval*xs4
           fismacdr(j) = fismacdr(j) + aval*xsdr4
           fisenedr(j) = fisenedr(j) + aval*xsdr4*drene2
           write(*,*)'drag3',j,fismacdr(j),fisenedr(j)
         endif
         if (nisq(m).eq.30060) then
           li6(j) = li6(j) + aval*xs3
         elseif (nisq(m).eq.30070) then
           li7(j) = li7(j) + aval*xs3
         endif
c
c...  Perform additional calculations and create an array of data
c...   from TAPE7 so that it does not have to be run again
c
         nisq1=nisq(m)/10
         nz=nisq1/1000
         a=float(nisq1)-float(1000*(nisq1/1000))
         if (nrst.eq.0) then
           if (nz.ge.90) then
             mtu(j) = mtu(j) + gad(m)*a
           endif
         endif
         n = n + 1
         gramat(n) =  gad(m) 
c
c...  For fissionable material, obtain the special number density,
c...    used for calculating Qfis.  Also calculate the number of
c...    atoms of each isotope for toxicity ("number" is in atoms)
c
         if (kxs.eq.2) then
           nn = nn + 1
           nuclf(nn) = nisq(m)
           grmatf(nn) = gad(m)
         endif
         nucl(n) = nisq(m)
         number(n) = aval*1.0e+24*voli(j)
       endif
c
  240 continue
      goto 220         
cCCCCCC Below is for CINDER calculation
      ELSE
        open(9,file=filec,status='unknown')
        do i=1,ntot(j)
          nisq1 = nisnr(i,j)/10          
          na = nisq1-(1000*(nisq1/1000))
          nz = nisq1/1000
          nmet = nisnr(i,j) - nisq1*10
          nid = na*10000 + nz*10 + nmet
          do m=1,4
            if (m.eq.1) nidi = nid + 10000 
            if (m.eq.2) nidi = nid - 10000 
            if (m.eq.3.and.nid.eq.60030) nidi = nid - 20000 - 10
            if (m.eq.3.and.nz.lt.89) nidi = nid - 30000 - 20
            if (m.eq.3.and.nz.ge.89) nidi = nid - 20000
            if (m.eq.4.and.nz.lt.89) nidi = nid - 10
            if (m.eq.4.and.nz.ge.89) nidi = 0 
            do l=1,63
              if (cflx(l,j).eq.0.0) then
                xsg(l,i,m,j) = 0.0
              else
                xsg(l,i,m,j) = xsg(l,i,m,j)/cflx(l,j)
              endif
            enddo
            if (nz.eq.95) then
              if (na.eq.241.or.na.eq.243) then
              write (9,'(1x,2i8,2x,a5)') nid,nidi+1,'1.000'
              if (na.eq.241) then
                do irep=1,6
                  write (9,'(10(1x,1pe11.4))') (0.1*xsg(l,i,m,j),
     &                 l=10*(irep-1)+1,10*(irep-1)+10)
                enddo
                write (9,'(3(1x,1pe11.4))') (0.1*xsg(l,i,m,j),l=61,63)
                do l=1,63
                  xsg(l,i,m,j) = 0.9*xsg(l,i,m,j)
                enddo
              elseif (na.eq.243) then
                do irep=1,6
                  write (9,'(10(1x,1pe11.4))') (0.33*xsg(l,i,m,j),
     &                 l=10*(irep-1)+1,10*(irep-1)+10)
                enddo
                write (9,'(3(1x,1pe11.4))') (0.33*xsg(l,i,m,j),l=61,63)
                do l=1,63
                  xsg(l,i,m,j) = 0.67*xsg(l,i,m,j)
                enddo
              endif
              endif
            endif 
            write (9,'(1x,2i8,2x,a5)') nid,nidi,'1.000'
            do irep=1,6
              write (9,'(10(1x,1pe11.4))') (xsg(l,i,m,j),
     &               l=10*(irep-1)+1,10*(irep-1)+10)
            enddo
            write (9,'(3(1x,1pe11.4))') (xsg(l,i,m,j),l=61,63)
          enddo
        enddo
        close (9)
c
c  Calculate macroscopic fission cross section
c 
        fisxs = 0.0
        do l=1,63
          do ii=1,nj(j)
            if (nisotop(ii,j).ge.890000) then
              do i=1,ntot(j)
                if (nisotop(ii,j).eq.nisnr(i,j)) then
                  mfis(ii,j,l) = xsg(l,i,4,j)
                endif
              enddo
            endif
            mafis(l,j) = mafis(l,j) + mfis(ii,j,l)*numb(ii,j)/
     &             voli(j)/1.0e+24
          enddo
          fisxs = fisxs + mafis(l,j)*cflx(l,j)
          li6(j) = li6(j) + mtrit6(l,j)*cflx(l,j)
          li7(j) = li7(j) + mtrit7(l,j)*cflx(l,j)
        enddo
        fismac(j) = fisxs/flx(j)
        li6(j) = li6(j)/flx(j)
        li7(j) = li7(j)/flx(j)
c 
        do n=1,nj(j)
          number(n) = numb(n,j)
          nucl(n) = nisotop(n,j)
          gramat(n) = numb(n,j)/6.022e+23
          if (nrst.eq.0) then
            do i=1,icind
              if (nis(i).eq.nisotop(n,j)) then
                thalf(n) = halflife(i)
              endif
            enddo
          else
            thalf(n) = th(n,j)
          endif
        enddo
        n = nj(j)
CCCC Finishes CINDER calculation
      ENDIF 
c
c...Calculate energy per fission qfis and flux norm factor
c...need to determine contribution of each iso to fission
c
  250 qrat=1.0
      do i=1,nj(j)
        mifis(i) = 0.0
        do l=1,63
          mifis(i) = mifis(i) + mfis(i,j,l)*cflx(l,j)*gramat(i)
        enddo
      enddo
      if (qu235.lt.0.)call calcq(qrat,nuclf,grmatf,nucli,xsec,nn,mn,
     &      mifis,nj(j),nucl)
      qfis(j)=abs(qu235)*qrat
c
c...Two different fluxes must be calculated:  one for the end
c...of step nrst, and one for the beginning of step (nrst+1)
c...The reason these two values are different is that the
c...power fraction for each outer loop step is different
c
      write(*,*)'i have reached here - 1a   ',CALC

      if (CALC.eq.'ORIGEN')then
      totpwr = totpwr + (qfis(j)*flx(j)*fismac(j)*voli(j)) 
      totfis = totfis + (flx(j)*fismac(j)*voli(j))
      qave = totpwr/totfis
      write(*,*)'orig4',totpwr,totfis,qave
      goto 302
      endif

      write(*,*)'i have reached here - 1b   ',CALC

      if (CALC.eq.'DRAGON') then
      write(*,*)'i have reached here - 1c   ',CALC
      fispowr=fispowr+fisenedr(j)*voli(j)
      abspowr=abspowr+absenedr(j)*voli(j)
      n2npowr=n2npowr+n2nenedr(j)*voli(j)
      fistot=fistot+fismacdr(j)*voli(j)
      abstot=abstot+absmacdr(j)*voli(j)
      n2ntot=n2ntot+n2nmacdr(j)*voli(j)
      write(*,*)'glob1',fispowr,abspowr,n2npowr,fistot,abstot,n2ntot
c     qave = (fispowr/fistot)+(abspowr/abstot)+(n2npowr/n2ntot)
      qave = fispowr+abspowr+n2npowr
      totdecay=totdecay+decaydr(j)*voli(j)
      ttt1=fispowr/fistot
      ttt2=abspowr/abstot
      ttt3=n2npowr/n2ntot
      write(*,*)'glob2',qave,ttt1,ttt2,ttt3
      goto 302
      endif


 302  continue
      write(*,*)'i have reached here - 2'

      if (nrst.eq.0) write (17,'(1pe10.3)') mtu(j)
c
c...  Write heatload and toxicity information to a file
c
      do 258 i=1,nauto(j)
       nisq1 = nisnr(i,j)/10
       atomwe(i) = float(nisq1)-float(1000*(nisq1/1000))
       thal(i) = 0.0
       qrec(i) = 0.0
c
c ORIGEN
c
       IF (olib(1:6).ne.'CINDER') then
        do 252 ll=1,l-1
        if (nuc(ll).eq.nisnr(i,j)) then
          thal(i) = thalf(ll)
          qrec(i) = qrec(ll)
          goto 254
        endif
  252   continue
       ENDIF 
  254  do 256 m=1,n
       if (nisnr(i,j).eq.nucl(m)) then
         IF (olib(1:6).eq.'CINDER') then
           thal(i) = thalf(m)
         ENDIF
         call activ(nucl(m),thal(i),number(m),atomwe(i),gramat(m),
     &          qrec(i),act(i),inha(i),inge(i),htld(i))
         grams(i) = gramat(m)*atomwe(i)
         goto 257
       endif
  256  continue
  257  act(nauto(j)+1) = act(nauto(j)+1) + act(i)
       htld(nauto(j)+1) = htld(nauto(j)+1) + htld(i)
       inha(nauto(j)+1) = inha(nauto(j)+1) + inha(i)
       inge(nauto(j)+1) = inge(nauto(j)+1) + inge(i)
  258 continue
      if (j.lt.10) then
       file18 = tmpfile//'mb18_'//char(j+48)//'.out'
      elseif (j.ge.10) then
       j1 = j/10
       j2 = j - j1*10
       file18 = tmpfile//'mb18_'//char(j1+48)//char(j2+48)//'.out'
      endif
      open (18,file=file18,status='unknown')
c
      write (18,'(1x,i3,1x,1pe9.2,250e10.2)') nrst,
     &  (frerr(i,j),i=1,nauto(j)+1)
      close (18)
  260 continue
c
c
      if (nrst.eq.0) then
        pfrac1 = pfra(1)
        pfrac2 = pfra(1)
      elseif (nrst.eq.nouter) then
        pfrac1 = pfra(nrst)
        pfrac2 = pfra(nrst)
      else
        pfrac1 = pfra(nrst)
        pfrac2 = pfra(nrst+1)
      endif
c
c... Normalize the flux obtained from MCNP by using the factors "nu"
c... power, energy per fission, and k-eff
c
      if (pow.lt.0.0) then
        fnorm =  (abs(pow)/1.0e+03)*pfrac1/1.602e-19
        f2norm = (abs(pow)/1.0e+03)*pfrac2/1.602e-19
      elseif (fsrc.eq.0.) then
         if (CALC.eq.'DRAGON')then
c       fnorm = nu*1.0e+6*(pow-totdecay)*pfrac1/1.602e-13/qave/keff
        fnorm = 1.0e+6*(pow-totdecay)*pfrac1/1.602e-13/qave
         write(*,*)'IHRHD2',nu,pow,totdecay,pfrac1,qave,keff,fnorm
c       f2norm = nu*1.0e+6*(pow-totdecay)*pfrac2/1.602e-13/qave/keff
        f2norm =1.0e+6*(pow-totdecay)*pfrac2/1.602e-13/qave
         write(*,*)'IHRHD3',nu,pow,totdecay,pfrac2,qave,keff,f2norm
         else
        fnorm = nu*1.0e+6*pow*pfrac1/1.602e-13/qave/keff
         write(*,*)'IHRH2',nu,pow,pfrac1,qave,keff,fnorm
        f2norm = nu*1.0e+6*pow*pfrac2/1.602e-13/qave/keff
         write(*,*)'IHRH3',nu,pow,pfrac2,qave,keff,f2norm
         endif
      else
        fnorm = src*1.0e+6*pow*pfrac1/1.602e-13/qave/floss
        f2norm = src*1.0e+6*pow*pfrac2/1.602e-13/qave/floss
      endif
c
c... Write xs data to various mb files
c
      do 160 j=1,nmat
      if (tal.ne.'yes') goto 120 
c
      if (j.lt.10) then
        file1 = tmpfile//'mb1_'//char(j+48)//'.out'
        file1t= tmpfile//'mb1t_'//char(j+48)//'.out'
        file2 = tmpfile//'mb2_'//char(j+48)//'.out'
        file3 = tmpfile//'mb3_'//char(j+48)//'.out'
        file8 = tmpfile//'mb8_'//char(j+48)//'.out'
        mtuf  = tmpfile//'mtu_'//char(j+48)//'.tmp'
      elseif (j.ge.10) then
        j1 = j/10
        j2 = j - j1*10         
        file1 = tmpfile//'mb1_'//char(j1+48)//char(j2+48)//'.out'
        file1t= tmpfile//'mb1t_'//char(j1+48)//char(j2+48)//'.out' 
        file2 = tmpfile//'mb2_'//char(j1+48)//char(j2+48)//'.out'
        file3 = tmpfile//'mb3_'//char(j1+48)//char(j2+48)//'.out'
        file8 = tmpfile//'mb8_'//char(j1+48)//char(j2+48)//'.out'
        mtuf  = tmpfile//'mtu_'//char(j1+48)//char(j2+48)//'.tmp'
      endif                                    
c
c      IF (olib(1:6).ne.'CINDER') THEN
      fsabs=xs(ntot(j)+1,1,j)
      fsfis=xs(ntot(j)+1,4,j)
      fsn3n=xs(ntot(j)+1,3,j)
      fsn2n=xs(ntot(j)+1,2,j)
      falabs=xs(ntot(j)+2,1,j)
      falfis=xs(ntot(j)+2,4,j)
      faln3n=xs(ntot(j)+2,3,j)
      faln2n=xs(ntot(j)+2,2,j)             
      open (14,file=file2,status='unknown')
      write (14,'(i3,1x,1pe9.2,250e10.2)')nrst,(xs(i,1,j),i=1,nauto(j))
      close (14)
      open (14,file=file3,status='unknown')
      do i=1,nauto(j)
c
c   Fission cross sections of non-actinides should be 0.0
c
        if (nisn(i,j).lt.89000) then
          tmpval(i) = xs(i,4,j)
          xs(i,4,j) = 0.0
        endif
      enddo
      write (14,'(i3,1x,1pe9.2,250e10.2)')nrst,(xs(i,4,j),i=1,nauto(j))
      do i=1,nauto(j)
        if (nisnr(i,j).lt.89000) then
          xs(i,4,j) = tmpval(i) 
        endif
      enddo
      close (14)
      do 119 i=1,nauto(j)
      if (xs(i,1,j).ne.0.0.and.nisn(i,j).ge.89000) then
        fiscap(i) = (xs(i,4,j)/xs(i,1,j))
      else
        fiscap(i) = 0.0
      endif
  119 continue
      open (14,file=file8,status='unknown')
      write (14,'(i3,1x,0pf9.4,250f10.4)')
     & nrst,(fiscap(i),i=1,nauto(j))
      close (14)
c      ENDIF
c
c... Write mcnp output to mb1t.out
c
  120 flux(j)=fnorm*flx(j)
      flux2(j)=f2norm*flx(j)
      if (CALC.eq.'DRAGON') then
      pwr(j)=(fisenedr(j)+absenedr(j)+n2nenedr(j)+decaydr(j))*
     &fnorm*voli(j)*1.602e-13/1.0e+6
      else
      pwr(j)=qfis(j)*flux(j)*fismac(j)*voli(j)*1.602e-13/1.0e+6
      endif
      eli6 = 4.7838
      eli7 = 3.35
      pwr(j) = pwr(j) + (li6(j)*eli6 + li7(j)*eli7)*voli(j)
     &         *flux(j)*1.602e-13/1.0e+6
c
c... Calculate power density in W/cc (multiply power by 10^6 and 
c...   divide by volume)
c
      pwrden(j) = pwr(j)*1.0e+06/voli(j)
c
c.. Calculate total accumulated burnup
c
      open (14,file=file1t,status='unknown')
      read (14,*)
      read (14,*)
      read (14,*)
      read (14,*)
      do 121 i=0,nrst-1
  121 read (14,'(54x,e10.3)') burnup(i,j)
      close (14)
      if (nrst.ge.1) then
        open (17,file=mtuf,status='unknown')
        read (17,'(1pe10.3)') mtu(j)
      endif
      if (mtu(j).ne.0.0.and.nrst.ne.0) then
       burnup(nrst,j) = burnup(nrst-1,j) 
     &                + pwr(j)*1000.0*day(nrst)/mtu(j)
      else
       burnup(nrst,j) = 0.0
      endif
      write (6,900) j,flux(j),fismac(j),pwr(j),burnup(nrst,j)
c
c   
c      IF (olib(1:6).ne.'CINDER') then
      if (fsfis.ne.0.0.and.fsabs.ne.0.0) then
        fisabs = fsfis/fsabs
      else
        fisabs = 0.0
      endif
      if ((nu*fsfis+2.*fsn2n+3.*fsn3n).ne.0.0.and.
     &                               (fsabs+fsfis).ne.0.0) then
        eta = (nu*fsfis+2.*fsn2n+3.*fsn3n)/(fsabs+fsfis)
      else
        eta = 0.0
      endif
      if (falfis.ne.0.0.and.falabs.ne.0.0) then
        fisall = falfis/falabs 
      else
        fisall = 0.0
      endif   
      if ((nu*falfis+2.*faln2n+3.*faln3n).ne.0.0.and.
     &                              (falabs+falfis).ne.0.0) then
        aeta = (nu*falfis+2.*faln2n+3.*faln3n)/(falabs+falfis)
      else
        aeta = 0.0
      endif
c
c  CINDER portion of this is needed!
c
c      ENDIF
      open (14,file=file1,status='unknown')
      write (14,902) nrst,qfis(j),flux(j),fismac(j),pwr(j),pwrden(j),
     & burnup(nrst,j),
     & falabs,falfis,fisall,faln2n,aeta,fsabs,fsfis,fisabs,fsn2n,eta
      close (14)
c
c...Modify flux in origen files
c
      do 150 ii=1,2
      if (ii.eq.1) then
       if (j.lt.10) then
        fname='TAPE5_'//char(j+48)//'.INP'
        fname2='TAPE5_'//char(j+48)//'.TMP'
       elseif (j.ge.10) then
        j1 = j/10
        j2 = j - j1*10
        fname='TAPE5_'//char(j1+48)//char(j2+48)//'.INP'
        fname2='TAPE5_'//char(j1+48)//char(j2+48)//'.TMP'
       endif
      else
       i=nrst+1
       if (j.lt.10) then
        if (i.lt.10) then
         fname=tmpfile//'TAPE5_'//char(j+48)//'.IN'
     &           //char(i+48)
         fname2=tmpfile//'TAPE5_'//char(j+48)//'.t'
     &           //char(i+48)
        elseif (i.lt.100) then
         i1 = i/10
         i2 = i - i1*10
         fname=tmpfile//'TAPE5_'//char(j+48)//
     &         '.I'//char(i1+48)//char(i2+48)
         fname2=tmpfile//'TAPE5_'//char(j+48)//'.t'
     &         //char(i1+48)//char(i2+48)
        else
         i1 = i/100
         i2 = (i - i1*100)/10
         i3 = i - i2*10 - i1*100
         fname=tmpfile//'TAPE5_'//char(j+48)//
     &         '.'//char(i1+48)//char(i2+48)//char(i3+48)
         fname2=tmpfile//'TAPE5_'//char(j+48)//'.t'
     &         //char(i1+48)//char(i2+48)//char(i3+48)
        endif
       elseif (j.ge.10) then
        j1 = j/10
        j2 = j - j1*10
        if (i.lt.10) then
         fname=tmpfile//'TAPE5_'//char(j1+48)//char(j2+48)//
     &         '.IN'//char(i+48)
         fname2=tmpfile//'TAPE5_'//char(j1+48)//char(j2+48)//'.t'
     &         //char(i+48)
        elseif (i.lt.100) then
         i1 = i/10
         i2 = i - i1*10
         fname=tmpfile//'TAPE5_'//char(j1+48)//char(j2+48)//
     &         '.I'//char(i1+48)//char(i2+48)
         fname2=tmpfile//'TAPE5_'//char(j1+48)//char(j2+48)//'.t'
     &         //char(i1+48)//char(i2+48)
        else
         i1 = i/100
         i2 = (i - i1*100)/10
         i3 = i - i2*10 - i1*100
         fname=tmpfile//'TAPE5_'//char(j1+48)//char(j2+48)//
     &         '.'//char(i1+48)//char(i2+48)//char(i3+48)
         fname2=tmpfile//'TAPE5_'//char(j1+48)//char(j2+48)//'.t'
     &         //char(i1+48)//char(i2+48)//char(i3+48)
        endif
       endif
      end if
c
      IF (olib(1:6).eq.'CINDER') then
        if (j.lt.10) then
          if (nrst.lt.10) then
            if (ii.eq.1.and.nrst.ne.0) then
            fname = tmpfile//'input_'//char(j+48)//'.'//char(nrst+48)
            f2name = tmpfile//'input_'//char(j+48)//'.tmp'
            else
              if (nrst.ne.9) then
                fname = tmpfile//'input_'//char(j+48)//'.'// 
     &              char(nrst+49)
                f2name = tmpfile//'input_'//char(j+48)//'.t'//
     &              char(nrst+49)
              else
                fname = tmpfile//'input_'//char(j+48)//'.10'
                f2name = tmpfile//'input_'//char(j+48)//'.t10'
              endif
            endif
          else
            i1 = nrst/10
            i2 = nrst - i1*10
            i3 = (nrst+1)/10
            i4 = (nrst+1) - i1*10
            if (ii.eq.1) then
            fname = tmpfile//'input_'//char(j+48)//'.'//char(i1+48)//
     &               char(i2+48)
            f2name = tmpfile//'input_'//char(j+48)//'.tmp'
            else
              if (nrst.eq.19) then
                fname = tmpfile//'input_'//char(j+48)//'.20'
                f2name = tmpfile//'input_'//char(j+48)//'.t20'
              elseif (nrst.eq.29) then
                fname = tmpfile//'input_'//char(j+48)//'.30'
                f2name = tmpfile//'input_'//char(j+48)//'.t30'
              elseif (nrst.eq.39) then
                fname = tmpfile//'input_'//char(j+48)//'.40'
                f2name = tmpfile//'input_'//char(j+48)//'.t40'
              else 
                fname = tmpfile//'input_'//char(j+48)//'.'//char(i3+48)
     &              //char(i4+48)
                f2name = tmpfile//'input_'//char(j+48)//'.t'//
     &               char(i3+48)//char(i4+48)
              endif
            endif
          endif
        elseif (j.ge.10) then
          j1 = j/10
          j2 = j - j1*10
          if (nrst.lt.10) then
            if (ii.eq.1.and.nrst.ne.0) then
            fname = tmpfile//'input_'//char(j1+48)//char(j2+48)//'.'//
     &                char(nrst+48)
            f2name = tmpfile//'input_'//char(j1+48)//char(j2+48)//'.tmp'
            else
            if (nrst.ne.9) then
              fname = tmpfile//'input_'//char(j1+48)//char(j2+48)//'.'
     &               //char(nrst+49)
              f2name = tmpfile//'input_'//char(j1+48)//char(j2+48)//'.t'
     &               //char(nrst+49)
            else 
              fname = tmpfile//'input_'//char(j1+48)//char(j2+48)//'.10'
              f2name = tmpfile//'input_'//char(j1+48)//char(j2+48)//
     &               '.t10'
            endif
            endif
          else
            i1 = nrst/10
            i2 = nrst - i1*10
            i3 = (nrst+1)/10
            i4 = (nrst+1) - i1*10
            if (ii.eq.1.and.nrst.ne.0) then
            fname = tmpfile//'input_'//char(j1+48)//char(j2+48)//'.'//
     &                char(i1+48)//char(i2+48)
            f2name = tmpfile//'input_'//char(j1+48)//char(j2+48)//'.tmp'
            else
              if (nrst.eq.19) then
                fname = tmpfile//'input_'//char(j1+48)//char(j2+48)
     &                         //'.20'
                f2name = tmpfile//'input_'//char(j1+48)//char(j2+48)
     &                         //'.t20'
              elseif (nrst.eq.29) then
                fname = tmpfile//'input_'//char(j1+48)//char(j2+48)
     &                         //'.30'
                f2name = tmpfile//'input_'//char(j1+48)//char(j2+48)
     &                         //'.t30'
              elseif (nrst.eq.39) then
                fname = tmpfile//'input_'//char(j1+48)//char(j2+48)
     &                         //'.40'
                f2name = tmpfile//'input_'//char(j1+48)//char(j2+48)
     &                         //'.t40'
              else
                fname = tmpfile//'input_'//char(j1+48)//char(j2+48)
     &                //'.'//char(i3+48)//char(i4+48)
                f2name = tmpfile//'input_'//char(j1+48)//char(j2+48)
     &                //'.t'//char(i3+48)//char(i4+48)
              endif
            endif
          endif
        endif
        if ((ii.eq.1.and.nrst.ne.0).or.(ii.eq.2.and.nrst.ne.nouter)) 
     &      then
          if (frth(j).ge.0.50) then
            nfps = 1
          else
            nfps = 2
          endif
        open (12,file=fname,status='old')
        open (13,file=f2name,status='unknown')
        read (12,'(a72)') char72
        write (13,'(a72)') char72
        read (12,'(23x,a9,1x,a7)') char9,char7
        if (ii.eq.1) then
          write (13,'(1pe11.4,a1,1pe11.4,a9,i1,a7)') voli(j),',',
     &      fnorm,char9,nfps,char7
        else
          write (13,'(1pe11.4,a1,1pe11.4,a9,i1,a7)') voli(j),',',
     &      f2norm,char9,nfps,char7
        endif
        do i=1,5
          read (12,'(a72)') char72
          write (13,'(a72)') char72
        enddo
        close (12)
        close (13)
        endif
      ELSE
      open (12,file=fname,status='old',err=140)
      open (13,file=fname2,status='unknown')
      if (mt(j).lt.0) then
        flux(j) = 0.0
        flux2(j) = 0.0
      endif
c
  130 read (12,'(a3)',end=140) ju3
      if (ju3.eq.'IRF') then
       backspace(12)
       read (12,'(a6,1pe13.5)',end=140) ju6,dstep
       if (ii.eq.1) then
         write (13,992) dstep,flux(j)
       else
         write (13,992) dstep,flux2(j)
       endif
      else
       backspace(12)
       read (12,'(a80)',end=140) ju80
       write (13,'(a80)') ju80
      end if
      goto 130
  140 continue
      close (12)
      close (13)
      ENDIF
  150 continue
  160 continue
c
c... Obtain power fraction for ALL steps for flux calculations
c...   if zero predictor steps are used
c
       IF (olib(1:6).ne.'CINDER') then
       if (npre.eq.0) then
       if (nfd.eq.1) then
        open (15,file='feed',status='old')
        read (15,*)
        read (15,*)
        do 111 i=1,nouter
         do 111 j=1,nmat
          if (j.eq.1) then
           read (15,*) tmst(i),day(i),pfra(i),
     &      nmt(1),nfeed(i,1),gf1(i,1),gf2(i,1),
     &      (nf(l,i,1),rf(l,i,1),l=1,3)
          elseif (j.ge.2) then
           read (15,*)
     &      nmt(j),nfeed(i,j),gf1(i,j),gf2(i,j),
     &      (nf(l,i,j),rf(l,i,j),l=1,3)
          endif
  111    continue
         close (15)
       else
         do 112 i=1,nouter
  112      pfra(i) = 1.0
       endif
c
c...Modify flux in origen files.  For zero predictor steps, modify all fluxes
c
      do 170 j=1,nmat
      do 168 i=2,nouter
       if (j.lt.10) then
        if (i.lt.10) then
          fname=tmpfile//'TAPE5_'//char(j+48)//'.IN'
     &        //char(i+48)
          fname2=tmpfile//'TAPE5_'//char(j+48)//'.t'//char(i+48)
        elseif (i.lt.100) then
         i1 = i/10
         i2 = i - i1*10
         fname=tmpfile//'TAPE5_'//char(j+48)//'.I'
     &         //char(i1+48)//char(i2+48)
         fname2=tmpfile//'TAPE5_'//char(j+48)//'.t'
     &          //char(i1+48)//char(i2+48)
        else
         i1 = i/100
         i2 = (i - i1*100)/10
         i3 = i - i2*10 - i1*100
         fname=tmpfile//'TAPE5_'//char(j+48)//'.'
     &         //char(i1+48)//char(i2+48)//char(i3+48)
         fname2=tmpfile//'TAPE5_'//char(j+48)//'.t'
     &          //char(i1+48)//char(i2+48)//char(i3+48)
        end if
       elseif (j.ge.10) then
        j1 = j/10
        j2 = j - j1*10
        if (i.lt.10) then
         fname=tmpfile//'TAPE5_'//char(j1+48)//char(j2+48)//
     &          '.IN'//char(i+48)
         fname2=tmpfile//'TAPE5_'//char(j1+48)//char(j2+48)//'.t'
     &          //char(i+48)
        elseif (i.lt.100) then
         i1 = i/10
         i2 = i - i1*10
         fname=tmpfile//'TAPE5_'//char(j1+48)//char(j2+48)//'.I'
     &           //char(i1+48)//char(i2+48)
         fname2=tmpfile//'TAPE5_'//char(j1+48)//char(j2+48)//'.t'
     &           //char(i1+48)//char(i2+48)
        else
         i1 = i/100
         i2 = (i - i1*100)/10
         i3 = i - i2*10 - i1*100
         fname=tmpfile//'TAPE5_'//char(j1+48)//char(j2+48)//'.'
     &       //char(i1+48)//char(i2+48)//char(i3+48)
         fname2=tmpfile//'TAPE5_'//char(j1+48)//char(j2+48)//'.t'
     &       //char(i1+48)//char(i2+48)//char(i3+48)
        end if
       endif
c
c
c... Normalize the flux obtained from MCNP by using the factors "nu"
c... power, energy per fission, and k-eff
c
      if (fsrc.eq.0.) then
       if (CALC.eq.'ORIGEN') then
       fnrm = nu*1.0e+6*pow*pfra(i)/1.602e-13/qave/keff
       f2nrm = nu*1.0e+6*pow*pfra(i)/1.602e-13/qave/keff
         write(*,*)'IHRH4',i,nu,pow,pfra(i),qave,keff
         else
       fnrm = 1.0e+6*(pow-totdecay)*pfra(i)/1.602e-13/qave
       f2nrm =1.0e+6*(pow-totdecay)*pfra(i)/1.602e-13/qave
       endif
      else
       if (CALC.eq.'ORIGEN') then
       fnrm = src*1.0e+6*pow*pfra(i)/1.602e-13/qave/floss
       f2nrm = src*1.0e+6*pow*pfra(i)/1.602e-13/qave/floss
       else
       fnrm = 1.0e+6*(pow-totdecay)*pfra(i)/1.602e-13/qave
       f2nrm =1.0e+6*(pow-totdecay)*pfra(i)/1.602e-13/qave
      endif
      endif
      fluxy(j)=fnrm*flx(j)
      fluxy2(j)=f2nrm*flx(j)
      if (mt(j).lt.0) then
        fluxy(j) = 0.0
        fluxy2(j) = 0.0
      endif
      open (12,file=fname,status='old',err=166)
      open (13,file=fname2,status='unknown')
c
  164 read (12,'(a3)',end=166) ju3

      if (ju3.eq.'IRF') then
       backspace(12)
       read (12,'(a6,1pe13.5)',end=166) ju6,dstep
       if (ii.eq.1) then
         write (13,992) dstep,fluxy(j)
       else
         write (13,992) dstep,fluxy2(j)
       endif
      else
       backspace(12)
       read (12,'(a80)',end=166) ju80
       write (13,'(a80)') ju80
      end if
      goto 164
  166 continue
      close (12)
      close (13)
  168 continue
  170 continue
      endif
      ENDIF
      endif
c
      open (15,file=tmpfile//'mb11.out',status='unknown')
      if (nrst.eq.0) then
         time = 0.0
      else
       if (posit.eq.'b') then
         time = daynum - day(nrst) + 0.01
       elseif (posit.eq.'m') then
         time = daynum - day(nrst)/2.0
       else
         time = daynum
       endif
      endif
c
c...Calculate k infinity and output results
c
      if (posit.eq.'m') then  
        macfis = 0.0
        macabs = 0.0
        macab = 0.0
        macn2n = 0.0
        macf = 0.0
        do 167 j=1,nmat
        macn2n = macn2n + n2nmac(j)
        macabs = macabs + absmac(j)
        macfis = macfis + fismac(j) 
        macf = macf + xs(ntot(j)+1,4,j)*totavalact(j)
  167   macab = macab + xs(ntot(j)+2,1,j)*totaval(j)
c        kinf = (nu*macfis + 2.0*macn2n)/(macfis + macabs) 
        kinf2 = (nu*macf + 2.0*macn2n)/(macf + macab)
        write (15,903) nrst,posit,time,keff,relerr,nu,qave,kinf2
      else
        write (15,904) nrst,posit,time,keff,relerr,nu
      endif
      close (15)
      write (6,901) keff,nu
  900 format (' ...MB: mcnp flux for material ',i3,' = ',1pe9.2,
     &        '  SigmaF = ',1pe9.2,'  power = ',0pf10.3,
     &        'MW  Burnup = ',1pe10.3,' GWd/MTHM')
  901 format (' ...MB: mcnp keff = ',f7.5,'  nu = ',f5.3)
  902 format (i3,1x,0pf10.3,1p3e10.2,1p2e10.3,1x,1p4e10.2,
     &              0pf8.3,2x,1p4e10.2,0pf8.3)
  903 format (i3,a1,1x,f8.2,1x,2f10.5,f10.3,1x,2f10.3)
  904 format (i3,a1,1x,f8.2,1x,2f10.5,f10.3)
  911 format (i4,4(1x,i6,2x,1pe10.4))
  992 format ('IRF   ',1p2e13.5,'    2  3  4  1')
      return
      end
c
c23456789*123456789*123456789*123456789*123456789*123456789*123456789*12
c
c...CALCQ calculates the MeV per fission based on fission distribution
c...and qu235 (recov. MeV per U235 fission)
c
      subroutine calcq(qrat,nuclf,grmatf,nucli,xsec,nn,mn,mifis,nj,nucl)
c
      common /mbinp/nmat,mt(49),voli(49),pow,qu235,days,nouter,ninner,
     & npre,nrst,frimp,nauto(49),ntot(49),nkeff,mbxs,nisn(999,49),
     & nisnr(999,49)
      common /mbinp2/niso(999,49),nisor(999,49),title,olib,locale,posit,
     &     tmpfile,machin,CALC
      character niso*10,nisor*6,title*72,olib*10,locale*72,posit*1,
     &          machin*4,tmpfile*10,CALC*6
      dimension nisact(0:50),qract(0:50),fis(0:50),nuclf(9999),
     &          grmatf(9999),xsec(6,9999),nucli(9999),nucl(9999)
      real mifis(9999)
c
      data (nisact(i),qract(i),i=0,31) /
     & 0,1.0,
     & 90227,0.9043, 90229,0.9247,
     & 90232,0.9573, 91231,0.9471,
     & 91233,0.9850, 92232,0.9553,
     & 92233,0.9881, 92234,0.9774,
     & 92235,1.0000, 92236,0.9973,
     & 92237,1.0074, 92238,1.0175,
     & 93237,1.0073, 93238,1.0175,
     & 94238,1.0175, 94239,1.0435,
     & 94240,1.0379, 94241,1.0536,
     & 94242,1.0583, 95241,1.0513,
     & 95242,1.0609, 95243,1.0685,
     & 96242,1.0583, 96243,1.0685,
     & 96244,1.0787, 96245,1.0889,
     & 96246,1.0991, 96248,1.1195,
     & 96249,1.1296, 98251,1.1501,
     & 99254,1.1807   /
      qrat=0.
      nact=31    
c
c...Read tape7 and tape9 to get density and fis xs
c
c
c...Calc relative fission per nuclide
c
      do 10 k=0,nact
   10 fis(k)=0.
      fistot=0.
      IF (olib(1:6).eq.'CINDER') then
        do 15 i=1,nj
          nisq1 = nucl(i)/10
          if (nisq1/1000.ge.90) then
            kk = 0
            do k=1,nact
              if (nisact(k).eq.nisq1) kk=k
            enddo
            fis(kk) = fis(kk) + mifis(i)    
            fistot = fistot + mifis(i)
          endif
   15   enddo
      ELSE 
      do 40 j=1,nn
        ixs=0
        do 20 m=1,mn
          if (nuclf(j).eq.nucli(m)) then
            ixs=1
            xs4 = xsec(4,m)
            gad = grmatf(j) 
            nisq1 = nuclf(j)/10
c            goto 24
          endif
   20   continue
c
   24   if (ixs.ne.0) then
          kk=0
          do 37 k=1,nact
            if (nisact(k).eq.nisq1) kk=k
   37     continue
c
c... Obtain fission contribution of each actinide
c... If actinide does not have a specific actinide fraction,
c...   then it is added into the total fissionable material
c...   and its Q is considered to be equal to that of U235
c...   and is kept in array 0
c
          fis(kk)=fis(kk)+gad*xs4
          fistot=fistot+gad*xs4
        else
c         write (6,*) 'Warning:  isotope', nuclf(j),' was not ',
c     &                'found in both libraries'
        endif
c
   40 continue
      ENDIF
c
c...Calculate Q based on fission percentage
c
      if (fistot.eq.0.) then
        qrat = 0.
      else
        do 60 k=0,nact
          qrat = qrat + fis(k)/fistot*qract(k) 
   60   continue
      end if
c
  911 format (i4,4(1x,i6,2x,1pe10.4))
  913 format (i4,a4)
  921 format (i4,i8,1p6e10.3,f7.1)
c
      return
      end
c
c23456789*123456789*123456789*123456789*123456789*123456789*123456789*12
c
c... ACTIV calculate activity, heatload, inhalation and ingestion
c...    radiotoxicities  
c
      subroutine activ(nuclid,thalf,number,atomwe,gad,qrec,
     &                 curies,inhala,ingest,heatlo) 
      dimension isot(56)
      real inhal(56),inges(56),number,ingest,inhala
c
c...  This toxicity data was taken from:
c...    Benedict, Pigford, and Levi, "Nuclear Chemical Engineering"
c...    Second edition, McGraw-Hill Book Company, New York, 1981
c...    Appendix D, which was taken from U.S. Nuclear Regulatory
c...    Commission, Rules and Regulations 10CFR20, Appendix B, 
c...    Table II, Federal Register, Dec. 1, 1978, (except for
c...    Ra-225). 
c
      data isot(1),inhal(1),inges(1) /952410,2.0e-13,4.0e-6/
      data isot(2),inhal(2),inges(2) /952421,2.0e-13,4.0e-6/
      data isot(3),inhal(3),inges(3) /952430,2.0e-13,4.0e-6/
      data isot(4),inhal(4),inges(4) /952420,1.0e-9,1.0e-4/
      data isot(5),inhal(5),inges(5) / 60140,1.0e-7,8.0e-4/
      data isot(6),inhal(6),inges(6) /551340,1.0e-9,9.0e-6/
      data isot(7),inhal(7),inges(7) /551370,2.0e-9,2.0e-5/
      data isot(8),inhal(8),inges(8) /962420,4.0e-12,2.0e-5/
      data isot(9),inhal(9),inges(9) /962430,2.0e-13,5.0e-6/
      data isot(10),inhal(10),inges(10) /962440,3.0e-13,7.0e-6/
      data isot(11),inhal(11),inges(11) /10030,2.0e-7,3.0e-3/
      data isot(12),inhal(12),inges(12) /531290,2.0e-11,6.0e-8/
      data isot(13),inhal(13),inges(13) /531310,1.0e-10,3.0e-7/
      data isot(14),inhal(14),inges(14) /531330,4.0e-10,1.0e-6/
      data isot(15),inhal(15),inges(15) /360851,1.0e-7,0.0/
      data isot(16),inhal(16),inges(16) /360850,3.0e-7,0.0/
      data isot(17),inhal(17),inges(17) /571400,5.0e-9,2.0e-5/
      data isot(18),inhal(18),inges(18) /932370,1.0e-13,3.0e-6/
      data isot(19),inhal(19),inges(19) /410931,4.0e-9,4.0e-4/
      data isot(20),inhal(20),inges(20) /410950,2.0e-8,1.0e-4/
      data isot(21),inhal(21),inges(21) /942380,7.0e-14,5.0e-6/
      data isot(22),inhal(22),inges(22) /942390,6.0e-14,5.0e-6/
      data isot(23),inhal(23),inges(23) /942400,6.0e-14,5.0e-6/
      data isot(24),inhal(24),inges(24) /942410,3.0e-12,2.0e-4/
      data isot(25),inhal(25),inges(25) /942420,6.0e-14,5.0e-6/
      data isot(26),inhal(26),inges(26) /912310,4.0e-14,9.0e-7/
      data isot(27),inhal(27),inges(27) /912330,2.0e-8,1.0e-4/
      data isot(28),inhal(28),inges(28) /882240,2.0e-10,2.0e-6/
      data isot(29),inhal(29),inges(29) /882250,0.0,5.0e-7/
      data isot(30),inhal(30),inges(30) /882260,3.0e-12,3.0e-8/
      data isot(31),inhal(31),inges(31) /882280,2.0e-12,3.0e-8/
      data isot(32),inhal(32),inges(32) /862200,1.0e-8,0.0/
      data isot(33),inhal(33),inges(33) /862220,3.0e-9,0.0/
      data isot(34),inhal(34),inges(34) /451031,3.0e-6,1.0e-2/
      data isot(35),inhal(35),inges(35) /441030,2.0e-8,8.0e-5/
      data isot(36),inhal(36),inges(36) /441060,3.0e-9,1.0e-5/
      data isot(37),inhal(37),inges(37) /380890,3.0e-10,3.0e-6/
      data isot(38),inhal(38),inges(38) /380900,3.0e-11,3.0e-7/
      data isot(39),inhal(39),inges(39) /430990,7.0e-8,3.0e-4/
      data isot(40),inhal(40),inges(40) /521290,2.0e-7,8.0e-4/
      data isot(41),inhal(41),inges(41) /521311,1.0e-8,6.0e-5/
      data isot(42),inhal(42),inges(42) /902280,3.0e-13,7.0e-6/
      data isot(43),inhal(43),inges(43) /902300,8.0e-14,2.0e-6/
      data isot(44),inhal(44),inges(44) /902310,5.0e-8,2.0e-4/
      data isot(45),inhal(45),inges(45) /902320,1.0e-12,2.0e-6/
      data isot(46),inhal(46),inges(46) /902340,2.0e-9,2.0e-5/
      data isot(47),inhal(47),inges(47) /922320,3.0e-12,3.0e-5/
      data isot(48),inhal(48),inges(48) /922330,2.0e-11,3.0e-5/
      data isot(49),inhal(49),inges(49) /922340,2.0e-11,3.0e-5/
      data isot(50),inhal(50),inges(50) /922350,2.0e-11,3.0e-5/
      data isot(51),inhal(51),inges(51) /922360,2.0e-11,3.0e-5/
      data isot(52),inhal(52),inges(52) /922380,3.0e-12,4.0e-5/
      data isot(53),inhal(53),inges(53) /541330,3.0e-7,0.0/
      data isot(54),inhal(54),inges(54) /390900,4.0e-9,2.0e-5/
      data isot(55),inhal(55),inges(55) /400930,4.0e-9,8.0e-4/
      data isot(56),inhal(56),inges(56) /400950,4.0e-9,6.0e-5/
      iflag = 0
      do 10 i=1,56
        if (nuclid.eq.isot(i)) then
          iflag = i 
          goto 20
        endif
   10 continue
c
c...  Determine activation power(?).  (not valid if isotope is stable)
c
   20 if (thalf.ne.0.0) then
c
c...  Specific activity in Bq/g
c...  Turner, James E. "Atoms, Radiation, and Radiation Protection",
c...        pg. 64
c
        specac = log(2.0)*6.022e+23/(atomwe*thalf)
c
c...  Convert grams of material to Curies (1 Ci = 3.7e+10 Bq)
c
        curies = gad*atomwe*specac/3.7e+10
        ingest = 0.0
        inhala = 0.0
        if (iflag.ne.0) then
           if (inges(iflag).gt.0.0) then
              ingest = log(2.0)*number/(thalf*inges(iflag)*3.7e+10)
           endif
           if (inhal(iflag).gt.0.0)  then
              inhala = log(2.0)*number/(thalf*inhal(iflag)*3.7e+10)
           endif
        endif
      else
        curies = 0.0
        ingest = 0.0
        inhala = 0.0
      endif
      heatlo = curies*3.7e+10*qrec*1.0e+6*1.60219e-19
c
      return
      end 
c
c23456789*123456789*123456789*123456789*123456789*123456789*123456789*12
c
c...WMCINP modifies the mcnp input file with new compositions, materials
c...are added if they are deemed "important players".  Data is
c...read from tape7 in gram-atoms, and put into mass fractions.
c
      subroutine wmcinp
c
      common /mbinp/nmat,mt(49),voli(49),pow,qu235,days,nouter,ninner,
     & npre,nrst,frimp,nauto(49),ntot(49),nkeff,mbxs,nisn(999,49),
     & nisnr(999,49)
      common /mbinp2/niso(999,49),nisor(999,49),title,olib,locale,posit,
     &     tmpfile,machin,CALC
      character niso*10,nisor*6,title*72,olib*10,locale*72,posit*1,
     &          machin*4,line*80,numcnp*10,nnat*10,filednz*9,filem*12,
     &          ninat*10,tape7*12,tape9*12,file7*22,file4*22,line82*82,
     &          fnat*22,finp*22,fmcnp*22,nmcnp*10,blanks*4,char10*10,
     &          nPufp*10,nUfp*10,f9err*22,line80*80,char5*5,tmpfile*10,
     &          nmbxs*10,CALC*6
      dimension nisq(4),gad(4),gden(49),nis(9999),nj(49),nmbxs(999),
     &          neleme(9999),nnat(9999),numcnp(9999),numc(9999),
     &          xsec(6,9999),nucli(9999),xs(4,9999),kx(9999),
     &          nisotop(9999,49),numden(9999,49),nisot(3500),nix(999)
      double precision gramat(9999),gmnat(9999),gm(9999,49),
     &          gmcnp(9999),gmtot,gmtot2,numden
      integer o,b(10),e(10),nele
      character mtlbname*6
      real*8 atperbcm(3500)
c
c...Read TAPE7, and TAPE9.  sum total gamma and fission, and
c...then step back through and determine contributors, sum mass
c...of each contibutor.
c
c   For CINDER, read material file to get isotopic compositions
c
      IF (olib(1:6).eq.'CINDER') then
c
        icind = 0
        open (7,file='library',status='old')
   41   read (7,'(a10)',end=43) char10
        if (char10.ne.'__________') goto 41
        icind = icind + 1
        read (7,'(7x,i7)') isoname
        nisot(icind) = (isoname-10*(isoname/10))+10*(isoname/10000)
     &      + 10000*((isoname - 10000*(isoname/10000))/10)
        goto 41
   43   continue
c
        if (nrst.eq.0) then
          open (7,file='material',status='unknown')
          read (7,*)
   62     read (7,'(3x,i3,i4,f10.8)',end=63) mat,nisos,atomden
          do 66 j=1,nmat
            if (mat.eq.abs(mt(j))) then
              nj(j) = nisos
              do k=1,nisos
                read (7,940) isoname,atomfra
                nisotop(k,j) = (isoname-10*(isoname/10))
     &            + 10*(isoname/10000)
     &            + 10000*((isoname - 10000*(isoname/10000))/10)
                numden(k,j) = atomfra*atomden
  940           format (i7,2x,f11.8)
              enddo
            endif
   66     continue
          goto 62
   63     close (7)
        endif
      ENDIF
c
      do 180 j=1,nmat
      gfp = 0.
      iflag = 0
      iflg = 0
      if (j.lt.10) then
        if (olib(1:6).eq.'CINDER') then
          filednz = 'alldnz_'//char(j+48)
        else
          tape7 = 'TAPE7_'//char(j+48)//'.OUT'
          tape9 = 'TAPE9_'//char(j+48)//'.INP'
        endif
        if (machin(1:3).ne.'VMS') then
          f9err = './tmpfile/T9err_'//char(j+48)//'.TXT'
        elseif (machin(1:3).eq.'VMS') then
          f9err = '[.tmpfile]T9err_'//char(j+48)//'.TXT'
        endif
        file4 = tmpfile//'mb4_'//char(j+48)//'.out'
        file7 = tmpfile//'mb7_'//char(j+48)//'.out'
        fnat = tmpfile//'mnat_'//char(j+48)//'.tmp'
        fmcnp = tmpfile//'mcnp_'//char(j+48)//'.inp'
        finp = tmpfile//'mat_'//char(j+48)//'.inp'
      elseif (j.ge.10) then
        j1 = j/10
        j2 = j - j1*10
        if (olib(1:6).eq.'CINDER') then
          filednz = 'alldnz_'//char(j1+48)//char(j2+48)
        else
          tape7 = 'TAPE7_'//char(j1+48)//char(j2+48)//'.OUT'
          tape9 = 'TAPE9_'//char(j1+48)//char(j2+48)//'.INP'
        endif
        if (machin(1:3).ne.'VMS') then
          f9err = './tmpfile/T9err_'//char(j1+48)//char(j2+48)//'.TXT'
        elseif (machin(1:3).eq.'VMS') then
          f9err = '[.tmpfile]T9err_'//char(j1+48)//char(j2+48)//'.TXT'
        endif
        file4 = tmpfile//'mb4_'//char(j1+48)//char(j2+48)//'.out'
        file7 = tmpfile//'mb7_'//char(j1+48)//char(j2+48)//'.out'
        fnat = tmpfile//'mnat_'//char(j1+48)//char(j2+48)//'.tmp'
        fmcnp = tmpfile//'mcnp_'//char(j1+48)//char(j2+48)//'.inp'
        finp = tmpfile//'mat_'//char(j1+48)//char(j2+48)//'.inp'
      endif
c
c... Read data about natural elements and other isotopes initially
c...    in the MCNP input file
c
       mm = 0
       nn = 0
       open (17,file=fmcnp,status='unknown')
   16  read (17,'(i5,2x,a10)',err=16,end=18) nmc,nmcnp
        mm = mm + 1
        numcnp(mm) = nmcnp
        numc(mm) = nmc
        goto 16
   18  close (17)
c
c...  Natural elements initially contained in MCNP input file
c
      open (11,file=fnat,status='unknown')
   26 read (11,'(i2,4x,a10)',err=26,end=28) nelem,ninat
       nn = nn + 1
       neleme(nn) = nelem
       nnat(nn) = ninat
       goto 26
   28 close (11)
      nm = 0
      do 15 n=1,999
      gmcnp(n) = 0.
   15 gmnat(n) = 0.
c
c... Open TAPE9 and TAPE7 files and a file for error messages
c
      IF (olib(1:6).eq.'CINDER') then
c
      if (nrst.eq.0) then
        do k=1,icind
          atperbcm(k) = 0.0
          do i=1,nj(j)
            if (nisotop(i,j).eq.nisot(k)) then
              atperbcm(k) = numden(i,j) 
            endif
          enddo
        enddo
      else
        open (unit=78,file=filednz,form='unformatted',status='old')
        read(78) mtlbname
        write(6,251) mtlbname
  251   format(' Read DNZ for matname=',a6)
        do 260 kb=1,2
        read (78) kbt,jnuc
        read (78) (atperbcm(i),i=1,jnuc)
  260   continue
        close (78)
      endif
c
      do 270 k=1,icind
        if (atperbcm(k).ne.0.0) then
          nm = nm + 1
          nis(nm) = nisot(k)
          gramat(nm) = atperbcm(k)*voli(j)/0.6022
          nisq1=nis(nm)/10
          a=float(nisq1)-float(1000*(nisq1/1000))
c
c  Tag MCNP input file isotopes and natural elements
c
          do 236 m=1,mm
           if (numc(m).eq.nisq1) then
            id = 1
            gmcnp(m)= a*gramat(nm)
           endif
  236     continue
          nele = nis(nm)/10000
          do 247 n=1,nn
           if (nele.eq.neleme(n)) then
            nisq1=nis(nm)/10
            a=float(nisq1)-float(1000*(nisq1/1000))
            gmnat(n)=gmnat(n)+a*gramat(nm)
           endif
  247     continue
c
          tmas=tmas+gramat(nm)*a
          tden=tden+gramat(nm)
        endif
  270 continue
      goto 290
  280 write(6,281)
  281 format(' ERR DNZ: No densities from preceding job input: STOP')
      stop 11
  284 write(6,285)
  285 format(' END DNZ: No densities from preceding job input: STOP')
      stop 12
  290 continue
c
      ELSE 
      open (12,file=tape7,status='old')
      open (13,file=tape9,status='old')
      open (11,file=f9err,status='unknown')    
c
c... Read cross section data from TAPE9 
c
      mn = 0
   91 ixs=0
      read (13,913,err=91,end=94) nflag,blanks
      if (nflag.gt.3.and.blanks.ne.'    ') then
        backspace(13)
   92   read (13,921,err=92)
     &  nxs,nnuc,xs1,xs2,xs3,xs4,xs5,xs6,xflag
        mn = mn + 1
        nucli(mn) = nnuc
        xsec(1,mn) = xs1
        xsec(2,mn) = xs2
        xsec(3,mn) = xs3
        xsec(4,mn) = xs4
        xsec(5,mn) = xs5
        xsec(6,mn) = xs6
      end if
      goto 91
   94 close (13)
c
c...Sum total density, gamma and fission
c
      tden=0.
      tmas=0.
      tabs=0.
      tfis=0.
      nm = 0
   20 read (12,911,err=20,end=50) kxs,(nisq(k),gad(k),k=1,4)
      do 40 k=1,4
      nm = nm + 1
      kx(nm) = kxs
      nis(nm) = nisq(k) 
      gramat(nm) = gad(k)
      if (nisq(k).gt.0) then 
       ixs=0
       do 30 m=1,mn
       if (nucli(m).eq.nisq(k)) then
         ixs=m
         goto 32 
       endif
   30  continue
   32  if (ixs.ne.0) then
         xs(1,nm) = xsec(1,ixs)
         xs(4,nm) = xsec(4,ixs)
       else
         xs(1,nm) = 0.0
         xs(4,nm) = 0.0 
       endif 
c
       nisq1=nisq(k)/10
       a=float(nisq1)-float(1000*(nisq1/1000))
       tmas=tmas+gad(k)*a
       tden=tden+gad(k)
       tabs=tabs+gad(k)*xs(1,nm)
       if (kxs.eq.2) then 
         iflg = 1 
         tfis=tfis+gad(k)*xs(4,nm)
       endif
c
c... Obtain composition (in grams) of all isotopes in MCNP input file
c...    to transfer them in case they are not found "important"
c
      if (kxs.eq.1.or.kxs.eq.2) then 
       id = 0
       do 36 m=1,mm
        if (numc(m).eq.nisq1) then
         id = 1
         gmcnp(m)= a*gad(k)         
        endif
   36  continue
      elseif (kxs.eq.3) then
        gfp = gfp + a*gad(k)
      endif
      end if
c
c... Add up gram totals for natural isotopes
c
      if (kxs.eq.1.or.kxs.eq.2) then
        nele = nisq(k)/10000
        do 47 n=1,nn
         if (nele.eq.neleme(n)) then 
          nisq1=nisq(k)/10
          a=float(nisq1)-float(1000*(nisq1/1000))               
          gmnat(n)=gmnat(n)+a*gad(k)
         endif
   47   continue
       endif
   40 continue
      goto 20
c
   50 close (12)
      close (13)
  911 format (i4,4(1x,i6,2x,1pe10.4))
c  912 format (i4,4(1x,i2,i4,2x,1pe10.4))
  913 format (i4,a4)
  921 format (i4,i8,1p6e10.3,f7.1)
      ENDIF
c
c...Begin list of mcnp input isos with automatic tallies list
c
      ntot(j)=nauto(j)
c
c...Now determine which iso's contribute based on frimp or are
c..already selected (auto due to input or may occur twice in table)
c
      gmtot=0.
      U235f=0.
      Pu239f=0.
      IF (olib(1:6).ne.'CINDER') then
        open (16,file=file7,status='unknown')
        write (16,*) 
      ENDIF
      do 80 k=1,nm
c
      if (nis(k).gt.0) then 
       ixs=0
       IF (olib(1:6).eq.'CINDER') then
         ixs = 1
       ELSE 
         do 70 m=1,mn
         if (nucli(m).eq.nis(k)) then
           ixs=1
           goto 79
         endif
   70    continue
   79    if (ixs.eq.0)  then
           if (kx(k).ne.3) then
             write (11,'(a27,i6,a20)') '***** MB WARNING:  Isotope ',
     &          nis(k),' not found in TAPE9'
           endif
         endif
       ENDIF                    
c
c...Determine which isos qualify, or are automatic or repeat.
c
       icon=0
       nisq1=nis(k)/10
       a=float(nisq1)-float(1000*(nisq1/1000))
       gmtot=gmtot+a*gramat(k)
       gpct=gramat(k)*a/tmas
       dpct=gramat(k)/tden
       if (olib(1:6).ne.'CINDER') then
         if (tabs.ne.0.) then
           apct=gramat(k)*xs(1,k)/tabs
         else
           apct = 0.0
         endif
         fpct=0.
         nz = nisq1/1000
         if (kx(k).eq.2.and.tfis.ne.0.) then 
           fpct=gramat(k)*xs(4,k)/tfis
           if (nz.le.92) U235f = U235f + fpct
           if (nz.gt.92) Pu239f = Pu239f + fpct
         endif
       endif
c
       if (gpct.gt.abs(frimp)) icon=1
       if (dpct.gt.abs(frimp)) icon=1
       if (olib(1:6).ne.'CINDER') then
         if (apct.gt.abs(frimp)) icon=1
         if (fpct.gt.abs(frimp)) icon=1
       endif
       kk=0
       do 77 m=1,ntot(j)
         if (nisnr(m,j).eq.nis(k)) then
            kk=m
c
c... If a fission product is flagged "automatic", then don't include it in 
c... lump sum of FPs.  Otherwise, do. (kk=0 indicates it was not "automatic")
c
            if (olib(1:6).ne.'CINDER'.and.kx(k).eq.3) then
              gfp = gfp - a*gramat(k) 
            endif
         endif
   77  continue
c
c... Make sure natural isotopes are not deemed "important" since they are 
c...   included later
c
      nele = nis(k)/10000
      do 96 n=1,nn
      if (nele.eq.neleme(n)) then
        icon = 0
      endif
   96 continue
c
c...If repeat or automatic isotope
c
       if (kk.gt.0) then
         gm(kk,j)=gm(kk,j)+a*gramat(k)
         if (gm(kk,j).gt.a*gramat(k)) then 
         write (6,953) nrst,kk,nisnr(kk,j),gm(kk,j),gpct,dpct,apct,fpct
         write (16,953) nrst,kk,nisnr(kk,j),gm(kk,j),gpct,dpct,apct,fpct
         else
         if (icon.eq.1) write(6,951) nrst,kk,nisnr(kk,j),gm(kk,j),gpct,
     &         dpct,apct,fpct
         if (icon.eq.0) write(6,952) nrst,kk,nisnr(kk,j),gm(kk,j),gpct,
     &         dpct,apct,fpct
         if (icon.eq.1) write(16,951) nrst,kk,nisnr(kk,j),gm(kk,j),gpct,
     &         dpct,apct,fpct
         if (icon.eq.0) write(16,952) nrst,kk,nisnr(kk,j),gm(kk,j),gpct,
     &         dpct,apct,fpct
         end if
       end if
c
c...Fission products that were not previously deemed "important" will
c...   be treated as a lump sum
c
       if (olib(1:6).ne.'CINDER'.and.kx(k).eq.3.and.kk.eq.0.and.
     &       frimp.lt.0.0) then
       else
c
c...If new qualifying isotope, first check if xs exists then add to ntot
c
       if (icon.eq.1.and.kk.eq.0) then
        if (mbxs.eq.1) then
          if (nrst.lt.10) then
           filem = 'mbxs_'//char(nrst+48)//'.inp'
          elseif (nrst.lt.100) then
           i1 = nrst/10
           i2 = nrst - i1*10
           filem = 'mbxs_'//char(i1+48)//char(i2+48)//'.inp'
          else
           i1 = nrst/100
           i2 = (nrst - i1*100)/10
           i3 = nrst - i2*10 - i1*100
           filem = 'mbxs_'//char(i1+48)//char(i2+48)//
     &                      char(i3+48)//'.inp'
          endif
        else
          filem = 'mbxs.inp'
        endif
        open (15,file=filem,status='unknown')
        ifd=0
   95   read (15,'(i5)',end=105) nixs
        nixs10 = nixs*10
        if (nixs.eq.95242) nixs10 = nixs10 + 1
        if (nis(k).eq.nixs10) ifd=1
        if (ifd.eq.0) goto 95
        backspace (15)
        read (15,'(a10)') niso(ntot(j)+1,j)
c
  105    if (ifd.eq.0) then
          write (6,*) '***** MB WARNING: mcnp xs not found  ', nis(k)
          write (16,*) '***** MB WARNING: mcnp xs not found  ', nis(k)
         end if
         close (15)
c
         if (ifd.eq.1) then
          ntot(j)=ntot(j)+1
          nisnr(ntot(j),j)=nis(k)
          nisn(ntot(j),j)=nisnr(ntot(j),j)/10 
          gm(ntot(j),j)=a*gramat(k)           
          write (6,951) nrst,ntot(j),nisnr(ntot(j),j),gm(ntot(j),j),
     &                 gpct,dpct,apct,fpct
          write (16,951) nrst,ntot(j),nisnr(ntot(j),j),gm(ntot(j),j),
     &                 gpct,dpct,apct,fpct
         end if
        end if
       endif
      end if
   80 continue
c
   90 continue      
  951 format (i4,i4,i10,1p5e10.2)
  952 format (i4,i4,i10,1p5e10.2,'automatic')
  953 format (i4,i4,i10,1p5e10.2,'repeat')
      close (16)
c
c...Write grams of material
c
      if (posit.eq.'m') then
        open (14,file=file4,status='unknown')
        write (14,'(i3,1x,1pe9.2,250e10.2)')nrst,(gm(i,j),i=1,nauto(j))
        close (14)
      endif
c
c...Rewrite mb.inp
c
c      call wmbinp
c
c...Check if mass of isos sent back to mcnp is same as came in.
c
      gmtot2=0.
      do 140 i=1,ntot(j)
  140 gmtot2=gmtot2+gm(i,j)
c
c...Read natural iso file and add to total mass
c
      do 144 n=1,nn
c
c... Delete isotopes specified as "automatic" by the user
c...  from the natural element concentrations if need be
c
      do 143 i=1,ntot(j)
       nz=nisn(i,j)/1000
       if (nz.eq.neleme(n)) then
         gmnat(n) = gmnat(n) - gm(i,j)
       endif
  143 continue
      gmtot2=gmtot2+gmnat(n)
  144 continue  
c
c... Add isotopes in original MCNP input file
c
      do 148 m=1,mm
      ifg = 0
      do 147 i=1,ntot(j)
       if (nisn(i,j).eq.numc(m)) ifg = 1
  147 continue
      if (ifg.ne.1) then
       gmtot2=gmtot2+gmcnp(m)
      endif
  148 continue
c
c... Add fission products to gram total, then separate into U-235 & Pu-239 ones
c
      if (gfp.gt.0.0.and.frimp.lt.0.0) then
       gmtot2=gmtot2 + gfp
       gUff = U235f*gfp
       gPuff = Pu239f*gfp
      endif
c
c... Compare total of isotopes to total included in MCNP input file
c... Calculate gram density of material
c
      write (6,*) 'mass not accounted for and % ',gmtot-gmtot2,
     & (gmtot-gmtot2)/gmtot
      gden(j) = -gmtot2/voli(j)
c
c...Modify mt card with input file mat.inp
c
  160 open (12,file=finp,status='unknown')
      if (abs(mt(j)).lt.10) write (12,931) abs(mt(j))
      if (abs(mt(j)).ge.10.and.abs(mt(j)).lt.100) 
     &             write (12,932) abs(mt(j))
      if (abs(mt(j)).ge.100.and.abs(mt(j)).lt.1000) 
     &             write (12,933) abs(mt(j))
      if (abs(mt(j)).ge.1000.and.abs(mt(j)).lt.10000) 
     &             write (12,934) abs(mt(j))
  931 format ('c'/'m',i1)
  932 format ('c'/'m',i2)
  933 format ('c'/'m',i3)
  934 format ('c'/'m',i4)
c
c...  Read cross section input file 
c      
       if (mbxs.eq.1) then
         if (nrst.lt.10) then
           filem = 'mbxs_'//char(nrst+48)//'.inp'
         elseif (nrst.lt.100) then
           i1 = nrst/10
           i2 = nrst - i1*10
           filem = 'mbxs_'//char(i1+48)//char(i2+48)//'.inp'
         else
           i1 = nrst/100
           i2 = (nrst - i1*100)/10
           i3 = nrst - i2*10 - i1*100
           filem = 'mbxs_'//char(i1+48)//char(i2+48)//
     &                      char(i3+48)//'.inp'
         endif
       else 
         filem = 'mbxs.inp'
       endif
       open (18,file=filem,status='unknown')
        nm = 1
  157   read (18,'(i5)',end=158) nix(nm)
        backspace (18)
        read (18,'(a10)') nmbxs(nm)
        nm = nm + 1
        goto 157
  158  close (18)
c
c... Add isotopes in original MCNP input file
c
      do 152 m=1,mm
      ifg = 0
       do 151 i=1,ntot(j)
        if (nisn(i,j).eq.numc(m)) ifg = 1
  151  continue
       if (ifg.ne.1) then
        if (gmcnp(m).eq.0.) gmcnp(m)=1.0e-20*gmtot2
c        if (mbxs.eq.1) then
          do n=1,nm-1
            if (numc(m).eq.nix(n)) numcnp(m) = nmbxs(n)
          enddo
c        endif
        write (12,'(6x,a10,1pe13.4)') numcnp(m),-gmcnp(m)/gmtot2
       endif
  152 continue
c
c...Add natural isos
c
      do 154 n=1,nn
      iflg = 0
      do 153 i=1,ntot(j)
       aa=(nisn(i,j)-1000*(nisn(i,j)/1000))
       if (aa.eq.0) then
         nz=nisn(i,j)/1000
         if (nz.eq.neleme(n)) then
           iflg = 1
           gm(i,j) = gm(i,j) + gmnat(n)
         endif
       endif
  153 continue
      if (iflg.ne.1) then
        if (gmnat(n).eq.0.) gmnat(n)=1.0e-20*gmtot2
        if (mbxs.eq.1) then
          do no=1,nm-1
            aa=(nix(no)-1000*(nix(no)/1000))
            if (aa.eq.0.and.neleme(n).eq.nix(no)/1000) then
              nnat(n) = nmbxs(no)
            endif
          enddo
        endif
        write (12,'(6x,a10,1pe13.4)') nnat(n),-gmnat(n)/gmtot2
      endif
  154 continue
c
c... Add "important" isotopes
c
      do 150 i=1,ntot(j)
      if (gm(i,j).eq.0.) gm(i,j)=1.0e-20*gmtot2
      if (nisn(i,j).ne.45117.and.nisn(i,j).ne.46119) then
c        if (mbxs.eq.1) then
          do n=1,nm-1
            if (nisn(i,j).eq.nix(n)) niso(i,j) = nmbxs(n)
          enddo
c        endif
        write (12,'(6x,a10,1pe13.4)') niso(i,j),-gm(i,j)/gmtot2
      endif
  150 continue
c
c...Rewrite mb.inp
c
      call wmbinp
c
c    Add Fission products to mat.inp files
c
       if (gfp.gt.0.0.and.frimp.lt.0.0) then
       if (gUff.ne.0) then
        ifd=0
        do n=1,nm
          if (nix(n).eq.45117) then
            ifd = 1
            goto 159
          endif 
        enddo
  159   if (ifd.eq.0) then
          write (6,*) '***** MB WARNING: No Uranium Fission Product ', 
     &               'library was provided in mbxs.inp'    
        else
          nUfp = nmbxs(n)
          write (12,'(6x,a10,1pe13.4)') nUfp,-gUff/gmtot2
        endif
       endif
c
       if (gPuff.ne.0) then
        ifd=0
        do n=1,nm
          if (nix(n).eq.46119) then
            ifd = 1
            goto 162 
          endif
        enddo
  162   if (ifd.eq.0) then
          write (6,*) '***** MB WARNING: No Plutonium Fission Product ',  
     &              'library was provided in mbxs.inp'
        else
          nPufp = nmbxs(n)      
          write (12,'(6x,a10,1pe13.4)') nPufp,-gPuff/gmtot2
        endif
       endif
      endif
c
c... End main material input section
c
      write (12,'(a1)') 'c'

c
c...Write actinide tally material
c
      if (posit.eq.'m') then
        ii = 9900 + j
        do 165 i=1,ntot(j)
  165   if (nisn(i,j).ge.89000) iflag = 1    
        if (iflag.eq.1) then
          write (12,'(a1,i4)') 'm',ii
          do 170 i=1,ntot(j)
          if (nisn(i,j).ge.89000) then
          if (gm(i,j).eq.0.) gm(i,j)=1.0e-10*gmtot2
          write (12,'(6x,a10,1pe13.4)') niso(i,j),-gm(i,j)/gmtot2
          end if
  170     continue
          write (12,'(a1)') 'c'
        endif
      endif
c
      close (11)
      close (12)      
      close (17)
  180 continue
c
c
c... Rewrite density(s) in MCNP input file
c
      nflag = 0
c
c    Initialize "kcode" flag
c
      if (nrst.eq.1.and.posit.eq.'m') then
        kprob = 0
      endif      
c
      open (15,file='mbmc.skl',status='unknown')
      open (17,file='mbmc.tmp',status='unknown')
  181 read (15,'(a5)',end=190) char5 
c
c    Determine if this is a kcode problem or not (a nps prob. is the other
c      option)
c
      if (char5(1:4).eq.'sdef'.and.posit.ne.'m'.and.nkeff.eq.2) then
          backspace (15)
          read (15,'(a80)') line80
c          need = 1
c          write (17,'(a28,a18)') 'ksrc  30 30 -75  30 60 -25  ',
c     &      '60 30 25  60 60 75'                       
          write (17,'(a2,a80)') 'c ',line80
c
c    Print 'ksrc' for beginning and end calculation
c
      elseif (char5(1:5).eq.'c ksr'.and.posit.ne.'m'.and.nkeff.eq.2)
     &       then
          backspace (15)
          read (15,'(a82)') line82
          write (17,'(a80)') line82(3:82)
      elseif (char5(1:4).eq.'ksrc'.and.posit.eq.'m'.and.nkeff.eq.2) then
          backspace (15)
          read (15,'(a80)') line80
          write (17,'(a2,a80)') 'c ',line80
      elseif (char5(1:5).eq.'c sde'.and.posit.eq.'m'.and.nkeff.eq.2)
     &         then
          backspace (15)
          read (15,'(a82)') line82
          write (17,'(a80)') line82(3:82)
      elseif (char5(1:5).eq.'kcode'.and.posit.eq.'m'.and.nkeff.eq.2)
     &         then
          backspace (15)
          read (15,*) char5,nps
          write (17,'(a4,i10)') 'nps ',nps*50/20
      elseif (char5(1:3).eq.'nps'.and.posit.ne.'m'.and.nkeff.eq.2) then
          backspace (15)
          read (15,*) char5,nps
          write (17,'(a6,i10,a12)') 'kcode ',nps*20/50,' 1.0 10 60 '
      elseif (char5(1:1).eq.'C'.or.char5(1:1).eq.'c'.or.
     &    char5.eq.'     '.or.nflag.eq.1) then
        backspace (15)
        read (15,'(a80)') line80
        if (line80(1:42).eq.'                                          '
     &  .and.line80(43:76).eq.'                                  ') then
           nflag = 1
           write (17,'(a80)') line80
        else
           write (17,'(a80)') line80
        endif
      else
      backspace (15)
      read (15,*,err=185,end=190) ncell,nmater
      ident = 0
      do 187 j=1,nmat
      if (nmater.eq.abs(mt(j))) then
        ident = 1
        backspace (15)
        read (15,'(a80)') line80
        o = 1
        n = 1
        ncount = 1
c
c... First find the first number (ncount allows it to always start in same position)
c
  183     if (line80(n:n).ne.' ') goto 182
          n = n + 1
          ncount = ncount + 1
          goto 183
c
c... Then identify the location of the next two numbers relative to blanks
c
  182     if (line80(n:n).eq.' ') then
            b(o) = n
            if (o.eq.3) goto 185
            m = n
  184       if (line80(m+1:m+1).eq.' ') then
              m = m + 1
              goto 184
            else
              e(o) = m
            endif
            o = o + 1
            n = m + 1
            goto 182 
          else
            n = n + 1
            goto 182
          endif
      else 
          goto 187
      endif
  187 continue
  185 if (ident.eq.1) then
c.... Replace values before density, density, and then those after density
        nident = 0
        do 188 i=b(3),80
        line(i:i) = line80(i:i)
  188   if (line80(i:i).ne.' ') nident = 1
        if (ncount.ge.2) then
          do 191 i=1,ncount-1
  191     line80(i:i) = ' '
        endif
        if (e(2).le.24) then
          do 192 i=e(2)+1,25
  192     line80(i:i) = ' '
        endif
        if (nident.eq.1) then
          write (17,'(a25,f10.5)') line80(1:25),gden(j)
          do 189 i=1,(b(3)-1)
  189     line(i:i) = ' '
          write (17,'(a80)') line 
        else
          write (17,'(a25,f10.5)') line80(1:25),gden(j)
        endif
      else
        backspace (15)
        read (15,'(a80)') line80
        write (17,'(a80)') line80
      endif
      endif
      goto 181
  190 return
      end
c
c23456789*123456789*123456789*123456789*123456789*123456789*123456789*12
c
c...GRAMS reads TAPE7 and prints out grams of tracked material to mb5
c
      subroutine grams
c
      common /mbinp/nmat,mt(49),voli(49),pow,qu235,days,nouter,ninner,
     & npre,nrst,frimp,nauto(49),ntot(49),nkeff,mbxs,nisn(999,49),
     & nisnr(999,49)
      common /mbinp2/niso(999,49),nisor(999,49),title,olib,locale,posit,
     &     tmpfile,machin,CALC
      character niso*10,nisor*6,title*72,olib*10,locale*72,posit*1,
     &          machin*4,tcell(999,49)*6,ncell*6,ju6*6,tmpfile*10,
     &          tape7*12,tape9*12,file5*22,file12*22,fil12x*22,
     &          file5x*22,file14*22,file15*22,file16*22,file17*22,
     &          tape6*12,line120*120,line80*80,filednz*9,char10*10,
     &          blanks*4,CALC*6
      dimension nisq(4),gad(4),gm(9999,49),thalf(9999),qrec(9999),
     &          nucl(9999),gramat(9999,49),iu(9999),fbx(9999),
     &          fpec(9999),fpecx(9999),fa(9999),fit(9999),
     &          fsf(9999),fn(9999),abund(9999),nuc(9999),
     &          arcg(9999),wrcg(9999),atomwe(9999,49),act(9999),
     &          ntc(49),activy(49),heaty(49),nis(3500),
     &          nisotop(3500,49),th(9999,49)
      real number(9999,49),htld(9999),inha(9999),inge(9999),vol1,
     &          vol(49)
      real*8 atperbcm(3500)
c
c... Determine volume of each material from MCNP output file
c      for atom density calculations (will be done later)
c
      if (posit.eq.'e') then
        if (machin(1:3).ne.'VMS') then
          open (55,file='mbmco',status='old')
        elseif (machin(1:3).eq.'VMS') then
          open (55,file='mbmco.dat',status='old')
        endif
   45   read (55,'(a6)') ju6
        if (ju6.ne.'1cells') goto 45
c
        read (55,'(///)')
   50   read (55,'(i6,a6,i5,1x,1p3e12.5)') n,ncell,nmt,aden,gden,vol1
        do 55 j=1,nmat
          ntc(j) = 0
          if (nmt.eq.abs(mt(j))) then
            ntc(j)=ntc(j)+1
            tcell(ntc(j),j)=ncell
            vol(j)=vol(j)+vol1
          end if
   55   continue
        if (n.ne.0) goto 50
      endif
c
      IF (olib(1:6).eq.'CINDER') THEN 
c
c   Read CINDER library to get fission cross sections
c
        icind = 0
        open (7,file='library',status='old')
   41   read (7,'(a10)',end=43) char10
        if (char10.ne.'__________') goto 41
        icind = icind + 1
        read (7,'(7x,i7,17x,1pe11.4)') isoname,thalf(icind)
        nis(icind) = (isoname - 10*(isoname/10)) + 10*(isoname/10000)
     &   + 10000*((isoname - 10000*(isoname/10000))/10)
        goto 41
   43   close (7)            
c
        if (nrst.eq.0.or.(nrst.eq.1.and.posit.eq.'b')) then
          open (7,file='material',status='unknown')
          read (7,*) line80 
   32     read (7,'(3x,i3,i4,f10.8)',end=33) mat,nisos,atomden
          do 36 j=1,nmat
            if (voli(j).eq.0.0) voli(j) = vol(j)        
            if (mat.eq.abs(mt(j))) then
              do k=1,nisos
                read (7,940) isoname,atomfra
                nisotop(k,j) = (isoname-10*(isoname/10))
     &            + 10*(isoname/10000)
     &            + 10000*((isoname-10000*(isoname/10000))/10)
                do ii=1,nauto(j)
                  if (nisotop(k,j).eq.nisnr(ii,j)) then
                    nisq1 = nisnr(ii,j)/10
                    atomwe(ii,j) = float(nisq1)-float(1000*(nisq1/1000))      
                    number(ii,j) = atomden*atomfra*voli(j)*1.0e+24
                    gm(ii,j) = number(ii,j)*atomwe(ii,j)/6.022e+23
                    gramat(ii,j) = gm(ii,j)/atomwe(ii,j)
                    if (nisotop(k,j).ge.890000) then
                      nisq1 = nisotop(k,j)/10
                      gm(nauto(j)+1,j)=gm(nauto(j)+1,j) +
     &                   atomden*atomfra*atomwe(ii,j)*
     &                   voli(j)/0.6022
                    endif
                    do i=1,icind
                      if (nis(i).eq.nisotop(k,j)) then
                        th(ii,j) = thalf(i)
                      endif
                    enddo
                  endif
                enddo
              enddo
  940         format (i7,2x,f11.8)
            endif
   36     continue                                    
          goto 32
   33     close (7)           
        endif
      ENDIF
c
      do 40 j=1,nmat
      act(nauto(j)+1) = 0.0
      htld(nauto(j)+1) = 0.0
      inha(nauto(j)+1) = 0.0
      inge(nauto(j)+1) = 0.0
      if (j.lt.10) then
       tape6 = 'TAPE6_'//char(j+48)//'.OUT'
       tape7 = 'TAPE7_'//char(j+48)//'.OUT'
       tape9 = 'TAPE9_'//char(j+48)//'.INP'
       file5  = tmpfile//'mb5_'//char(j+48)//'.out'
       file12 = tmpfile//'mb12_'//char(j+48)//'.out'
       fil12x = tmpfile//'mb12x_'//char(j+48)//'.out'
       file5x = tmpfile//'mb5x_'//char(j+48)//'.out'
       file14 = tmpfile//'mb14_'//char(j+48)//'.out'
       file15 = tmpfile//'mb15_'//char(j+48)//'.out'
       file16 = tmpfile//'mb16_'//char(j+48)//'.out'
       file17 = tmpfile//'mb17_'//char(j+48)//'.out'
       filednz = 'alldnz_'//char(j+48)      
      elseif (j.ge.10) then
       j1 = j/10
       j2 = j - j1*10
       tape6 = 'TAPE6_'//char(j1+48)//char(j2+48)//'.OUT'
       tape7 = 'TAPE7_'//char(j1+48)//char(j2+48)//'.OUT'
       tape9 = 'TAPE9_'//char(j1+48)//char(j2+48)//'.INP'
       file5  = tmpfile//'mb5_'//char(j1+48)//char(j2+48)//'.out'
       file12 = tmpfile//'mb12_'//char(j1+48)//char(j2+48)//'.out'
       fil12x = tmpfile//'mb12x_'//char(j1+48)//char(j2+48)//'.out'
       file5x = tmpfile//'mb5x_'//char(j1+48)//char(j2+48)//'.out'
       file14 = tmpfile//'mb14_'//char(j1+48)//char(j2+48)//'.out'
       file15 = tmpfile//'mb15_'//char(j1+48)//char(j2+48)//'.out'
       file16 = tmpfile//'mb16_'//char(j1+48)//char(j2+48)//'.out'
       file17 = tmpfile//'mb17_'//char(j1+48)//char(j2+48)//'.out'
       filednz = 'alldnz_'//char(j1+48)//char(j2+48)  
      endif
      if (voli(j).eq.0.0) voli(j) = vol(j)              
      IF (olib(1:6).eq.'CINDER') then
c
c   Read material or DNZ file
c
        if (nrst.gt.0) then
          if (posit.eq.'b'.and.nrst.eq.1) then
          else
          open (unit=78,file=filednz,form='unformatted',status='old')
          read (78) mtlbname
          do 38 kb=1,2
          read (78) kbt,jnuc
   38     read (78) (atperbcm(i),i=1,jnuc)
          close (78)
          do 39 i=1,jnuc
            if (atperbcm(i).gt.0.0) then
              do ii=1,nauto(j)
                if (nis(i).eq.nisnr(ii,j)) then
                  th(ii,j) = thalf(i)
                  nisq1 = nisnr(ii,j)/10
                  atomwe(ii,j) = float(nisq1)-float(1000*(nisq1/1000))
                  number(ii,j) = atperbcm(i)*voli(j)*1.0e+24
                  gm(ii,j) = number(ii,j)*atomwe(ii,j)/6.022e+23
                  gramat(ii,j) = gm(ii,j)/atomwe(ii,j)
                endif
              enddo
              if (nis(i).ge.890000) then
                nisq1 = nis(i)/10
                a = float(nisq1)-float(1000*(nisq1/1000))
                gm(nauto(j)+1,j)=gm(nauto(j)+1,j) +
     &             atperbcm(i)*a*voli(j)/0.6022
              endif
            endif
   39     continue
          endif
        endif
      ELSE
      n = 0
      open (12,file=tape7,status='old')
c
   10 read (12,911,err=10,end=30) kxs,(nisq(m),gad(m),m=1,4)
c
      do 20 m=1,4
        kk=0
        do 15 k=1,nauto(j)
          if (nisnr(k,j).eq.nisq(m)) kk=k
   15   continue
c
c... To print data (activity, heatload, toxicities) after each burnup step
c
        if (posit.eq.'e') then
c
c... Add data to array of isotopes from TAPE7
c
          if (nisq(m).ne.0) then
            aval = gad(m)*0.6022/voli(j)
            n = n + 1
            gramat(n,j) =  gad(m)
            nucl(n) = nisq(m)
            number(n,j) = aval*1.0e+24*voli(j)
          endif
        endif
c
c... Calculate grams of each isotope
c
        if (kk.gt.0.or.nisq(m).ge.890000) then
          nisq1=nisq(m)/10
          a=float(nisq1)-float(1000*(nisq1/1000))
          if (kk.gt.0) gm(kk,j)=gm(kk,j)+a*gad(m)
          if (nisq(m).ge.890000) gm(nauto(j)+1,j)=
     &           gm(nauto(j)+1,j)+a*gad(m)
        endif
c
   20 continue
      goto 10
c
   30 continue
c
  911 format (i4,4(1x,i6,2x,1pe10.4))
  913 format (i4,a4)
  922 format (i4,i8,i3,4x,1p6e10.3)
  923 format (i4,15x,1p6e10.3)
c
c... Get heatload, activity, and other information
c
        l = 1
        open (13,file=tape9,status='old')
   87   read (13,913,err=87,end=90) nflag,blanks
        if (nflag.le.3) then
          if (blanks.ne.'    '.and.nflag.ne.-1) then
            backspace (13)
   88       read (13,922,err=88)
c
c...  See ORIGEN2 manual for meaning of other variables -
c...    thalf(l) is halflife of isotope and iu(l) is units
c...    qrec(l) is "average, total, recoverable energy released by
c...      each decay event (MeV)"
c
     &         nxs,nuc(l),iu(l),thalf(l),fbx(l),fpec(l),
     &         fpecx(l),fa(l),fit(l)
   89       read (13,923,err=89)
     &         nxs,fsf(l),fn(l),qrec(l),abund(l),arcg(l),wrcg(l)
c
c...  Convert all halflife values to seconds (iu = 1)
c
            if (iu(l).eq.2) thalf(l) = thalf(l)*60.0
            if (iu(l).eq.3) thalf(l) = thalf(l)*3600.0
            if (iu(l).eq.4) thalf(l) = thalf(l)*3600.0*24.0
            if (iu(l).eq.5) thalf(l) = thalf(l)*3600.0*24.0*365.24
            if (iu(l).eq.6) thalf(l) = 0.0
            if (iu(l).eq.7) then
              thalf(l) = thalf(l)*3600.0*24.0*365.24*1.0e+3
            elseif (iu(l).eq.8) then
              thalf(l) = thalf(l)*3600.0*24.0*365.24*1.0e+6
            elseif (iu(l).eq.9) then
              thalf(l) = thalf(l)*3600.0*24.0*365.24*1.0e+9
            endif
            l = l + 1
            goto 87
          else
            goto 87
          endif
        endif
        ENDIF
c
   90 if (posit.eq.'e') then
        open (14,file=file5,status='unknown')
        open (15,file=file5x,status='unknown')
        write (14,'(i3,1x,1pe9.2,250e10.2)')
     &                    nrst, (gm(i,j),i=1,nauto(j)+1)
        write (15,'(i3,1x,1pe13.7,250e14.7)')
     &                    nrst, (gm(i,j),i=1,nauto(j)+1)
        close (14)
        close (15)           
c
c...  Write heatload and toxicity information to a file
c
        do 258 i=1,nauto(j)
         IF (olib(1:6).eq.'CINDER') then
           call activ(nisnr(i,j),th(i,j),number(i,j),atomwe(i,j),
     &         gramat(i,j),0.0,act(i),inha(i),inge(i),htld(i))
         ELSE
            nisq1 = nisnr(i,j)/10
            atomwe(i,j) = float(nisq1)-float(1000*(nisq1/1000))
            th(i,j) = 0.0
            qrec(i) = 0.0
            do 252 ll=1,l-1
              if (nuc(ll).eq.nisnr(i,j)) then
                th(i,j) = thalf(ll)
                qrec(i) = qrec(ll)
                goto 254
              endif
  252       continue
  254       do 256 m=1,n
              if (nisnr(i,j).eq.nucl(m)) then
                call activ(nucl(m),th(i,j),number(m,j),atomwe(i,j),
     &               gramat(m,j),qrec(i),act(i),inha(i),inge(i),htld(i))
                goto 257
              endif
  256       continue
         ENDIF
  257  act(nauto(j)+1) = act(nauto(j)+1) + act(i)
       htld(nauto(j)+1) = htld(nauto(j)+1) + htld(i)
       inha(nauto(j)+1) = inha(nauto(j)+1) + inha(i)
       inge(nauto(j)+1) = inge(nauto(j)+1) + inge(i)
  258  continue
c
        open (14,file=file14,status='unknown')
        open (15,file=file15,status='unknown')
        open (16,file=file16,status='unknown')
        open (17,file=file17,status='unknown')
c
c   Calculate total heatload and activity
c
      if (posit.eq.'e'.and.nrst.ne.0.and.olib(1:6).ne.'CINDER') then
        ntimes = 0
        open (8,file=tape6,status='unknown')
  210   read (8,'(a120)',end=211) line120
        if (line120(1:9).ne.'AP+ACT+FP'.and.line120(2:10)
     &          .ne.'AP+ACT+FP') goto 210
        if (ntimes.eq.4) then
          backspace(8)
          read (8,'(31x,e10.3)') activy(j)
        endif
        if (ntimes.eq.5) then
          backspace(8)
          read (8,'(31x,e10.3)') heaty(j)
        endif
        ntimes = ntimes + 1
        goto 210
c
  211   close (8)
c
        write (14,'(1x,i3,1x,1pe9.2,250e10.2)')
     &             nrst, (act(i),i=1,nauto(j)+1),activy(j)
        write (15,'(1x,i3,1x,1pe9.2,250e10.2)')
     &             nrst, (htld(i),i=1,nauto(j)+1),heaty(j)
      elseif (posit.eq.'e') then
        write (14,'(1x,i3,1x,1pe9.2,250e10.2)')
     &             nrst, (act(i),i=1,nauto(j)+1)
        write (15,'(1x,i3,1x,1pe9.2,250e10.2)')
     &             nrst, (htld(i),i=1,nauto(j)+1)
      endif
      if (posit.eq.'e') then
        write (16,'(1x,i3,1x,1pe9.2,250e10.2)')
     &             nrst, (inha(i),i=1,nauto(j)+1)
        write (17,'(1x,i3,1x,1pe9.2,250e10.2)')
     &             nrst, (inge(i),i=1,nauto(j)+1)
      endif
        close (13)
        close (14)
        close (15)
        close (16)
        close (17)
c
      elseif (posit.eq.'b') then
        open (14,file=file12,status='unknown')
        open (15,file=fil12x,status='unknown')
        write (14,'(i3,1x,1pe9.2,250e10.2)')
     &             nrst, (gm(i,j),i=1,nauto(j)+1)
        write (15,'(i3,1x,1pe13.7,250e14.7)')
     &             nrst, (gm(i,j),i=1,nauto(j)+1)
        close (14)
        close (15)
      endif
c
      close (12)
   40 continue
c
      return
      end
c
c23456789*123456789*123456789*123456789*123456789*123456789*123456789*12
c
c...RMHALF removes 1/2 way predictor cards in TAPE5 
c
      subroutine rmhalf
      common /mbinp/nmat,mt(49),voli(49),pow,qu235,days,nouter,ninner,
     & npre,nrst,frimp,nauto(49),ntot(49),nkeff,mbxs,nisn(999,49),
     & nisnr(999,49)
      common /mbinp2/niso(999,49),nisor(999,49),title,olib,locale,posit,
     &     tmpfile,machin,CALC
      character niso*10,nisor*6,title*72,olib*10,locale*72,posit*1,
     &     machin*4,CALC*6
      character ju8*8,ju80*80,fname*21,f2name*22,char72*72,tmpfile*10
c
      do 140 j=1,nmat
      IF (olib(1:6).eq.'CINDER') then
        if (j.lt.10) then
          if (nrst.lt.10) then
            fname = tmpfile//'input_'//char(j+48)//'.'//char(nrst+48)
            f2name = tmpfile//'input_'//char(j+48)//'.tmp'
          else
            i1 = nrst/10
            i2 = nrst - i1*10
            fname = tmpfile//'input_'//char(j+48)//'.'//char(i1+48)//
     &               char(i2+48)
            f2name = tmpfile//'input_'//char(j+48)//'.tmp'
          endif
        elseif (j.ge.10) then
          j1 = j/10
          j2 = j - j1*10
          if (nrst.lt.10) then
            fname = tmpfile//'input_'//char(j1+48)//char(j2+48)//'.'//
     &                char(nrst+48)
            f2name = tmpfile//'input_'//char(j1+48)//char(j2+48)//'.tmp'
          else
            i1 = nrst/10
            i2 = nrst - i1*10
            fname = tmpfile//'input_'//char(j1+48)//char(j2+48)//'.'//
     &                char(i1+48)//char(i2+48)
            f2name = tmpfile//'input_'//char(j1+48)//char(j2+48)//'.tmp'
          endif
        endif
        open (12,file=fname,status='old')
        open (13,file=f2name,status='unknown')
        do i=1,6
          read (12,'(a72)') char72 
          write (13,'(a72)') char72
        enddo
        read (12,'(4x,1pe11.4)') day
        write (13,'(4x,1pe11.4,a4)') day*2.0," 'd'"
        close (12)
        close (13)
      ELSE
      if (j.lt.10) then
        fname = 'TAPE5_'//char(j+48)//'.INP'
        f2name = 'TAPE5_'//char(j+48)//'.TMP'
      elseif (j.ge.10) then
        j1 = j/10
        j2 = j - j1*10
        fname = 'TAPE5_'//char(j1+48)//char(j2+48)//'.INP'
        f2name = 'TAPE5_'//char(j1+48)//char(j2+48)//'.TMP'
      endif
      open (12,file=fname,status='old')
      open (13,file=f2name,status='unknown')
c
      ino = 0
  120 read (12,'(a8)',end=125) ju8
c
      if (ju8.eq.'RDA Firs') ino=1 
      if (ino.eq.0) then
       backspace(12)
       read (12,'(a80)',end=125) ju80
       write (13,'(a80)') ju80
      end if
      if (ju8.eq.'RDA Last') ino=0
      goto 120
  125 continue
      close (12)
      close (13)
      ENDIF
  140 continue
c
      return
      end
c
c23456789*123456789*123456789*123456789*123456789*123456789*123456789*12
c
c...BURNCALC calculates material burned/produced based on feed and inven
c
      subroutine burnca
c
      common /mbinp/nmat,mt(49),voli(49),pow,qu235,days,nouter,ninner,
     & npre,nrst,frimp,nauto(49),ntot(49),nkeff,mbxs,nisn(999,49),
     & nisnr(999,49)
      common /mbinp2/niso(999,49),nisor(999,49),title,olib,locale,posit,
     &     tmpfile,machin,CALC
      integer i1
      character niso*10,nisor*6,title*72,olib*10,locale*72,posit*1,
     &          machin*4,fil12a*22,tmpfile*10,filen*21,
     &          file10*22,file9t*22,file5x*22,file9*22,CALC*6
      dimension tfeed(999),g1(999),g2(999),bb(999),bb2(999),day(999)
      dimension dfeed(999),totbb(999)
c
c...Read feed data
c
      do 100 j=1,nmat
      do 3 m=1,nauto(j)+1
   3   totbb(m) = 0.0 
      if (j.lt.10) then
        file9t=tmpfile//'mb9t_'//char(j+48)//'.out'
        file5x=tmpfile//'mb5tx_'//char(j+48)//'.out'
        fil12a=tmpfile//'mb12a_'//char(j+48)//'.out'
        file9 =tmpfile//'mb9_'//char(j+48)//'.out'
        file10=tmpfile//'mb10t_'//char(j+48)//'.out'
      elseif (j.ge.10) then
        j1 = j/10
        j2 = j - j1*10
        file9t=tmpfile//'mb9t_'//char(j1+48)//char(j2+48)//'.out'
        file5x=tmpfile//'mb5tx_'//char(j1+48)//char(j2+48)//'.out'
        fil12a=tmpfile//'mb12a_'//char(j1+48)//char(j2+48)//'.out'
        file9 =tmpfile//'mb9_'//char(j1+48)//char(j2+48)//'.out'
        file10=tmpfile//'mb10t_'//char(j1+48)//char(j2+48)//'.out'
      endif
      open (11,file=file9t,status='unknown') 
      read (11,'(//)')
      do 10 i=1,nouter
   10 read (11,'(4x,f8.2,3x,1pe9.2,250e10.2)') 
     &            day(i),(tfeed(m),m=1,nauto(j)+1)
      read (11,*) 
      read (11,*)
      read (11,*)
      read (11,*)
      if (nrst.gt.1) then
        do 13 i=1,nrst-1
        read (11,'(i3,1x,1pe9.2,250e10.2)')
     &          i1,(bb(m),m=1,nauto(j)+1)
        do 13 m=1,nauto(j)+1
        totbb(m) = totbb(m) + bb(m)
   13   continue
      endif
      close (11)
c
c...Read inventory data
c
      open (11,file=file5x,status='unknown')
      read (11,'(//)')
      do 20 i=0,nrst
   20 read (11,'(4x,1pe13.7,250e14.7)') (g2(m),m=1,nauto(j)+1)
      close (11)
      open (11,file=fil12a,status='unknown')
      read (11,'(//)')
      do 22 i=0,nrst
   22 read (11,'(4x,1pe13.7,250e14.7)') (g1(m),m=1,nauto(j)+1)
      close (11)
c
c...Write burn data
c
      do 30 m=1,nauto(j)+1
      bb(m)=g2(m)-g1(m)
   30 totbb(m) = totbb(m) + bb(m)
      open (14,file=file9,status='unknown')
      write (14,'(i3,1x,1pe9.2,250e10.2)') 
     &          nrst,(bb(m),m=1,nauto(j)+1)
c
c...Write final burn data if last step
c
      if (nrst.eq.nouter) then
c
      open (11,file=file9t,status='unknown')
      read (11,'(//)')
      do 40 i=1,nrst
   40 read (11,*)
      read (11,'(4x,f8.2,3x,1pe9.2,250e10.2)') 
     &         day(nrst),(tfeed(m),m=1,nauto(j)+1)
      close (11)
c
      open (11,file=file5x,status='unknown')
      read (11,'(//)')
      read (11,'(4x,1pe13.7,250e14.7)') (g1(m),m=1,nauto(j)+1)
      close (11)
c
      write (14,'(a3,1pe9.2,250e10.2)') 'tot',(totbb(m),m=1,nauto(j)+1)
      write (14,'(/,a36,a13,i3,a22,i3,a1)') 
     & 'Summary of Inventory/Feed/Production',
     & ' for material',j,' (MCNP Material Number',abs(mt(j)),')'
      write (14,'(3x,a9,250(1x,a9))')(niso(i,j),i=1,nauto(j)),'actinide'
c
      write (14,'(a3,1pe9.2,250e10.2)') 'ini',(g1(m),m=1,nauto(j)+1)
      write (14,'(a3,1pe9.2,250e10.2)') 'fin',(g2(m),m=1,nauto(j)+1)
      write (14,'(a3,1pe9.2,250e10.2)') 'fed',(tfeed(m),m=1,nauto(j)+1)
      write (14,'(a3,1pe9.2,250e10.2)') 'net',(totbb(m),m=1,nauto(j)+1)
c
      end if
c
      close (14)
c
c...Write mb10.out containing feed/burn rates
c
      if (nrst.eq.nouter) then      
      open (14,file=tmpfile//'mb10.txt',status='unknown')
      write (14,'(/,a28)') 'Monteburns Inventory (cont.)' 
      close (14)
      open (14,file=file10,status='unknown')
c
c...Read data and divide by time interval
c
      open (11,file=file9t,status='unknown')
      read (11,'(//)')
      write (14,'(/,a17,a13,i3,a22,i3,a1)') 'Feed Rate (g/day)',
     & ' for material',j,' (MCNP Material Number',abs(mt(j)),')'
      write (14,'(3x,a9,250(1x,a9))')(niso(i,j),i=1,nauto(j)),'actinide'
      do 80 i=1,nouter
      read (11,'(4x,f8.2,3x,1pe9.2,250e10.2)')
     &            day(i),(tfeed(m),m=1,nauto(j)+1)
c
c...  Determine if a feed input file exists or not
c
      filen = tmpfile//'params2.dat'
      open (17,file=filen,status='unknown')
      read (17,'(i4)') nfd
      close (17)
      if (nfd.eq.1) then
       write (14,'(i3,1x,1pe9.2,250e10.2)') i,
     & (tfeed(m)/day(i),m=1,nauto(j)+1)
      else
        do 77 m=1,nauto(j)+1
   77   dfeed(m) = 0.0
        write (14,'(i3,1x,1pe9.2,250e10.2)') i,
     & (dfeed(m),m=1,nauto(j)+1)
      endif
   80 continue
      read (11,'(///)')
      write (14,'(/,a35,a13,i3,a22,i3,a1)') 
     & 'Production/Destruction Rate (g/day)',
     & ' for material',j,' (MCNP Material Number',abs(mt(j)),')'
      write (14,'(3x,a9,250(1x,a9))')(niso(i,j),i=1,nauto(j)),'actinide'
      do 90 i=1,nouter-1
      read (11,'(4x,1pe9.2,250e10.2)') (bb2(m),m=1,nauto(j)+1)
   90 write (14,'(i3,1x,1pe9.2,250e10.2)') i,
     & (bb2(m)/day(i),m=1,nauto(j)+1)
      write (14,'(i3,1x,1pe9.2,250e10.2)') nouter,
     & (bb(m)/day(nouter),m=1,nauto(j)+1)
      close (11)
      write (14,*)
      close (14)
      end if
  100 continue
c
      return
      end
c
c...DISCRETE makes additions in TAPE7 and mat.inp for discrete feed
c
      subroutine discr
c
      common /mbinp/nmat,mt(49),voli(49),pow,qu235,days,nouter,ninner,
     & npre,nrst,frimp,nauto(49),ntot(49),nkeff,mbxs,nisn(999,49),
     & nisnr(999,49)
      common /mbinp2/niso(999,49),nisor(999,49),title,olib,locale,posit,
     &     tmpfile,machin,CALC
      character niso*10,nisor*6,title*72,olib*10,locale*72,posit*1,
     & machin*4,line*80,tape7*12,t7tmp*15,met*1,char10*10,
     & tmpfile*10,filen*21,mtlbname*6,fildnz*10,filednz*9,CALC*6
      dimension nisq(4),gad(4),gmafed(999,49),ifd6(99,49),a(99),
     & day(999),nfeed(999,49),gf1(999,49),gf2(999,49),mfeed(999),
     & kfeed(99),kfeed1(99,99),kfeed2(99,99),ifeed(99,99),ncount(99,49),
     & nf(3,999,49),rf(3,999,49),pfra(999),nmt(49),ffeed(99,99),
     & nelem(99,49),tmst(999),weight(99),nis(3500),
     & nisoto(99,49,99),nisop(99,49),atomfr(99,49,99),adenfed(999,49),
     & iflag(99,49),imfeed(99,99),fmfeed(99,99),mmfeed(99),gfeed(99,49)
      real*8 atperbcm(3500)
c...
c... Determine if feed file exists
c...
      filen = tmpfile//'params2.dat'
      open (17,file=filen,status='unknown')
      read (17,'(i4)') nfd
      close (17)
      if (nfd.eq.1) then
        open (11,file='feed',status='old')
        read (11,*)
        read (11,*)
        do 10 i=1,nouter
         do 10 j=1,nmat
          if (j.eq.1) then
            read (11,*) tmst(i),day(i),
     &      pfra(i),nmt(1),nfeed(i,1),gf1(i,1),gf2(i,1),
     &      (nf(l,i,1),rf(l,i,1),l=1,3)
          elseif (j.ge.2) then
            read (11,*) nmt(j),nfeed(i,j),gf1(i,j),gf2(i,j),
     &      (nf(l,i,j),rf(l,i,j),l=1,3)
          endif          
   10    continue             
         read (11,*) nfs
         do 12 n=1,nfs
           read (11,*) mfeed(n)
         do 12 m=1,mfeed(n)
   12      read (11,*) ifeed(n,m),ffeed(n,m)
           read (11,*) nrs
         do 15 n=1,nrs
           read (11,*) kfeed(n)
         do 15 k=1,kfeed(n)
   15      read (11,*) kfeed1(n,k),kfeed2(n,k)
      endif        
      IF (olib(1:6).eq.'CINDER') THEN
c
c   Read CINDER library to get fission cross sections
c
        icind = 0
        open (7,file='library',status='old')
   41   read (7,'(a10)',end=43) char10
        if (char10.ne.'__________') goto 41
        icind = icind + 1
        read (7,'(7x,i7,17x,e11.4)') isoname
        nis(icind) = (isoname - 10*(isoname/10)) + 10*(isoname/10000)
     &   + 10000*((isoname - 10000*(isoname/10000))/10)
        goto 41
   43   close (7)
c
      ENDIF
c
c...Rewrite TAPE7
c
      do 100 j=1,nmat
      n = 0
      i = nrst
      n = nfeed(i,j)
      if (j.lt.10) then
        tape7 = 'TAPE7_'//char(j+48)//'.OUT'
        t7tmp = 'TAPE7_'//char(j+48)//'.TMP'
        filednz = 'alldnz_'//char(j+48)
        fildnz = 'alldnz2_'//char(j+48)
      elseif (j.ge.10) then
        j1 = j/10
        j2 = j - j1*10
        tape7 = 'TAPE7_'//char(j1+48)//char(j2+48)//'.OUT'
        t7tmp = 'TAPE7_'//char(j1+48)//char(j2+48)//'.TMP'
        filednz = 'alldnz_'//char(j1+48)//char(j2+48)
        fildnz = 'alldnz2_'//char(j1+48)//char(j2+48)
      endif
      if (n.eq.0) then
         goto 90
      endif
c
c... Check to see if any feed materials are natural elements
c
      mmfeed(n) = mfeed(n)
      do 25 m=1,mfeed(n)
      iflag(m,j) = 0
      nai = ifeed(n,m)-1000*(ifeed(n,m)/1000) 
      if (nai.eq.0.and.ifeed(n,m).gt.0) then
        filen = tmpfile//'natelem'
        open (16,file=filen,status='unknown')
        read (16,*)
        read (16,*)
   18   read (16,*) nelem(m,j)
        read (16,*) nisop(m,j)
        totwe = 0.0
        do 20 mm=1,nisop(m,j)
          read (16,'(i5,3x,f10.5)',err=20,end=23)
     &    nisoto(m,j,mm),atomfr(m,j,mm)
          weight(mm) = nisoto(m,j,mm)-1000*(nisoto(m,j,mm)/1000)
   20     totwe = totwe + atomfr(m,j,mm)*weight(mm)      
        if (nelem(m,j).eq.ifeed(n,m)/1000) then
          iflag(m,j) = 1
          imfeed(n,m) = nisoto(m,j,1)
          weigfra = atomfr(m,j,1)*weight(1)/totwe
          fmfeed(n,m) = ffeed(n,m)*weigfra
          do 22 mn=1,(nisop(m,j)-1)
            weigfra = atomfr(m,j,1+mn)*weight(1+mn)/totwe
            mmfeed(n) = mmfeed(n) + 1 
            imfeed(n,mmfeed(n)) = nisoto(m,j,1+mn)
   22       fmfeed(n,mmfeed(n)) = ffeed(n,m)*weigfra
          goto 23
        else
          goto 18 
        endif
   23   close (16)       
      else
        imfeed(n,m) = ifeed(n,m)
        fmfeed(n,m) = ffeed(n,m)
      endif
   25 continue
c
c...Convert grams of feed to gram-atoms of feed
c
       do 28 m=1,mmfeed(n)
        ifd6(n,m) = imfeed(n,m)*10
        if (ifd6(n,m).eq.952420) ifd6(n,m)=ifd6(n,m)+1      
        gfeed(m,j)=fmfeed(n,m)*gf2(i,j)*day(i)
        ai = float(imfeed(n,m))-float(1000*(imfeed(n,m)/1000))
        gmafed(m,j) = gfeed(m,j)/ai            
        adenfed(m,j) = gfeed(m,j)*0.6022/voli(j)/ai
        ncount(m,j) = 0
   28  continue       
      IF (olib(1:6).eq.'CINDER') then
        open (unit=78,file=filednz,form='unformatted',status='old')
        read (78) mtlbname
        open (unit=79,file=fildnz,form='unformatted',status='unknown')
        write (79) mtlbname
c
        do 38 kb=1,2
        read (78) kbt,jnuc
        write (79) kbt,jnuc
        read (78) (atperbcm(i),i=1,jnuc)
   38   if (kb.eq.1) write (79) (atperbcm(i),i=1,jnuc)
        close (78)
        do 39 i=1,icind
          do m=1,mmfeed(n)
            if (nis(i).eq.ifd6(n,m)) then
              atperbcm(i) = atperbcm(i) + adenfed(m,j)
            endif
          enddo
   39   continue 
        write (79) (atperbcm(i),i=1,jnuc)
        close (79)
c
      ELSE
      open (12,file=tape7,status='unknown')
      open (13,file='tape.tmp',status='unknown')
   30 read (12,901,err=45,end=50) kxs,(nisq(k),gad(k),k=1,4)
  901 format (i4,4(1x,i6,2x,1pe10.4))
      if (kxs.eq.0) goto 45
      do 40 k=1,4
       do 40 m=1,mmfeed(n) 
       if (nisq(k).eq.ifd6(n,m).and.kxs.le.2) then 
          if (ncount(m,j).eq.0) gad(k) = gad(k) + gmafed(m,j)
          ncount(m,j) = 1
       endif
   40  continue
      write (13,901) kxs,(nisq(k),gad(k),k=1,4)
      goto 30
   45 backspace (12)
      read (12,'(a80)') line
      write (13,'(a80)') line
      goto 30
   50 close (12)
      close (13)
c
c...Write non-actinides to TAPE7 that are part of discrete feed but did not
c... previously exist
c
      open (13,file='tape.tmp',status='unknown')
      open (14,file=t7tmp,status='unknown')
      kxsold = 1
      nadd = 0
   63 read (13,'(i4)',err=80,end=99) kxs
      if (kxs.eq.kxsold) then
        backspace (13)
        read (13,'(a80)') line
        write (14,'(a80)') line
        kxsold = kxs
      else
      kxsold = kxs
      if (nadd.eq.0) then
      do 65 k=1,mmfeed(n)
       nmin=99999
       ni=0
       do 60 m=1,mmfeed(n)
        a(m)=float(imfeed(n,m))-float(1000*(imfeed(n,m)/1000))
        if (imfeed(n,m).lt.83000.and.imfeed(n,m).gt.1000) then
         if (a(m).gt.0) then
          if (imfeed(n,m).lt.nmin) then
           nmin=imfeed(n,m)
           ni=m
          end if
         endif
        end if
   60  continue
       if (ni.gt.0) then
        kxs=1
        met='0'
        if (ncount(ni,j).eq.0) then
          ncount(ni,j) = 1
          write (14,912) kxs,ifd6(n,ni),gmafed(ni,j)
        endif
        imfeed(n,ni)=0
       end if
   65  continue
c
c...Write actinides to TAPE7, sort numerically for xs file read
c
      do 75 k=1,mmfeed(n)
       nmin=99999
       ni=0
       do 70 m=1,mmfeed(n)
        a(m)=float(imfeed(n,m))-float(1000*(imfeed(n,m)/1000))
        if (imfeed(n,m).ge.83000.and.a(m).gt.0.) then
         if (imfeed(n,m).lt.nmin) then
          nmin=imfeed(n,m)
          ni=m
         end if
        end if
   70  continue
       if (ni.gt.0) then
        kxs=2
        met='0'
        if (ncount(ni,j).eq.0) then
          ncount(ni,j) = 1
          write (14,912) kxs,ifd6(n,ni),gmafed(ni,j)
        endif
        imfeed(n,ni)=0
       end if
   75 continue
      nadd = 1
      endif
      if (kxsold.eq.0) goto 80
      backspace(13)
      read (13,'(a80)') line
      write (14,'(a80)') line
      endif
      goto 63
   80 backspace(13)
      read (13,'(a80)') line
      write (14,'(a80)') line
      goto 63
   99 close (13)
      close (14)
      ENDIF
      goto 100
   90 IF (olib(1:6).eq.'CINDER') then
        open (unit=78,file=filednz,form='unformatted',status='old')
        read (78) mtlbname
        open (unit=79,file=fildnz,form='unformatted',status='unknown')
        write (79) mtlbname
        do 92 kb=1,2
        read (78) kbt,jnuc
        write (79) kbt,jnuc
        read (78) (atperbcm(i),i=1,jnuc)
   92   write (79) (atperbcm(i),i=1,jnuc)
        close (78)
        close (79)
      ELSE 
        open (12,file=tape7,status='unknown')
        open (14,file=t7tmp,status='unknown')
   95   read (12,'(a80)',end=97) line
        write (14,'(a80)') line
        goto 95
   97   close (12)
        close (14)
      ENDIF
  100 continue
  911 format (i4,i6,a1,1pe12.4,
     & '      0  0.0000E+00      0  0.0000E+00      0  0.0000E+00')
  912 format (i4,1x,i6,1pe12.4,
     & '      0  0.0000E+00      0  0.0000E+00      0  0.0000E+00')   
      end
c
      subroutine dremo
c
      common /mbinp/nmat,mt(49),voli(49),pow,qu235,days,nouter,ninner,
     & npre,nrst,frimp,nauto(49),ntot(49),nkeff,mbxs,nisn(999,49),
     & nisnr(999,49)
      common /mbinp2/niso(999,49),nisor(999,49),title,olib,locale,posit,
     &     tmpfile,machin,CALC
      character niso*10,nisor*6,title*72,olib*10,locale*72,posit*1,
     & machin*4,line*72,tape7*12,t7tmp*15,nisq2(4)*4,mtlbname*6,
     & tmpfile*10,filen*21,filednz*9,fildnz*10,char10*10,CALC*6
      dimension nisq1(4),gad(4),nisq3(4),nis(3500),
     & day(999),nfeed(999,49),gf1(999,49),gf2(999,49),
     & kfeed(99),kfeed1(99,99),kfeed2(99,99),ifeed(99,99),tmst(999),
     & nf(3,999,49),rf(3,999,49),pfra(999),nmt(49),ffeed(99,99),
     & mfeed(99)
      real*8 atperbcm(3500)
c...
c... Determine if feed file exists
c...
      filen = tmpfile//'params2.dat'
      open (17,file=filen,status='unknown')
      read (17,'(i4)') nfd
      close (17)
      if (nfd.eq.1) then
        open (11,file='feed',status='old')
        read (11,*)
        read (11,*)
        do 10 i=1,nouter
         do 10 j=1,nmat
          if (j.eq.1) then
            read (11,*) tmst(i),day(i),pfra(i),
     &       nmt(1),nfeed(i,1),gf1(i,1),gf2(i,1),
     &       (nf(l,i,1),rf(l,i,1),l=1,3)
          elseif (j.ge.2) then
            read (11,*)
     &       nmt(j),nfeed(i,j),gf1(i,j),gf2(i,j),
     &       (nf(l,i,j),rf(l,i,j),l=1,3)
          endif
   10    continue
         read (11,*) nfs
         do 12 n=1,nfs
           read (11,*) mfeed(n)
         do 12 m=1,mfeed(n)
   12      read (11,*) ifeed(n,m),ffeed(n,m)
           read (11,*) nrs
         do 15 n=1,nrs
           read (11,*) kfeed(n)
         do 15 k=1,kfeed(n)
   15      read (11,*) kfeed1(n,k),kfeed2(n,k)     
      endif    
      IF (olib(1:6).eq.'CINDER') then
c
c   Read CINDER library to get fission cross sections
c
        icind = 0
        open (7,file='library',status='old')
   41   read (7,'(a10)',end=43) char10
        if (char10.ne.'__________') goto 41
        icind = icind + 1
        read (7,'(7x,i7,17x,e11.4)') isoname
        nis(icind) = (isoname - 10*(isoname/10)) + 10*(isoname/10000)
     &   + 10000*((isoname - 10000*(isoname/10000))/10)
        goto 41
   43   close (7)
      ENDIF
c
c...Rewrite TAPE7
c
      do 60 j=1,nmat
      if (nf(1,nrst,j).ge.0.and.nf(2,nrst,j).ge.0.and.
     &    nf(3,nrst,j).ge.0) goto 60
      if (j.lt.10) then
        tape7 = 'TAPE7_'//char(j+48)//'.OUT'
        t7tmp = 'TAPE7_'//char(j+48)//'.TEM'
        filednz = 'alldnz_'//char(j+48)
        fildnz = 'alldnz2_'//char(j+48)
      elseif (j.ge.10) then
        j1 = j/10
        j2 = j - j1*10
        tape7 = 'TAPE7_'//char(j1+48)//char(j2+48)//'.OUT'
        t7tmp = 'TAPE7_'//char(j1+48)//char(j2+48)//'.TEM'
        filednz = 'alldnz_'//char(j1+48)//char(j2+48)
        fildnz = 'alldnz2_'//char(j1+48)//char(j2+48)
      endif
      IF (olib(1:6).eq.'CINDER') then
        open (unit=78,file=filednz,form='unformatted',status='old')
        read (78) mtlbname
        open (unit=79,file=fildnz,form='unformatted',status='unknown')
        write (79) mtlbname
c
        do 38 kb=1,2
        read (78) kbt,jnuc
        write (79) kbt,jnuc
        read (78) (atperbcm(i),i=1,jnuc)
   38   if (kb.eq.1) write (79) (atperbcm(i),i=1,jnuc)
        close (78)
        do l=1,3
        nrem = abs(nf(l,nrst,j))
        do 49 i=1,icind
          if (nrem.ne.0) then
          do 39 n=1,kfeed(nrem)
            do 39 m=abs(kfeed1(nrem,n)),abs(kfeed2(nrem,n))
              nisq = nis(i)/10000
              if (nisq.eq.m.and.kfeed1(nrem,n).ge.0) then
                atperbcm(i) = atperbcm(i) - atperbcm(i)*
     &            rf(l,nrst,j)
              endif
   39     enddo
          endif
   49   enddo
        enddo
        write (79) (atperbcm(i),i=1,jnuc)
        close (79)
      ELSE
      open (12,file=tape7,status='unknown')
      open (13,file=t7tmp,status='unknown')
c...                 
c... Remove elements in removal group from TAPE7 
c...
   30 read (12,901,err=45,end=50) kxs,(nisq1(k),nisq2(k),gad(k),k=1,4)
      backspace (12)
      read (12,903,err=45,end=50) kxs,(nisq3(k),nisq2(k),gad(k),k=1,4)
  901 format (i4,4(1x,i2,a4,2x,1pe10.4))
  903 format (i4,4(1x,a2,a4,2x,1pe10.4))
      do l=1,3
      nrem = abs(nf(l,nrst,j))
      if (nrem.ne.0) then
      do 40 k=1,4
       do 40 n=1,kfeed(nrem)
        do 40 m=abs(kfeed1(nrem,n)),abs(kfeed2(nrem,n))
        if (nisq1(k).eq.m) then
          if ((kfeed1(nrem,n).lt.0.and.kxs.eq.3)
     &                             .or.kfeed1(nrem,n).ge.0) then
            gad(k) = gad(k) - gad(k)*rf(l,nrst,j)
          endif
        endif
   40  continue
       endif
       enddo
       if (kxs.eq.0) then
         write (13,902) kxs,(nisq2(k),gad(k),k=1,4)
  902 format (i4,4(1x,2x,a4,2x,1pe10.4))
       else
         write (13,903) kxs,(nisq3(k),nisq2(k),gad(k),k=1,4)
       endif
       goto 30
   45  backspace (12)
       read (12,'(a72)') line
       write (13,'(a72)') line
       goto 30                 
   50 close (12)
      close (13)
      ENDIF
   60 continue
      end             
c
c...REGION makes indicates what materials are substituted in various
c... regions 
c
      subroutine region 
c
      common /mbinp/nmat,mt(49),voli(49),pow,qu235,days,nouter,ninner,
     & npre,nrst,frimp,nauto(49),ntot(49),nkeff,mbxs,nisn(999,49),
     & nisnr(999,49)
      common /mbinp2/niso(999,49),nisor(999,49),title,olib,locale,posit,
     &     tmpfile,machin,CALC
      character niso*10,nisor*6,title*72,olib*10,locale*72,posit*1,
     &          machin*4,tmpfile*10,filednz*9,filednz2*10,CALC*6
      character fname*22,filen*21
      dimension day(999),pfra(999),nmt(49),nfeed(999,49),gf1(999,49),
     &          gf2(999,49),nf(3,999,49),rf(3,999,49),tmst(999)
      real*8 atperbcm(3500)
c
c...First discover if feed input file exists
c
      filen = tmpfile//'params2.dat'
      open (17,file=filen,status='unknown')
      read (17,'(i4)') nfd
      if (nfd.eq.1) then         
c
c...First read the two lines of headings
c...
      open (11,file='feed',status='unknown')
      read (11,*)
      read (11,*)
      do 8 i=1,nrst
        do 8 j=1,nmat
        if (j.eq.1) then
         read (11,*) tmst(i),day(i),
     &   pfra(i),nmt(1),nfeed(i,1),gf1(i,1),gf2(i,1),
     &   (nf(l,i,1),rf(l,i,1),l=1,3)
        elseif (j.ge.2) then
         read (11,*) nmt(j),
     &   nfeed(i,j),gf1(i,j),gf2(i,j),
     &   (nf(l,i,j),rf(l,i,j),l=1,3)
        endif                                        
    8  continue
       close (11)
      else
       do 10 j=1,nmat
   10  nmt(j) = j
      endif
c
      do 20 j=1,nmat
      if (j.lt.10) then
       fname = tmpfile//'para3_'//char(j+48)//'.dat'
      elseif (j.ge.10) then
       j1 = j/10
       j2 = j - j1*10
       fname = tmpfile//'para3_'//char(j1+48)//char(j2+48)//'.dat'
      endif
      if (olib(1:6).eq.'CINDER'.and.nrst.gt.1) then
        if (nmt(j).eq.0) then
          write (6,*) 'ERROR:  nmt is zero for mat ',j
          stop
        endif
        if (j.lt.10) then
          filednz  = 'alldnz_'//char(j+48)
          filednz2 = 'alldnz2_'//char(j+48)
        elseif (j.ge.10) then
          j1 = j/10
          j2 = j - j1*10
          filednz  = 'alldnz_'//char(j1+48)//char(j2+48)
          filednz2 = 'alldnz2_'//char(j1+48)//char(j2+48)
        endif
        open (78,file=filednz,form='unformatted',status='unknown')
        open (79,file=filednz2,form='unformatted',status='unknown')
        read (78) mtlbname
        mflag = 0
        do jj=1,nmat
          if (j.eq.nmt(jj)) then
            if (abs(mt(jj)).lt.10) then
              write (79) 'mat  '//char(abs(mt(jj))+48)
            else
              j1 = abs(mt(jj))/10
              j2 = abs(mt(jj)) - j1*10
              write (79) 'mat '//char(j1+48)//char(j2+48)
            endif
            mflag = 1
          endif
        enddo
        if (mflag.eq.0) then
          write (6,*) 'ERROR:  mflag is zero for mat',j
          stop
        endif
c
        do 38 kb=1,2
        read (78) kbt,jnuc
        write (79) kbt,jnuc
        read (78) (atperbcm(i),i=1,jnuc)
   38   write (79) (atperbcm(i),i=1,jnuc)
        close (78)
        close (79)
      endif 
      open (12,file=fname,status='unknown')
      if (nmt(j).eq.0) then
        write (12,905) j
      else
        write (12,905) nmt(j)
      endif
  905 format (i4,'  nval')
c
   20 continue
      end
c
c23456789*123456789*123456789*123456789*123456789*123456789*123456789*12
c
c...WMBINP rewrites mb.inp
c
      subroutine wmbinp
c
      common /mbinp/nmat,mt(49),voli(49),pow,qu235,days,nouter,ninner,
     & npre,nrst,frimp,nauto(49),ntot(49),nkeff,mbxs,nisn(999,49),
     & nisnr(999,49)
      common /mbinp2/niso(999,49),nisor(999,49),title,olib,locale,posit,
     &     tmpfile,machin,CALC
      character niso*10,nisor*6,title*72,olib*10,locale*72,posit*1,
     &          machin*4,tmpfile*10,CALC*6
c
c...Rewrite mb.inp
c
      open (11,file='mb.inp',status='unknown')
      write (11,'(a72)') title
      write (11,'(a4)') machin
      write (11,'(a6)') CALC 
      write (11,*) nmat
      do 20 j=1,nmat
   20 write (11,*) mt(j)
      do 30 j=1,nmat
   30 write (11,*) voli(j)
      write (11,*) pow
      write (11,*) qu235
      write (11,*) days
      write (11,*) nouter
      write (11,*) ninner
      write (11,*) npre
      write (11,*) nrst
      write (11,'(a10)') olib
      write (11,'(a72)') locale
      write (11,*) frimp
      write (11,*) nkeff
      do 60 j=1,nmat
      write (11,*) nauto(j)
      write (11,*) ntot(j)
      do 60 i=1,ntot(j)
   60 write (11,'(a10)') niso(i,j)
      write (11,*) mbxs
      close (11)
c
      return
      end
c  
c  This subroutine creates a file containig isotopic breakdowns
c  for natural elements
c
      subroutine natele
      common /mbinp/nmat,mt(49),voli(49),pow,qu235,days,nouter,ninner,
     & npre,nrst,frimp,nauto(49),ntot(49),nkeff,mbxs,nisn(999,49),
     & nisnr(999,49)
      common /mbinp2/niso(999,49),nisor(999,49),title,olib,locale,posit,
     &     tmpfile,machin,CALC
      character niso*10,nisor*6,title*72,olib*10,locale*72,posit*1,
     &          machin*4,tmpfile*10,CALC*6
      dimension nelem(40),nisot(40,40),atomfr(40,40),nisop(40)
c
c  Isotopic compositions of natural elements
c  Ref:  Nuclides and Isotopes, Fifteenth Edition
c
      open (16,file=tmpfile//'natelem',status='unknown')
      data (nelem(i),i=1,33) /
     &    6, 12, 14, 16, 17, 18, 19, 20, 22, 
     &   23, 24, 25, 26, 28, 29, 30, 31, 40,
     &   42, 47, 48, 49, 50, 51, 54, 63, 64,
     &   72, 74, 77, 78, 80, 82    /
      write (16,*)
      write (16,*)
      do 80 i=1,33
      nz = nelem(i)
      if (nz.eq.6) then                 !  Carbon
        nisos = 2                 !  Number of isotopes in natural carbon
        data (nisot(1,n),atomfr(1,n),n=1,2) /
     &    6012,  0.98900,
     &    6013,   0.01100    /
      endif
      if (nz.eq.12) then                !  Magnesium
        nisos = 3                 !  Number of isotopes in natural carbon
        data (nisot(2,n),atomfr(2,n),n=1,3) /
     &    12024,   0.78990,
     &    12025,   0.10000,
     &    12026,   0.11010   /
      endif
      if (nz.eq.14) then                !  Silicon
        nisos = 3                 !  Number of isotopes in natural carbon
        data (nisot(3,n),atomfr(3,n),n=1,3) /
     &    14028,   0.92230,
     &    14029,   0.04670,
     &    14030,   0.03100   /
      endif
      if (nz.eq.16) then                !  Sulfur
        nisos = 4                 !  Number of isotopes in natural carbon
        data (nisot(4,n),atomfr(4,n),n=1,4) /
     &    16032,   0.95020,
     &    16033,   0.00750,
     &    16034,   0.04210,
     &    16036,   0.00020   /
      endif
      if (nz.eq.17) then                !  Chlorine
        nisos = 2                 !  Number of isotopes in natural carbon
        data (nisot(5,n),atomfr(5,n),n=1,2) /
     &    17035,   0.75770,
     &    17037,   0.24230   /
      endif
      if (nz.eq.18) then                !  Argon
        nisos = 3                 !  Number of isotopes in natural carbon
        data (nisot(6,n),atomfr(6,n),n=1,3) /
     &    18036,   0.00337,
     &    18038,   0.00063,
     &    18040,   0.99600   /
      endif
      if (nz.eq.19) then                !  Potassium
        nisos = 3                 !  Number of isotopes in natural carbon
        data (nisot(7,n),atomfr(7,n),n=1,3) /
     &    19039,   0.93258,
     &    19040,   0.00012,
     &    19041,   0.06730    /
      endif
      if (nz.eq.20) then                !  Calcium
        nisos = 6                 !  Number of isotopes in natural carbon
        data (nisot(8,n),atomfr(8,n),n=1,6) /
     &    20040,   0.96941, 
     &    20042,   0.00647,
     &    20043,   0.00135,
     &    20044,   0.02086,
     &    20046,   0.00004,
     &    20048,   0.00187   /
      endif
      if (nz.eq.22) then                !  Titanium
        nisos = 5                 !  Number of isotopes in natural carbon
        data (nisot(9,n),atomfr(9,n),n=1,5) /
     &    22046,   0.08250,
     &    22047,   0.07440,
     &    22048,   0.73720,
     &    22049,   0.05410,
     &    22050,   0.05180   /
      endif
      if (nz.eq.23) then                !  Vanadium
        nisos = 2                 !  Number of isotopes in natural carbon
        data (nisot(10,n),atomfr(10,n),n=1,2) /
     &    23050,   0.00250,
     &    23051,   0.99750   /
      endif
      if (nz.eq.24) then                !  Chromium
        nisos = 4                 !  Number of isotopes in natural carbon
        data (nisot(11,n),atomfr(11,n),n=1,4) /
     &    24050,   0.04350,
     &    24052,   0.83790,
     &    24053,   0.09500,
     &    24054,   0.02360   /
      endif
      if (nz.eq.25) then                !  Manganese
        nisos = 1                 !  Number of isotopes in natural carbon
        data (nisot(12,n),atomfr(12,n),n=1,1) /
     &    25055,   0.10000   /
      endif
      if (nz.eq.26) then                !  Iron 
        nisos = 4                 !  Number of isotopes in natural carbon
        data (nisot(13,n),atomfr(13,n),n=1,4) /
     &    26054,   0.05850,
     &    26056,   0.91750,
     &    26057,   0.02120,
     &    26058,   0.00280   /
      endif
      if (nz.eq.28) then                !  Nickel 
        nisos = 5                 !  Number of isotopes in natural carbon
        data (nisot(14,n),atomfr(14,n),n=1,5) /
     &    28058,   0.68080,
     &    28060,   0.26220,
     &    28061,   0.01140,
     &    28062,   0.03630,
     &    28064,   0.00930   /
      endif
      if (nz.eq.29) then                !  Copper
        nisos = 2                 !  Number of isotopes in natural carbon
        data (nisot(15,n),atomfr(15,n),n=1,2) /
     &    29063,   0.69170,
     &    29065,   0.30830   /
      endif
      if (nz.eq.30) then                !  Zinc 
        nisos = 4                 !  Number of isotopes in natural carbon
        data (nisot(16,n),atomfr(16,n),n=1,4) /
     &    30064,   0.48600,
     &    30066,   0.27900,
     &    30067,   0.04100,
     &    30068,   0.18800   /
      endif
      if (nz.eq.31) then                !  Gallium
        nisos = 2                 !  Number of isotopes in natural carbon
        data (nisot(17,n),atomfr(17,n),n=1,2) /
     &    31069,   0.60110,
     &    31071,   0.39890   /
      endif
      if (nz.eq.40) then                !  Zirconium
        nisos = 5                 !  Number of isotopes in natural carbon
        data (nisot(18,n),atomfr(18,n),n=1,5) /
     &    40090,   0.51450,
     &    40091,   0.11220,
     &    40092,   0.17150,
     &    40094,   0.17380,
     &    40096,   0.02800   /
      endif
      if (nz.eq.42) then                !  Molybdenum
        nisos = 7                 !  Number of isotopes in natural carbon
        data (nisot(19,n),atomfr(19,n),n=1,7) /
     &    42092,   0.14840,
     &    42094,   0.09250,
     &    42095,   0.15920,
     &    42096,   0.16680,
     &    42097,   0.09550,
     &    42098,   0.24130,
     &    42100,   0.09630   /
      endif
      if (nz.eq.47) then                !  Silver 
        nisos = 2                 !  Number of isotopes in natural carbon
        data (nisot(20,n),atomfr(20,n),n=1,2) /
     &    47107,   0.51839,
     &    47109,   0.48161   /
      endif
      if (nz.eq.48) then                !  Cadmium
        nisos = 8                 !  Number of isotopes in natural carbon
        data (nisot(21,n),atomfr(21,n),n=1,8) /
     &    48106,   0.01250,
     &    48108,   0.00890,
     &    48110,   0.12490,
     &    48111,   0.12800,
     &    48112,   0.24130,
     &    48113,   0.12220,
     &    48114,   0.28730,
     &    48116,   0.07490   /
      endif
      if (nz.eq.49) then                !  Indium
        nisos = 2                 !  Number of isotopes in natural carbon
        data (nisot(22,n),atomfr(22,n),n=1,2) /
     &    49113,   0.04290,
     &    49115,   0.95710   /
      endif
      if (nz.eq.50) then                !  Tin 
        nisos = 10                 !  Number of isotopes in natural carbon
        data (nisot(23,n),atomfr(23,n),n=1,10) /
     &    50112,   0.00970,
     &    50114,   0.00650,
     &    50115,   0.00340,
     &    50116,   0.14540,
     &    50117,   0.07680,
     &    50118,   0.24220,
     &    50119,   0.08590,
     &    50120,   0.32590,
     &    50122,   0.04630,
     &    50124,   0.05790   /
      endif
      if (nz.eq.51) then                !  Antimony 
        nisos = 2                 !  Number of isotopes in natural carbon
        data (nisot(24,n),atomfr(24,n),n=1,2) /
     &    51121,   0.57300,
     &    51123,   0.42700   /
      endif
      if (nz.eq.54) then                !  Xenon 
        nisos = 9                 !  Number of isotopes in natural carbon
        data (nisot(25,n),atomfr(25,n),n=1,9) /
     &    54124,   0.00100,
     &    54126,   0.00090,
     &    54128,   0.01910,
     &    54129,   0.26400,
     &    54130,   0.04100,
     &    54131,   0.21200,
     &    54132,   0.26900,
     &    54134,   0.10400,
     &    54136,   0.08900   /
      endif
      if (nz.eq.63) then                !  Europium 
        nisos = 2                 !  Number of isotopes in natural carbon
        data (nisot(26,n),atomfr(26,n),n=1,2) /
     &    63151,   0.47800,
     &    63153,   0.52200   /
      endif
      if (nz.eq.64) then                !  Gadolinium
        nisos = 7                 !  Number of isotopes in natural carbon
        data (nisot(27,n),atomfr(27,n),n=1,7) /
     &    64152,   0.00200,
     &    64154,   0.02180,
     &    64155,   0.14800,
     &    64156,   0.20470,
     &    64157,   0.15650,
     &    64158,   0.24840,
     &    64160,   0.21860   /
      endif
      if (nz.eq.72) then                !  Hafnium
        nisos = 6                 !  Number of isotopes in natural carbon
        data (nisot(28,n),atomfr(28,n),n=1,6) /
     &    72174,   0.00162,
     &    72176,   0.05206,
     &    72177,   0.18606,
     &    72178,   0.27297,
     &    72179,   0.13629,
     &    72180,   0.35100   /
      endif
      if (nz.eq.74) then                !  Tungsten 
        nisos = 5                 !  Number of isotopes in natural carbon
        data (nisot(29,n),atomfr(29,n),n=1,5) /
     &    74180,   0.00120,
     &    74182,   0.26498,
     &    74183,   0.14314,
     &    74184,   0.30642,
     &    74186,   0.28426   /
      endif
      if (nz.eq.77) then                !  Iridium 
        nisos = 2                 !  Number of isotopes in natural carbon
        data (nisot(30,n),atomfr(30,n),n=1,2) /
     &    77191,   0.37300,
     &    77193,   0.62700   /
      endif
      if (nz.eq.78) then                !  Platinum
        nisos = 6                 !  Number of isotopes in natural carbon
        data (nisot(31,n),atomfr(31,n),n=1,6) /
     &    78190,   0.00010,
     &    78192,   0.00790,
     &    78194,   0.32900,
     &    78195,   0.33800,
     &    78196,   0.25300,
     &    78198,   0.07200   /
      endif
      if (nz.eq.80) then                !  Mercury
        nisos = 7                  !  Number of isotopes in natural carbon
        data (nisot(32,n),atomfr(32,n),n=1,7) /
     &    80196,   0.00150,
     &    80198,   0.09970,
     &    80199,   0.16870,
     &    80200,   0.23100,
     &    80201,   0.13180,
     &    80202,   0.29860,
     &    80204,   0.06870   /
      endif
      if (nz.eq.82) then                !  Lead 
        nisos = 4                 !  Number of isotopes in natural carbon
        data (nisot(33,n),atomfr(33,n),n=1,4) /
     &    82204,   0.01400,
     &    82206,   0.24100,
     &    82207,   0.22100,
     &    82208,   0.52400   /
      endif
c
      nisop(i) = nisos
      write (16,*) nelem(i)
      write (16,*) nisop(i)
      do 60 n=1,nisop(i)
   60 write (16,'(i5,3x,f10.5)')
     &        nisot(i,n),atomfr(i,n)
   80 continue
      close (16)
c
      return
      end
c
c
      subroutine isogas
c
      common /mbinp/nmat,mt(49),voli(49),pow,qu235,days,nouter,ninner,
     & npre,nrst,frimp,nauto(49),ntot(49),nkeff,mbxs,nisn(999,49),
     & nisnr(999,49)
      common /mbinp2/niso(999,49),nisor(999,49),title,olib,locale,posit,
     &     tmpfile,machin,CALC
      character niso*10,nisor*6,title*72,olib*10,locale*72,posit*1,
     & machin*4,tmpfile*10,CALC*6
c
c This program adds gas production data and isomeric state data
c to the opt8* files created by HTAPE3X. The program HTAPE3X gives
c data for isomeric states but does not compile this information
c into the opt8* files. This code adds the gas production rates, as
c well as isomeric state data to the proper out8* files.
c
c Based on the GAS code written by Eric Pitcher and modified by
c Russ Kidman to include isomeric states.
c
c Modification History:
c
c 991015 EJP Fixed bug in code that produced bogus z=1 and z=2 data
c            when uranium is a target material (increased first
c            dimensions of b and re arrays from 92 to 98).
c
c 991005 EJP Allow filename input on execution line.
c
c Parameter Definitions:
c
c   maxreg    maximum number of CINDER'90 regions in the problem
c   maxmat    maximum number of "struck nucleus" material being investigated
c               (note:  these may cross more than one material region in MCNP)
c               = 26 because there are only 26 letters in the alphabet....
c
      parameter (maxreg=49)
      character id(maxreg)*56,string*102,
     *          suffix(maxreg)*2,xid*56,opt8file*8,out8file*8
      integer   i,j,k,l,m,o,count,ll
      real      h1(maxreg),h1e(maxreg),h2(maxreg),h2e(maxreg),
     *          h3(maxreg),h3e(maxreg),he3(maxreg),he3e(maxreg),
     *          he4(maxreg),he4e(maxreg),b(98,146,3),re(98,146,3),
     *          error
c
      data suffix/'a ','b ','c ','d ','e ','f ','g ','h ','i ','j ',
     *            'k ','l ','m ','n ','o ','p ','q ','r ','s ','t ',
     *            'u ','v ','w ','x ','y ','z ','aa','ab','ac','ad',
     *            'ae','af','ag','ah','ai','aj','ak','al','am','an',
     *            'ao','ap','aq','ar','as','at','au','av','aw'/
      do i=1,98
        do j=1,146
          do k=1,3
            b(i,j,k) = 0.0
          enddo
        enddo
      enddo
c
c Read gas production information from outgas file.
c
      open (1,file='outt14',status='old',err=9010)
      i = 0
      do while (.true.)
        read (1,10105,end=100) string
        if (index(string,'gas production in').ne.0) then
          i = i+1
          id(i) = string(index(string,' in')+4:)
          do while (string(13:20).ne.'hydrogen')
            read (1,10105) string
          enddo
          read (1,*,err=9020) h1(i),h1e(i),h2(i),h2e(i),h3(i),h3e(i)
          read (1,*)
          read (1,*)
          read (1,*,err=9020) he3(i),he3e(i),he4(i),he4e(i)
        endif
      enddo
 100  close (1)
      numreg = i
      if (numreg.ne.nmat) then
        write (6,*) 'MB ERROR:  number of regions in outt14 and '
     &      ,'mb.inp do not match' 
        stop
      endif
c
c Get total isotope production rates from out8 file.
c
      do i=1,numreg
        if (i.eq.1) open (2,file='outt08',err=9040)
        if (i.eq.27) open (2,file='outt08a',err=9040)
        open (2,file='outt08',err=9040)
        read (2,'(a102)',end=9050) string
        do while (string(11:41).ne.'distribution of residual nuclei')
          read (2,'(a102)',end=9050) string
        enddo
        read (2,'(a102)',end=9050) string
        do while (string(6:8).ne.'z =')
          read (2,'(a102)',end=9050) string
        enddo
        do while (string(6:10).ne.'all z')
          read (string,'(8x,i3,5x,i4,3x,d11.5,f7.4)')
     &          iz,in,sp,re(iz,in,1)
          b(iz,in,1)=sp
          do while (string(14:16).eq.'n =')
             read (string,'(16x,i4,3x,d11.5,f7.4)') in,sp,re(iz,in,1)
             b(iz,in,1)=sp
             read (2,'(a102)',end=9050) string
          enddo
          read (2,'(a102)',end=9050) string
          read (2,'(a102)',end=9050) string
        enddo               
1300    continue
c
c Get metastable isotope production information from out8 file.
c
1400     read (2,'(a102)',end=9050) string
         if (string(12:38).eq.'metastable state production') go to 1500
         go to 1400
1500     read (2,'(a102)',end=9050) string
	 read (2,'(a102)',end=9050) string
	 read (2,'(a102)',end=9050) string
         read (2,'(a102)',end=9050) string
         do while (string(3:5).ne.'   ')
	     read (string,'(3i5,f10.5,2e14.5,f7.4)') iz,ia,ll,elev,thalf,
     *                                             slev,error
             in=ia-iz
             if (elev.gt.0.0.and.b(iz,in,2).eq.0.0) then
                b(iz,in,2)=slev
                re(iz,in,2)=error  
                re(iz,in,2)=sqrt((re(iz,in,1)**2.0E0)+(error**2.0E0))
             else
                b(iz,in,3)=slev
                re(iz,in,3)=error
                re(iz,in,3)=sqrt((re(iz,in,1)**2.0E0)+(error**2.0E0))             
             endif
             read (2,'(a102)',end=9050) string
         enddo
c
c  Re-compute isotopic fractions to incorporate metastable isotopes.
c
         do 1600 j=1,98
	    do 1600 k=1,146
               if (b(j,k,1).eq.0.0.and.b(j,k,2).ne.0.0) then
                  b(j,k,2)=1.0
                  b(j,k,3)=0.0
               else
                  b(j,k,2)=b(j,k,2)*b(j,k,1)
                  b(j,k,3)=b(j,k,3)*b(j,k,1)
                  b(j,k,1)=b(j,k,1)-b(j,k,2)-b(j,k,3)
               endif
1600     continue
c 
c   Open output files according to suffix rule
c
           if (i.le.26) then
             opt8file = 'opt8'//suffix(i)(1:1)
             out8file = 'out8'//suffix(i)(1:1)
           else
             opt8file = 'opt8'//suffix(i)
             out8file = 'out8'//suffix(i)
           endif 
           open (3,file=opt8file,err=9020)
           open (4,file=out8file)
c
           read (3,10105) string
           write (4,10105) string
           write (4,'(e10.3)') voli(i)
           xid = string(index(string,' in ')+4:)
           if (xid.ne.id(i)) go to 9030
           if (h1(i).ne.0.0) write (4,10205) 1,0,h1(i),h1e(i),0
           if (h2(i).ne.0.0) write (4,10305)   1,h2(i),h2e(i),0
           if (h3(i).ne.0.0) write (4,10305)   2,h3(i),h3e(i),0
           if (he3(i).ne.0.0) then
              write (4,10205) 2,1,he3(i),he3e(i),0
              if (he4(i).ne.0.0) then
                 write (4,10305)   2,he4(i),he4e(i),0
              endif
           elseif (he3(i).eq.0.0) then
              if (he4(i).ne.0.0) then
                 write (4,10205) 2,2,he4(i),he4e(i),0
              endif
           endif
           do 2100 l=1,98
              count=0
              do 2100 m=1,146
                 do 2100 k=1,3
                      if (b(l,m,k).eq.0.0) go to 2100
                      if (count.eq.0) then
                         write (4,10205) l,m,b(l,m,k),re(l,m,k),
     &                        k-1
                         count=1
                      else
                         write (4,10305) m,b(l,m,k),re(l,m,k),k-1
                      endif
2100       continue
           close (3)
           close (4)
c   
c   Clear all values of b for each region
c
        do 2180 l=1,98
          do 2180 m=1,146
            do 2180 o=1,3
              b(l,m,o)=0.0 
2180    continue
        if (i.eq.26.or.i.eq.numreg) close (2)
      enddo
2200  goto 2300 
c   error section.
9010  write (6,*) 'ERROR: ISOGAS: incurred while attempting to open '//
     &            'outt08.'
      stop
9020  write (6,*) 'ERROR: ISOGAS: number of cases in outgas and opt8'//
     &            ' files disagree.'
      stop
9030  write (6,*) 'ERROR: ISOGAS: mat/cell numbers in outgas and opt'//
     &            '8 files disagree.'
      stop
9040  write (6,*) 'ERROR: ISOGAS: incurred while attempting to open '//
     &            'out8.'
      stop
9050  write (6,*) 'ERROR: ISOGAS: number of cases in outt08 and out8'//
     &            ' files disagree.'
      stop
c
c Format write statements.
c
10105 format(a102)
10205 format('     z =',i3,'  n =',i4,3x,1pd11.5,1x,0pf6.4,i3)
10305 format(11x,'  n =',i4,3x,1pd11.5,1x,0pf6.4,i3)
 2300 return
      end
