*cpl
*lst
*ident up1
*/ 8 may 92 -- fix transport correction.
*i transx.1184
c
c     the following forces transx to collapse all orders using the
c     scalar flux.  high-order collapses don't give good results
c     when using fluxes from infinite-lattice calculations.
      noho=1
*d transx.1591,1595
      ilx=il
      if (noho.eq.1) ilx=1
*i transx.1600
      if (il.lt.illo) go to 375
*d transx.1608,1612
      if (iptot+nup+1.le.ntabl.and.il.ge.illo.and.il.le.ilhi)
     x c(iptot+nup+1,jm-1+il,ig)=c(iptot+nup+1,jm-1+il,ig)-add
      if (il.gt.1) go to 395
      if (itrc.eq.1.and.ilt.eq.1) go to 385
      go to 395
  380 if (itrc.gt.1.and.(ilt.eq.lim.or.ilt.ge.iltx)) go to 385
*d transx.1618
      if (in.lt.illo.or.in.gt.ilhi) go to 390
      c(iptot+nup+1,jm-1+in,ig)=c(iptot+nup+1,jm-1+in,ig)+add
  390 continue
*d transx.1649,1650
      ilx=2
      if (nl.eq.1) ilx=1
c     if (noho.eq.1) ilx=1
      if (cflux(jga,imy,ilx).eq.0) go to 428
      addtrd=addd*fflux(jj+jc2,irg,ilx)/cflux(jga,imy,ilx)
*d transx.1829,1831
      ilt=il
      if (noho.eq.1) ilt=1
*ident up2
*/ 26 may 92 -- fix paging for material ordering
*i transx.1996
      if (imx.lt.imlo.or.imx.gt.imhi) go to 690
*i transx.2050
      if (im.lt.imlo.or.im.gt.imhi) go to 740
*ident up3
*/ 22 jul 92 -- allow abs correction to operate over wider range
*i transx.1173
      data hn2a/6hn2a   /, hn3a/6hn3a   /, hn2p/6hn2p   /
      data hnpa/6hnpa   /, hnt2a/6hnt2a  /, hnd2a/6hnd2a  /
      data hnpd/6hnpd   /, hnpt/6hnpt   /, hn2n1/6hn2n1  /
      data hn2n2/6hhn2n2  /, hn2n3/6hn2n3  /, hn2n4/6hn2n4  /
      data hn2na/6hn2na  /, hn2ni/6hn2ni  /, hn2n2a/6hn2n2a /
      data hn2np/6hn2np  /, hn3na/6hn3na  /, hn3np/6hn3np  /
      data hn4n/6hn4n   /
*i transx.1504
      if (hvps.eq.hn2a) iabsc=1
      if (hvps.eq.hn3a) iabsc=1
      if (hvps.eq.hn2p) iabsc=1
      if (hvps.eq.hnpa) iabsc=1
      if (hvps.eq.hnt2a) iabsc=1
      if (hvps.eq.hnd2a) iabsc=1
      if (hvps.eq.hnpd) iabsc=1
      if (hvps.eq.hnpt) iabsc=1
*i transx.1505
      if (hvps.eq.hn2n1) iabsc=-1
      if (hvps.eq.hn2n2) iabsc=-1
      if (hvps.eq.hn2n3) iabsc=-1
      if (hvps.eq.hn2n4) iabsc=-1
      if (hvps.eq.hn2na) iabsc=-1
      if (hvps.eq.hn2ni) iabsc=-1
      if (hvps.eq.hn2n2a) iabsc=-1
      if (hvps.eq.hn2np) iabsc=-1
*i transx.1506
      if (hvps.eq.hn3na) iabsc=-2
      if (hvps.eq.hn3np) iabsc=-2
      if (hvps.eq.hn4n) iabsc=-3
*d transx.2054
*d transx.2056
      if (abs(diff).gt.0.01*c(iptot,jm,jg-jglo+1)) go to 735
*ident up4
*/ 15 jan 92 -- fix miscellaneous problems:
*/      errors in writing isotxs file,
*/      errors discovered by the cft77 compiler (uninitialized variables),
*/      fix of infinite loop if no self-shielding but temp other than base,
*/      hollerith problems, and
*/      unset and unused variable found by lahey compiler.
*d transx.188
      common/isot/llsfis,lsnalf,llsnp,llsn2n,llsnd,llsnt,lsngam
*d transx.197,198
*d transx.205
      data hcard/6hcard  /, hclaw/6hclaw  /, hfido/6hfido  /
      data hanis/6hanisn /, hgoxs/6hgoxs  /
      data hrtfl/6hrtflux/, hrzmf/6hrzmflx/, hrzfl/6hrzflux/
*d transx.220
*d transx.242
*d transx.247
*d transx.287,292
      if (iout.eq.1) houtxs=hcard
      if (iout.eq.2) houtxs=hclaw
      if (iout.eq.3) houtxs=hfido
      if (iout.eq.4) houtxs=hanis
      if (iout.eq.5) houtxs=hgoxs
      if (iout.eq.6) houtxs=hisotx
*d transx.298,300
      if (iabs(initf).eq.2) hflux=hrtfl
      if (iabs(initf).eq.3) hflux=hrzmf
      if (iabs(initf).eq.4) hflux=hrzfl
*d transx.786
*d transx.790
      if (n2nd.gt.0) nkk=n2nd
*d transx.861
     x nmix,nreg,nmixs,nmixr,ngnf,nfine,nl,iprint)
*d transx.959
      call rmatxs(a,ia,ha,l1,l1h,l2,l2h,a(lc+1),nin,irzm,maxw,
*d transx.961
     x ngmax,icoll,kpos,npos,locg,iset,iptot,itrc,nmixr,
*i transx.971
     x iprob,inflo,iprint,iform,
*d transx.1021
     x ha(lhed+1),ngroup,ntabl,iptot,ned,nout)
*d transx.1026
      call wfido(a(lc+1),hmixn,im,il,jm,njm,ngroup,
     x ntabl,iptot,nout,ncom,iout)
*d transx.1096
     x a(lflux+nwcf+1),a(lflux+1),kpos,npos,iptot,ngg,
*d transx.1130
      subroutine rmatxs(a,ia,ha,l1,l1h,l2,l2h,c,nin,irzm,maxw,
*d transx.1132
     x ngmax,icoll,kpos,npos,locg,iset,iptot,itrc,nmixr,
*i transx.1137
     x iprob,inflo,iprint,iform,
*d transx.1169
      data hn2nf/6hn2nf  /, hn3nf/6hn3nf  /
*d transx.1175,1176
      data hgwt0/6hgwt0  /, hgtot/6hgtot0 /, hnwt0/6hnwt0  /
*d transx.1184
       data hblank/6h      /, hnone/6hnone  /
*d transx.1221
*d transx.1386
*d transx.1431,1432
  275 do 280 i=1,5
*d transx.1825
      if (tesc.gt.+.8) tesc=+.8
*d transx.2093
     x nmix,nreg,nmixs,nmixr,ngnf,nfine,nl,iprint)
*d transx.2472
*i transx.2488
      if (ihet.eq.0) go to 510
*d transx.2669
  510 sznow=0.
*d transx.2792
     x hed,hmixn,igtab,vel,grp,fflux,cflux,kpos,npos,iptot,ngg,
*d transx.2996
      subroutine wfido(c,hmixn,im,il,jm,njm,ngroup,
     x ntabl,iptot,nout,ncom,iout)
*d transx.3052
      subroutine wclaw(c,hmixn,im,il,jm,njm,hed,ngroup,
     x ntabl,iptot,ned,nout)
*i transx.3090
      l=il-1
*d transx.3124,3125
      common/isot/llsfis,lsnalf,llsnp,llsn2n,llsnd,llsnt,lsngam
      data hisotx/6hisotxs/, htrans/6htransx/, hblank/6h      /
      data hmatxs/6hmatxs /
*d transx.3193
      ha(loc)=hmixn(im)
*d transx.3859
      real*8 hname,hchang
*d transx.3861
      integer hname,hchang
*i transx.3867
      data hchang/6hchange/
*d transx.3869
      if (hname.eq.hchang) go to 210
*ident up5
*/ 24 feb 92 -- improve interface to anisn
*i transx.52
c                  7   anisnb (anisn binary)
*d up4.13
      data hanis/6hanisn /, hgoxs/6hgoxs  /, hanisb/6hanisnb/
*i transx.263
      if (iout.eq.7) iform=1
*d transx.269
     x               ''5=goxs/6=isotxs/7=anisnb)''/
*i up4.24
      if (iout.eq.7) houtxs=hanisb
*d transx.295
      if (iout.ge.5.and.iout.le.7) nop=1
*i transx.890
      if (iout.eq.7) then
         lanis=lc
         lc=lanis+ntabl*ngroup
      endif
*d transx.1037
  440 if (iout.ne.6) go to 450
*i transx.1042
      go to 455
c
c     ***anisn binary format
  450 if (iout.ne.7) go to 455
      call wanisb(a(lc+1),hmixn,im,il,jm,njm,ngroup,
     x ntabl,iptot,nout,a(lanis+1))
*d transx.2999
c     the anisn format has the 2*l+1 factor included, and
c     the header cards have a different format.
*d transx.3012,3013
      if (iout.eq.3) then
         write(nout,'(1x,a6,'' p'',i1,i4,''x'',i3,'' table'',
     x    50x,i6)') hmixn,l,ntabl,ngroup,iseq
      else
         ic=0
         write(nout,'(''/'',i5,3i6,1x,a6,'' p'',i1,'' table'',
     x    32x,i8)') ngroup,ntabl,ic,jm,hmixn,l,iseq
      endif
*i transx.3048
      if (iout.eq.4.and.jm.eq.njm) then
         iseq=iseq+1
         ic=7
         id=0
         write(nout,
     x     '(''/'',i5,3i6,1x,''end of anisn data'',30x,i8)')
     x     ngroup,ntabl,ic,id,iseq
      endif
*i transx.3295
c
      subroutine wanisb(c,hmixn,im,il,jm,njm,ngroup,ntabl,
     x iptot,nout,scr)
c     ******************************************************************
c     write this material and order in the binary anisn format.
c     ******************************************************************
*if sw
      implicit real*8 (h)
*else
      implicit integer (h)
*endif
      dimension c(ntabl,njm,ngroup),scr(ntabl,ngroup)
      character title*48
c
      l=il-1
      do 110 jg=1,ngroup
      do 110 ip=1,ntabl
      t=c(ip,jm,jg)
      if (ip.gt.iptot) t=t*(2*il-1)
      scr(ip,jg)=t
  110 continue
      ic=0
      id=jm
      write(title,'(1x,a6,'' p'',i1,'' table'')') hmixn,l
      write(nout) ngroup,ntabl,ic,id,title
      write(nout) scr
      if (jm.lt.njm) return
      ic=7
      id=0
      title=' end of anisn data'
      write(nout) ngroup,ntabl,ic,id,title
      return
      end
*ident up6
*/ 24 feb 93 -- fix indexing error for photon production
*d transx.1837
     x xsec=xsec*ffis(jjp,imz)/sfis(jjp)
*d transx.1839
     x xsec=xsec*fgam(jjp,imz)/sgam(jjp)
*ident up7
*/ 20 may 93-- fix problem of overwriting energies and velocities
*d transx.219
      inmax=7000
*d transx.3176
      a(loc)=grp(1)
*ident up8
*/ 26 may 93 -- use * for assumed length arrays
*d transx.1159
      dimension fflux(nfine,nreg,*),cflux(ngroup,nmix,*)
*d transx.2113
      dimension wtm(ngnf),fflux(nfine,nreg,*),ffmod(nfine,nreg)
*d transx.2808
      dimension fflux(nfine,nreg,*),cflux(ngroup,nmix,*)
*d transx.2970
      dimension c(ntabl,njm,*)
*d transx.3006
      dimension c(ntabl,njm,*),s(18)
*d transx.3065
      dimension c(ntabl,njm,*),hed(ned)
*d transx.3120
      dimension c(ntabl,njm,*)
*d transx.3122
      dimension fflux(nfine,nreg,*),cflux(ngroup,nmix,*)
*ident up9
*/ 29 sep 93 -- more *'s for assumed length arrays
*d transx.1148
      dimension a(*),ia(*),ha(*)
*d transx.2103
      dimension a(*),ia(*),ha(*)
*d transx.2805,2807
      dimension a(*),ia(*),ha(*)
      dimension c(*)
      dimension hed(ned),hmixn(nmix),igtab(*),vel(*),grp(*)
*d transx.3119
      dimension a(*),ia(*),ha(*)
*d transx.3121
      dimension hmixn(nmix),vel(*),grp(*),igtab(*)
*d transx.3551
      dimension a(80),hn(10),z(*)
*/ 29 sep 93 -- fix problem with 2d rtflux
*i transx.669
      nblok=0
      if (initf.eq.2) nblok=ia(l1+8)
*d up4.31
      if (n2nd.gt.0) nkk=nblok
*ident up10
*/ 16 nov 93 -- install random access option
*d transx.35
c     large jobs.  the matxs library can be either a file, or a
c     directory containing single-material files for random access.
*i transx.79
c                  set ngroup negative to trigger
c                  material random access mode.
*i transx.88
c
c       card 3a (ngroup negative only)
c        mpath    path for matxs directory (24 char max)
*i transx.187
      character*24 mpath
      character*6 sflux,hanis,hgoxs,hanisb,hisotx,hmatxs,
     x           hclaw,hfido,hrtfl,hrzmf,hrzfl,hcard,houtxs,hflux
      character*30 smatxs
*i transx.190
      common/matx/mpath
      common/rand/ira
*d transx.204
*d up4.12
*d up5.6
*d up4.14
      data hmatxs,hisotx,hcard,hclaw,hfido,hanis,hgoxs,hanisb,hrtfl,
     x   hrzmf,hrzfl/'matxs ','isotxs','card  ','claw  ','fido  ',
     x   'anisn ','goxs  ','anisnb','rtflux','rzmflx','rzflux'/
*d transx.240,243
*d transx.297
      hflux = '      '
*d transx.301,302
*i transx.307
      if (ngroup.lt.0) then
         ira=1
         ngroup=-ngroup
      endif
*i transx.332
c
c     ***get path for random access mode
      if (ira.eq.1) then
         nz=6
         call free(nsysi,z(1),nz,4)
         write(mpath,'(6a4)') (z(i),i=1,nz)
         write(nsyso,'(/
     x     '' random access mode selected.  matxs path is''/
     x     '' -------------------------------------------''/
     x     1x,a)') mpath
      endif
*i transx.640
      nflx=0
      write(sflux,'(a6)') hflux
      call seek(sflux,0,nflx,0)
*d transx.675
      iuniq=0
  230 iuniq=iuniq+1
      if (ira.eq.0) then
         write(smatxs,'(a6)') hmatxs
         call seek(smatxs,0,nin,0)
      else
         lb=index(mpath,' ')
         lb=lb-1
         write(smatxs,'(a,a6)') mpath(1:lb),ha(lhuniq+iuniq)
         if (iuniq.ne.1) close (nin)
         call seek(smatxs,0,nin,0)
      endif
      nwds=1+3*mult
*i transx.759
      if (ira.eq.1.and.iuniq.lt.nuniq) go to 230
*i transx.858
     x nuniq,ha(lhuniq+1),
*i transx.967
     x nuniq,ha(lhuniq+1),
*i transx.1135
     x nuniq,huniq,
*i transx.1161
      dimension huniq(nuniq)
*i transx.1165
      character mpath*24,smatxs*30
      common/matx/mpath
      common/rand/ira
*d transx.1201
      im=1
      iuniq=1
  127 if (ira.eq.1) then
         lb=index(mpath,' ')
         lb=lb-1
         write(smatxs,'(a,a6)') mpath(1:lb),huniq(iuniq)
         if (iuniq.ne.1) close (nin)
         call seek(smatxs,0,nin,0)
         irec=1
         call reed(nin,irec,a(l1),1,0)
         irec=4
         nwds=(npart+ntype+nmat)*mult+npart+2*ntype+2*nmat
         call reed(nin,irec,a(l1),nwds,0)
      endif
*d transx.2035
  700 if (ira.eq.0) then
         im=im+1
         if (im.le.nmat) go to 127
      else
         iuniq=iuniq+1
         if (iuniq.le.nuniq) go to 127
      endif
*i transx.2091
     x nuniq,huniq,
*i transx.2114
      dimension huniq(nuniq)
*i transx.2116
      character mpath*24,smatxs*30
      common/matx/mpath
      common/rand/ira
*d transx.2141
      im=1
      iuniq=1
  107 if (ira.eq.1) then
         lb=index(mpath,' ')
         lb=lb-1
         write(smatxs,'(a,a6)') mpath(1:lb),huniq(iuniq)
         if (iuniq.ne.1) close (nin)
         call seek(smatxs,0,nin,0)
         irec=1
         call reed(nin,irec,a(l1),1,0)
         irec=4
         nwds=(npart+ntype+nmat)*mult+npart+2*ntype+2*nmat
         call reed(nin,irec,a(l1),nwds,0)
      endif
*d transx.2452
  380 if (ira.eq.0) then
         im=im+1
         if (im.le.nmat) go to 107
      else
         iuniq=iuniq+1
         if (iuniq.le.nuniq) go to 107
      endif
*d transx.3846
      subroutine seek(hfile,ivers,nref,nop)
*d transx.3858,3862
      character*(*) hfile
*d transx.3864,3865
      character mess*60,age*7,fn*11
*d up4.93
*d up4.95
      if (hfile.eq.'change') go to 210
*d transx.3873,3877
*d transx.3904
  210 write(mess,10) hfile,nop
*d transx.3906
  220 write(mess,20) hfile
*d transx.3908
  230 write(mess,30) hfile
*d transx.3912,3914
   10 format(17h seek--bad option,3x,a,3x,i2)
   20 format(26h seek--file does not exist,3x,a)
   30 format(25h seek--no units available,3x,a)
*ident up11
*/  11 jan 1994 -- fix problem with calculating sigma zero only
*/                 in specified regions
*/  2 feb 1994 -- fix problem with reading rtflux file on short word
*/                machines
*d transx.782
*if sw
      if (initf.eq.2) then
         if (mod(lc,2).eq.1) lc=lc+1
         call reed(nflx,jrec,a(lc+1),nwds*mult,0)
      else
         call reed(nflx,jrec,a(lc+1),nwds,0)
      endif
*else
      call reed (nflx,jrec,a(lc+1),nwds,0)
*endif
*d transx.795
*if sw
      if (initf.eq.2) then
         if (mod(lc,2).eq.1) lc=lc+1
         call reed(nflx,jrec,a(lc+1),nwds*mult,0)
      else
         call reed(nflx,jrec,a(lc+1),nwds,0)
      endif
*else
      call reed (nflx,jrec,a(lc+1),nwds,0)
*endif
*d transx.811,transx.812
*if sw
      if (initf.eq.2.and.n2nd.gt.0) lcx=lc+(irfl-1)*mult
      if (initf.eq.2.and.n2nd.eq.0) lcx=lc+(irfl-1+nrfl*(jj-1))*mult
*else
      if (initf.eq.2.and.n2nd.gt.0) lcx=lc+irfl-1
      if (initf.eq.2.and.n2nd.eq.0) lcx=lc+irfl-1+nrfl*(jj-1)
*endif
*d transx.823
*if sw
      if (initf.eq.2) then
         a(lfx)=ha((lcx+jl*mult)/mult)*a(lrvol+ireg)
      else
         a(lfx)=a(lcx+jl)*a(lrvol+ireg)
      endif
*else
      a(lfx)=a(lcx+jl)*a(lrvol+ireg)
*endif
*d transx.828
*if sw
      if (initf.eq.2) then
         a(lfy)=a(lfy)+ha((lcx+jl*mult)/mult)*a(lrvol+ireg)
      else
         a(lfy)=a(lfy)+a(lcx+jl)*a(lrvol+ireg)
      endif
*else
      a(lfy)=a(lfy)+a(lcx+jl)*a(lrvol+ireg)
*endif
*i transx.2458
      numss = 0
*i transx.2471
      numss=numss+ihet
      if(ihet.eq.0) go to 520
*d up4.69
*d up4.71
      sznow = 0.
*d transx.2680
      if(iok.eq.0.and.numss.ne.0) go to 390
*d transx.2655
      dancof=expint(3,xxr)+expint(3,xxl)
*ident up12
*/  29 mar 1994 -- replace e1,e3,gami,gam1 routines with expint from
*/                   Numerical Recipes 2nd edition.
*d transx.3297,transx.3532
      function expint(n,x)
c     ******************************************************************
c     exponential integral of order n for x.
c     this function is from Numerical Recipes 2nd edition.
c     maxit is the max iterations,
c     eps is the relative error,
c     fpmin is a number near the smallest fp number,
c     euler is euler's constant
c     ******************************************************************
      integer n,maxit
      real expint,x,eps,fpmin,euler
*if sw
      parameter (maxit=100,eps=1.e-7,fpmin=1.e-30,euler=.5772156649)
*else
      parameter (maxit=100,eps=1.e-20,fpmin=1.e-50,euler=.5772156649)
*endif
      integer i,ii,nm1
      real a,b,c,d,del,fact,h,psi
c
      nm1=n-1
      if (n.lt.0.or.x.lt.0..or.(x.eq.0..and.(n.eq.0.or.n.eq.1))) then
         call error( 'bad arguments in expint')
      else if (n.eq.0) then
         expint = exp(-x)/x
      else if (x.eq.0.) then
         expint=1./nm1
      else if (x.gt.1.) then
         b=x+n
         c=1./fpmin
         d=1./b
         h=d
         do 10 i=1,maxit
            a=-i*(nm1+i)
            b=b+2.
            d=1./(a*d+b)
            c=b+a/c
            del=c*d
            h=h*del
            if (abs(del-1.).lt.eps) then
               expint=h*exp(-x)
               return
            endif
 10      continue
         call error( 'continued fraction failed in expint')
      else
         if (nm1.ne.0) then
            expint=1./nm1
         else
            expint=-log(x)-euler
         endif
         fact=1.
         do 12 i=1,maxit
            fact=-fact*x/i
            if (i.ne.nm1) then
               del=-fact/(i-nm1)
            else
               psi=-euler
               do 11 ii=1,nm1
                  psi=psi+1./ii
 11            continue
               del=fact*(-log(x)+psi)
            endif
            expint=expint+del
            if (abs(del).lt.abs(expint)*eps) return
  12     continue
         call error( 'series failed in expint')
      endif
      return
      end
c
*ident up13
*/ 16 aug 94 -- fix problem with last line of card output
*i transx.2984
      i=i+1
*d transx.2986
*/ 16 aug 94 -- allow more digits for compression messages
*d transx.1031,1032
     x '' original length  '',i8/
     x '' compressed length'',i8)') nold,ncom
*d transx.2953,2954
      write(nsyso,'(/'' goxs file written''/'' original length'',i8/
     x '' compressed length'',i8/'' longest scattering record'',i7)')
*/ 16 aug 94 -- fix numerical problem in fido
*d transx.3816,3817
      if (a.lt.0.) m=m-1
*i transx.3819
      a=a+.000005*10.**m
*d transx.3820
  120 l=a/10.**m+.0000005
*i transx.3821
      if (l.gt.10) call error('fido conversion failed')
*i transx.3829
      if (a.lt.0.) a=0.
*/ 22 aug 94 -- to get self-shielded xsecs if iprint.gt.0 (mattes)
*d transx.2684
      if (iprint.gt.0) go to 635
*ident up14
*/ 21 oct 94 -- generalize the downscatter limit for selfshielding
*i transx.841
      maxds=5+5*nl
*d transx.846
      ncmax=ncmax-nmixs-10*nmixr-nmixr-maxds*nmixr
*d transx.847
      maxgrp=ncmax/(10*maxds+1)/nmixr
*i transx.848
      if (iprint.eq.0) write(nsyso,'(/
     x '' self-shielding calculation''/
     x '' --------------------------''/
     x '' words available for self-shielding ='',i8/
     x '' number of groups per pass ='',i6)')
     x ncmax,maxgrp
*d transx.852
      lsz=lsm+10*maxds*nmixr*maxgrp
*d transx.855
      next=lrec+maxds*nmixr
*i transx.856
     x maxds,
*d transx.867
      lc=lss+maxds*nmixr*(iss2-iss1+1)
*d transx.869
      nxnr=maxds*nmixr
*i up4.35
     x maxds,
*i up4.48
     x maxds,
*d transx.1580
      sig=a(lss+ii+maxds*(imr-1+nmixr*(jj-iss1)))
*d transx.1799
      if (ii.le.maxds) xsnew=a(lss+ii+maxds*(imr-1+nmixr*(jjp-iss1)))
*i transx.2090
     x maxds,
*d transx.2107
      dimension sig0(nmixr,maxgrp), sigs(10,maxds,nmixr,maxgrp)
*d transx.2112
      dimension rec(maxds,nmixr)
*d transx.2135
      do 105 ix=1,maxds
*d transx.2416
c     ***take up to maxds-5 elastic scattering elements
*d transx.2418
      if (ix.lt.6.or.ix.gt.maxds) go to 330
*d transx.2730
      do 640 ix=1,maxds
*d transx.2738
      do 642 ix=6,maxds,nlp
*d transx.2750
      write(nsz) ((rec(i,j),i=1,maxds),j=1,nmixr)
*d transx.2751
      do 650 i=1,maxds
*ident up15
*/ 21 oct 94 -- fix the sequence numbering for anisn
*i transx.981
      km=il+nl*(im-1)
      kmm=nl+nl*(nmix-1)
*d up4.43
      call wfido(a(lc+1),hmixn,imlo,im,il,km,kmm,jm,njm,ngroup,
*d up5.27
      call wanisb(a(lc+1),hmixn,km,kmm,im,il,jm,njm,ngroup,
*d up5.39
     x    32x,i8)') ngroup,ntabl,ic,km,hmixn,l,iseq
*i transx.3037
      if (iout.eq.4) go to 130
*d transx.3047,3048
      if (iout.eq.3.and.iend.eq.1) then
         iseq=iseq+1
         write(nout,'(''  t'',69x,i8)') iseq
      endif
*d up5.42
      if (iout.eq.4.and.jm.eq.kmm) then
*d up4.75
      subroutine wfido(c,hmixn,imlo,im,il,km,kmm,jm,njm,ngroup,
*d up5.52
      subroutine wanisb(c,hmixn,km,kmm,im,il,jm,njm,ngroup,ntabl,
*d up5.73
      id=km
*d up5.77
      if (km.lt.kmm) return
*/ 21 oct 94 -- add a binary groupwise format for anisn
*i up5.4
c                  8   anigif (anisn group-ordered binary)
*d up10.15
      character*6 sflux,hanis,hgoxs,hanisb,hangif,hisotx,hmatxs,
*d up10.25,27
      data hmatxs,hisotx,hcard,hclaw,hfido,hanis,hgoxs,hanisb,hangif,
     x   hrtfl,hrzmf,hrzfl/'matxs ','isotxs','card  ','claw  ','fido  ',
     x   'anisn ','goxs  ','anisnb','anigif','rtflux','rzmflx','rzflux'/
*i up5.8
      if (iout.eq.8) iform=2
*d up5.10
     x               ''5=goxs/6=isotxs/''/
     x               18x,''7=anisnb/8=anigif)''/
*d up5.14
      if (iout.ge.5.and.iout.le.8) nop=1
*i up5.12
      if (iout.eq.8) houtxs=hangif
*d transx.1093
  530 if (iout.ne.5) go to 532
*i transx.1097
      go to 540
c
c     ***anisn group-independent format
  532 if (iout.ne.8) go to 540
      call wanigi(a(lc+1),jg,jglo,jghi,nout,ntabl,njm,ngroup,nl,iptot)
*i up5.83
c
      subroutine wanigi(c,jg,jglo,jghi,nout,ntabl,njm,ngroup,nl,iptot)
c     ******************************************************************
c     write a group-independent anisn file (binary).
c     ******************************************************************
*if sw
      implicit real*8 (h)
*else
      implicit integer (h)
*endif
      dimension c(ntabl,njm,ngroup)
c
c     ***put the 2*l+1 factor into the tables
      k=jg-jglo+1
      i1=iptot+1
      do 120 j=1,njm
      l=mod(j-1,nl)
      do 110 i=i1,ntabl
      c(i,j,k)=(2*l+1)*c(i,j,k)
  110 continue
  120 continue
c
c     ***write data block for this group
      write(nout) ((c(i,j,k),i=1,ntabl),j=1,njm)
      return
      end
*/ 3 nov 94 -- fix title line for anisnb output
*i up5.62
      dimension ititle(12)
*d up5.75
      read(title,'(12a4)') ititle
      write(nout) ngroup,ntabl,ic,id,ititle
*d up5.81
      read(title,'(12a4)') ititle
      write(nout) ngroup,ntabl,ic,id,ititle
*/ 10 nov 94 -- fix formats to allow for more memory
*d transx.910
     x '' words available for table ='',i8/
*d transx.941
      write(nsyso,'('' words available for table ='',i8/
*ident size
*/ increase size of main container array
*d transx.180
      dimension a(1200000)
*d transx.218
      namax=1200000
*ident vers
*/ version update for transx
*d transx.7
c     vers. 2.15 (10 nov 94)
*d transx.207
      data vers/'vers. 2.15 (10 nov 94)'/