*deck readme
c readme.for: This readme file 
c avrfpy.for: Fission product yields & decay data processing code
c avrfpyR4.for: Real*4 version of avrfpy.for
c chkspc.for: Check weighting spectra in NJOY inputs
c d2oe3b.for: Summarize WLUP D2O Benchmarks
c d2osmr.for: Summarize WLUP D2O Benchmarks
c dckspl.for: split source files (*.src) files into decks
c dopben.for: Summarize WLUP DOPPLER Supplementary Benchmarks
c dopbench.for: Postprocessing code for doppler benchmarks
c e1t1.for: Postprocessing code for e1t1 benchmark
c e1t2.for: Postprocessing code for e1t2 benchmark
c e1t3.for: Postprocessing code for e1t3 benchmark
c e1t4.for: Postprocessing code for e1t4 benchmark
c e2t1.for: Postprocessing code for e2t1 benchmark
c e2t2.for: Postprocessing code for e2t2 benchmark
c e2t2p.for: Summarize WLUP E2T2 Benchmark (54 pin-cluster with Gd)
c e2t2w86.for: Postprocessing code for e2t2 benchmark (WIMS-86 library)
c e3.for: Postprocessing code for e3 benchmark
c enfiss.for: Calculate energy released by fission from an ENDF tape.
c fidlam.for: Fiddle the Am-241 fission cross section
c getmf2.for: Get relevant data from the ENDF-6/MF=2.
c getzam.for: Extract one or more materials from an ENDF tape
c mrgmat.for: Merge ENDF material files into a single library
c mtrb2.for: Summarize WLUP MTR-OWR Benchmark
c mtrburn.for: Process one wims output for benchmark mtr-burn
c njbfp.for: Prepare NJOY fission product yields
c njinjb.for: Edit the F.P. yields data in NJOY input
c njispl.for: Split Merged NJOY input into separate files
c njrrat.for: Calculate Reaction Rate Ratios from NJOY Output
c pintcr.for: Calculation of temperature coefficient (NORA, KRITZ, etc)
c pltwli.for: Prepare WILLIE input to plot WIMS-D cross sections
c pseudo.for: Prepare the needed files to generate pseudo fission product
c qval_k.for: Tabulate distribution of deviations in Keff from QVALUE output
c qvalue.for: Analyse WLUP benchmarks by slowing-down density q(E)
c qvalue_w.for: Analyse WLUP benchmarks by slowing-down density q(E)
c rpinke.for: Average contributions to Rowlands pin-cell benchmark
c rtcben.for: Summarize WLUP RTC Supplementary Benchmarks
c smrdi2.for: Tabulate and compare BNL-Th benchmark summary results
c smrdif.for: Tabulate and compare benchmark summary results
c smrlib.for: Compare SMRDIF summary results for different libraries
c thburn.for: Process WIMS output for PWR thorium pin cell benchmark
c updbrn.for: Update energy released per fission and decay data in NJOY inputs
c wedb1a.for: Analyse Burnup Credit Criticality Benchmark PART-1A
c wedb1b.for: Analyse Burnup Credit Criticality Benchmark PART-1B
c wedkin.for: Extract k-inf from WIMS output as a function of burnup
c wedog2.for: Calculate 2-group reaction rates from WIMS output
c wedrpu.for: Process WIMS-D results for Rowlands Pu pin cell benchmark
c wedru.for: Process WIMS-D outputs for Rowlands U pin cell benchmark
c wedspe.for: Extract spectra from WIMS output
c willie.for: WIMS-D library utility and management code
c wimsie.for: Prepare a WIMS-D formatted dosimetry file
c wwercr.for: Post-process WWER-type lattice criticality benchmarks.
c xspmix.for: Mix fission spectra for the WIMS-D Library
c ----------------------------------------------------------------------------
c
*deck avrfpy  
      PROGRAM AVRFPY
C-Title  : Program AVRFPY
C-Purpose: Calculate Spectrum Averaged F.P Yields
C-Author : A.Trkov, Institute J.Stefan, Ljubljana, Slovenia (1995)
C-Version: 1995 Original distribution
C-V  99/02 Minor corrections to fix bugs.
C-V  99/05 A.Trkov: Fix bugs in comparison mode.
C-V  01/11 A.Trkov: Upgrade to support INTER 6.12 output.
C-V  05/06 A.Trkov & D. L. Aldama: fix bugs processing f.p yields
C-V                                and decay data from JEFF-3.1
C-V  12/14 D. L. Aldama: Converted to Real*8
C-V
C-M
C-M  Manual for Program AVRFPY
C-M  =========================
C-M
C-M  The fission product yields data (ENDF-5, ENDF-6 format File 8)
C-M  are analysed. Energy dependent fission yields are accepted.
C-M  They are averaged, making some assumptions about the averaging
C-M  fission reaction rate. For all nuclides in the fission product
C-M  list the decay data are retrieved from the appropriate ENDF
C-M  file. The INTER (Version 6.11 and 6.12) output is also processed
C-M  to extract the thermal (Maxwellian average) cross section, the
C-M  resonance integral and the fission spectrum averaged cross
C-M  section. All information is written onto an intermediate file,
C-M  defined from input (default name AVRFPY.FPY).
C-M    A record on the intermediate file contains the nuclide
C-M  identification, fission yield [fraction], half-life [s], thermal
C-M  cross section [barns], resonance integral [barns], reaction
C-M  fraction (defined as the product of the yield and the average
C-M  cross section) [barns], the number of decay modes (which is zero
C-M  for unknown or stable nuclides) and the capture branching ratio
C-M  for the metastable isomer (if present). For decaying nuclides,
C-M  additional records follow (one for each decay mode), giving the
C-M  decay mode, the branching ratio and the product nuclide. Various
C-M  decay modes are represented by the following symbols:
C-M    g - gamma decay,
C-M    b - beta decay,
C-M    + - positron emission,
C-M    I - isomeric transition,
C-M    a - alpha decay,
C-M    n - neutron emission,
C-M    F - fission,
C-M    p - proton emission.
C-M  In addition, the capture products are identified by the symbol
C-M  "c". These are treated only approximately, assuming that the
C-M  product is in the ground state, except for a few specific cases
C-M  such as Pm-147 where Pm-148 and Pm-148m are produced. The
C-M  branching ratio is built into the code because the appropriate
C-M  data (ENDF file 9 data) are seldom present.
C-M
C-M  The intermediate file which is produced can be processed to
C-M  print the data according to some specified selection criteria
C-M  or to compare the data from different intermediate files.
C-M  The following criteria are applicable:
C-M    EPU - Long decay rate threshold [barn.days] is the criterion
C-M          on the product of the half-life and the capture cross
C-M          section. Above this threshold the fission products
C-M          are treated as stable and their decay influences the
C-M          equillibrium concentration by less then a fraction EPS.
C-M          The EPU criterion depends on the neutron flux level FLUX.
C-M          It is given by:
C-M            EPU = (1.E24/(24*3600)) * DLOG(2) * EPS / FLX
C-M          Typical value: EPU=4.E8 [barn.days]
C-M          Assuming     : EPS=2E-3, FLUX=1E+13 [n/cm2/s]
C-M    EPD - Short decay rate threshold [barn.days] is the criterion
C-M          on the product of the half-life and the capture cross
C-M          section. Below this threshold the fission products
C-M          are very short-lived and their capture reaction rate
C-M          represents less than a fraction EPS of the fission rate.
C-M          The yields of nuclides which fall below this criterion
C-M          are added to their decay products.
C-M          Parameter EPD is given by:
C-M            EPD = (1.E24/(24*3600)) * DLOG(2) / (EPS*FLUX)
C-M          Typical value: EPD=1600 [barn.days]
C-M          Assuming     : EPS=2E-3, FLUX=1E+13 [n/cm2/s]
C-M    EPR - Reaction rate threshold [barns] is the criterion
C-M          on the product of the yield and the capture cross
C-M          section. Below this threshold the capture reaction rate
C-M          represents less than a fraction EPS of the fission rate
C-M          so the fission product is removed from the output
C-M          list. It depends on the neutron flux FLUX and the
C-M          fuel irradiation time TRES.
C-M          Parameter EPR is given by:
C-M            EPR=(2.E24/(24*3600))*(EPS/(FLUX*TRES)
C-M          Typical value: EPR=0.12 [barns]
C-M          Assuming     : EPS=0.5E-4, FLUX=1E+13 [n/cm2/s]
C-M                        ,TRES=1000 [days]
C-M    EPC - Capture product reaction rate threshold [barns**2] is the
C-M          criterion on the product of the yield, the capture cross
C-M          section of the parent nuclide and the capture cross
C-M          section of the capture product. Below this threshold the
C-M          capture reaction rate by the capture product represents
C-M          less than a fraction EPS of the fission rate. Capture
C-M          products, which pass this test, are added to the list
C-M          of nuclides for printout even if their cumulative yield
C-M          from fission is small. The EPC criterion depends on the
C-M          neutron flux FLUX and the fuel irradiation time TRES.
C-M          It is givn by:
C-M            EPC=(6.E48/(24*3600)**2)*(EPS/(FLUX*TRES)**2)
C-M          Typical value: EPC=400 [barns**2]
C-M          Assuming     : EPS=0.5E-4, FLUX=1E+13 [n/cm2/s]
C-M                        ,TRES=1000 [days]
C-M    EPY - lower fission yield threshold [%] to suppress printout
C-M          of the fission product data with low yields.
C-M          Typical value: 0.5%. (See also the EPR criterion).
C-M    EPX - lower cross section threshold [barns] to suppress the
C-M          printout of the fission products with unknown or zero
C-M          cross sections. Typical value: 100 barns. (See also
C-M          the EPR criterion).
C-M
C-M  NOTE: cumulative yields are calculated automatically in the
C-M  case when the independent yields are processed from the source
C-M  ENDF file.
C-M
C-M  AVERAGING SPECTRUM: is required to interpret the cross sections
C-M  and the weighting function for the fission product yields. It
C-M  is defined in three broad groups:
C-M    1  1.E-5 eV  to  5.5 eV
C-M    2  5.5 eV    to  0.1 MeV
C-M    3  0.1 MeV   to  10. MeV
C-M  In group-2 the spectrum is assumed to have a "1/E" shape. The
C-M  average thermal spectrum is given in terms of the spectral
C-M  ratio SPR, defined as the ratio of the spectrum integral in
C-M  groups-2 and -3 to that in group-1. Parameter SPR=2.78 is
C-M  fixed and defined in the DATA statement. Similarly, the fast
C-M  spectrum is given in terms of the ratio of the epithermal to
C-M  fast flux EFR and is defined as the ratio of the spectrum
C-M  integral in group-2 to that in group-3. Parameter EFR=0.928
C-M  is fixed and defined in the DATA statement.
C-M
C-M    The fission product yields must be averaged by the fission
C-M  reaction rate. Since the yields are usually given on a very
C-M  coarse energy grid, a crude approximation to the weighting
C-M  function is adequate. For the parent fissile nucleus the
C-M  thermal cross section, the resonance integral and the fission
C-M  spectrum averaged cross section are read crom the INTER output
C-M  fule. The averaging spectrum is calculated at the coarse group
C-M  energy boundaries defined above, such that the integrals are
C-M  conserved assuming log-log interpolation (the log-log
C-M  interpolation rule is chosen to reproduce correctly the 1/E
C-M  behaviour in the epithermal range). Similarly, the cross
C-M  sections are calculated at the same energy points. The cross
C-M  section at the thermal to epithermal boundary is calculated
C-M  by the log-log interpolation from the 2200 m/s value (assuming
C-M  a 1/v behaviour in the thermal range) and the epithermal
C-M  average cross section at the average energy. When the fission
C-M  product yields are energy-dependent, histogram interpolation
C-M  is assumed, although in principle the interpolation flag is
C-M  given in the file.
C-M
C-M  Instructions:
C-M  -------------
C-M  Data are processed in two steps. In the first one the basic
C-M  files are processed and the intermediate file is written.
C-M  In the second step the intermediate file is processed. The
C-M  printout criteria are defined and the main output files are
C-M  written.
C-M
C-M  Input Intermediate file:
C-M  By default, program proceeds from step two, requesting the
C-M  name of the intermediate file to be processed. Responding
C-M  with "-" for the filename results in processing the basic
C-M  files to produce a new intermediate file on output.
C-M
C-M  Input Data Files:
C-M  To generate a new intermediate file, the filenames and other
C-M  relevant information is requested as follows:
C-M  - FLDY Decay data ENDF file. This file is mandatory.
C-M  - FLNI Fission product yields ENDF file. If blank is entered,
C-M    the selected nuclides are expected from a list file
C-M    (see below).
C-M  - MAT Material number of the parent fissile nuclide for
C-M    which the fission product yields are processed. If blank
C-M    is entered, selection is done through the ZA entry.
C-M  - ZA Parent fissile nuclide designation (ZA=1000*Z+A). This
C-M    is an alternative input to the MAT entry, described above.
C-M  - MT Fission yields reaction number: MT=454 for the independent
C-M    yields and MT=459 for cumulative yields. If independent
C-M    yields are selected, they are summed internally to calculate
C-M    the cumulative yields.
C-M  - EPU Long decay rate threshold [barn.days]. This entry
C-M    request appears only when independent fission product yields
C-M    are to be processed (see also the nuclide selection
C-M    parameters description).
C-M    Typical value: EPU=8.E7 [barn.days]
C-M    Assuming     : EPS=1E-4, FLUX=1E+13 [n/cm2/s]
C-M  - FLLS nuclide list filename, defined when fission product
C-M    yields are not processed. The first  record of this list
C-M    file is a comment header, followed by a list of nuclides
C-M    defined by their ZA value in columns 1-11, one nuclide per
C-M    record, until a blank line or an end-of-file is encountered.
C-M  - FLXS Filename of the INTER output from which the thermal cross
C-M    section, the resonance integral and the fission spectrum
C-M    average cross sections are read. A variant of the format
C-M    is recognised in which the ZA designation has an additional
C-M    decimal digit to identify the metastable isomers. If blank
C-M    name is entered, cross section processing is suppressed.
C-M  - MTX the relevant MT number for the cross sections is specified.
C-M    By default, MTX=102 for radiative capture is assumed.
C-M
C-M  Output files:
C-M  The following user defined output files are defined:
C-M  - FLYI Filename of the intermediate file (default AVRFPY.FPY).
C-M    The request is issued only when a new file is generated.
C-M  - FLNO Main output filename. The file contains the fission yields,
C-M    decay constants and other data for the selected list of
C-M    nuclides. The output is suppressed if "-" is entered.
C-M  - FLYA Auxiliary output filename. The information is the same
C-M    as in the main output filename, except that it is
C-M    intended for reading by the program (default AUXFPY.FPY).
C-M    The output is suppressed if "-" is entered.
C-M  In addition, the log file AVRFPY.LOG is opened unconditionally.
C-M  All error and warning messages are recorded there.
C-M
C-M  Nuclide selection criteria:
C-M  Nuclides to appear on the output can be selected by
C-M  specifying the list of requested nuclides. In this case the
C-M  input request is:
C-M  - FLLS Filename of the nuclide list file. The first
C-M    record of this list file is a comment header, followed by
C-M    a list of nuclides defined by their ZA value in columns
C-M    1-11, one nuclide per record, until a blank line or an
C-M    end-of-file is encountered.
C-M  Alternatively, a set of selection criteria can be
C-M  specified:
C-M  - EPU Long decay rate threshold [barn.days]. This entry
C-M    request appears unless it has been defined when specifying
C-M    the request to process independent fiss.prod. yields.
C-M    Typical value: EPU=8.E7 [barn.days]
C-M    Assuming     : EPS=1E-4, FLUX=1E+13 [n/cm2/s]
C-M  - EPD Short decay rate threshold [barn.days]
C-M    Typical value: EPD=8000 [barn.days]
C-M    Assuming     : EPS=1E-4, FLUX=1E+13 [n/cm2/s]
C-M  - EPR Reaction rate threshold [barns]
C-M    Typical value: EPR=0.25 [barns]
C-M    Assuming     : EPS=1E-4, FLUX=1E+13 [n/cm2/s]
C-M                  ,TRES=1000 [days]
C-M  - EPC Capture product reaction rate threshold [barns**2]
C-M    Typical value: EPC=800 [barns**2]
C-M    Assuming     : EPS=1E-4, FLUX=1E+13 [n/cm2/s]
C-M                        ,TRES=1000 [days]
C-M  - EPY lower fission yield threshold [%]
C-M    Typical value: 0.1%. (See also the EPR criterion).
C-M  - EPX lower cross section threshold [barns]
C-M    Typical value: 100 barns. (See also the EPR criterion).
C-M
C-References:
C-R [1] A.Trkov: Processing of the Fission Product Yield and Decay
C-R     Data, Institite J.Stefan, Ljubljana, Slovenia,
C-R     IJS-DP-draft, (1998).
C-R [2] R.W.Mills: Recommendation for the Use of Energy Dependent
C-R     JEF-2.2 Fission Product Yields, BNFL Sellafield,
C-R     OECD/NEA Data Bank, JEF/DOC-629.
C-
      implicit real*8 (a-h,o-z)
      PARAMETER   (MXFP=5000, MXDK=4, MXST=10)
      CHARACTER*1  CHD, RC(10), FLAG(MXFP), CHR1(MXDK,MXFP)
      CHARACTER*2  MX(10)
      CHARACTER*2  CH2,CS(100)
      CHARACTER*40 BLNK,FLNM,FLNI,FLXS,FLDY,FLNO,FLYA,FLYI,FLOG
     1            ,FLWI,FLNJ,FLLS
      CHARACTER*80 REC
      DIMENSION    EGB (4),    FRR (4),    FIN (4),  FAV(4)
     1            ,ZAP (MXFP), YLD (MXFP), HLF (MXFP),ZAC(MXFP)
     2            ,PAR1(MXFP), PAR2(MXFP), PAR3(MXFP), IPAR(MXFP)
     3            ,PAR4(MXDK,MXFP),        PAR5(MXDK,MXFP)
     4            ,PAR6(MXFP), PAR7(MXFP), PAR8(MXFP)
     5            ,AMT (MXFP), YDDP(MXST), NDDP(MXST) ,NDDK(MXST)
      DATA  LIN,LDY,LXS,LOU,LKB,LTT,LER,LYA,LYI,LWI,LNJ
     1     /  1,  2,  3,  4,  5,  6,  7,  8,  9, 16, 17 /
      DATA  BLNK/'                                        '/
     1      FLNI/'FPYLD.DAT'/
     2      FLDY/'DECAY.DAT'/
     3      FLXS/'INTER.OUT'/
     4      FLNO/'AVRFPY.OUT'/
     7      FLOG/'AVRFPY.LOG'/
     8      FLYA/'AVRFPY.AUX'/
     9      FLYI/'AVRFPY.FPY'/
     6      FLWI/'AVRFPY.WIM'/
      DATA MX/'  ','M ','M2','M3','M4','M5','M6','M7','M8','Mn'/
      DATA CS/   'H ','He','Li','Be','B ','C ','N ','O ','F ','Ne',
     1 'Na','Mg','Al','Si','P ','S ','Cl','Ar','K ','Ca','Sc','Ti',
     2 'V ','Cr','Mn','Fe','Co','Ni','Cu','Zn','Ga','Ge','As','Se',
     3 'Br','Kr','Rb','Sr','Y ','Zr','Nb','Mo','Tc','Ru','Rh','Pd',
     4 'Ag','Cd','In','Sn','Sb','Te','I ','Xe','Cs','Ba','La','Ce',
     5 'Pr','Nd','Pm','Sm','Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb',
     6 'Pr','Hf','Ta','W ','Re','Os','Ir','Pt','Au','Hg','Tl','Pb',
     7 'Bi','Po','At','Rn','Fr','Ra','Ac','Th','Pa','U ','Np','Pu',
     8 'Am','Cm','Bk','Cf','Es','Fm'/
C* Upper removal threshold [barn.days] identifying stable nuclides
      DATA EPU/0/
C* Thermal, epithermal and fast group boundaries and average flux
      DATA EGB/ 1.E-5, 0.55, 1.E+5, 1.E+7 /
C* Define group flux integrals with respect to the epithermal flux
      DATA SPR,EFR/ 5.785, 0.9279 /
      FIN(2)= DLOG(EGB(3)/EGB(2))
      FIN(3)= FIN(2)/EFR
      FIN(1)=(FIN(2)+FIN(3))/SPR
      IFPY=0
C*
C* Write banner to terminal screen
      WRITE(LTT,891)
C* Open the log file
      OPEN (UNIT=LER,FILE=FLOG,STATUS='UNKNOWN')
      WRITE(LER,891)
C*
C* Analyse a processed F.P. yields file or generate a new one
    1 WRITE(LTT,692) ' Define or select F.P. parameters file  '
      WRITE(LTT,692) ' -------------------------------------  '
      WRITE(LTT,692)
      WRITE(LTT,692) ' Default F.P.param.file to be processed:',FLYI
      WRITE(LTT,692) '        Enter new name to redefine    or'
      WRITE(LTT,692) '$       Enter "-" to generate new file: '
      READ (LKB,692) FLNM
      IYI=0
      IF(FLNM(1:1).EQ.'-') GO TO 20
      IF(FLNM.NE.BLNK) FLYI=FLNM
      OPEN (UNIT=LYI,FILE=FLYI,STATUS='OLD',ERR=1)
C* Read the processed yields file
      WRITE(LTT,692)
      WRITE(LTT,692) ' Reading F.P. parameters file         : ',FLYI
C*
      READ (LYI,692) FLNM,FLNI
      READ (LYI,692) FLNM,FLDY
      READ (LYI,692) FLNM,FLXS
      READ (LYI,803) FLNM,MT0
      READ (LYI,803) FLNM,MTX
      READ (LYI,804) FLNM,FIN1
      READ (LYI,804) FLNM,FIN2
      READ (LYI,804) FLNM,FIN3
      READ (LYI,803) FLNM,MAT
      READ (LYI,804) FLNM,ZA
      READ (LYI,803) FLNM,NFP
      READ (LYI,802) FLNM,EPU
      READ (LYI,803) FLNM
      IF(FIN1.NE.0) FIN(1)=FIN1
      IF(FIN2.NE.0) FIN(2)=FIN2
      IF(FIN3.NE.0) FIN(3)=FIN3
      DO 3 I=1,NFP
        READ (LYI,874)
     1   ZAP(I),YLD(I),HLF(I),PAR1(I),PAR2(I),PAR3(I)
     1  ,IPAR(I),PAR6(I),ZAC(I)
        AMT(I)=ZAP(I)
        NDK=MIN(MXDK,IPAR(I))
        IF(NDK.LE.0) GO TO 3
        DO 2 J=1,NDK
          READ (LYI,875) CHR1(J,I),PAR4(J,I),PAR5(J,I)
    2   CONTINUE
    3 CONTINUE
      CLOSE(UNIT=LYI)
      IYI=1
      IF(MT0.GT.0) IFPY=1
C*
C* Define the output list file
    4 WRITE(LTT,692)
      WRITE(LTT,692) ' Define the output files                '
      WRITE(LTT,692) ' -----------------------                '
      WRITE(LTT,692)
      WRITE(LTT,692) ' Default output list filename         : ',FLNO
      WRITE(LTT,692) '$       Enter new name or "-" to quit : '
      READ (LKB,692) FLNM
      IF(FLNM(1:1).EQ.'-') GO TO 90
      IF(FLNM.NE.BLNK) FLNO=FLNM
      OPEN (UNIT=LOU,FILE=FLNO,STATUS='UNKNOWN')
C*
C* Auxilliary processed F.P. yields file
    5 WRITE(LTT,692) ' Short F.P. parameters filename       : ',FLYA
      WRITE(LTT,692) '$     Enter new name or "-" to ignore : '
      READ (LKB,692) FLNM
      IYA=0
      IF(FLNM(1:1).NE.'-') THEN
        IF(FLNM.NE.BLNK) FLYA=FLNM
        WRITE(LTT,692) '               Compare reference file : ',FLYI
        WRITE(LTT,692) '                                 to   : ',FLYA
        WRITE(LTT,692) '$                             (y=Yes) : '
        READ (LKB,692) FLNM
        IF(FLNM(1:1).EQ.'y' .OR. FLNM(1:1).EQ.'Y') THEN
          LYC=ABS(LYC)
          OPEN (UNIT=LYC,FILE=FLYA,STATUS='OLD',ERR=5)
          GO TO 80
        END IF
C        WRITE(LTT,692) '$            Write a new file (y=Yes) : '
C        READ (LKB,692) FLNM
C        IF(FLNM(1:1).NE.'y' .AND. FLNM(1:1).NE.'Y') GO TO 5
        LYA=ABS(LYI)
        OPEN (UNIT=LYA,FILE=FLYA,STATUS='UNKNOWN',ERR=5)
        IYA=1
      END IF
C*
C* Define the thresholds for printout
      IF(MT0.NE.0) THEN
        WRITE(LTT,692)
        WRITE(LTT,692) ' Define nuclide selection criteria      '
        WRITE(LTT,692) ' ---------------------------------      '
        WRITE(LTT,692)
C*
    6   WRITE(LTT,692) '$Enter nuclide list file/blank=ignore : '
        READ (LKB,692) FLLS
        ILST=0
        IF(FLLS.EQ.BLNK) GO TO 16
C* Read the list of nuclides from a file
        OPEN (UNIT=LIN,FILE=FLLS,STATUS='OLD',ERR=21)
        READ (LIN,692,END=20) FLNM
        WRITE(LTT,692) '                  Nuclide list header : ',FLNM
        ILST=1
        DO I=1,NFP
          FLAG(I)='L'
        END DO
    8   READ (LIN,692,END=12) FLNM
        IF(FLNM.EQ.BLNK) GO TO 12
        READ (FLNM,694) ZAPI,AMTI
        IF(AMTI.EQ.0) AMTI=ZAPI
        DO 9 I=1,NFP
          IF(NINT(10.*ZAP(I)).NE.NINT(10.*ZAPI)) GO TO 9
          FLAG(I)='9'
          AMT (I)=AMTI
          GO TO 8
    9   CONTINUE
        WRITE(LTT,806) ' AVRFPY WARNING - No fiss. prod.  ZA  : '
     1                ,IDINT(ZAPI)
        GO TO 8
   12   CLOSE(UNIT=LIN)
        GO TO 19
C* Define nuclide selection criteria explicitly
   16   WRITE(LTT,692)
        WRITE(LTT,692) ' Enter main printout selection criteria '
        WRITE(LTT,692) ' -------------------------------------- '
        WRITE(LTT,692)
        IF(EPU.LE.0) THEN
          WRITE(LTT,692) '$Long  decay rate thresh. [barn.days] : '
          READ (LKB,694,ERR=16) EPU
        END IF
        WRITE(LTT,692) '$Short decay rate thresh. [barn.days] : '
        READ (LKB,694,ERR=16) EPD
        WRITE(LTT,692) '$Reaction rate thresh. [barns]        : '
        READ (LKB,694,ERR=16) EPR
        WRITE(LTT,692) '$Capt.Prod.Reac.rate thresh.[barns**2]: '
        READ (LKB,694,ERR=16) EPC
C*
   17   WRITE(LTT,692)
        WRITE(LTT,692) ' Auxiliary  printout selection criteria '
        WRITE(LTT,692)
        WRITE(LTT,692) '$Enter fission yield threshold   [%]  : '
        READ (LKB,694,ERR=17) EPY
        WRITE(LTT,692) '$Enter cross sect. threshold  [barns] : '
        READ (LKB,694,ERR=17) EPX
      END IF
   19 IF(IYA.NE.1) GO TO 60
C*
C* Write the auxiliary file
      WRITE(LYA,692) ' Fission product yields ENDF file     : ',FLNI
      WRITE(LYA,692) ' Decay data ENDF file                 : ',FLDY
      WRITE(LYA,692) ' INTER output file processed          : ',FLXS
      WRITE(LYA,803) ' Fission product yields             MT: ',MT0
      WRITE(LYA,803) ' Cross sections for reaction        MT: ',MTX
      WRITE(LYA,804) ' Thermal flux integral                : ',FIN(1)
      WRITE(LYA,804) ' Epithermal flux integral             : ',FIN(2)
      WRITE(LYA,804) ' Fast flux integral                   : ',FIN(3)
      WRITE(LYA,803) ' Fissile parent MAT number            : ',MAT
      WRITE(LYA,804) '                ZA  designation       : ',ZA
C     WRITE(LYA,803) ' Number of fission product nuclides   : ',NFP
      GO TO 60
C*
C* Define the F.P. yields ENDF file to be processed
   20 WRITE(LTT,692) ' Define ENDF files to generate F.P.param'
      WRITE(LTT,692) ' ---------------------------------------'
      WRITE(LTT,692)
      IDE=0
      WRITE(LTT,692) '$Enter Decay data file/blank to ignore: '
      READ (LKB,692)   FLDY
      IF(FLDY.NE.BLNK)
     1OPEN (UNIT=LDY,FILE=FLDY,STATUS='OLD',ERR=20)
      IDE=1
   21 WRITE(LTT,692) '$Enter F.P.yields file/blank to ignore: '
      READ (LKB,692) FLNI
      IF(FLNI.NE.BLNK) THEN
C*
C* Case: Fission products yield ENDF file specified
      OPEN (UNIT=LIN,FILE=FLNI,STATUS='OLD',ERR=21)
C* Select the material number and reaction type
   22 WRITE(LTT,692) ' Select parent fissile nuclide MAT/ZA   '
      WRITE(LTT,692) '$      Enter MAT or zero to select ZA : '
      READ (LKB,693,ERR=22) MAT
      IF(MAT.LE.0) THEN
   23   WRITE(LTT,692) '$                  Enter ZA =1000*Z+A : '
        READ (LKB,694,ERR=23) ZA
      ELSE
C* Extract the ZA value from the F.P. Yields file
   26   READ (LIN,812) REC,MM
        IF(MM.LT.0) STOP 'AVRFPY ERROR - Material not in FPY file'
        IF(MM.NE.MAT) GO TO 26
        READ (REC,814) ZA
        READ (LIN,812) REC
        READ (REC,814) DMY,DMY,DMY,ZA1
        ZA=ZA+0.1*ZA1
        REWIND LIN
      END IF
   24 WRITE(LTT,692) '$Enter the  MT number (454 OR 459)    : '
      READ (LKB,693,ERR=24) MT0
      IFPY=1
      IF(MT0.LE.0) GO TO 34
      IF(MT0.EQ.454) THEN
   25 WRITE(LTT,692) '$Long  decay rate thresh. [barn.days] : '
      READ (LKB,694,ERR=25) EPU
      END IF
      IF(MT0.NE.454 .AND. MT0.NE.459) GO TO 24
      ELSE
C*
C* Case: Nuclide list specified
      WRITE(LTT,692) '$Enter nuclide selection list file    : '
      READ (LKB,692) FLLS
      IF(FLLS.EQ.BLNK) GO TO 21
      OPEN (UNIT=LIN,FILE=FLLS,STATUS='OLD',ERR=21)
      READ (LIN,692,END=20) FLNM
      WRITE(LTT,692) '                  Nuclide list header : ',FLNM
      IFPY=0
      NFP =0
   27 READ (LIN,692,END=28) FLNM
      IF(FLNM.EQ.BLNK) GO TO 28
      NFP=NFP+1
      READ (FLNM,694) ZAP(NFP)
      YLD(NFP)=0.
      FLAG(NFP)='9'
      GO TO 27
   28 CLOSE(UNIT=LIN)
      END IF
C*
C* Define the cross sections file (INTER output)
   34 MTX=0
      WRITE(LTT,692) '$Enter INTER output /blank to ignore  : '
      READ (LKB,692)   FLXS
      IF(FLXS.NE.BLNK) THEN
      OPEN (UNIT=LXS,FILE=FLXS,STATUS='OLD',ERR=34)
C* Define the reaction type number MT
   35 WRITE(LTT,692) ' Default reaction is Capture (MT=102)   '
      WRITE(LTT,692) '$            Enter new MT to redefine : '
      READ (LKB,693,ERR=35) MT
      MTX=102
      IF(MT.NE.0) MTX=MT
      END IF
C*
C* Define the filename to store the processed F.P. yields
   36 WRITE(LTT,692) ' Processed F.P. parameters output file: ',FLYI
      WRITE(LTT,692) '$           Enter new name to redefine: '
      READ (LKB,692) FLNM
      IF(FLNM.NE.BLNK) FLYI=FLNM
      OPEN (UNIT=LYI,FILE=FLYI,STATUS='UNKNOWN')
C* Label the Log-file
      WRITE(LER,692) ' Decay data ENDF file                 : ',FLDY
      IF(IFPY.EQ.1) THEN
      WRITE(LER,692) ' Fission product yields ENDF file     : ',FLNI
      WRITE(LER,803) ' Fission product yields             MT: ',MT0
      WRITE(LER,892) MAT,IDINT(ZA+0.1)
      ELSE
      WRITE(LER,692) ' Fission product list file            : ',FLLS
      END IF
      WRITE(LER,692)
C*
C* Define the weighting function for the F.P yields
      FF=0.
      DO 37 IG=1,3
      FAV(IG)=FIN(IG)
      FRR(IG)=0.
      FF=FF+FAV(IG)
   37 CONTINUE
      FRR( 4)=0.
      FRR( 2)=(1./EGB(2))*FIN(2)/DLOG(EGB(3)/EGB(2))
      IF(MTX.LE.0 .OR. IFPY.LE.0) GO TO 38
C* If cross sections file is given, find the fissile parent fiss.x-sect.
      CALL REACRT(LXS,LER,18,1,ZA,FTH,FRI,FFS ,IER)
      REWIND LXS
      IF(IER.LT.0) THEN
        WRITE(LER,883) MAT,ZA
        WRITE(LTT,883) MAT,ZA
      ELSE
        FAV(1)=FAV(1)*FTH
        FAV(2)=FAV(2)*FRI/FIN(2)
        FAV(3)=FAV(3)*FFS
        FF    =FAV(1)+FAV(2)+FAV(3)
        xfct=(2.d0/DSQRT(3.1415926d0))
        FRR(2)=FRR(2)*FTH*xfct*DSQRT(0.0253d0/EGB(2))
        IF(FTH.LE.0) FRR(3)=FAV(3)/(EGB(4)-EGB(3))
      END IF
C* Define other points log-log interpolable conserving the integrals
   38 CALL FLXPNT(3,EGB,FRR,FAV,IER)
      WRITE(LER,881)
      DO 39 I=1,4
      WRITE(LER,882) EGB(I),FRR(I)/FF
   39 CONTINUE
      WRITE(LER,692)
C*
C* Begin processing the data
      IF(IFPY.NE.1) GO TO 41
      MT =MT0
C* Process the fission products yields data
      CALL FPRYLD(LIN,LER,MAT,MT,ZA,NFP,ZAP,YLD
     1           ,PAR1,PAR2,PAR3,PAR4,PAR5 ,EGB,FRR ,MXFP,IER)
      IF(IER.GT.0) THEN
        WRITE(LTT,692) ' ERROR reading file                     ',FLNI
        GO TO 90
      END IF
      WRITE(LTT,892) MAT,IDINT(ZA+0.1)
C*
   41 CLOSE(UNIT=LIN)
C* Assign thermal x-sect. and res.int. to the list of F.P. nuclides
      DO 42 I=1,NFP
      PAR1(I)=0.
      PAR2(I)=0.
      PAR3(I)=0.
   42 CONTINUE
      IF(MTX.GT.0) CALL REACRT(LXS,LER,MTX,NFP,ZAP,PAR1,PAR2,PAR3 ,IER)
      IF(IER.NE.0) WRITE(LTT,896) IER
      CLOSE(UNIT=LXS)
C* Assign the decay data to the list of F.P. nuclides
      DO 44 I=1,NFP
      HLF (I)=0.
      IPAR(I)=0
   44 CONTINUE
      IF(IDE.GT.0) CALL DECYMD(LDY,LER,NFP,ZAP,HLF,IPAR
     1                        ,MXDK,CHR1,PAR4,PAR5 ,IER)
C* Assign capture product branching ratio for the isomer
      CALL CAPBRR(NFP,ZAP,PAR6)
C* Save the results
      WRITE(LYI,692) ' Fission product yields ENDF file     : ',FLNI
      WRITE(LYI,692) ' Decay data ENDF file                 : ',FLDY
      WRITE(LYI,692) ' INTER output file processed          : ',FLXS
      WRITE(LYI,803) ' Fission product yields             MT: ',MT0
      WRITE(LYI,803) ' Cross sections for reaction        MT: ',MTX
      WRITE(LYI,804) ' Thermal flux integral                : ',FIN(1)
      WRITE(LYI,804) ' Epithermal flux integral             : ',FIN(2)
      WRITE(LYI,804) ' Fast flux integral                   : ',FIN(3)
      WRITE(LYI,803) ' Fissile parent MAT number            : ',MAT
      WRITE(LYI,804) '                ZA  designation       : ',ZA
      WRITE(LYI,803) ' Number of fission product nuclides   : ',NFP
      WRITE(LYI,802) ' Long decay rate threshold [barn.days]: ',EPU
      WRITE(LYI,692) '        ZA     yield    T(1/2)      Sig0'
     1              ,'      R.I.        RR D      B.R.        '
      DO 48 I=1,NFP
C* Special print sequence for an extra digit in yield
c     REC=BLNK//BLNK
c     WRITE(REC,874)
c    1 ZAP(I),YLD(I),HLF(I),PAR1(I),PAR2(I),PAR3(I)
C    1,IPAR(I),PAR6(I),ZAC(I)
c     REC(12:17)=REC(11:16)
c     REC(11:11)=' '
c     WRITE(LYI,691) REC
      WRITE(LYI,874)
     1 ZAP(I),YLD(I),HLF(I),PAR1(I),PAR2(I),PAR3(I)
     1,IPAR(I),PAR6(I),ZAC(I)
C*
      NDK=MIN(MXDK,IPAR(I))
      IF(NDK.LE.0) GO TO 48
      DO 47 J=1,NDK
      WRITE(LYI,875) CHR1(J,I),PAR4(J,I),PAR5(J,I)
   47 CONTINUE
   48 CONTINUE
      CLOSE(UNIT=LYI)
      GO TO 4
C*
C* Write the results to output - label the output file
   60 WRITE(LOU,891)
      WRITE(LOU,692) ' Fission product yields ENDF file     : ',FLNI
      WRITE(LOU,692) ' Decay data ENDF file                 : ',FLDY
      WRITE(LOU,692) ' INTER output file processed          : ',FLXS
      WRITE(LOU,692)
      IF(MT0.EQ.454)
     1WRITE(LOU,803) ' Independent fission product yields MT: ',MT0
      IF(MT0.EQ.459)
     1WRITE(LOU,803) ' Cumulative fission product yields  MT: ',MT0
      IF(MTX.NE.0)
     1WRITE(LOU,803) ' Cross sections for reaction        MT: ',MTX
      WRITE(LOU,804) ' Epith.+Fast/thermal spectral ratio   : '
     1              ,(FIN(2)+FIN(3))/FIN(1)
      WRITE(LOU,804) ' Epithermal/fast spectral ratio       : '
     1              , FIN(2) / FIN(3)
      WRITE(LOU,692)
      WRITE(LOU,692) ' Reactions imply the fraction of reactio'
     1              ,'n rates on the specific fission product '
     2              ,' per unit flux (reaction=yield*aver.cros'
     2              ,'s-section).                             '
C*
      IF(ILST.EQ.1) THEN
        WRITE(LOU,692)
        WRITE(LOU,692) ' Nuclide list read from file          : ',FLLS
      ELSE
        IPU=EPU
        WRITE(LOU,692)
        WRITE(LOU,804) ' Printout constraint thresholds:        '
        IF(EPU.GT.0)
     1  WRITE(LOU,806) '   Long  decay rate thresh.[barn.days] :',IPU
        IF(EPD.GT.0)
     1  WRITE(LOU,804) '   Short decay rate thresh.[barn.days] :',EPD
        IF(EPR.GT.0)
     1  WRITE(LOU,804) '   Reaction rate thresh.       [barns] :',EPR
        IF(EPC.GT.0)
     1  WRITE(LOU,804) '   Capt.Prod.Reac.Rate thr. [barns**2] :',EPC
        IF(EPY.GT.0)
     1  WRITE(LOU,804) '   Fission product yield           [%] :',EPY
        IF(EPX.GT.0)
     1  WRITE(LOU,804) '   Cross sections(th,epith,av) [barns] :',EPX
      END IF
C*
      WRITE(LOU,892) MAT,IDINT(ZA+0.1)
      WRITE(LOU,893)
C* Label the Log-file
      WRITE(LER,692) ' Fission product yields ENDF file     : ',FLNI
      WRITE(LER,692) ' Decay data ENDF file                 : ',FLDY
      WRITE(LER,803) ' Fission product yields             MT: ',MT0
      WRITE(LER,892) MAT,IDINT(ZA+0.1)
      WRITE(LER,692)
C* Check the internal consistency of the cumulative yields data
      IF(MT0.EQ.459)
     1  CALL CHKCUM(LER,NFP,EPU,ZAP,YLD,HLF,PAR1,PAR2,PAR3,IPAR
     1             ,MXDK,PAR4,PAR5,CHR1,FIN)
C* Calculate cumulative yields if independent yields are given
      EPUC=EPU
      IF(MT0.EQ.454) THEN
        CALL YLDCUM(LER,NFP,EPU,ZAP,YLD,HLF,PAR1,PAR2,PAR3,IPAR
     1             ,MXDK,PAR4,PAR5,PAR7,PAR8,FIN)
        EPUC=0.
      END IF
C* Check the printout criteria
      IF(IFPY.EQ.1 .AND. ILST.EQ.0)
     1CALL CHKFPY(LER,NFP,ZAP,YLD,HLF,PAR1,PAR2,PAR3,IPAR,MXDK
     1           ,PAR4,PAR5,PAR6,FLAG,EPY,EPX,EPR,EPD,EPUC,EPC,FIN)
C* Loop over all fission product niclides
      NMT=0
      DO I=1,NFP
        IF(FLAG(I).LE.'9') NMT=NMT+1
      END DO
      IF(IYA.GT.0) THEN
        WRITE(LYA,803) ' Number of fission product nuclides   : ',NMT
        WRITE(LYA,692) '        ZA     yield    T(1/2)      Sig0'
     1                ,'      R.I.        RR D      B.R.        '
      END IF
      FPT=0.
      RRT=0.
      DO 65 I=1,NFP
      IF(FLAG(I).GT.'9') GO TO 65
      IZA=ZAP(I)+0.01
      IZ =IZA/1000
      IA =IZA-1000*IZ
      MM=MIN(10., 10.*(ZAP(I)-FLOAT(IZA))+1.01)
      YI =YLD(I)*100.
      XF =PAR3(I)
      RI =PAR2(I)
      XT =PAR1(I)
      XE =RI/FIN(2)
      XA =XSAV3G(XT,XE,XF,FIN)
      XX =MAX(XT,XE,XF,XA)
      RR =YLD(I)*XA
      HL =HLF(I)
C* Decay constant
      DC =0.
      IF(HL.GT.0) DC=DLOG(2.d0)/HL
C* Half-life in days
      HD =HL/(24.*3600)
      ND =IPAR(I)
C* Chemical symbol
        CH2='  '
        IF(IZ.GT.0 .AND. (IA.EQ.0 .OR. IA.LE.3*IZ)) CH2=CS(IZ)
C* Print record to output  (check Format 893)
      WRITE(LOU,894) IZ,CH2,IA,MX(MM),YI,XT,NINT(RI),RR,DC,FLAG(I)
C     WRITE(LOU,894) IZ,CH2,IA,MX(MM),YI,XT,NINT(RI),RR,HL,FLAG(I)
C     WRITE(LOU,894) IZ,CH2,IA,MX(MM),YI,XT,NINT(RI),RR,HD,FLAG(I)
C* Print the capture product when present in the ZAC field
      IF(ZAC(I).GT.0 .AND. PAR6(I).GT.-1.) THEN
        IZC=ZAC(I)/1000.
        IAC=ZAC(I)-1000*IZC
        CH2='  '
        IF(IZC.GT.0 .AND. (IAC.EQ.0.OR.IAC.LE.3*IZC)) CH2=CS(IZC)
        WRITE(LOU,898) 'c',1.0-PAR6(I),IZC,CH2,IAC
      END IF
C* Print the capture product when the FLAG is set
      IF(FLAG(I).EQ.'3' .OR. FLAG(I).EQ.'5') THEN
        IA1=IA+1
        ZAC(I)=IZ*1000+IA1
        WRITE(LOU,898) 'c',1.0-PAR6(I),IZ,CH2,IA1
        IF(PAR6(I).NE.0)
     1  WRITE(LOU,898) 'c',    PAR6(I),IZ,CH2,IA1,MX(2)
      END IF
      IF(IYA.GT.0)
     1WRITE(LYA,874)
     1 ZAP(I),YLD(I),HLF(I),PAR1(I),PAR2(I),PAR3(I)
     1,IPAR(I),PAR6(I),ZAC(I)
      IF(ND.LT.1) GO TO 64
      DO 63 J=1,ND
      JZA=PAR5(J,I)
      JZ =JZA/1000
      JA =JZA-1000*JZ
      JM =MIN(10., 10.*(PAR5(J,I)-FLOAT(JZA))+1.01)
      CH2='  '
      IF(JZ.GT.0 .AND. (JA.EQ.0 .OR. JA.LE.3*JZ)) CH2=CS(JZ)
      WRITE(LOU,898) CHR1(J,I),PAR4(J,I),JZ,CH2,JA,MX(JM)
      IF(IYA.GT.0)
     1WRITE(LYA,875) CHR1(J,I),PAR4(J,I),PAR5(J,I)
   63 CONTINUE
   64 FPT=FPT+YI
      RRT=RRT+RR
   65 CONTINUE
      IF(IYA.GT.0) THEN
        CLOSE(UNIT=LYA)
        IYA=0
      END IF
C     IF(NMT.GT.0) WRITE(LOU,895) NMT,FPT,RRT
      IF(NMT.GT.0) WRITE(LOU,895) NMT
C* Write the yields for NJOY and in WIMS-D library format
      IF(FLWI.EQ.BLNK .OR. ZA.LE.0) GO TO 78
C* Subtract the yields from explicitly represented decay products
      DO 75 I=1,NFP
      IF(FLAG(I).LE.'0' .OR. FLAG(I).GT.'9') GO TO 75
      IF(IPAR(I).LE.0) GO TO 75
      K  =I
      JD =0
      YDI=YLD(K)
C* Next nuclide
   71 ND =IPAR(K)
      IF(ND.LE.0) GO TO 72
C*     Check for nearly stable nuclides
      XA =XSAV3G(PAR1(K),PAR2(K)/FIN(2),PAR3(K),FIN)
      HL =HLF(K)/(3600. * 24.)
      IF(XA.GT.0) HL=XA*HL
      IF(EPU.GT.0 .AND. HL.GT.EPU) GO TO 72
        IF (JD .GE. MXST) THEN
          WRITE(LTT,884) JD, ZAP(I)
          NDDP(JD)=0
          GO TO 72
        END IF
C* If decaying, increase level JD
        JD=JD+1
        NDDP(JD)=ND
        NDDK(JD)=K
        YDDP(JD)=YDI
C* NDDP contains No. of remaining decay products in level JD
   72 J =NDDP(JD)
      K =NDDK(JD)
      IF(J.LT.1) THEN
C* No more decay products in this level - decrease level
        JD=JD-1
        IF(JD.LT.1) GO TO 75
        GO TO 72
      END IF
      YDI=YDDP(JD)
      NDDP(JD)=J-1
C* Process the yield for this nuclide
      YDI=YDI*PAR4(J,K)
      ZAM=PAR5(J,K)
      CALL SRCIDX(NFP,ZAP,ZAM,KK)
      IF(ABS(ZAP(KK)-ZAM).GT.0.05) THEN
        WRITE(LTT,886) ZAM,YDI,PAR4(J,K)
        GO TO 72
      END IF
      K=KK
      IF(FLAG(K).GT.'0' .AND. FLAG(K).LE.'9') THEN
        YLD(K)=MAX(0., YLD(K)-YDI)
      END IF
      GO TO 71
   75 CONTINUE
      DO I=1,8
        PAR8(I)=0.
      END DO
      NP=8
      AMW=ZA
      DO 77 I=1,NFP
      IF(ABS(ZAP(I)-ZA).LT.0.01) AMW=AMT(I)
      IF(FLAG(I).LE.'0' .OR. FLAG(I).GT.'9') GO TO 77
      PAR8(NP+1)=YLD(I)
      PAR8(NP+2)=AMT(I)
      NP=NP+2
   77 CONTINUE
      ICH=1
      ISTOP=0
      FLNJ=BLNK
      DO WHILE (ISTOP.NE.1)
        IF(FLNO(ICH:ICH).NE.'.') THEN
          FLNJ(ICH:ICH)=FLNO(ICH:ICH)
          ICH=ICH+1
        ELSE IF (FLNO(ICH+1:ICH+1).EQ.'.') THEN
          FLNJ(ICH:ICH)=FLNO(ICH:ICH)
          ICH=ICH+1
          FLNJ(ICH:ICH)=FLNO(ICH:ICH)
          ICH=ICH+1
        ELSE
          ISTOP=1
          FLNJ(ICH:ICH)=FLNO(ICH:ICH)
          FLNJ(ICH+1:ICH+1)='N'
          FLNJ(ICH+2:ICH+2)='J'
          FLNJ(ICH+3:ICH+3)='B'
        ENDIF
        IF (ICH.GT.37) THEN
          FLNJ='AVRFPY.NJB'
          ISTOP=1
        ENDIF
      END DO
      OPEN (UNIT=LWI,FILE=FLWI,STATUS='UNKNOWN')
      PAR8(2)=AMW
      WRITE(LWI,809) NP
      WRITE(LWI,808) (PAR8(J),IDINT(PAR8(J+1)),J=1,NP,2)
      CLOSE(UNIT=LWI)
C* Write the fission product yields for NJOY input
      OPEN (UNIT=LNJ,FILE=FLNJ,STATUS='UNKNOWN')
      WRITE(LNJ,807) NP/2,0.
      WRITE(LNJ,807) (IDINT(PAR8(J+1)),PAR8(J),J=9,NP,2)
      CLOSE(UNIT=LNJ)
C*
C* Sort and list the rejected nuclides
   78 K=0
      DO 79 I=1,NFP
      IF(FLAG(I).LE.'9') GO TO 79
      K=K+1
      ZAP(K)=ZAP(I)
      FLAG(K)=FLAG(I)
   79 CONTINUE
      IF(K.GT.0) THEN
        WRITE(LER,688)
        WRITE(LER,689) (ZAP(I),FLAG(I),I=1,K)
      END IF
      WRITE(LTT,692)
      WRITE(LTT,803) ' Total number of fission products     : ',NFP
      WRITE(LTT,803) ' Number of nuclides printed           : ',NMT
      WRITE(LTT,803) ' Number of nuclides skipped           : ',K
      GO TO 90
C* Processed F.P. yields file comparison
   80 WRITE(LOU,891)
      WRITE(LOU,692)
      WRITE(LOU,692) ' REFERENCE data file                  : ',FLYI
      WRITE(LOU,692) ' COMPARED  data file                  : ',FLYA
      WRITE(LOU,692)
      WRITE(LOU,692) ' The reference data are quoted, followed'
     1              ,' by the compared data, expressed        '
      WRITE(LOU,692) ' as % difference where relevant.        '
      WRITE(LOU,692)
C*
      WRITE(LOU,692) ' Fission product yields ENDF file     : ',FLNI
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
      WRITE(LOU,692) ' Decay data ENDF file                 : ',FLDY
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
      WRITE(LOU,692) ' INTER output file processed          : ',FLXS
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
      WRITE(LOU,803) ' Fission product yields             MT: ',MT0
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
      WRITE(LOU,803) ' Cross sections for reaction        MT: ',MTX
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
      WRITE(LOU,804) ' Thermal flux integral                : ',FIN(1)
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
      WRITE(LOU,804) ' Epithermal flux integral             : ',FIN(2)
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
      WRITE(LOU,804) ' Fast flux integral                   : ',FIN(3)
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
      WRITE(LOU,803) ' Fissile parent MAT number            : ',MAT
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
      WRITE(LOU,804) '                ZA  designation       : ',ZA
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
      WRITE(LOU,803) ' Number of fission product nuclides   : ',NFP
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
C*
      WRITE(LOU,893)
      NDF=0
   82 READ (LYC,874,ERR=82,END=88)
     1 ZAPI,YLDI,HLFI,PAR1I,PAR2I,PAR3I,IPARI,PAR6I,ZACI
      IF(ZAPI.LE.0) GO TO 82
      CALL SRCIDX(NFP,ZAP,ZAPI,I)
      IF(ABS(ZAP(I)-ZAPI).GT.0.05) GO TO 82
      IZA=ZAP(I)+0.01
      IZ =IZA/1000
      IA =IZA-1000*IZ
      MM=MIN(10., 10.*(ZAP(I)-FLOAT(IZA))+1.01)
      YI =YLD(I)*100.
      XF =PAR3(I)
      RI =PAR2(I)
      XT =PAR1(I)
      XE =RI/FIN(2)
      XA =XSAV3G(XT,XE,XF,FIN)
      RR =YLD(I)*XA
      HL =HLF(I)
C* Decay constant
      DC =0.
      IF(HL.GT.0) DC=DLOG(2.d0)/HL
C* Half-life in days
      HD =HL/(24.*3600.)
C*
      CHD=' '
      IF(IPAR(I).NE.0) CHD='d'
C*
      WRITE(LOU,894) IZ,CS(IZ),IA,MX(MM),YI,XT,NINT(RI),RR,DC,CHD
C     WRITE(LOU,894) IZ,CS(IZ),IA,MX(MM),YI,XT,NINT(RI),RR,HL,CHD
C     WRITE(LOU,894) IZ,CS(IZ),IA,MX(MM),YI,XT,NINT(RI),RR,HD,CHD
      RRI=YLDI*XSAV3G(PAR1I,PAR2I/FIN(2),PAR3I,FIN)
      PYI=0.
      PXT=0.
      PRI=0.
      PRR=0.
      PHL=0.
      IF(YI.GT.0) PYI =100.*( YLDI/YLD(I)-1.)
      IF(XT.GT.0) PXT =100.*(PAR1I/XT    -1.)
      IF(RI.GT.0) PRI =100.*(PAR2I/RI    -1.)
      IF(RR.GT.0) PRR =100.*(  RRI/RR    -1.)
      IF(HL.GT.0) PHL =100.*( HLFI/HL    -1.)
C* Upper bound
      IF(PYI.GT. 9999.9) PYI = 9999.9
      IF(PXT.GT. 9999.9) PXT = 9999.9
      IF(PRI.GT. 9999.9) PRI = 9999.9
      IF(PRR.GT. 9999.9) PRR = 9999.9
      IF(PHL.GT. 9999.9) PHL = 9999.9
C* Lower bound
      IF(PYI.LT.-9999.9) PYI =-9999.9
      IF(PXT.LT.-9999.9) PXT =-9999.9
      IF(PRI.LT.-9999.9) PRI =-9999.9
      IF(PRR.LT.-9999.9) PRR =-9999.9
      IF(PHL.LT.-9999.9) PHL =-9999.9
C*
      PMX=MAX(ABS(PYI),ABS(PXT),ABS(PRI),ABS(PRR),ABS(PHL))
      CHD=' '
      IF(IPARI.NE.0) CHD='d'
      IF(PMX.GT.0.05) THEN
        WRITE(REC,897) PYI,PXT,PRI,PRR,PHL,CHD
        IF( YLDI.EQ.0 .OR. YLD(I).EQ.0) REC(12:20)='         '
        IF(PAR1I.EQ.0 .OR. XT    .EQ.0) REC(21:30)='          '
        IF(PAR2I.EQ.0 .OR. RI    .EQ.0) REC(31:40)='          '
        IF(  RRI.EQ.0 .OR. RR    .EQ.0) REC(41:50)='          '
        IF( HLFI.EQ.0 .OR. HL    .EQ.0) REC(51:60)='          '
        WRITE(LOU,691) REC
        NDF=NDF+1
      END IF
      DO 86 J=1,IPARI
      READ (LYC,875)
   86 CONTINUE
      GO TO 82
   88 WRITE(LOU,885) NDF
      CLOSE(UNIT=LOU)
      CLOSE(UNIT=LYC)
C* All data processed
   90 STOP 'AVRFPY Completed'
C*
  691 FORMAT(A80)
  692 FORMAT(2A40)
  693 FORMAT(BN,I11)
  694 FORMAT(BN,2F11.0)
  688 FORMAT(' List of rejected nuclides (ZA X) where X is the flag:'/
     1       '   U - nearly stable precursor'/
     2       '   Y - low yield'/
     3       '   X - small cross section'/
     4       '   R - small reaction rate (yield*cross-section)'/
     5       '   D - short decay time'/
     6       '   H - long-lived precursor of a stable nuclide'/
     7       '   S - small cross section of a stable nuclide'/
     8       '  ------------------------------------------------'
     8      ,'----------')
  689 FORMAT(5(F10.1,1X,A1))
  802 FORMAT(A40,1PE12.4)
  803 FORMAT(A40,I4)
  804 FORMAT(A40,F12.4)
  806 FORMAT(A40,I12)
  807 FORMAT(I6,1P,E11.4)
  808 FORMAT(3(1P,E15.7,I6))
  809 FORMAT(5I15)
  812 FORMAT(A66,I4,I2,I3,I5)
  814 FORMAT(6F11.0)
  874 FORMAT(F10.2,1P,E10.4,4E10.3,I2,E10.3,0P,F8.1)
  875 FORMAT(9X,A1,1P,E10.3,0P,F10.2)
  881 FORMAT( ' Log-log interpolable weight function for F.P yields'/
     1        '     Energy     Weight'/
     2        '  --------------------')
  882 FORMAT(1P,2E11.4)
  883 FORMAT(' WARNING - Parent material MAT',I6,'    ZA',I6
     1      ,' cross sections not found'/)
  884 FORMAT(' WARNING - decay level stack exceeded',I4,' for ',F12.1)
  885 FORMAT(
     3'  ----------------------------------------------------------',
     3'--------------------'/
     4'  Differences in',I4,' nuclides encountered')
  886 FORMAT(' WARNING - Decay product',F8.1,' yield',1P,E10.3
     1      , ' BR=',E10.3,' not in yield list')
  891 FORMAT(//' AVRFPY - Average fission product yields'/
     1         ' ======================================='/)
  892 FORMAT(/' Parent material MAT',I6,'    ZA',I6
     1       ,'  F.P. yields processed')
C...Print decay constant in [s-1]
  893 FORMAT(/
     1'               Yield   Sig(th)  Res.Int. Reactions Dcy.const',
     1' D     BR   Product'/
     2'    Isotope      [%]    [barn] [barn.eV] [n/s/cm3]   [s-1]  '/
     3'  ----------------------------------------------------------',
     3'--------------------')
C...Print half-life in [s]
C 893 FORMAT(/
C    1'               Yield   Sig(th)  Res.Int. Reactions Half life',
C    1' D     BR   Product'/
C    2'    Isotope      [%]    [barn] [barn.eV] [n/s/cm3]     [s]  '/
C    3'  ----------------------------------------------------------',
C    3'--------------------')
C...Print half-life in [days]
C 893 FORMAT(/
C    1'               Yield   Sig(th)  Res.Int. Reactions Half life',
C    1' D     BR   Product'/
C    2'    Isotope      [%]    [barn] [barn.eV] [n/s/cm3]   [days] '/
C    3'  ----------------------------------------------------------',
C    3'--------------------')
C...
  894 FORMAT(I4,'-',A2,'-',I3,A2,F7.5,F10.1,I10,F10.2,1P,E10.3,1X
     1      ,A1,0P,F7.4,I3,'-',A2,'-',I3,A2)
  895 FORMAT(
     3'  ----------------------------------------------------------',
     3'--------------------'/
     4'  Tot.',I5,2X,F7.3,20X,F10.2)
  896 FORMAT(' Cross sections for',I4,' nuclides processed')
  897 FORMAT(11X,F8.1,'%',4(F9.1,'%'),1X,A1)
  898 FORMAT(61X,A1,F7.4,I3,'-',A2,'-',I3,A2)
      END
      SUBROUTINE FLXPNT(NG,EGB,FRR,FIN,IER)
C-Title  : FLXPNT Subroutine
C-Purpose: Determine log-log interpolable points from integral values
      implicit real*8 (a-h,o-z)
      DIMENSION EGB(*),FRR(*),FIN(*)
      IER=0
   10 IER=IER+1
      DO 60 IG=1,NG
      FQ =FIN(IG)
      E1 =EGB(IG)
      E2 =EGB(IG+1)
      F1 =FRR(IG)
      F2 =FRR(IG+1)
      IF(FQ.EQ.0) GO TO 60
      IF(F1.NE.0) GO TO 20
      IF(F2.EQ.0) GO TO 60
      IF(IG.EQ.1) IER=0
C* Iterate on the lower point to match the average (log-log)
      F1 = F2*E2/E1
      Q  = F1*E1*DLOG(E2/E1)
      IF(Q-FQ.EQ.0) GO TO 18
      IF(Q-FQ.LT.0) GO TO 14
C*      Iteration sequence on F1 (case: B+1<0)
      F1 = 0.5*F1
   12 F  = F1
      B  =(E2*F2-E1*F )/FQ - 1.
      F1 = F2*(E1/E2)**B
      IF(ABS(F1-F).GT.1E-5*F) GO TO 12
      GO TO 18
C*      Iteration sequence on B  (case: B+1>0)
   14 F1 = 1.5*F1
      AE = DLOG(E2/E1)
   16 F  = F1
      B  = DLOG(F2/F )/AE
      F1 =(E2*F2-FQ*(B+1.))/E1
      IF(ABS(F1-F).GT.1E-5*F) GO TO 16
   18 FRR(IG)=F1
      GO TO 60
C* Iterate on the upper point to match the average (log-log)
   20 IF(F2.NE.0) GO TO 60
      IF(F1.EQ.0) GO TO 60
      IF(IG.EQ.1) IER=0
      F2 = F1*E1/E2
      Q  = F1*E1*DLOG(E2/E1)
      IF(Q-FQ.EQ.0) GO TO 28
      IF(Q-FQ.LT.0) GO TO 24
C*      Iteration sequence on F2 (case: B+1<0)
      F2 = 0.5*F2
   22 F  = F2
      B  =(E2*F -E1*F1)/FQ - 1.
      F2 = F1*(E2/E1)**B
      IF(ABS(F2-F).GT.1E-5*F) GO TO 22
      GO TO 28
C*      Iteration sequence on B  (case: B+1>0)
   24 F2 = 1.5*F2
      AE = DLOG(E2/E1)
   26 F  = F2
      B  = DLOG(F /F1)/AE
      F2 =(E1*F1+FQ*(B+1.))/E2
      IF(ABS(F2-F).GT.1E-5*F) GO TO 26
   28 FRR(IG+1)=F2
   60 CONTINUE
      IF(IER.GT.0 .AND. IER.LT.NG) GO TO 10
      RETURN
      END
      FUNCTION XSAV3G(XT,XE,XF,FIN)
C-Title  : XSAV3G Function
C-Purpose: Calculate average from 3-group cross sections
      implicit real*8 (a-h, o-z)
      DIMENSION FIN(*)
      FF=FIN(1)+FIN(2)+FIN(3)
      XSAV3G =(XT*FIN(1) + XE*FIN(2) + XF*FIN(3))/FF
      RETURN
      END
      SUBROUTINE CHKFPY(LER,NFP,ZAP,YLD,HLF,XTH,RIN,XFS,NDK,MXDK,BRR,ZAD
     1                 ,BRC,FLAG,EPY,EPX,EPR,EPD,EPU,EPC,FIN)
C-Title  : CHKFPY Subroutine
C-Purpose: Set flag for nuclides which violate the selection criteria
C-Description:
C-D  FIRST LOOP
C-D  - Check for nearly-stable nuclides and remove their contribution
C-D    from the cumulative yield of the decay product.
C-D    Nearly-stable nuclides are those for which the product of
C-D    their average cross section [barns] and half-life [days]
C-D    exceeds EPU. If the cross section is not known, it is
C-D    assumed 1 barn.
C-D  SECOND LOOP
C-D  The following conditions define nuclides eligible for printout:
C-D  1. Nuclides with yields greater than EPY
C-D  2. Nuclides with large cross sections (x-sect > EPX)
C-D  3. (Not defined)
C-D  4. Nuclides with high capture reaction rates:
C-D     - not short-lived, (x-sect*half-life > EPD)
C-D     - high yield and capture cross section
C-D       (yield*x-sect > EPR)
C-D  5. Nuclides with high cross sections capture products
C-D     - not short-lived, (x-sect*half-life > EPD)
C-D     - high yield and high capture cross sections of both
C-D       the parent and the capture product
C-D       (yield*x-sect-parent*x-sect-product > EPC)
C-D     Isomer production on capture is taken into account.
C-D  8. Capture products from item 5.
C-
      implicit real*8 (a-h,o-z)
      CHARACTER*1 FLG,    FLAG(*)
      DIMENSION   ZAP(*), YLD(*), HLF(*), XTH(*), RIN(*), XFS(*)
     1           ,BRC(*), NDK(*), BRR(MXDK,*)   , ZAD(MXDK,*), FIN(*)
C*
C* Process "nearly stable" nuclides
      DO 28 I=1,NFP
C* Preset the printout flag
      FLAG(I)='0'
      IF(EPU.LE.0) GO TO 28
C* Remove contribution from the cumulative yields of decay products
      XA =XSAV3G(XTH(I),RIN(I)/FIN(2),XFS(I),FIN)
      HL =HLF(I)/(3600. * 24.)
      IF(XA.GT.0) HL=XA*HL
      IF(HL.LE.EPU) GO TO 28
C* Loop over the decay products
      ND =MIN(MXDK, NDK(I))
      IF(ND.LE.0) GO TO 28
      DO 26 J=1,ND
      ZAM=ZAD(J,I)
      IF(ZAM.LE.0) GO TO 26
      CALL SRCIDX(NFP,ZAP,ZAM,K)
      IF(ABS(ZAP(K)-ZAM).GT.0.5) GO TO 26
      BY=BRR(J,I)*YLD(I)
      YI=YLD(K)-BY
C* Remove the decay product from the direct contribution
      IF(YI.GT.-1.E-5*YLD(I)) GO TO 22
        WRITE(LER,94) ZAP(I),YLD(I),HLF(I),ZAP(K),YLD(K)
        GO TO 26
   22 YLD(K) =MAX(0., YI)
      IF(YLD(K).LT.0.01*YLD(I)) FLAG(K)='U'
      XA =XSAV3G(XTH(K),RIN(K)/FIN(2),XFS(K),FIN)
      HK =HLF(K)/(3600. * 24.)
      IF(XA.GT.0) HK =XA*HK
C* Check if decay product itself is unstable
      IF(HK.GT.EPD) GO TO 26
      KD =MIN(MXDK, NDK(K))
C* Apply corrections on one more level of decay products
      DO 24 M=1,KD
      ZAM=ZAD(M,K)
      IF(ZAM.LE.0) GO TO 24
      CALL SRCIDX(NFP,ZAP,ZAM,L)
      IF(ABS(ZAP(L)-ZAM).GT.0.5) GO TO 24
      BY=BRR(M,K)*BY
      YI=YLD(L)-BY
C* Remove the decay product from the direct contribution
      IF(YI.GT.-1.E-5*YLD(K)) THEN
        YLD(L) =MAX(0., YI)
      ELSE
        WRITE(LER,94) ZAP(K),YLD(K),HLF(K),ZAP(L),YLD(L)
      END IF
   24 CONTINUE
   26 CONTINUE
   28 CONTINUE
C*
C* Check the printout criteria
   40 DO 68 I=1,NFP
      YI =YLD(I)*100.
      XT =XTH(I)
      XE =RIN(I)/FIN(2)
      XF =XFS(I)
      XA =XSAV3G(XT,XE,XF,FIN)
      XX =MAX(XT,XE,XF,XA)
      RR =YLD(I)*XA
      HI =HLF(I)/(3600. * 24.)
      IF(XA.GT.0) HI=XA*HI
      ND =NDK(I)
      FLG=FLAG(I)
C* Check if a specific print request has already been issued
      IF(FLG.GT.'0' .AND. FLG.LE.'9') GO TO 68
C* 1.: Test on high yield
      IF(EPY.LE.0) GO TO 42
      IF( YI.GT.EPY) THEN
        FLAG(I)='1'
      ELSE
        FLG='Y'
      END IF
C* 2.: Test on high cross sections
   42 IF(EPX.LE.0) GO TO 52
      IF( XA.GE.EPX) THEN
        FLAG(I)='2'
      ELSE
        FLG='X'
      END IF
C* 4.: Test on high capture reaction rate
   52 IF(EPR.LE. 0 ) GO TO 53
C*     Exclude short-lived products
      IF(HI.GT.0 .AND. HI.LT.EPD) THEN
        FLG='D'
        GO TO 53
      END IF
      IF( RR.GE.EPR) THEN
        FLAG(I)='4'
      ELSE
        FLG='R'
      END IF
C* 5.: Test on high capture reaction rate of the capture product
   53 IF(EPC.LE.0) GO TO 65
      RL =RR
      HL =HI
      L  =I
   54 ZAM=IDINT(ZAP(L))+1
   55 CALL SRCIDX(NFP,ZAP,ZAM,K)
      IF(ABS(ZAP(K)-ZAM).GT.0.5) GO TO 65
        XC =XSAV3G(XTH(K),RIN(K)/FIN(2),XFS(K),FIN)
        RC =RL*XC
        HC =HLF(K)/(3600. * 24.)
        IF(XC.GT.0) HC=XC*HC
        IF(RC.GE.EPC .AND. (HC.LE.0 .OR. HC.GT.EPD)) THEN
          FLAG(L)='5'
          FLAG(K)='8'
C*      Isomer production on capture
          IF(BRC(L).NE.0 .AND. ZAM-ZAP(L)-1.LT.0.05) THEN
            ZAM=ZAM+0.1
            GO TO 55
          END IF
          RL =YLD(I)*XC
          HL =HC
          L  =K
          GO TO 54
        END IF
   65 IF(FLAG(I).LE.'0' .OR. FLAG(I).GT.'9') FLAG(I)=FLG
   68 CONTINUE
C* All criteria checked
   90 RETURN
   94 FORMAT(' WARNING - Inconsistent yields for ZA',0P,F8.1
     1      ,' yield',1P,E10.3,' Th[s]',E10.3/
     2       '                 and decay product ZA',0P,F8.1
     2      ,' yield',1P,E10.3)
      END
      SUBROUTINE YLDCUM(LER,NFP,EPU,ZAP,YLD,HLF,XTH,RIN,XFS,MDD
     1                 ,MXDK,BRR,ZAD,YL1,YL2,FIN)
C-Title  : YLDCUM Subroutine
C-Purpose: Calculate cumulative F.P yields from independent yields
      implicit real*8 (a-h,o-z)
      DIMENSION  MDD(*), ZAP(*), YLD(*), HLF(*), XTH(*), RIN(*), XFS(*)
     1          ,YL1(*), YL2(*), BRR(MXDK,*),    ZAD(MXDK,*),    FIN(*)
C* Clear the scratch yields arrays
      DO 20 I=1,NFP
      YL1(I)=0.
      YL2(I)=0.
   20 CONTINUE
C* Process direct decay products
      DO 40 I=1,NFP
      ND = MIN(MXDK,MDD(I))
      YI = YLD(I)
      XA =XSAV3G(XTH(I),RIN(I)/FIN(2),XFS(I),FIN)
      HL = HLF(I)/(3600. * 24.)
      IF(XA.GT.0) HL=XA*HL
      IF(HL.LE.0 .OR. (HL.GT.EPU .AND. EPU.GT.0)) GO TO 40
      IF(ND.LT.1) GO TO 40
      DO 24 J=1,ND
      BR = BRR(J,I)
      ZAM= ZAD(J,I)
      IF(ZAM.LE.0) GO TO 24
      CALL SRCIDX(NFP,ZAP,ZAM,K)
      IF(ABS(ZAP(K)-ZAM).GT.0.5) GO TO 24
      YL1(K)=YL1(K)+BR*YI
   24 CONTINUE
   40 CONTINUE
C* Process secondary decay products
   50 ID =  0
      DO 60 I=1,NFP
      YI = YL1(I)
      IF(YI.LE.0) GO TO 60
      ND = MIN(MXDK,MDD(I))
      XA =XSAV3G(XTH(I),RIN(I)/FIN(2),XFS(I),FIN)
      HL = HLF(I)/(3600. * 24.)
      IF(XA.GT.0) HL=XA*HL
      YL1(I)=0.
      YLD(I)=YLD(I)+YI
      IF(ND.LE.0) GO TO 60
      IF(HL.LE.0 .OR. (HL.GE.EPU .AND. EPU.GT.0)) GO TO 60
C* Case: Calculate yields of secondary decay products
      DO 56 J=1,ND
      BR = BRR(J,I)
      ZAM= ZAD(J,I)
      IF(ZAM.LE.0) GO TO 56
      CALL SRCIDX(NFP,ZAP,ZAM,K)
      IF(ABS(ZAP(K)-ZAM).GT.0.5) GO TO 56
C*       Guard against erroneous data
      IF(K.EQ.I) THEN
        WRITE(LER,94) ZAM
        GO TO 56
      END IF
      YL2(K)=YL2(K)+BR*YI
      ID =ID+1
   56 CONTINUE
   60 CONTINUE
C* Prepare for the next generation of decay products
      DO 62 I=1,NFP
      YL1(I)=YL2(I)
      YL2(I)=0.
   62 CONTINUE
C* Repeat the procedure if more daughter product generations exist
      WRITE(LER,96) ID
      IF(ID.NE.0) GO TO 50
      RETURN
   94 FORMAT(' WARNING - Erroneous decay data for ZA',F8.1)
   96 FORMAT(' Number of secondary daughter-products',I5)
      END
      SUBROUTINE CHKCUM(LER,NFP,EPU,ZAP,YLD,HLF,XTH,RIN,XFS,MDD
     1                 ,MXDK,BRR,ZAD,DKM,FIN)
C-Title  : CHKCUM Subroutine
C-Purpose: Check the consistency of the cumulative F.P yields
      implicit real*8 (a-h,o-z)
      PARAMETER  (MXP=10)
      CHARACTER*1 RC(10)  ,RCK(MXP),DKM(MXDK,*)
      DIMENSION   ZAK(MXP),YLK(MXP),BRK(MXP),HLK(MXP)
      DIMENSION   MDD(*), ZAP(*), YLD(*), HLF(*), XTH(*), RIN(*), XFS(*)
     1           ,BRR(MXDK,*), ZAD(MXDK,*), FIN(*)
      DATA RC/'g','b','+','I','a','n','F','p','8','x'/
C* Process each fission product
      DO 60 I=1,NFP
      ZAM= ZAP(I)
      YI = YLD(I)
      YK = 0.
      NP = 0
      DO 40 K=1,NFP
      ND = MIN(MXDK,MDD(K))
      IF(ND.LE.0) GO TO 40
      DO 24 J=1,ND
      ZAJ= ZAD(J,K)
      IF(ZAJ.LE.0) GO TO 24
      IF(ABS(ZAJ-ZAM).GT.0.05) GO TO 24
        XA =XSAV3G(XTH(K),RIN(K)/FIN(2),XFS(K),FIN)
        HL = HLF(K)/(3600. * 24.)
        IF(XA.GT.0) HL=XA*HL
        IF(HL.LE.0 .OR. (HL.GT.EPU .AND. EPU.GT.0)) GO TO 24
        YK = YK + YLD(K)*BRR(J,K)
        IF(NP.GE.MXP) GO TO 24
        NP=NP+1
        ZAK(NP)=ZAP(K)
        YLK(NP)=YLD(K)
        HLK(NP)=HLF(K)
        BRK(NP)=BRR(J,K)
        RCK(NP)=DKM(J,K)
   24 CONTINUE
   40 CONTINUE
      IF(YK.LE.YI) GO TO 60
      ER=999.99
      IF(YI.GT. 0) ER=MIN(ER, 100.*(YK/YI-1.))
      IF(ER.LT.0.01) GO TO 60
      WRITE(LER,94) ZAM,YI,ER
      IF(NP.LT. 1) GO TO 60
      DO 52 J=1,NP
      WRITE(LER,96) ZAK(J),YLK(J),HLK(J),RCK(J),BRK(J)
   52 CONTINUE
   60 CONTINUE
      RETURN
   94 FORMAT(' WARNING - ZA',F8.1,' yield',1P,E10.3
     1      ,' cumulative yield inconsistent',0P,F6.2,'%')
   96 FORMAT('    precursor',F8.1,' yield',1P,E10.3
     1      ,' T(1/2)',E10.3,' React. ',A1,' BR',0P,F8.5)
      END
      SUBROUTINE DECYMD(LDY,LER,NFP,ZAP,HLF,NDK,LDK,DKM,BRR,ZAD,IER)
C-Title  : DECYMD Subroutine
C-Purpose: Assign the decay data to the list of F.P. nuclides
      implicit real*8 (a-h,o-z)
      PARAMETER   (MXDK=10)
      CHARACTER*1  RC(MXDK), DKM(LDK,*)
      DIMENSION    BR(MXDK),MD(MXDK),IZAP(MXDK),IZOP(MXDK)
      DIMENSION    BRR(LDK,*),ZAD(LDK,*), ZAP(*),HLF(*),NDK(*)
      DATA RC/'g','b','+','I','a','n','F','p','8','x'/
   10 MAT=0
      IZA=-1
      LIZ=-1
      IZO=-1
      CALL IZADCY(LDY,MAT,IZA,LIZ,IZO,HL,ND,BR,MD,IZAP,IZOP,MXDK,IEF)
      ZAM =FLOAT(IZA)+0.1*FLOAT(IZO)
      IF(IEF.GE.10) GO TO 90
C* Find the index of the current nuclide on the list
      CALL SRCIDX(NFP,ZAP,ZAM,K)
      IF(ABS(ZAP(K)-ZAM).GT.0.05) GO TO 10
C* Transfer the data to the output array
      NDK(K)=ND
      HLF(K)=HL
      ND=MIN(LDK, ND)
      DO I=1,ND
        JR=MIN(MXDK,MD(I)+1)
        DKM(I,K)=RC(JR)
        BRR(I,K)=BR(I)
        ZAD(I,K)=FLOAT(IZAP(I))+0.1*FLOAT(IZOP(I))
      END DO
      IF(IEF.LT.10) GO TO 10
C* All file processed
   90 IER=0
      IF(IEF.GE.20) IER=-1
      RETURN
      END
      SUBROUTINE IZADCY(LIN,MAT0,IZA0,LIZ0,IZO0
     1                 ,HLF,NDK,BRR,MDD,IZAP,IZOP,MXDK,IER)
C-Title  : IZADCY Subroutine
C-Purpose: Assign decay modes to the selected nuclide
      implicit real*8 (a-h,o-z)
      CHARACTER*66   REC
      DIMENSION      BRR(*), MDD(*), IZAP(*), IZOP(*)
   20 READ (LIN,622,END=92,ERR=93) REC,MAT,MF,MT
      IF(MAT.LT.0) GO TO 91
C* Find the decay data
      IF(MF.NE.8 .OR. MT.NE.457) GO TO 20
      READ (REC,623) ZA,AWR,LIZ,IZO
      IZA = ZA+0.1
C* Skip if not the right material
      IF(MAT0.LT.0) GO TO 40
      IF(IZA0.LT.0) GO TO 40
      IF(MAT0.GT.0 .AND. MAT0.EQ.MAT) GO TO 40
      IF(IZA0.GT.0 .AND. IZA0.EQ.IZA) GO TO 40
      IF(LIZ0.GE.0 .AND. LIZ0.EQ.LIZ) GO TO 40
      IF(IZO0.GE.0 .AND. IZO0.EQ.IZO) GO TO 40
   22 READ (LIN,622,END=92,ERR=93) REC,MAT,MF,MT
      IF(MAT.NE.0) GO TO 22
      GO TO 20
C* Process the decay data
   40 READ (LIN,623) HLF, DHLF, I, I, NC2, I
      READ (LIN,624) (xx,i=1,nc2)
      READ (LIN,623) SPI,PAR, I, I, I, NDK
      JDK=NDK
      IF(NDK.LE.MXDK) GO TO 41
      IER=9
      JDK=MXDK
   41 DO 42 I=1,JDK
      READ (LIN,624) RTY,RFS,QQ,DQ,BRR(I)
      IZOP(I)=NINT(RFS)
      IZAP(I)=IZA
C* Process decay type flag - allow up to 4 digits
      ITYI=NINT(RTY*1000)
      ITYO=1
      DO WHILE (ITYI.GT.0)
C*      Consider last digit of the decay type flag
        ITY =ITYI-10*(ITYI/10)
        ITYI=ITYI/10
        IF(ITY.GT.0) THEN
          ITYO=ITYO*10
          IF(ITY.EQ.1) IZAP(I)=IZAP(I)+1000
          IF(ITY.EQ.2) IZAP(I)=IZAP(I)-1000
          IF(ITY.EQ.3) IZAP(I)=IZAP(I)
          IF(ITY.EQ.4) IZAP(I)=IZAP(I)-2004
          IF(ITY.EQ.5) IZAP(I)=IZAP(I)-   1
          IF(ITY.EQ.7) IZAP(I)=IZAP(I)-1001
        END IF
      END DO
      ITYO=NINT(RTY*ITYO/10)
      MDD(I)=ITYO
      IF(ITYO.EQ.0) IZAP(I)=0
   42 CONTINUE
C* Skip the rest of the data for this material
   44 READ (LIN,622,END=92,ERR=93) REC,MAT,MF,MT
      IF(MAT.NE.0) GO TO 44
C* Reassign the nuclide identifiers and finish
      MAT0=MAT
      IZA0=IZA
      LIZ0=LIZ
      IZO0=IZO
      RETURN
C* Last material processed
   91 IER=10
      RETURN
C* EOF error trap
   92 IER=12
      RETURN
C* Format read error trap
   93 IER=20
      RETURN
  622 FORMAT(A66,I4,I2,I3)
  623 FORMAT(2F11.0,4I11)
  624 FORMAT(6F11.0)
      END
      SUBROUTINE REACRT(LXS,LER,MTX,NFP,ZAP,XTH,RIN,XFS ,IER)
C-Title  : REACRT Subroutine
C-Purpose: Assign cross sections to a list of nuclides
C-Version:
C-V  01/11 A.Trkov: Upgrade to support INTER 6.12 output
C-Description:
C-D  A record is read from a file, assuming it is in the INTER output
C-D  format. Version of INTER is identified from the first record.
C-D  A modification of the 6.11 format is allowed where an extra
C-D  digit is read for ZA to identify the isomer state. Records
C-D  which can not be read or where MAT number is zero are ignored
C-
      implicit real*8 (a-h,o-z)
      CHARACTER*120 REC
      CHARACTER*11  RCT
      DIMENSION     ZAP(*),XTH(*),RIN(*),XFS(*)
C*
      DATA RPI2/ 0.886226925 /
      NM  =0
      IZA0=0
      IVER=612
C* Try to identify the INTER version
      READ (LXS,860,END=90) REC
      IF(REC(39:51).EQ.'INTER VERSION') THEN
        READ (REC(52:56),864,ERR=42) VER
        IVER=NINT(VER*100)
C* Position the file to the beginning of the data
   30   READ (LXS,860,END=90) REC
        IF(IVER.GE.612) THEN
          IF(REC(1:16).NE.' Material number') GO TO 30
          READ (REC(26:31),865) MAT
        ELSE
          IF(REC(1:16).NE.'  MAT    ZA    M') GO TO 30
        END IF
      ELSE
C* Header record missing - assume INTER Version 6.12 or higher
        GO TO 42
      END IF
C* Process each entry in turn on the INTER output file
   40 READ (LXS,860,END=90) REC
   42 IF(REC(1:20).EQ.'                    ') GO TO 40
      IF(IVER.GE.612) THEN
        IF(REC(1:16).EQ.'  Z    A  LISO  ') GO TO 40
        IF(REC(1:16).EQ.' Material number') THEN
          READ (REC(26:31),865) MAT
          GO TO 40
        END IF
        READ (REC,861) IZ,IA,LIS0,LFS,MT,RCT,SG0,SE0,STH,GWE,RI,SFS,S14
        IZA=IZ*10000+IA*10+LIS0
        ZA =IZA*0.1
        ZAM=ZA
        STH=STH*RPI2
      ELSE
C* Assume format INTER 6.11 - read all records that conform to format
        IF(REC(13:13).EQ.' ') THEN
C*        INTER 6.11 regular format (ZA)
          READ (REC,862,ERR=40) MAT,ZA,MT,RCT,SG0,SE0,STH,GWE,RI,SFS,S14
        ELSE
C*        INTER 6.11 MODIFIED format (ZA.m with decimal isomer state m)
          READ (REC,863,ERR=40) MAT,ZA,MT,RCT,SG0,SE0,STH,GWE,RI,SFS,S14
        END IF
        IF(MAT.LE. 0 ) GO TO 40
        IZA=NINT(ZA*10)
      END IF
C* Test for the specified MT number
      IF( MT.NE.MTX) GO TO 40
C* If same ZA consecutively for this MT, assume it is an isomer
      IF(IVER.LT.612 .AND. IZA.EQ.IZA0) THEN
        ZAM =ZAM+0.1
      ELSE
        ZAM =ZA
        IZA0=NINT(ZA*10)
      END IF
C* Find the index of the current nuclide on the list
      CALL SRCIDX(NFP,ZAP,ZAM,K)
C* Isomer data are approximated by the ground-state data
      IF(ABS(ZAP(K)-ZAM).GT.0.5) GO TO 40
C* Enter the thermal x-sect. and res.int. into the output array
      XTH(K)=STH
      RIN(K)=RI
      XFS(K)=SFS
      NM =NM+1
      GO TO 40
C* End-of-file check
   90 IER=0
      IF(NM.NE.NFP) IER=NM
      IF(NM.LE.0)   IER=-1
      RETURN
  860 FORMAT(A120)
  861 FORMAT(I4,I5,I4,2I5,1X,A11,2F12.0,F11.0,F8.0,F13.0,2F12.0)
  862 FORMAT(I5,F7.0,I4,A11,2E12.5,E11.4,F8.5,E13.5,2E12.5)
  863 FORMAT(I5,F8.1,I4,A11,2E12.5,E11.4,F8.5,E13.5,2E12.5)
  864 FORMAT(F5.0)
  865 FORMAT(I5.0)
      END
      SUBROUTINE SRCIDX(N,X,R,K)
C-Title  : SRCIDX
C-Purpose: Find index K in array X that most closely matches R
      implicit real*8 (a-h,o-z)
      DIMENSION X(*)
      K=1
      IF(N.LT.2) RETURN
      E=X(1)
      DO 40 I=2,N
      IF(ABS(X(I)-R).GT.E) GO TO 40
      K=I
      E=ABS(X(I)-R)
   40 CONTINUE
      RETURN
      END
      SUBROUTINE FPRYLD(LIN,LER,MAT,MT,ZA,NFP,ZAP,YLD,FPS
     1          ,ZAP1,YLD1,ZAP2,YLD2 ,EGB,FRR ,MXFP,IER)
C-Title  : FPRYLD Subroutine
C-Purpose: Process fission products yields ENDF file
      implicit real*8 (a-h, o-z)
      CHARACTER*66 REC
      DIMENSION    EGB(4)    , FRR(4)
     1            ,ZAP (MXFP), YLD (MXFP), FPS(MXFP)
     2            ,ZAP1(MXFP), YLD1(MXFP)
     3            ,ZAP2(MXFP), YLD2(MXFP)
      IER=0
C* Process the ENDF file
   20 READ (LIN,695,END=90) REC,MAT0,MF0,MT0
C*      Check the MAT,MF,MT numbers
      IF(MAT0.LT.0) GO TO 90
      IF(MAT0.NE.MAT .AND. MAT.GT. 0 ) GO TO 20
      IF( MF0.NE.8) GO TO 20
      IF( MT0.NE.454  .AND.  MT0.NE.459) GO TO 20
      IF( MT0.NE.MT   .AND.  MT .GT.  0) GO TO 20
      IF( ZA.EQ.0) GO TO 32
C*      Check the ZA number
      READ (REC,696) ZA0,AWR,NE
      IF(ABS(ZA0-ZA).LT.0.5) GO TO 32
C*      In case if an incorrect ZA number skip to the end of material
   22 READ (LIN,695,END=90) REC,MAT0,MF0,MT0
      IF(MAT0.NE.0) GO TO 22
      GO TO 20
C* Fission product yields data found
   32 MAT=MAT0
      MT =MT0
      READ (REC,696) ZA,AWR,NE
      READ (LIN,696) EN,DD ,INT,II,II,NFP
      IF(NFP.GT.MXFP) STOP 'AVRFPY ERROR - Array capacity exceeded'
C* Read the data at the first energy point
      READ (LIN,698) (ZAP (I),FPS(I) ,YLD (I),DD,I=1,NFP)
      DO 41 I=1,NFP
      ZAP(I)=ZAP(I)+0.1*FPS(I)
      IF(I.LE.1) GO TO 41
      IF(ZAP(I-1).GE.ZAP(I)) WRITE(LER,803) ZAP(I-1),ZAP(I)
   41 CONTINUE
      CALL SRTBB2(NFP,ZAP,YLD,IES)
      IF(IES.GT.0) WRITE(LER,802) IES,EN
      SF=1.
      IF(NE.LE.1) GO TO 80
C* Save the data if more energy points present
      DO 42 I=1,NFP
      ZAP2(I)=ZAP(I)
      YLD2(I)=YLD(I)
      YLD (I)=0.
   42 CONTINUE
      NFP2=NFP
      SF=0.
      E2=EN
      JE=1
C* Read the data at the next energy point
   50 IF(JE.GE.NE) GO TO 80
      JE=JE+1
      E1=E2
      NFP1=NFP2
      DO 54 I=1,NFP1
      ZAP1(I)=ZAP2(I)
      YLD1(I)=YLD2(I)
   54 CONTINUE
      READ (LIN,696) E2,DD ,INT,II,II,NFP2
      IF(NFP2.GT.MXFP) STOP 'AVRFPY ERROR - Array capacity exceeded'
      READ (LIN,698) (ZAP2(I),FPS(I),YLD2(I),DD,I=1,NFP2)
      DO 56 I=1,NFP2
      ZAP2(I)=ZAP2(I)+0.1*FPS(I)
      IF(I.LE.1) GO TO 56
      IF(ZAP2(I-1).GE.ZAP2(I)) WRITE(LER,803) ZAP2(I-1),ZAP2(I)
   56 CONTINUE
      CALL SRTBB2(NFP2,ZAP2,YLD2,IES)
      IF(IES.GT.0) WRITE(LER,802) IES,E2
C*
C* Integral of the assumed spectrum (assume log-log interpolable)
C*   SG - spectrum contribution in the interval E1 - E2
C*   SF - total spectrum
      SG=0.
      DO 58 IG=1,3
      EA=MAX(E1, EGB(IG))
      EB=MIN(E2, EGB(IG+1))
      IF(EB.LE.EA) GO TO 58
      B =DLOG(FRR(IG+1)/FRR(IG))/DLOG(EGB(IG+1)/EGB(IG))
      B1=B+1.
      IF(ABS(B1).LT.1.E-4) THEN
        SG=SG+FRR(IG)*EA*DLOG(EB/EA)
      ELSE
        SG=SG+( EB*(EB/EGB(IG))**B - EA*(EA/EGB(IG))**B )*FRR(IG)/B1
      END IF
   58 CONTINUE
      SF=SF+SG
      I =1
      J =1
      K =1
C* Add the contribution to the average
   60 IF(K.GT.NFP) GO TO 50
      Y1=0.
      Y2=0.
      L =J
      IF(J.GT.NFP2) GO TO 62
      IF(ZAP2(L).GT.ZAP1(I)) GO TO 61
      ZP=ZAP2(J)
      Y2=YLD2(J)
      J =J+1
      GO TO 62
C* Print warning when yield at E2 for the current isotope is missing
   61 IF(LER.GT. 0) WRITE(LER,801) 2,IDINT(ZAP1(I)+0.1),E2
   62 IF(I.GT.NFP1) GO TO 64
      IF(ZAP1(I).GT.ZAP2(L)) GO TO 63
      ZP=ZAP1(I)
      Y1=YLD1(I)
      I =I+1
      GO TO 64
C* Print warning when yield at E1 for the current isotope is missing
   63 IF(LER.GT. 0) WRITE(LER,801) 1,IDINT(ZAP2(L)+0.1),E1
      ZP=ZAP2(L)
C* Weighted integral of the yield over the current energy interval
   64 Y =0.
      DO 68 IG=1,3
      EA=MAX(E1, EGB(IG  ))
      EB=MIN(E2, EGB(IG+1))
      IF(EB.LE.EA) GO TO 68
      IF(FRR(IG)*FRR(IG+1).LE.0) GO TO 68
C* Fission yields assumed log-log interpolable
C     B =DLOG(FRR(IG+1)/FRR(IG))/DLOG(EGB(IG+1)/EGB(IG))
C     B1=B+1.
C     B2=B+2.
C     A =FRR(IG)/EGB(IG)**B
C     G =(Y2-Y1)/(E2-E1)
C     C =Y1-E1*G
C     IF(ABS(B1).LT.1.E-4) THEN
C       Y = Y + C*A*DLOG(EB/EA)
C     ELSE IF(ABS(B2).LT.1.E-4) THEN
C       Y = Y + G*A*DLOG(EB/EA) - C*A*(1./EB - 1./EA)
C     ELSE
C       Y =Y + A*( (EB*G/(B+2.)+C/(B+1.))*EB**(B+1.)
C    1            -(EA*G/(B+2.)+C/(B+1.))*EA**(B+1.) )
C     END IF
C* Integral of the weighting function over the energy interval
      B =DLOG(FRR(IG+1)/FRR(IG))/DLOG(EGB(IG+1)/EGB(IG))
      B1=B+1.
      IF(ABS(B1).LT.1.E-4) THEN
        SG=FRR(IG)*EA*DLOG(EB/EA)
      ELSE
        SG=( EB*(EB/EGB(IG))**B - EA*(EA/EGB(IG))**B )*FRR(IG)/B1
      END IF
C* Fission yields assumed in histogram form
        Y =Y +Y1*SG
   68 CONTINUE
C* Check the isotope list in the master array
   70 IF(ZAP(K).EQ.ZP) GO TO 76
      IF(ZAP(K).LT.ZP) GO TO 77
C* Insert an entry in the list
      IF(NFP.GE.MXFP) STOP 'AVRFPY ERROR - Array capacity exceeded'
      DO 75 L=K,NFP
      ZAP(NFP+K-L+1)=ZAP(NFP+K-L)
      YLD(NFP+K-L+1)=YLD(NFP+K-L)
   75 CONTINUE
      ZAP(K)=ZP
      YLD(K)=0.
      NFP=NFP+1
C* Cae: Add the contribution for the current isotope
   76 YLD(K)=YLD(K) + Y
      K  =K+1
      GO TO 60
C* Case: No data for the current isotope in this interval
   77 K  =K+1
      IF(K.LE.NFP) GO TO 70
      NFP=K
      IF(NFP.GE.MXFP) STOP 'AVRFPY ERROR - Array capacity exceeded'
      ZAP(NFP)=ZP
      YLD(NFP)=Y
      IF(I.LE.NFP1 .OR. J.LE.NFP2) GO TO 60
C* Normalize by the integral of the spectrum and finish
   80 DO 81 I=1,NFP
      YLD(I)=YLD(I)/SF
   81 CONTINUE
      RETURN
C* End-of-file encountered
   90 IER=1
      RETURN
  695 FORMAT(A66,I4,I2,I3)
  696 FORMAT(2F11.0,4I11)
  698 FORMAT(6F11.0)
  801 FORMAT(' WARNING',I2,'  ZA',I6,' at',1P,E9.2,' eV missing.')
  802 FORMAT(' WARNING -',I4,' swaps at',1P,E9.2,' eV were necessary.')
  803 FORMAT(' WARNING - material',F8.1,' appears before',F8.1
     1      ,' in the F.P. yields data')
      END
      SUBROUTINE SRTBB2(N,X,Y,IER)
C-Title  : SRTBB2 Subroutine
C-Purpose: Bubble sort of arrays X,Y in ascending order of X
C-Description:
C-D  Element pairs of arrays X(i) and Y(i) of length N are sorted
C-D  in ascending order of X by the bubble sort method. On exit, IER
C-D  is the number of swap operations performed.
      implicit real*8 (a-h,o-z)
      DIMENSION X(*),Y(*)
      IER=0
      IF(N.LT.2) RETURN
      DO 40 K=2,N
      I=K-1
      DO 20 J=K,N
      IF(X(I).LE.X(J)) GO TO 20
      XI  =X(I)
      YI  =Y(I)
      X(I)=X(J)
      Y(I)=Y(J)
      X(J)=XI
      Y(J)=YI
      IER =IER+1
   20 CONTINUE
   40 CONTINUE
      RETURN
      END
      SUBROUTINE CAPBRR(NFP,ZAP,BRC)
C-Title  : CAPBRR Subroutine
C-Purpose: Assign capture product isomer branching ratio
C-Description:
C-D  The branching ratios for isomer production on capture should be
C-D  obtained from ENDF File-9 data but the relevant information is
C-D  usually lacking. This is an ad-hoc routine which defines the
C-D  branching ratios for some known cases.
      implicit real*8 (a-h,o-z)
      DIMENSION ZAP(*),BRC(*)
      DO 20 I=1,NFP
      BRC(I)=0.
C* 61-Pm-147 giving 43% 61-Pm-148m and 57% 61-Pm-148
      IF(ABS(ZAP(I)-61147.).LT.0.05) BRC(I)=0.43
   20 CONTINUE
      RETURN
      END
*deck avrfpyR4 
      PROGRAM AVRFPY
C-Title  : Program AVRFPY
C-Purpose: Calculate Spectrum Averaged F.P Yields
C-Author : A.Trkov, Institute J.Stefan, Ljubljana, Slovenia (1995)
C-Version: 1995 Original distribution
C-V  99/02 Minor corrections to fix bugs.
C-V  99/05 A.Trkov: Fix bugs in comparison mode.
C-V  01/11 A.Trkov: Upgrade to support INTER 6.12 output.
C-V  05/06 A.Trkov & D. L. Aldama: fix bugs processing f.p yields
C-V                                and decay data from JEFF-3.1
C-V
C-M
C-M  Manual for Program AVRFPY
C-M  =========================
C-M
C-M  The fission product yields data (ENDF-5, ENDF-6 format File 8)
C-M  are analysed. Energy dependent fission yields are accepted.
C-M  They are averaged, making some assumptions about the averaging
C-M  fission reaction rate. For all nuclides in the fission product
C-M  list the decay data are retrieved from the appropriate ENDF
C-M  file. The INTER (Version 6.11 and 6.12) output is also processed
C-M  to extract the thermal (Maxwellian average) cross section, the
C-M  resonance integral and the fission spectrum averaged cross
C-M  section. All information is written onto an intermediate file,
C-M  defined from input (default name AVRFPY.FPY).
C-M    A record on the intermediate file contains the nuclide
C-M  identification, fission yield [fraction], half-life [s], thermal
C-M  cross section [barns], resonance integral [barns], reaction
C-M  fraction (defined as the product of the yield and the average
C-M  cross section) [barns], the number of decay modes (which is zero
C-M  for unknown or stable nuclides) and the capture branching ratio
C-M  for the metastable isomer (if present). For decaying nuclides,
C-M  additional records follow (one for each decay mode), giving the
C-M  decay mode, the branching ratio and the product nuclide. Various
C-M  decay modes are represented by the following symbols:
C-M    g - gamma decay,
C-M    b - beta decay,
C-M    + - positron emission,
C-M    I - isomeric transition,
C-M    a - alpha decay,
C-M    n - neutron emission,
C-M    F - fission,
C-M    p - proton emission.
C-M  In addition, the capture products are identified by the symbol
C-M  "c". These are treated only approximately, assuming that the
C-M  product is in the ground state, except for a few specific cases
C-M  such as Pm-147 where Pm-148 and Pm-148m are produced. The
C-M  branching ratio is built into the code because the appropriate
C-M  data (ENDF file 9 data) are seldom present.
C-M
C-M  The intermediate file which is produced can be processed to
C-M  print the data according to some specified selection criteria
C-M  or to compare the data from different intermediate files.
C-M  The following criteria are applicable:
C-M    EPU - Long decay rate threshold [barn.days] is the criterion
C-M          on the product of the half-life and the capture cross
C-M          section. Above this threshold the fission products
C-M          are treated as stable and their decay influences the
C-M          equillibrium concentration by less then a fraction EPS.
C-M          The EPU criterion depends on the neutron flux level FLUX.
C-M          It is given by:
C-M            EPU = (1.E24/(24*3600)) * ALOG(2) * EPS / FLX
C-M          Typical value: EPU=4.E8 [barn.days]
C-M          Assuming     : EPS=2E-3, FLUX=1E+13 [n/cm2/s]
C-M    EPD - Short decay rate threshold [barn.days] is the criterion
C-M          on the product of the half-life and the capture cross
C-M          section. Below this threshold the fission products
C-M          are very short-lived and their capture reaction rate
C-M          represents less than a fraction EPS of the fission rate.
C-M          The yields of nuclides which fall below this criterion
C-M          are added to their decay products.
C-M          Parameter EPD is given by:
C-M            EPD = (1.E24/(24*3600)) * ALOG(2) / (EPS*FLUX)
C-M          Typical value: EPD=1600 [barn.days]
C-M          Assuming     : EPS=2E-3, FLUX=1E+13 [n/cm2/s]
C-M    EPR - Reaction rate threshold [barns] is the criterion
C-M          on the product of the yield and the capture cross
C-M          section. Below this threshold the capture reaction rate
C-M          represents less than a fraction EPS of the fission rate
C-M          so the fission product is removed from the output
C-M          list. It depends on the neutron flux FLUX and the
C-M          fuel irradiation time TRES.
C-M          Parameter EPR is given by:
C-M            EPR=(2.E24/(24*3600))*(EPS/(FLUX*TRES)
C-M          Typical value: EPR=0.12 [barns]
C-M          Assuming     : EPS=0.5E-4, FLUX=1E+13 [n/cm2/s]
C-M                        ,TRES=1000 [days]
C-M    EPC - Capture product reaction rate threshold [barns**2] is the
C-M          criterion on the product of the yield, the capture cross
C-M          section of the parent nuclide and the capture cross
C-M          section of the capture product. Below this threshold the
C-M          capture reaction rate by the capture product represents
C-M          less than a fraction EPS of the fission rate. Capture
C-M          products, which pass this test, are added to the list
C-M          of nuclides for printout even if their cumulative yield
C-M          from fission is small. The EPC criterion depends on the
C-M          neutron flux FLUX and the fuel irradiation time TRES.
C-M          It is givn by:
C-M            EPC=(6.E48/(24*3600)**2)*(EPS/(FLUX*TRES)**2)
C-M          Typical value: EPC=400 [barns**2]
C-M          Assuming     : EPS=0.5E-4, FLUX=1E+13 [n/cm2/s]
C-M                        ,TRES=1000 [days]
C-M    EPY - lower fission yield threshold [%] to suppress printout
C-M          of the fission product data with low yields.
C-M          Typical value: 0.5%. (See also the EPR criterion).
C-M    EPX - lower cross section threshold [barns] to suppress the
C-M          printout of the fission products with unknown or zero
C-M          cross sections. Typical value: 100 barns. (See also
C-M          the EPR criterion).
C-M
C-M  NOTE: cumulative yields are calculated automatically in the
C-M  case when the independent yields are processed from the source
C-M  ENDF file.
C-M
C-M  AVERAGING SPECTRUM: is required to interpret the cross sections
C-M  and the weighting function for the fission product yields. It
C-M  is defined in three broad groups:
C-M    1  1.E-5 eV  to  5.5 eV
C-M    2  5.5 eV    to  0.1 MeV
C-M    3  0.1 MeV   to  10. MeV
C-M  In group-2 the spectrum is assumed to have a "1/E" shape. The
C-M  average thermal spectrum is given in terms of the spectral
C-M  ratio SPR, defined as the ratio of the spectrum integral in
C-M  groups-2 and -3 to that in group-1. Parameter SPR=2.78 is
C-M  fixed and defined in the DATA statement. Similarly, the fast
C-M  spectrum is given in terms of the ratio of the epithermal to
C-M  fast flux EFR and is defined as the ratio of the spectrum
C-M  integral in group-2 to that in group-3. Parameter EFR=0.928
C-M  is fixed and defined in the DATA statement.
C-M
C-M    The fission product yields must be averaged by the fission
C-M  reaction rate. Since the yields are usually given on a very
C-M  coarse energy grid, a crude approximation to the weighting
C-M  function is adequate. For the parent fissile nucleus the
C-M  thermal cross section, the resonance integral and the fission
C-M  spectrum averaged cross section are read crom the INTER output
C-M  fule. The averaging spectrum is calculated at the coarse group
C-M  energy boundaries defined above, such that the integrals are
C-M  conserved assuming log-log interpolation (the log-log
C-M  interpolation rule is chosen to reproduce correctly the 1/E
C-M  behaviour in the epithermal range). Similarly, the cross
C-M  sections are calculated at the same energy points. The cross
C-M  section at the thermal to epithermal boundary is calculated
C-M  by the log-log interpolation from the 2200 m/s value (assuming
C-M  a 1/v behaviour in the thermal range) and the epithermal
C-M  average cross section at the average energy. When the fission
C-M  product yields are energy-dependent, histogram interpolation
C-M  is assumed, although in principle the interpolation flag is
C-M  given in the file.
C-M
C-M  Instructions:
C-M  -------------
C-M  Data are processed in two steps. In the first one the basic
C-M  files are processed and the intermediate file is written.
C-M  In the second step the intermediate file is processed. The
C-M  printout criteria are defined and the main output files are
C-M  written.
C-M
C-M  Input Intermediate file:
C-M  By default, program proceeds from step two, requesting the
C-M  name of the intermediate file to be processed. Responding
C-M  with "-" for the filename results in processing the basic
C-M  files to produce a new intermediate file on output.
C-M
C-M  Input Data Files:
C-M  To generate a new intermediate file, the filenames and other
C-M  relevant information is requested as follows:
C-M  - FLDY Decay data ENDF file. This file is mandatory.
C-M  - FLNI Fission product yields ENDF file. If blank is entered,
C-M    the selected nuclides are expected from a list file
C-M    (see below).
C-M  - MAT Material number of the parent fissile nuclide for
C-M    which the fission product yields are processed. If blank
C-M    is entered, selection is done through the ZA entry.
C-M  - ZA Parent fissile nuclide designation (ZA=1000*Z+A). This
C-M    is an alternative input to the MAT entry, described above.
C-M  - MT Fission yields reaction number: MT=454 for the independent
C-M    yields and MT=459 for cumulative yields. If independent
C-M    yields are selected, they are summed internally to calculate
C-M    the cumulative yields.
C-M  - EPU Long decay rate threshold [barn.days]. This entry
C-M    request appears only when independent fission product yields
C-M    are to be processed (see also the nuclide selection
C-M    parameters description).
C-M    Typical value: EPU=8.E7 [barn.days]
C-M    Assuming     : EPS=1E-4, FLUX=1E+13 [n/cm2/s]
C-M  - FLLS nuclide list filename, defined when fission product
C-M    yields are not processed. The first  record of this list
C-M    file is a comment header, followed by a list of nuclides
C-M    defined by their ZA value in columns 1-11, one nuclide per
C-M    record, until a blank line or an end-of-file is encountered.
C-M  - FLXS Filename of the INTER output from which the thermal cross
C-M    section, the resonance integral and the fission spectrum
C-M    average cross sections are read. A variant of the format
C-M    is recognised in which the ZA designation has an additional
C-M    decimal digit to identify the metastable isomers. If blank
C-M    name is entered, cross section processing is suppressed.
C-M  - MTX the relevant MT number for the cross sections is specified.
C-M    By default, MTX=102 for radiative capture is assumed.
C-M
C-M  Output files:
C-M  The following user defined output files are defined:
C-M  - FLYI Filename of the intermediate file (default AVRFPY.FPY).
C-M    The request is issued only when a new file is generated.
C-M  - FLNO Main output filename. The file contains the fission yields,
C-M    decay constants and other data for the selected list of
C-M    nuclides. The output is suppressed if "-" is entered.
C-M  - FLYA Auxiliary output filename. The information is the same
C-M    as in the main output filename, except that it is
C-M    intended for reading by the program (default AUXFPY.FPY).
C-M    The output is suppressed if "-" is entered.
C-M  In addition, the log file AVRFPY.LOG is opened unconditionally.
C-M  All error and warning messages are recorded there.
C-M
C-M  Nuclide selection criteria:
C-M  Nuclides to appear on the output can be selected by
C-M  specifying the list of requested nuclides. In this case the
C-M  input request is:
C-M  - FLLS Filename of the nuclide list file. The first
C-M    record of this list file is a comment header, followed by
C-M    a list of nuclides defined by their ZA value in columns
C-M    1-11, one nuclide per record, until a blank line or an
C-M    end-of-file is encountered.
C-M  Alternatively, a set of selection criteria can be
C-M  specified:
C-M  - EPU Long decay rate threshold [barn.days]. This entry
C-M    request appears unless it has been defined when specifying
C-M    the request to process independent fiss.prod. yields.
C-M    Typical value: EPU=8.E7 [barn.days]
C-M    Assuming     : EPS=1E-4, FLUX=1E+13 [n/cm2/s]
C-M  - EPD Short decay rate threshold [barn.days]
C-M    Typical value: EPD=8000 [barn.days]
C-M    Assuming     : EPS=1E-4, FLUX=1E+13 [n/cm2/s]
C-M  - EPR Reaction rate threshold [barns]
C-M    Typical value: EPR=0.25 [barns]
C-M    Assuming     : EPS=1E-4, FLUX=1E+13 [n/cm2/s]
C-M                  ,TRES=1000 [days]
C-M  - EPC Capture product reaction rate threshold [barns**2]
C-M    Typical value: EPC=800 [barns**2]
C-M    Assuming     : EPS=1E-4, FLUX=1E+13 [n/cm2/s]
C-M                        ,TRES=1000 [days]
C-M  - EPY lower fission yield threshold [%]
C-M    Typical value: 0.1%. (See also the EPR criterion).
C-M  - EPX lower cross section threshold [barns]
C-M    Typical value: 100 barns. (See also the EPR criterion).
C-M
C-References:
C-R [1] A.Trkov: Processing of the Fission Product Yield and Decay
C-R     Data, Institite J.Stefan, Ljubljana, Slovenia,
C-R     IJS-DP-draft, (1998).
C-R [2] R.W.Mills: Recommendation for the Use of Energy Dependent
C-R     JEF-2.2 Fission Product Yields, BNFL Sellafield,
C-R     OECD/NEA Data Bank, JEF/DOC-629.
C-
      PARAMETER   (MXFP=5000, MXDK=4, MXST=10)
      CHARACTER*1  CHD, RC(10), FLAG(MXFP), CHR1(MXDK,MXFP)
      CHARACTER*2  MX(10)
      CHARACTER*2  CH2,CS(100)
      CHARACTER*40 BLNK,FLNM,FLNI,FLXS,FLDY,FLNO,FLYA,FLYI,FLOG
     1            ,FLWI,FLNJ,FLLS
      CHARACTER*80 REC
      DIMENSION    EGB (4),    FRR (4),    FIN (4),  FAV(4)
     1            ,ZAP (MXFP), YLD (MXFP), HLF (MXFP),ZAC(MXFP)
     2            ,PAR1(MXFP), PAR2(MXFP), PAR3(MXFP), IPAR(MXFP)
     3            ,PAR4(MXDK,MXFP),        PAR5(MXDK,MXFP)
     4            ,PAR6(MXFP), PAR7(MXFP), PAR8(MXFP)
     5            ,AMT (MXFP), YDDP(MXST), NDDP(MXST) ,NDDK(MXST)
      DATA  LIN,LDY,LXS,LOU,LKB,LTT,LER,LYA,LYI,LWI,LNJ
     1     /  1,  2,  3,  4,  5,  6,  7,  8,  9, 16, 17 /
      DATA  BLNK/'                                        '/
     1      FLNI/'FPYLD.DAT'/
     2      FLDY/'DECAY.DAT'/
     3      FLXS/'INTER.OUT'/
     4      FLNO/'AVRFPY.OUT'/
     7      FLOG/'AVRFPY.LOG'/
     8      FLYA/'AVRFPY.AUX'/
     9      FLYI/'AVRFPY.FPY'/
     6      FLWI/'AVRFPY.WIM'/
      DATA MX/'  ','M ','M2','M3','M4','M5','M6','M7','M8','Mn'/
      DATA CS/   'H ','He','Li','Be','B ','C ','N ','O ','F ','Ne',
     1 'Na','Mg','Al','Si','P ','S ','Cl','Ar','K ','Ca','Sc','Ti',
     2 'V ','Cr','Mn','Fe','Co','Ni','Cu','Zn','Ga','Ge','As','Se',
     3 'Br','Kr','Rb','Sr','Y ','Zr','Nb','Mo','Tc','Ru','Rh','Pd',
     4 'Ag','Cd','In','Sn','Sb','Te','I ','Xe','Cs','Ba','La','Ce',
     5 'Pr','Nd','Pm','Sm','Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb',
     6 'Pr','Hf','Ta','W ','Re','Os','Ir','Pt','Au','Hg','Tl','Pb',
     7 'Bi','Po','At','Rn','Fr','Ra','Ac','Th','Pa','U ','Np','Pu',
     8 'Am','Cm','Bk','Cf','Es','Fm'/
C* Upper removal threshold [barn.days] identifying stable nuclides
      DATA EPU/0/
C* Thermal, epithermal and fast group boundaries and average flux
      DATA EGB/ 1.E-5, 0.55, 1.E+5, 1.E+7 /
C* Define group flux integrals with respect to the epithermal flux
      DATA SPR,EFR/ 5.785, 0.9279 /
      FIN(2)= ALOG(EGB(3)/EGB(2))
      FIN(3)= FIN(2)/EFR
      FIN(1)=(FIN(2)+FIN(3))/SPR
      IFPY=0
C*
C* Write banner to terminal screen
      WRITE(LTT,891)
C* Open the log file
      OPEN (UNIT=LER,FILE=FLOG,STATUS='UNKNOWN')
      WRITE(LER,891)
C*
C* Analyse a processed F.P. yields file or generate a new one
    1 WRITE(LTT,692) ' Define or select F.P. parameters file  '
      WRITE(LTT,692) ' -------------------------------------  '
      WRITE(LTT,692)
      WRITE(LTT,692) ' Default F.P.param.file to be processed:',FLYI
      WRITE(LTT,692) '        Enter new name to redefine    or'
      WRITE(LTT,692) '$       Enter "-" to generate new file: '
      READ (LKB,692) FLNM
      IYI=0
      IF(FLNM(1:1).EQ.'-') GO TO 20
      IF(FLNM.NE.BLNK) FLYI=FLNM
      OPEN (UNIT=LYI,FILE=FLYI,STATUS='OLD',ERR=1)
C* Read the processed yields file
      WRITE(LTT,692)
      WRITE(LTT,692) ' Reading F.P. parameters file         : ',FLYI
C*
      READ (LYI,692) FLNM,FLNI
      READ (LYI,692) FLNM,FLDY
      READ (LYI,692) FLNM,FLXS
      READ (LYI,803) FLNM,MT0
      READ (LYI,803) FLNM,MTX
      READ (LYI,804) FLNM,FIN1
      READ (LYI,804) FLNM,FIN2
      READ (LYI,804) FLNM,FIN3
      READ (LYI,803) FLNM,MAT
      READ (LYI,804) FLNM,ZA
      READ (LYI,803) FLNM,NFP
      READ (LYI,802) FLNM,EPU
      READ (LYI,803) FLNM
      IF(FIN1.NE.0) FIN(1)=FIN1
      IF(FIN2.NE.0) FIN(2)=FIN2
      IF(FIN3.NE.0) FIN(3)=FIN3
      DO 3 I=1,NFP
        READ (LYI,874)
     1   ZAP(I),YLD(I),HLF(I),PAR1(I),PAR2(I),PAR3(I)
     1  ,IPAR(I),PAR6(I),ZAC(I)
        AMT(I)=ZAP(I)
        NDK=MIN(MXDK,IPAR(I))
        IF(NDK.LE.0) GO TO 3
        DO 2 J=1,NDK
          READ (LYI,875) CHR1(J,I),PAR4(J,I),PAR5(J,I)
    2   CONTINUE
    3 CONTINUE
      CLOSE(UNIT=LYI)
      IYI=1
      IF(MT0.GT.0) IFPY=1
C*
C* Define the output list file
    4 WRITE(LTT,692)
      WRITE(LTT,692) ' Define the output files                '
      WRITE(LTT,692) ' -----------------------                '
      WRITE(LTT,692)
      WRITE(LTT,692) ' Default output list filename         : ',FLNO
      WRITE(LTT,692) '$       Enter new name or "-" to quit : '
      READ (LKB,692) FLNM
      IF(FLNM(1:1).EQ.'-') GO TO 90
      IF(FLNM.NE.BLNK) FLNO=FLNM
      OPEN (UNIT=LOU,FILE=FLNO,STATUS='UNKNOWN')
C*
C* Auxilliary processed F.P. yields file
    5 WRITE(LTT,692) ' Short F.P. parameters filename       : ',FLYA
      WRITE(LTT,692) '$     Enter new name or "-" to ignore : '
      READ (LKB,692) FLNM
      IYA=0
      IF(FLNM(1:1).NE.'-') THEN
        IF(FLNM.NE.BLNK) FLYA=FLNM
        WRITE(LTT,692) '               Compare reference file : ',FLYI
        WRITE(LTT,692) '                                 to   : ',FLYA
        WRITE(LTT,692) '$                             (y=Yes) : '
        READ (LKB,692) FLNM
        IF(FLNM(1:1).EQ.'y' .OR. FLNM(1:1).EQ.'Y') THEN
          LYC=ABS(LYC)
          OPEN (UNIT=LYC,FILE=FLYA,STATUS='OLD',ERR=5)
          GO TO 80
        END IF
C        WRITE(LTT,692) '$            Write a new file (y=Yes) : '
C        READ (LKB,692) FLNM
C        IF(FLNM(1:1).NE.'y' .AND. FLNM(1:1).NE.'Y') GO TO 5
        LYA=ABS(LYI)
        OPEN (UNIT=LYA,FILE=FLYA,STATUS='UNKNOWN',ERR=5)
        IYA=1
      END IF
C*
C* Define the thresholds for printout
      IF(MT0.NE.0) THEN
        WRITE(LTT,692)
        WRITE(LTT,692) ' Define nuclide selection criteria      '
        WRITE(LTT,692) ' ---------------------------------      '
        WRITE(LTT,692)
C*
    6   WRITE(LTT,692) '$Enter nuclide list file/blank=ignore : '
        READ (LKB,692) FLLS
        ILST=0
        IF(FLLS.EQ.BLNK) GO TO 16
C* Read the list of nuclides from a file
        OPEN (UNIT=LIN,FILE=FLLS,STATUS='OLD',ERR=21)
        READ (LIN,692,END=20) FLNM
        WRITE(LTT,692) '                  Nuclide list header : ',FLNM
        ILST=1
        DO I=1,NFP
          FLAG(I)='L'
        END DO
    8   READ (LIN,692,END=12) FLNM
        IF(FLNM.EQ.BLNK) GO TO 12
        READ (FLNM,694) ZAPI,AMTI
        IF(AMTI.EQ.0) AMTI=ZAPI
        DO 9 I=1,NFP
          IF(NINT(10.*ZAP(I)).NE.NINT(10.*ZAPI)) GO TO 9
          FLAG(I)='9'
          AMT (I)=AMTI
          GO TO 8
    9   CONTINUE
        WRITE(LTT,806) ' AVRFPY WARNING - No fiss. prod.  ZA  : '
     1                ,IFIX(ZAPI)
        GO TO 8
   12   CLOSE(UNIT=LIN)
        GO TO 19
C* Define nuclide selection criteria explicitly
   16   WRITE(LTT,692)
        WRITE(LTT,692) ' Enter main printout selection criteria '
        WRITE(LTT,692) ' -------------------------------------- '
        WRITE(LTT,692)
        IF(EPU.LE.0) THEN
          WRITE(LTT,692) '$Long  decay rate thresh. [barn.days] : '
          READ (LKB,694,ERR=16) EPU
        END IF
        WRITE(LTT,692) '$Short decay rate thresh. [barn.days] : '
        READ (LKB,694,ERR=16) EPD
        WRITE(LTT,692) '$Reaction rate thresh. [barns]        : '
        READ (LKB,694,ERR=16) EPR
        WRITE(LTT,692) '$Capt.Prod.Reac.rate thresh.[barns**2]: '
        READ (LKB,694,ERR=16) EPC
C*
   17   WRITE(LTT,692)
        WRITE(LTT,692) ' Auxiliary  printout selection criteria '
        WRITE(LTT,692)
        WRITE(LTT,692) '$Enter fission yield threshold   [%]  : '
        READ (LKB,694,ERR=17) EPY
        WRITE(LTT,692) '$Enter cross sect. threshold  [barns] : '
        READ (LKB,694,ERR=17) EPX
      END IF
   19 IF(IYA.NE.1) GO TO 60
C*
C* Write the auxiliary file
      WRITE(LYA,692) ' Fission product yields ENDF file     : ',FLNI
      WRITE(LYA,692) ' Decay data ENDF file                 : ',FLDY
      WRITE(LYA,692) ' INTER output file processed          : ',FLXS
      WRITE(LYA,803) ' Fission product yields             MT: ',MT0
      WRITE(LYA,803) ' Cross sections for reaction        MT: ',MTX
      WRITE(LYA,804) ' Thermal flux integral                : ',FIN(1)
      WRITE(LYA,804) ' Epithermal flux integral             : ',FIN(2)
      WRITE(LYA,804) ' Fast flux integral                   : ',FIN(3)
      WRITE(LYA,803) ' Fissile parent MAT number            : ',MAT
      WRITE(LYA,804) '                ZA  designation       : ',ZA
C     WRITE(LYA,803) ' Number of fission product nuclides   : ',NFP
      GO TO 60
C*
C* Define the F.P. yields ENDF file to be processed
   20 WRITE(LTT,692) ' Define ENDF files to generate F.P.param'
      WRITE(LTT,692) ' ---------------------------------------'
      WRITE(LTT,692)
      IDE=0
      WRITE(LTT,692) '$Enter Decay data file/blank to ignore: '
      READ (LKB,692)   FLDY
      IF(FLDY.NE.BLNK)
     1OPEN (UNIT=LDY,FILE=FLDY,STATUS='OLD',ERR=20)
      IDE=1
   21 WRITE(LTT,692) '$Enter F.P.yields file/blank to ignore: '
      READ (LKB,692) FLNI
      IF(FLNI.NE.BLNK) THEN
C*
C* Case: Fission products yield ENDF file specified
      OPEN (UNIT=LIN,FILE=FLNI,STATUS='OLD',ERR=21)
C* Select the material number and reaction type
   22 WRITE(LTT,692) ' Select parent fissile nuclide MAT/ZA   '
      WRITE(LTT,692) '$      Enter MAT or zero to select ZA : '
      READ (LKB,693,ERR=22) MAT
      IF(MAT.LE.0) THEN
   23   WRITE(LTT,692) '$                  Enter ZA =1000*Z+A : '
        READ (LKB,694,ERR=23) ZA
      ELSE
C* Extract the ZA value from the F.P. Yields file
   26   READ (LIN,812) REC,MM
        IF(MM.LT.0) STOP 'AVRFPY ERROR - Material not in FPY file'
        IF(MM.NE.MAT) GO TO 26
        READ (REC,814) ZA
        READ (LIN,812) REC
        READ (REC,814) DMY,DMY,DMY,ZA1
        ZA=ZA+0.1*ZA1
        REWIND LIN
      END IF
   24 WRITE(LTT,692) '$Enter the  MT number (454 OR 459)    : '
      READ (LKB,693,ERR=24) MT0
      IFPY=1
      IF(MT0.LE.0) GO TO 34
      IF(MT0.EQ.454) THEN
   25 WRITE(LTT,692) '$Long  decay rate thresh. [barn.days] : '
      READ (LKB,694,ERR=25) EPU
      END IF
      IF(MT0.NE.454 .AND. MT0.NE.459) GO TO 24
      ELSE
C*
C* Case: Nuclide list specified
      WRITE(LTT,692) '$Enter nuclide selection list file    : '
      READ (LKB,692) FLLS
      IF(FLLS.EQ.BLNK) GO TO 21
      OPEN (UNIT=LIN,FILE=FLLS,STATUS='OLD',ERR=21)
      READ (LIN,692,END=20) FLNM
      WRITE(LTT,692) '                  Nuclide list header : ',FLNM
      IFPY=0
      NFP =0
   27 READ (LIN,692,END=28) FLNM
      IF(FLNM.EQ.BLNK) GO TO 28
      NFP=NFP+1
      READ (FLNM,694) ZAP(NFP)
      YLD(NFP)=0.
      FLAG(NFP)='9'
      GO TO 27
   28 CLOSE(UNIT=LIN)
      END IF
C*
C* Define the cross sections file (INTER output)
   34 MTX=0
      WRITE(LTT,692) '$Enter INTER output /blank to ignore  : '
      READ (LKB,692)   FLXS
      IF(FLXS.NE.BLNK) THEN
      OPEN (UNIT=LXS,FILE=FLXS,STATUS='OLD',ERR=34)
C* Define the reaction type number MT
   35 WRITE(LTT,692) ' Default reaction is Capture (MT=102)   '
      WRITE(LTT,692) '$            Enter new MT to redefine : '
      READ (LKB,693,ERR=35) MT
      MTX=102
      IF(MT.NE.0) MTX=MT
      END IF
C*
C* Define the filename to store the processed F.P. yields
   36 WRITE(LTT,692) ' Processed F.P. parameters output file: ',FLYI
      WRITE(LTT,692) '$           Enter new name to redefine: '
      READ (LKB,692) FLNM
      IF(FLNM.NE.BLNK) FLYI=FLNM
      OPEN (UNIT=LYI,FILE=FLYI,STATUS='UNKNOWN')
C* Label the Log-file
      WRITE(LER,692) ' Decay data ENDF file                 : ',FLDY
      IF(IFPY.EQ.1) THEN
      WRITE(LER,692) ' Fission product yields ENDF file     : ',FLNI
      WRITE(LER,803) ' Fission product yields             MT: ',MT0
      WRITE(LER,892) MAT,IFIX(ZA+0.1)
      ELSE
      WRITE(LER,692) ' Fission product list file            : ',FLLS
      END IF
      WRITE(LER,692)
C*
C* Define the weighting function for the F.P yields
      FF=0.
      DO 37 IG=1,3
      FAV(IG)=FIN(IG)
      FRR(IG)=0.
      FF=FF+FAV(IG)
   37 CONTINUE
      FRR( 4)=0.
      FRR( 2)=(1./EGB(2))*FIN(2)/ALOG(EGB(3)/EGB(2))
      IF(MTX.LE.0 .OR. IFPY.LE.0) GO TO 38
C* If cross sections file is given, find the fissile parent fiss.x-sect.
      CALL REACRT(LXS,LER,18,1,ZA,FTH,FRI,FFS ,IER)
      REWIND LXS
      IF(IER.LT.0) THEN
        WRITE(LER,883) MAT,ZA
        WRITE(LTT,883) MAT,ZA
      ELSE
        FAV(1)=FAV(1)*FTH
        FAV(2)=FAV(2)*FRI/FIN(2)
        FAV(3)=FAV(3)*FFS
        FF    =FAV(1)+FAV(2)+FAV(3)
        FRR(2)=FRR(2) * FTH * (2./SQRT(3.1415926)) * SQRT(0.0253/EGB(2))
        IF(FTH.LE.0)
     1  FRR(3)=FAV(3)/(EGB(4)-EGB(3))
      END IF
C* Define other points log-log interpolable conserving the integrals
   38 CALL FLXPNT(3,EGB,FRR,FAV,IER)
      WRITE(LER,881)
      DO 39 I=1,4
      WRITE(LER,882) EGB(I),FRR(I)/FF
   39 CONTINUE
      WRITE(LER,692)
C*
C* Begin processing the data
      IF(IFPY.NE.1) GO TO 41
      MT =MT0
C* Process the fission products yields data
      CALL FPRYLD(LIN,LER,MAT,MT,ZA,NFP,ZAP,YLD
     1           ,PAR1,PAR2,PAR3,PAR4,PAR5 ,EGB,FRR ,MXFP,IER)
      IF(IER.GT.0) THEN
        WRITE(LTT,692) ' ERROR reading file                     ',FLNI
        GO TO 90
      END IF
      WRITE(LTT,892) MAT,IFIX(ZA+0.1)
C*
   41 CLOSE(UNIT=LIN)
C* Assign thermal x-sect. and res.int. to the list of F.P. nuclides
      DO 42 I=1,NFP
      PAR1(I)=0.
      PAR2(I)=0.
      PAR3(I)=0.
   42 CONTINUE
      IF(MTX.GT.0) CALL REACRT(LXS,LER,MTX,NFP,ZAP,PAR1,PAR2,PAR3 ,IER)
      IF(IER.NE.0) WRITE(LTT,896) IER
      CLOSE(UNIT=LXS)
C* Assign the decay data to the list of F.P. nuclides
      DO 44 I=1,NFP
      HLF (I)=0.
      IPAR(I)=0
   44 CONTINUE
      IF(IDE.GT.0) CALL DECYMD(LDY,LER,NFP,ZAP,HLF,IPAR
     1                        ,MXDK,CHR1,PAR4,PAR5 ,IER)
C* Assign capture product branching ratio for the isomer
      CALL CAPBRR(NFP,ZAP,PAR6)
C* Save the results
      WRITE(LYI,692) ' Fission product yields ENDF file     : ',FLNI
      WRITE(LYI,692) ' Decay data ENDF file                 : ',FLDY
      WRITE(LYI,692) ' INTER output file processed          : ',FLXS
      WRITE(LYI,803) ' Fission product yields             MT: ',MT0
      WRITE(LYI,803) ' Cross sections for reaction        MT: ',MTX
      WRITE(LYI,804) ' Thermal flux integral                : ',FIN(1)
      WRITE(LYI,804) ' Epithermal flux integral             : ',FIN(2)
      WRITE(LYI,804) ' Fast flux integral                   : ',FIN(3)
      WRITE(LYI,803) ' Fissile parent MAT number            : ',MAT
      WRITE(LYI,804) '                ZA  designation       : ',ZA
      WRITE(LYI,803) ' Number of fission product nuclides   : ',NFP
      WRITE(LYI,802) ' Long decay rate threshold [barn.days]: ',EPU
      WRITE(LYI,692) '        ZA     yield    T(1/2)      Sig0'
     1              ,'      R.I.        RR D      B.R.        '
      DO 48 I=1,NFP
C* Special print sequence for an extra digit in yield
c     REC=BLNK//BLNK
c     WRITE(REC,874)
c    1 ZAP(I),YLD(I),HLF(I),PAR1(I),PAR2(I),PAR3(I)
C    1,IPAR(I),PAR6(I),ZAC(I)
c     REC(12:17)=REC(11:16)
c     REC(11:11)=' '
c     WRITE(LYI,691) REC
      WRITE(LYI,874)
     1 ZAP(I),YLD(I),HLF(I),PAR1(I),PAR2(I),PAR3(I)
     1,IPAR(I),PAR6(I),ZAC(I)
C*
      NDK=MIN(MXDK,IPAR(I))
      IF(NDK.LE.0) GO TO 48
      DO 47 J=1,NDK
      WRITE(LYI,875) CHR1(J,I),PAR4(J,I),PAR5(J,I)
   47 CONTINUE
   48 CONTINUE
      CLOSE(UNIT=LYI)
      GO TO 4
C*
C* Write the results to output - label the output file
   60 WRITE(LOU,891)
      WRITE(LOU,692) ' Fission product yields ENDF file     : ',FLNI
      WRITE(LOU,692) ' Decay data ENDF file                 : ',FLDY
      WRITE(LOU,692) ' INTER output file processed          : ',FLXS
      WRITE(LOU,692)
      IF(MT0.EQ.454)
     1WRITE(LOU,803) ' Independent fission product yields MT: ',MT0
      IF(MT0.EQ.459)
     1WRITE(LOU,803) ' Cumulative fission product yields  MT: ',MT0
      IF(MTX.NE.0)
     1WRITE(LOU,803) ' Cross sections for reaction        MT: ',MTX
      WRITE(LOU,804) ' Epith.+Fast/thermal spectral ratio   : '
     1              ,(FIN(2)+FIN(3))/FIN(1)
      WRITE(LOU,804) ' Epithermal/fast spectral ratio       : '
     1              , FIN(2) / FIN(3)
      WRITE(LOU,692)
      WRITE(LOU,692) ' Reactions imply the fraction of reactio'
     1              ,'n rates on the specific fission product '
     2              ,' per unit flux (reaction=yield*aver.cros'
     2              ,'s-section).                             '
C*
      IF(ILST.EQ.1) THEN
        WRITE(LOU,692)
        WRITE(LOU,692) ' Nuclide list read from file          : ',FLLS
      ELSE
        IPU=EPU
        WRITE(LOU,692)
        WRITE(LOU,804) ' Printout constraint thresholds:        '
        IF(EPU.GT.0)
     1  WRITE(LOU,806) '   Long  decay rate thresh.[barn.days] :',IPU
        IF(EPD.GT.0)
     1  WRITE(LOU,804) '   Short decay rate thresh.[barn.days] :',EPD
        IF(EPR.GT.0)
     1  WRITE(LOU,804) '   Reaction rate thresh.       [barns] :',EPR
        IF(EPC.GT.0)
     1  WRITE(LOU,804) '   Capt.Prod.Reac.Rate thr. [barns**2] :',EPC
        IF(EPY.GT.0)
     1  WRITE(LOU,804) '   Fission product yield           [%] :',EPY
        IF(EPX.GT.0)
     1  WRITE(LOU,804) '   Cross sections(th,epith,av) [barns] :',EPX
      END IF
C*
      WRITE(LOU,892) MAT,IFIX(ZA+0.1)
      WRITE(LOU,893)
C* Label the Log-file
      WRITE(LER,692) ' Fission product yields ENDF file     : ',FLNI
      WRITE(LER,692) ' Decay data ENDF file                 : ',FLDY
      WRITE(LER,803) ' Fission product yields             MT: ',MT0
      WRITE(LER,892) MAT,IFIX(ZA+0.1)
      WRITE(LER,692)
C* Check the internal consistency of the cumulative yields data
      IF(MT0.EQ.459)
     1  CALL CHKCUM(LER,NFP,EPU,ZAP,YLD,HLF,PAR1,PAR2,PAR3,IPAR
     1             ,MXDK,PAR4,PAR5,CHR1,FIN)
C* Calculate cumulative yields if independent yields are given
      EPUC=EPU
      IF(MT0.EQ.454) THEN
        CALL YLDCUM(LER,NFP,EPU,ZAP,YLD,HLF,PAR1,PAR2,PAR3,IPAR
     1             ,MXDK,PAR4,PAR5,PAR7,PAR8,FIN)
        EPUC=0.
      END IF
C* Check the printout criteria
      IF(IFPY.EQ.1 .AND. ILST.EQ.0)
     1CALL CHKFPY(LER,NFP,ZAP,YLD,HLF,PAR1,PAR2,PAR3,IPAR,MXDK
     1           ,PAR4,PAR5,PAR6,FLAG,EPY,EPX,EPR,EPD,EPUC,EPC,FIN)
C* Loop over all fission product niclides
      NMT=0
      DO I=1,NFP
        IF(FLAG(I).LE.'9') NMT=NMT+1
      END DO
      IF(IYA.GT.0) THEN
        WRITE(LYA,803) ' Number of fission product nuclides   : ',NMT
        WRITE(LYA,692) '        ZA     yield    T(1/2)      Sig0'
     1                ,'      R.I.        RR D      B.R.        '
      END IF
      FPT=0.
      RRT=0.
      DO 65 I=1,NFP
      IF(FLAG(I).GT.'9') GO TO 65
      IZA=ZAP(I)+0.01
      IZ =IZA/1000
      IA =IZA-1000*IZ
      MM=MIN(10., 10.*(ZAP(I)-FLOAT(IZA))+1.01)
      YI =YLD(I)*100.
      XF =PAR3(I)
      RI =PAR2(I)
      XT =PAR1(I)
      XE =RI/FIN(2)
      XA =XSAV3G(XT,XE,XF,FIN)
      XX =MAX(XT,XE,XF,XA)
      RR =YLD(I)*XA
      HL =HLF(I)
C* Decay constant
      DC =0.
      IF(HL.GT.0) DC=ALOG(2.)/HL
C* Half-life in days
      HD =HL/(24.*3600)
      ND =IPAR(I)
C* Chemical symbol
        CH2='  '
        IF(IZ.GT.0 .AND. (IA.EQ.0 .OR. IA.LE.3*IZ)) CH2=CS(IZ)
C* Print record to output  (check Format 893)
      WRITE(LOU,894) IZ,CH2,IA,MX(MM),YI,XT,NINT(RI),RR,DC,FLAG(I)
C     WRITE(LOU,894) IZ,CH2,IA,MX(MM),YI,XT,NINT(RI),RR,HL,FLAG(I)
C     WRITE(LOU,894) IZ,CH2,IA,MX(MM),YI,XT,NINT(RI),RR,HD,FLAG(I)
C* Print the capture product when present in the ZAC field
      IF(ZAC(I).GT.0 .AND. PAR6(I).GT.-1.) THEN
        IZC=ZAC(I)/1000.
        IAC=ZAC(I)-1000*IZC
        CH2='  '
        IF(IZC.GT.0 .AND. (IAC.EQ.0.OR.IAC.LE.3*IZC)) CH2=CS(IZC)
        WRITE(LOU,898) 'c',1.0-PAR6(I),IZC,CH2,IAC
      END IF
C* Print the capture product when the FLAG is set
      IF(FLAG(I).EQ.'3' .OR. FLAG(I).EQ.'5') THEN
        IA1=IA+1
        ZAC(I)=IZ*1000+IA1
        WRITE(LOU,898) 'c',1.0-PAR6(I),IZ,CH2,IA1
        IF(PAR6(I).NE.0)
     1  WRITE(LOU,898) 'c',    PAR6(I),IZ,CH2,IA1,MX(2)
      END IF
      IF(IYA.GT.0)
     1WRITE(LYA,874)
     1 ZAP(I),YLD(I),HLF(I),PAR1(I),PAR2(I),PAR3(I)
     1,IPAR(I),PAR6(I),ZAC(I)
      IF(ND.LT.1) GO TO 64
      DO 63 J=1,ND
      JZA=PAR5(J,I)
      JZ =JZA/1000
      JA =JZA-1000*JZ
      JM =MIN(10., 10.*(PAR5(J,I)-FLOAT(JZA))+1.01)
      CH2='  '
      IF(JZ.GT.0 .AND. (JA.EQ.0 .OR. JA.LE.3*JZ)) CH2=CS(JZ)
      WRITE(LOU,898) CHR1(J,I),PAR4(J,I),JZ,CH2,JA,MX(JM)
      IF(IYA.GT.0)
     1WRITE(LYA,875) CHR1(J,I),PAR4(J,I),PAR5(J,I)
   63 CONTINUE
   64 FPT=FPT+YI
      RRT=RRT+RR
   65 CONTINUE
      IF(IYA.GT.0) THEN
        CLOSE(UNIT=LYA)
        IYA=0
      END IF
C     IF(NMT.GT.0) WRITE(LOU,895) NMT,FPT,RRT
      IF(NMT.GT.0) WRITE(LOU,895) NMT
C* Write the yields for NJOY and in WIMS-D library format
      IF(FLWI.EQ.BLNK .OR. ZA.LE.0) GO TO 78
C* Subtract the yields from explicitly represented decay products
      DO 75 I=1,NFP
      IF(FLAG(I).LE.'0' .OR. FLAG(I).GT.'9') GO TO 75
      IF(IPAR(I).LE.0) GO TO 75
      K  =I
      JD =0
      YDI=YLD(K)
C* Next nuclide
   71 ND =IPAR(K)
      IF(ND.LE.0) GO TO 72
C*     Check for nearly stable nuclides
      XA =XSAV3G(PAR1(K),PAR2(K)/FIN(2),PAR3(K),FIN)
      HL =HLF(K)/(3600. * 24.)
      IF(XA.GT.0) HL=XA*HL
      IF(EPU.GT.0 .AND. HL.GT.EPU) GO TO 72
        IF (JD .GE. MXST) THEN
          WRITE(LTT,884) JD, ZAP(I)
          NDDP(JD)=0
          GO TO 72
        END IF
C* If decaying, increase level JD
        JD=JD+1
        NDDP(JD)=ND
        NDDK(JD)=K
        YDDP(JD)=YDI
C* NDDP contains No. of remaining decay products in level JD
   72 J =NDDP(JD)
      K =NDDK(JD)
      IF(J.LT.1) THEN
C* No more decay products in this level - decrease level
        JD=JD-1
        IF(JD.LT.1) GO TO 75
        GO TO 72
      END IF
      YDI=YDDP(JD)
      NDDP(JD)=J-1
C* Process the yield for this nuclide
      YDI=YDI*PAR4(J,K)
      ZAM=PAR5(J,K)
      CALL SRCIDX(NFP,ZAP,ZAM,KK)
      IF(ABS(ZAP(KK)-ZAM).GT.0.05) THEN
        WRITE(LTT,886) ZAM,YDI,PAR4(J,K)
        GO TO 72
      END IF
      K=KK
      IF(FLAG(K).GT.'0' .AND. FLAG(K).LE.'9') THEN
        YLD(K)=MAX(0., YLD(K)-YDI)
      END IF
      GO TO 71
   75 CONTINUE
      DO I=1,8
        PAR8(I)=0.
      END DO
      NP=8
      AMW=ZA
      DO 77 I=1,NFP
      IF(ABS(ZAP(I)-ZA).LT.0.01) AMW=AMT(I)
      IF(FLAG(I).LE.'0' .OR. FLAG(I).GT.'9') GO TO 77
      PAR8(NP+1)=YLD(I)
      PAR8(NP+2)=AMT(I)
      NP=NP+2
   77 CONTINUE
      ICH=1
      ISTOP=0
      FLNJ=BLNK
      DO WHILE (ISTOP.NE.1)
        IF(FLNO(ICH:ICH).NE.'.') THEN
          FLNJ(ICH:ICH)=FLNO(ICH:ICH)
          ICH=ICH+1
        ELSE IF (FLNO(ICH+1:ICH+1).EQ.'.') THEN
          FLNJ(ICH:ICH)=FLNO(ICH:ICH)
          ICH=ICH+1
          FLNJ(ICH:ICH)=FLNO(ICH:ICH)
          ICH=ICH+1
        ELSE
          ISTOP=1
          FLNJ(ICH:ICH)=FLNO(ICH:ICH)
          FLNJ(ICH+1:ICH+1)='N'
          FLNJ(ICH+2:ICH+2)='J'
          FLNJ(ICH+3:ICH+3)='B'
        ENDIF
        IF (ICH.GT.37) THEN
          FLNJ='AVRFPY.NJB'
          ISTOP=1
        ENDIF
      END DO
      OPEN (UNIT=LWI,FILE=FLWI,STATUS='UNKNOWN')
      PAR8(2)=AMW
      WRITE(LWI,809) NP
      WRITE(LWI,808) (PAR8(J),IFIX(PAR8(J+1)),J=1,NP,2)
      CLOSE(UNIT=LWI)
C* Write the fission product yields for NJOY input
      OPEN (UNIT=LNJ,FILE=FLNJ,STATUS='UNKNOWN')
      WRITE(LNJ,807) NP/2,0.
      WRITE(LNJ,807) (IFIX(PAR8(J+1)),PAR8(J),J=9,NP,2)
      CLOSE(UNIT=LNJ)
C*
C* Sort and list the rejected nuclides
   78 K=0
      DO 79 I=1,NFP
      IF(FLAG(I).LE.'9') GO TO 79
      K=K+1
      ZAP(K)=ZAP(I)
      FLAG(K)=FLAG(I)
   79 CONTINUE
      IF(K.GT.0) THEN
        WRITE(LER,688)
        WRITE(LER,689) (ZAP(I),FLAG(I),I=1,K)
      END IF
      WRITE(LTT,692)
      WRITE(LTT,803) ' Total number of fission products     : ',NFP
      WRITE(LTT,803) ' Number of nuclides printed           : ',NMT
      WRITE(LTT,803) ' Number of nuclides skipped           : ',K
      GO TO 90
C* Processed F.P. yields file comparison
   80 WRITE(LOU,891)
      WRITE(LOU,692)
      WRITE(LOU,692) ' REFERENCE data file                  : ',FLYI
      WRITE(LOU,692) ' COMPARED  data file                  : ',FLYA
      WRITE(LOU,692)
      WRITE(LOU,692) ' The reference data are quoted, followed'
     1              ,' by the compared data, expressed        '
      WRITE(LOU,692) ' as % difference where relevant.        '
      WRITE(LOU,692)
C*
      WRITE(LOU,692) ' Fission product yields ENDF file     : ',FLNI
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
      WRITE(LOU,692) ' Decay data ENDF file                 : ',FLDY
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
      WRITE(LOU,692) ' INTER output file processed          : ',FLXS
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
      WRITE(LOU,803) ' Fission product yields             MT: ',MT0
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
      WRITE(LOU,803) ' Cross sections for reaction        MT: ',MTX
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
      WRITE(LOU,804) ' Thermal flux integral                : ',FIN(1)
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
      WRITE(LOU,804) ' Epithermal flux integral             : ',FIN(2)
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
      WRITE(LOU,804) ' Fast flux integral                   : ',FIN(3)
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
      WRITE(LOU,803) ' Fissile parent MAT number            : ',MAT
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
      WRITE(LOU,804) '                ZA  designation       : ',ZA
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
      WRITE(LOU,803) ' Number of fission product nuclides   : ',NFP
      READ (LYC,692) FLNM,FLNM
      WRITE(LOU,692) BLNK,FLNM
C*
      WRITE(LOU,893)
      NDF=0
   82 READ (LYC,874,ERR=82,END=88)
     1 ZAPI,YLDI,HLFI,PAR1I,PAR2I,PAR3I,IPARI,PAR6I,ZACI
      IF(ZAPI.LE.0) GO TO 82
      CALL SRCIDX(NFP,ZAP,ZAPI,I)
      IF(ABS(ZAP(I)-ZAPI).GT.0.05) GO TO 82
      IZA=ZAP(I)+0.01
      IZ =IZA/1000
      IA =IZA-1000*IZ
      MM=MIN(10., 10.*(ZAP(I)-FLOAT(IZA))+1.01)
      YI =YLD(I)*100.
      XF =PAR3(I)
      RI =PAR2(I)
      XT =PAR1(I)
      XE =RI/FIN(2)
      XA =XSAV3G(XT,XE,XF,FIN)
      RR =YLD(I)*XA
      HL =HLF(I)
C* Decay constant
      DC =0.
      IF(HL.GT.0) DC=ALOG(2.)/HL
C* Half-life in days
      HD =HL/(24.*3600.)
C*
      CHD=' '
      IF(IPAR(I).NE.0) CHD='d'
C*
      WRITE(LOU,894) IZ,CS(IZ),IA,MX(MM),YI,XT,NINT(RI),RR,DC,CHD
C     WRITE(LOU,894) IZ,CS(IZ),IA,MX(MM),YI,XT,NINT(RI),RR,HL,CHD
C     WRITE(LOU,894) IZ,CS(IZ),IA,MX(MM),YI,XT,NINT(RI),RR,HD,CHD
      RRI=YLDI*XSAV3G(PAR1I,PAR2I/FIN(2),PAR3I,FIN)
      PYI=0.
      PXT=0.
      PRI=0.
      PRR=0.
      PHL=0.
      IF(YI.GT.0) PYI =100.*( YLDI/YLD(I)-1.)
      IF(XT.GT.0) PXT =100.*(PAR1I/XT    -1.)
      IF(RI.GT.0) PRI =100.*(PAR2I/RI    -1.)
      IF(RR.GT.0) PRR =100.*(  RRI/RR    -1.)
      IF(HL.GT.0) PHL =100.*( HLFI/HL    -1.)
C* Upper bound
      IF(PYI.GT. 9999.9) PYI = 9999.9
      IF(PXT.GT. 9999.9) PXT = 9999.9
      IF(PRI.GT. 9999.9) PRI = 9999.9
      IF(PRR.GT. 9999.9) PRR = 9999.9
      IF(PHL.GT. 9999.9) PHL = 9999.9
C* Lower bound
      IF(PYI.LT.-9999.9) PYI =-9999.9
      IF(PXT.LT.-9999.9) PXT =-9999.9
      IF(PRI.LT.-9999.9) PRI =-9999.9
      IF(PRR.LT.-9999.9) PRR =-9999.9
      IF(PHL.LT.-9999.9) PHL =-9999.9
C*
      PMX=MAX(ABS(PYI),ABS(PXT),ABS(PRI),ABS(PRR),ABS(PHL))
      CHD=' '
      IF(IPARI.NE.0) CHD='d'
      IF(PMX.GT.0.05) THEN
        WRITE(REC,897) PYI,PXT,PRI,PRR,PHL,CHD
        IF( YLDI.EQ.0 .OR. YLD(I).EQ.0) REC(12:20)='         '
        IF(PAR1I.EQ.0 .OR. XT    .EQ.0) REC(21:30)='          '
        IF(PAR2I.EQ.0 .OR. RI    .EQ.0) REC(31:40)='          '
        IF(  RRI.EQ.0 .OR. RR    .EQ.0) REC(41:50)='          '
        IF( HLFI.EQ.0 .OR. HL    .EQ.0) REC(51:60)='          '
        WRITE(LOU,691) REC
        NDF=NDF+1
      END IF
      DO 86 J=1,IPARI
      READ (LYC,875)
   86 CONTINUE
      GO TO 82
   88 WRITE(LOU,885) NDF
      CLOSE(UNIT=LOU)
      CLOSE(UNIT=LYC)
C* All data processed
   90 STOP 'AVRFPY Completed'
C*
  691 FORMAT(A80)
  692 FORMAT(2A40)
  693 FORMAT(BN,I11)
  694 FORMAT(BN,2F11.0)
  688 FORMAT(' List of rejected nuclides (ZA X) where X is the flag:'/
     1       '   U - nearly stable precursor'/
     2       '   Y - low yield'/
     3       '   X - small cross section'/
     4       '   R - small reaction rate (yield*cross-section)'/
     5       '   D - short decay time'/
     6       '   H - long-lived precursor of a stable nuclide'/
     7       '   S - small cross section of a stable nuclide'/
     8       '  ------------------------------------------------'
     8      ,'----------')
  689 FORMAT(5(F10.1,1X,A1))
  802 FORMAT(A40,1PE12.4)
  803 FORMAT(A40,I4)
  804 FORMAT(A40,F12.4)
  806 FORMAT(A40,I12)
  807 FORMAT(I6,1P,E11.4)
  808 FORMAT(3(1P,E15.7,I6))
  809 FORMAT(5I15)
  812 FORMAT(A66,I4,I2,I3,I5)
  814 FORMAT(6F11.0)
  874 FORMAT(F10.2,1P,E10.4,4E10.3,I2,E10.3,0P,F8.1)
  875 FORMAT(9X,A1,1P,E10.3,0P,F10.2)
  881 FORMAT( ' Log-log interpolable weight function for F.P yields'/
     1        '     Energy     Weight'/
     2        '  --------------------')
  882 FORMAT(1P,2E11.4)
  883 FORMAT(' WARNING - Parent material MAT',I6,'    ZA',I6
     1      ,' cross sections not found'/)
  884 FORMAT(' WARNING - decay level stack exceeded',I4,' for ',F12.1)
  885 FORMAT(
     3'  ----------------------------------------------------------',
     3'--------------------'/
     4'  Differences in',I4,' nuclides encountered')
  886 FORMAT(' WARNING - Decay product',F8.1,' yield',1P,E10.3
     1      , ' BR=',E10.3,' not in yield list')
  891 FORMAT(//' AVRFPY - Average fission product yields'/
     1         ' ======================================='/)
  892 FORMAT(/' Parent material MAT',I6,'    ZA',I6
     1       ,'  F.P. yields processed')
C...Print decay constant in [s-1]
  893 FORMAT(/
     1'               Yield   Sig(th)  Res.Int. Reactions Dcy.const',
     1' D     BR   Product'/
     2'    Isotope      [%]    [barn] [barn.eV] [n/s/cm3]   [s-1]  '/
     3'  ----------------------------------------------------------',
     3'--------------------')
C...Print half-life in [s]
C 893 FORMAT(/
C    1'               Yield   Sig(th)  Res.Int. Reactions Half life',
C    1' D     BR   Product'/
C    2'    Isotope      [%]    [barn] [barn.eV] [n/s/cm3]     [s]  '/
C    3'  ----------------------------------------------------------',
C    3'--------------------')
C...Print half-life in [days]
C 893 FORMAT(/
C    1'               Yield   Sig(th)  Res.Int. Reactions Half life',
C    1' D     BR   Product'/
C    2'    Isotope      [%]    [barn] [barn.eV] [n/s/cm3]   [days] '/
C    3'  ----------------------------------------------------------',
C    3'--------------------')
C...
  894 FORMAT(I4,'-',A2,'-',I3,A2,F7.5,F10.1,I10,F10.2,1P,E10.3,1X
     1      ,A1,0P,F7.4,I3,'-',A2,'-',I3,A2)
  895 FORMAT(
     3'  ----------------------------------------------------------',
     3'--------------------'/
     4'  Tot.',I5,2X,F7.3,20X,F10.2)
  896 FORMAT(' Cross sections for',I4,' nuclides processed')
  897 FORMAT(11X,F8.1,'%',4(F9.1,'%'),1X,A1)
  898 FORMAT(61X,A1,F7.4,I3,'-',A2,'-',I3,A2)
      END
      SUBROUTINE FLXPNT(NG,EGB,FRR,FIN,IER)
C-Title  : FLXPNT Subroutine
C-Purpose: Determine log-log interpolable points from integral values
      DIMENSION EGB(1),FRR(1),FIN(1)
      IER=0
   10 IER=IER+1
      DO 60 IG=1,NG
      FQ =FIN(IG)
      E1 =EGB(IG)
      E2 =EGB(IG+1)
      F1 =FRR(IG)
      F2 =FRR(IG+1)
      IF(FQ.EQ.0) GO TO 60
      IF(F1.NE.0) GO TO 20
      IF(F2.EQ.0) GO TO 60
      IF(IG.EQ.1) IER=0
C* Iterate on the lower point to match the average (log-log)
      F1 = F2*E2/E1
      Q  = F1*E1*ALOG(E2/E1)
      IF(Q-FQ.EQ.0) GO TO 18
      IF(Q-FQ.LT.0) GO TO 14
C*      Iteration sequence on F1 (case: B+1<0)
      F1 = 0.5*F1
   12 F  = F1
      B  =(E2*F2-E1*F )/FQ - 1.
      F1 = F2*(E1/E2)**B
      IF(ABS(F1-F).GT.1E-5*F) GO TO 12
      GO TO 18
C*      Iteration sequence on B  (case: B+1>0)
   14 F1 = 1.5*F1
      AE = ALOG(E2/E1)
   16 F  = F1
      B  = ALOG(F2/F )/AE
      F1 =(E2*F2-FQ*(B+1.))/E1
      IF(ABS(F1-F).GT.1E-5*F) GO TO 16
   18 FRR(IG)=F1
      GO TO 60
C* Iterate on the upper point to match the average (log-log)
   20 IF(F2.NE.0) GO TO 60
      IF(F1.EQ.0) GO TO 60
      IF(IG.EQ.1) IER=0
      F2 = F1*E1/E2
      Q  = F1*E1*ALOG(E2/E1)
      IF(Q-FQ.EQ.0) GO TO 28
      IF(Q-FQ.LT.0) GO TO 24
C*      Iteration sequence on F2 (case: B+1<0)
      F2 = 0.5*F2
   22 F  = F2
      B  =(E2*F -E1*F1)/FQ - 1.
      F2 = F1*(E2/E1)**B
      IF(ABS(F2-F).GT.1E-5*F) GO TO 22
      GO TO 28
C*      Iteration sequence on B  (case: B+1>0)
   24 F2 = 1.5*F2
      AE = ALOG(E2/E1)
   26 F  = F2
      B  = ALOG(F /F1)/AE
      F2 =(E1*F1+FQ*(B+1.))/E2
      IF(ABS(F2-F).GT.1E-5*F) GO TO 26
   28 FRR(IG+1)=F2
   60 CONTINUE
      IF(IER.GT.0 .AND. IER.LT.NG) GO TO 10
      RETURN
      END
      FUNCTION XSAV3G(XT,XE,XF,FIN)
C-Title  : XSAV3G Function
C-Purpose: Calculate average from 3-group cross sections
      DIMENSION FIN(*)
      FF=FIN(1)+FIN(2)+FIN(3)
      XSAV3G =(XT*FIN(1) + XE*FIN(2) + XF*FIN(3))/FF
      RETURN
      END
      SUBROUTINE CHKFPY(LER,NFP,ZAP,YLD,HLF,XTH,RIN,XFS,NDK,MXDK,BRR,ZAD
     1                 ,BRC,FLAG,EPY,EPX,EPR,EPD,EPU,EPC,FIN)
C-Title  : CHKFPY Subroutine
C-Purpose: Set flag for nuclides which violate the selection criteria
C-Description:
C-D  FIRST LOOP
C-D  - Check for nearly-stable nuclides and remove their contribution
C-D    from the cumulative yield of the decay product.
C-D    Nearly-stable nuclides are those for which the product of
C-D    their average cross section [barns] and half-life [days]
C-D    exceeds EPU. If the cross section is not known, it is
C-D    assumed 1 barn.
C-D  SECOND LOOP
C-D  The following conditions define nuclides eligible for printout:
C-D  1. Nuclides with yields greater than EPY
C-D  2. Nuclides with large cross sections (x-sect > EPX)
C-D  3. (Not defined)
C-D  4. Nuclides with high capture reaction rates:
C-D     - not short-lived, (x-sect*half-life > EPD)
C-D     - high yield and capture cross section
C-D       (yield*x-sect > EPR)
C-D  5. Nuclides with high cross sections capture products
C-D     - not short-lived, (x-sect*half-life > EPD)
C-D     - high yield and high capture cross sections of both
C-D       the parent and the capture product
C-D       (yield*x-sect-parent*x-sect-product > EPC)
C-D     Isomer production on capture is taken into account.
C-D  8. Capture products from item 5.
C-
      CHARACTER*1 FLG,    FLAG(*)
      DIMENSION   ZAP(*), YLD(*), HLF(*), XTH(*), RIN(*), XFS(*)
     1           ,BRC(*), NDK(*), BRR(MXDK,*)   , ZAD(MXDK,*), FIN(*)
C*
C* Process "nearly stable" nuclides
      DO 28 I=1,NFP
C* Preset the printout flag
      FLAG(I)='0'
      IF(EPU.LE.0) GO TO 28
C* Remove contribution from the cumulative yields of decay products
      XA =XSAV3G(XTH(I),RIN(I)/FIN(2),XFS(I),FIN)
      HL =HLF(I)/(3600. * 24.)
      IF(XA.GT.0) HL=XA*HL
      IF(HL.LE.EPU) GO TO 28
C* Loop over the decay products
      ND =MIN(MXDK, NDK(I))
      IF(ND.LE.0) GO TO 28
      DO 26 J=1,ND
      ZAM=ZAD(J,I)
      IF(ZAM.LE.0) GO TO 26
      CALL SRCIDX(NFP,ZAP,ZAM,K)
      IF(ABS(ZAP(K)-ZAM).GT.0.5) GO TO 26
      BY=BRR(J,I)*YLD(I)
      YI=YLD(K)-BY
C* Remove the decay product from the direct contribution
      IF(YI.GT.-1.E-5*YLD(I)) GO TO 22
        WRITE(LER,94) ZAP(I),YLD(I),HLF(I),ZAP(K),YLD(K)
        GO TO 26
   22 YLD(K) =MAX(0., YI)
      IF(YLD(K).LT.0.01*YLD(I)) FLAG(K)='U'
      XA =XSAV3G(XTH(K),RIN(K)/FIN(2),XFS(K),FIN)
      HK =HLF(K)/(3600. * 24.)
      IF(XA.GT.0) HK =XA*HK
C* Check if decay product itself is unstable
      IF(HK.GT.EPD) GO TO 26
      KD =MIN(MXDK, NDK(K))
C* Apply corrections on one more level of decay products
      DO 24 M=1,KD
      ZAM=ZAD(M,K)
      IF(ZAM.LE.0) GO TO 24
      CALL SRCIDX(NFP,ZAP,ZAM,L)
      IF(ABS(ZAP(L)-ZAM).GT.0.5) GO TO 24
      BY=BRR(M,K)*BY
      YI=YLD(L)-BY
C* Remove the decay product from the direct contribution
      IF(YI.GT.-1.E-5*YLD(K)) THEN
        YLD(L) =MAX(0., YI)
      ELSE
        WRITE(LER,94) ZAP(K),YLD(K),HLF(K),ZAP(L),YLD(L)
      END IF
   24 CONTINUE
   26 CONTINUE
   28 CONTINUE
C*
C* Check the printout criteria
   40 DO 68 I=1,NFP
      YI =YLD(I)*100.
      XT =XTH(I)
      XE =RIN(I)/FIN(2)
      XF =XFS(I)
      XA =XSAV3G(XT,XE,XF,FIN)
      XX =MAX(XT,XE,XF,XA)
      RR =YLD(I)*XA
      HI =HLF(I)/(3600. * 24.)
      IF(XA.GT.0) HI=XA*HI
      ND =NDK(I)
      FLG=FLAG(I)
C* Check if a specific print request has already been issued
      IF(FLG.GT.'0' .AND. FLG.LE.'9') GO TO 68
C* 1.: Test on high yield
      IF(EPY.LE.0) GO TO 42
      IF( YI.GT.EPY) THEN
        FLAG(I)='1'
      ELSE
        FLG='Y'
      END IF
C* 2.: Test on high cross sections
   42 IF(EPX.LE.0) GO TO 52
      IF( XA.GE.EPX) THEN
        FLAG(I)='2'
      ELSE
        FLG='X'
      END IF
C* 4.: Test on high capture reaction rate
   52 IF(EPR.LE. 0 ) GO TO 53
C*     Exclude short-lived products
      IF(HI.GT.0 .AND. HI.LT.EPD) THEN
        FLG='D'
        GO TO 53
      END IF
      IF( RR.GE.EPR) THEN
        FLAG(I)='4'
      ELSE
        FLG='R'
      END IF
C* 5.: Test on high capture reaction rate of the capture product
   53 IF(EPC.LE.0) GO TO 65
      RL =RR
      HL =HI
      L  =I
   54 ZAM=IFIX(ZAP(L))+1
   55 CALL SRCIDX(NFP,ZAP,ZAM,K)
      IF(ABS(ZAP(K)-ZAM).GT.0.5) GO TO 65
        XC =XSAV3G(XTH(K),RIN(K)/FIN(2),XFS(K),FIN)
        RC =RL*XC
        HC =HLF(K)/(3600. * 24.)
        IF(XC.GT.0) HC=XC*HC
        IF(RC.GE.EPC .AND. (HC.LE.0 .OR. HC.GT.EPD)) THEN
          FLAG(L)='5'
          FLAG(K)='8'
C*      Isomer production on capture
          IF(BRC(L).NE.0 .AND. ZAM-ZAP(L)-1.LT.0.05) THEN
            ZAM=ZAM+0.1
            GO TO 55
          END IF
          RL =YLD(I)*XC
          HL =HC
          L  =K
          GO TO 54
        END IF
   65 IF(FLAG(I).LE.'0' .OR. FLAG(I).GT.'9') FLAG(I)=FLG
   68 CONTINUE
C* All criteria checked
   90 RETURN
   94 FORMAT(' WARNING - Inconsistent yields for ZA',0P,F8.1
     1      ,' yield',1P,E10.3,' Th[s]',E10.3/
     2       '                 and decay product ZA',0P,F8.1
     2      ,' yield',1P,E10.3)
      END
      SUBROUTINE YLDCUM(LER,NFP,EPU,ZAP,YLD,HLF,XTH,RIN,XFS,MDD
     1                 ,MXDK,BRR,ZAD,YL1,YL2,FIN)
C-Title  : YLDCUM Subroutine
C-Purpose: Calculate cumulative F.P yields from independent yields
      DIMENSION  MDD(*), ZAP(*), YLD(*), HLF(*), XTH(*), RIN(*), XFS(*)
     1          ,YL1(*), YL2(*), BRR(MXDK,*),    ZAD(MXDK,*),    FIN(*)
C* Clear the scratch yields arrays
      DO 20 I=1,NFP
      YL1(I)=0.
      YL2(I)=0.
   20 CONTINUE
C* Process direct decay products
      DO 40 I=1,NFP
      ND = MIN(MXDK,MDD(I))
      YI = YLD(I)
      XA =XSAV3G(XTH(I),RIN(I)/FIN(2),XFS(I),FIN)
      HL = HLF(I)/(3600. * 24.)
      IF(XA.GT.0) HL=XA*HL
      IF(HL.LE.0 .OR. (HL.GT.EPU .AND. EPU.GT.0)) GO TO 40
      IF(ND.LT.1) GO TO 40
      DO 24 J=1,ND
      BR = BRR(J,I)
      ZAM= ZAD(J,I)
      IF(ZAM.LE.0) GO TO 24
      CALL SRCIDX(NFP,ZAP,ZAM,K)
      IF(ABS(ZAP(K)-ZAM).GT.0.5) GO TO 24
      YL1(K)=YL1(K)+BR*YI
   24 CONTINUE
   40 CONTINUE
C* Process secondary decay products
   50 ID =  0
      DO 60 I=1,NFP
      YI = YL1(I)
      IF(YI.LE.0) GO TO 60
      ND = MIN(MXDK,MDD(I))
      XA =XSAV3G(XTH(I),RIN(I)/FIN(2),XFS(I),FIN)
      HL = HLF(I)/(3600. * 24.)
      IF(XA.GT.0) HL=XA*HL
      YL1(I)=0.
      YLD(I)=YLD(I)+YI
      IF(ND.LE.0) GO TO 60
      IF(HL.LE.0 .OR. (HL.GE.EPU .AND. EPU.GT.0)) GO TO 60
C* Case: Calculate yields of secondary decay products
      DO 56 J=1,ND
      BR = BRR(J,I)
      ZAM= ZAD(J,I)
      IF(ZAM.LE.0) GO TO 56
      CALL SRCIDX(NFP,ZAP,ZAM,K)
      IF(ABS(ZAP(K)-ZAM).GT.0.5) GO TO 56
C*       Guard against erroneous data
      IF(K.EQ.I) THEN
        WRITE(LER,94) ZAM
        GO TO 56
      END IF
      YL2(K)=YL2(K)+BR*YI
      ID =ID+1
   56 CONTINUE
   60 CONTINUE
C* Prepare for the next generation of decay products
      DO 62 I=1,NFP
      YL1(I)=YL2(I)
      YL2(I)=0.
   62 CONTINUE
C* Repeat the procedure if more daughter product generations exist
      WRITE(LER,96) ID
      IF(ID.NE.0) GO TO 50
      RETURN
   94 FORMAT(' WARNING - Erroneous decay data for ZA',F8.1)
   96 FORMAT(' Number of secondary daughter-products',I5)
      END
      SUBROUTINE CHKCUM(LER,NFP,EPU,ZAP,YLD,HLF,XTH,RIN,XFS,MDD
     1                 ,MXDK,BRR,ZAD,DKM,FIN)
C-Title  : CHKCUM Subroutine
C-Purpose: Check the consistency of the cumulative F.P yields
      PARAMETER  (MXP=10)
      CHARACTER*1 RC(10)  ,RCK(MXP),DKM(MXDK,*)
      DIMENSION   ZAK(MXP),YLK(MXP),BRK(MXP),HLK(MXP)
      DIMENSION   MDD(*), ZAP(*), YLD(*), HLF(*), XTH(*), RIN(*), XFS(*)
     1           ,BRR(MXDK,*), ZAD(MXDK,*), FIN(*)
      DATA RC/'g','b','+','I','a','n','F','p','8','x'/
C* Process each fission product
      DO 60 I=1,NFP
      ZAM= ZAP(I)
      YI = YLD(I)
      YK = 0.
      NP = 0
      DO 40 K=1,NFP
      ND = MIN(MXDK,MDD(K))
      IF(ND.LE.0) GO TO 40
      DO 24 J=1,ND
      ZAJ= ZAD(J,K)
      IF(ZAJ.LE.0) GO TO 24
      IF(ABS(ZAJ-ZAM).GT.0.05) GO TO 24
        XA =XSAV3G(XTH(K),RIN(K)/FIN(2),XFS(K),FIN)
        HL = HLF(K)/(3600. * 24.)
        IF(XA.GT.0) HL=XA*HL
        IF(HL.LE.0 .OR. (HL.GT.EPU .AND. EPU.GT.0)) GO TO 24
        YK = YK + YLD(K)*BRR(J,K)
        IF(NP.GE.MXP) GO TO 24
        NP=NP+1
        ZAK(NP)=ZAP(K)
        YLK(NP)=YLD(K)
        HLK(NP)=HLF(K)
        BRK(NP)=BRR(J,K)
        RCK(NP)=DKM(J,K)
   24 CONTINUE
   40 CONTINUE
      IF(YK.LE.YI) GO TO 60
      ER=999.99
      IF(YI.GT. 0) ER=MIN(ER, 100.*(YK/YI-1.))
      IF(ER.LT.0.01) GO TO 60
      WRITE(LER,94) ZAM,YI,ER
      IF(NP.LT. 1) GO TO 60
      DO 52 J=1,NP
      WRITE(LER,96) ZAK(J),YLK(J),HLK(J),RCK(J),BRK(J)
   52 CONTINUE
   60 CONTINUE
      RETURN
   94 FORMAT(' WARNING - ZA',F8.1,' yield',1P,E10.3
     1      ,' cumulative yield inconsistent',0P,F6.2,'%')
   96 FORMAT('    precursor',F8.1,' yield',1P,E10.3
     1      ,' T(1/2)',E10.3,' React. ',A1,' BR',0P,F8.5)
      END
      SUBROUTINE DECYMD(LDY,LER,NFP,ZAP,HLF,NDK,LDK,DKM,BRR,ZAD,IER)
C-Title  : DECYMD Subroutine
C-Purpose: Assign the decay data to the list of F.P. nuclides
      PARAMETER   (MXDK=10)
      CHARACTER*1  RC(MXDK), DKM(LDK,*)
      DIMENSION    BR(MXDK),MD(MXDK),IZAP(MXDK),IZOP(MXDK)
      DIMENSION    BRR(LDK,*),ZAD(LDK,*), ZAP(*),HLF(*),NDK(*)
      DATA RC/'g','b','+','I','a','n','F','p','8','x'/
   10 MAT=0
      IZA=-1
      LIZ=-1
      IZO=-1
      CALL IZADCY(LDY,MAT,IZA,LIZ,IZO,HL,ND,BR,MD,IZAP,IZOP,MXDK,IEF)
      ZAM =FLOAT(IZA)+0.1*FLOAT(IZO)
      IF(IEF.GE.10) GO TO 90
C* Find the index of the current nuclide on the list
      CALL SRCIDX(NFP,ZAP,ZAM,K)
      IF(ABS(ZAP(K)-ZAM).GT.0.05) GO TO 10
C* Transfer the data to the output array
      NDK(K)=ND
      HLF(K)=HL
      ND=MIN(LDK, ND)
      DO I=1,ND
        JR=MIN(MXDK,MD(I)+1)
        DKM(I,K)=RC(JR)
        BRR(I,K)=BR(I)
        ZAD(I,K)=FLOAT(IZAP(I))+0.1*FLOAT(IZOP(I))
      END DO
      IF(IEF.LT.10) GO TO 10
C* All file processed
   90 IER=0
      IF(IEF.GE.20) IER=-1
      RETURN
      END
      SUBROUTINE IZADCY(LIN,MAT0,IZA0,LIZ0,IZO0
     1                 ,HLF,NDK,BRR,MDD,IZAP,IZOP,MXDK,IER)
C-Title  : IZADCY Subroutine
C-Purpose: Assign decay modes to the selected nuclide
      CHARACTER*66   REC
      DIMENSION      BRR(1), MDD(1), IZAP(1), IZOP(1)
   20 READ (LIN,622,END=92,ERR=93) REC,MAT,MF,MT
      IF(MAT.LT.0) GO TO 91
C* Find the decay data
      IF(MF.NE.8 .OR. MT.NE.457) GO TO 20
      READ (REC,623) ZA,AWR,LIZ,IZO
      IZA = ZA+0.1
C* Skip if not the right material
      IF(MAT0.LT.0) GO TO 40
      IF(IZA0.LT.0) GO TO 40
      IF(MAT0.GT.0 .AND. MAT0.EQ.MAT) GO TO 40
      IF(IZA0.GT.0 .AND. IZA0.EQ.IZA) GO TO 40
      IF(LIZ0.GE.0 .AND. LIZ0.EQ.LIZ) GO TO 40
      IF(IZO0.GE.0 .AND. IZO0.EQ.IZO) GO TO 40
   22 READ (LIN,622,END=92,ERR=93) REC,MAT,MF,MT
      IF(MAT.NE.0) GO TO 22
      GO TO 20
C* Process the decay data
   40 READ (LIN,623) HLF, DHLF, I, I, NC2, I
      READ (LIN,624) (xx,i=1,nc2)
      READ (LIN,623) SPI,PAR, I, I, I, NDK
      JDK=NDK
      IF(NDK.LE.MXDK) GO TO 41
      IER=9
      JDK=MXDK
   41 DO 42 I=1,JDK
      READ (LIN,624) RTY,RFS,QQ,DQ,BRR(I)
      IZOP(I)=NINT(RFS)
      IZAP(I)=IZA
C* Process decay type flag - allow up to 4 digits
      ITYI=NINT(RTY*1000)
      ITYO=1
      DO WHILE (ITYI.GT.0)
C*      Consider last digit of the decay type flag
        ITY =ITYI-10*(ITYI/10)
        ITYI=ITYI/10
        IF(ITY.GT.0) THEN
          ITYO=ITYO*10
          IF(ITY.EQ.1) IZAP(I)=IZAP(I)+1000
          IF(ITY.EQ.2) IZAP(I)=IZAP(I)-1000
          IF(ITY.EQ.3) IZAP(I)=IZAP(I)
          IF(ITY.EQ.4) IZAP(I)=IZAP(I)-2004
          IF(ITY.EQ.5) IZAP(I)=IZAP(I)-   1
          IF(ITY.EQ.7) IZAP(I)=IZAP(I)-1001
        END IF
      END DO
      ITYO=NINT(RTY*ITYO/10)
      MDD(I)=ITYO
      IF(ITYO.EQ.0) IZAP(I)=0
   42 CONTINUE
C* Skip the rest of the data for this material
   44 READ (LIN,622,END=92,ERR=93) REC,MAT,MF,MT
      IF(MAT.NE.0) GO TO 44
C* Reassign the nuclide identifiers and finish
      MAT0=MAT
      IZA0=IZA
      LIZ0=LIZ
      IZO0=IZO
      RETURN
C* Last material processed
   91 IER=10
      RETURN
C* EOF error trap
   92 IER=12
      RETURN
C* Format read error trap
   93 IER=20
      RETURN
  622 FORMAT(A66,I4,I2,I3)
  623 FORMAT(2F11.0,4I11)
  624 FORMAT(6F11.0)
      END
      SUBROUTINE REACRT(LXS,LER,MTX,NFP,ZAP,XTH,RIN,XFS ,IER)
C-Title  : REACRT Subroutine
C-Purpose: Assign cross sections to a list of nuclides
C-Version:
C-V  01/11 A.Trkov: Upgrade to support INTER 6.12 output
C-Description:
C-D  A record is read from a file, assuming it is in the INTER output
C-D  format. Version of INTER is identified from the first record.
C-D  A modification of the 6.11 format is allowed where an extra
C-D  digit is read for ZA to identify the isomer state. Records
C-D  which can not be read or where MAT number is zero are ignored
C-
      CHARACTER*120 REC
      CHARACTER*11  RCT
      DIMENSION     ZAP(1),XTH(1),RIN(1),XFS(1)
C*
      DATA RPI2/ 0.886226925 /
      NM  =0
      IZA0=0
      IVER=612
C* Try to identify the INTER version
      READ (LXS,860,END=90) REC
      IF(REC(39:51).EQ.'INTER VERSION') THEN
        READ (REC(52:56),864,ERR=42) VER
        IVER=NINT(VER*100)
C* Position the file to the beginning of the data
   30   READ (LXS,860,END=90) REC
        IF(IVER.GE.612) THEN
          IF(REC(1:16).NE.' Material number') GO TO 30
          READ (REC(26:31),865) MAT
        ELSE
          IF(REC(1:16).NE.'  MAT    ZA    M') GO TO 30
        END IF
      ELSE
C* Header record missing - assume INTER Version 6.12 or higher
        GO TO 42
      END IF
C* Process each entry in turn on the INTER output file
   40 READ (LXS,860,END=90) REC
   42 IF(REC(1:20).EQ.'                    ') GO TO 40
      IF(IVER.GE.612) THEN
        IF(REC(1:16).EQ.'  Z    A  LISO  ') GO TO 40
        IF(REC(1:16).EQ.' Material number') THEN
          READ (REC(26:31),865) MAT
          GO TO 40
        END IF
        READ (REC,861) IZ,IA,LIS0,LFS,MT,RCT,SG0,SE0,STH,GWE,RI,SFS,S14
        IZA=IZ*10000+IA*10+LIS0
        ZA =IZA*0.1
        ZAM=ZA
        STH=STH*RPI2
      ELSE
C* Assume format INTER 6.11 - read all records that conform to format
        IF(REC(13:13).EQ.' ') THEN
C*        INTER 6.11 regular format (ZA)
          READ (REC,862,ERR=40) MAT,ZA,MT,RCT,SG0,SE0,STH,GWE,RI,SFS,S14
        ELSE
C*        INTER 6.11 MODIFIED format (ZA.m with decimal isomer state m)
          READ (REC,863,ERR=40) MAT,ZA,MT,RCT,SG0,SE0,STH,GWE,RI,SFS,S14
        END IF
        IF(MAT.LE. 0 ) GO TO 40
        IZA=NINT(ZA*10)
      END IF
C* Test for the specified MT number
      IF( MT.NE.MTX) GO TO 40
C* If same ZA consecutively for this MT, assume it is an isomer
      IF(IVER.LT.612 .AND. IZA.EQ.IZA0) THEN
        ZAM =ZAM+0.1
      ELSE
        ZAM =ZA
        IZA0=NINT(ZA*10)
      END IF
C* Find the index of the current nuclide on the list
      CALL SRCIDX(NFP,ZAP,ZAM,K)
C* Isomer data are approximated by the ground-state data
      IF(ABS(ZAP(K)-ZAM).GT.0.5) GO TO 40
C* Enter the thermal x-sect. and res.int. into the output array
      XTH(K)=STH
      RIN(K)=RI
      XFS(K)=SFS
      NM =NM+1
      GO TO 40
C* End-of-file check
   90 IER=0
      IF(NM.NE.NFP) IER=NM
      IF(NM.LE.0)   IER=-1
      RETURN
  860 FORMAT(A120)
  861 FORMAT(I4,I5,I4,2I5,1X,A11,2F12.0,F11.0,F8.0,F13.0,2F12.0)
  862 FORMAT(I5,F7.0,I4,A11,2E12.5,E11.4,F8.5,E13.5,2E12.5)
  863 FORMAT(I5,F8.1,I4,A11,2E12.5,E11.4,F8.5,E13.5,2E12.5)
  864 FORMAT(F5.0)
  865 FORMAT(I5.0)
      END
      SUBROUTINE SRCIDX(N,X,R,K)
C-Title  : SRCIDX
C-Purpose: Find index K in array X that most closely matches R
      DIMENSION X(1)
      K=1
      IF(N.LT.2) RETURN
      E=X(1)
      DO 40 I=2,N
      IF(ABS(X(I)-R).GT.E) GO TO 40
      K=I
      E=ABS(X(I)-R)
   40 CONTINUE
      RETURN
      END
      SUBROUTINE FPRYLD(LIN,LER,MAT,MT,ZA,NFP,ZAP,YLD,FPS
     1          ,ZAP1,YLD1,ZAP2,YLD2 ,EGB,FRR ,MXFP,IER)
C-Title  : FPRYLD Subroutine
C-Purpose: Process fission products yields ENDF file
      CHARACTER*66 REC
      DIMENSION    EGB(4)    , FRR(4)
     1            ,ZAP (MXFP), YLD (MXFP), FPS(MXFP)
     2            ,ZAP1(MXFP), YLD1(MXFP)
     3            ,ZAP2(MXFP), YLD2(MXFP)
      IER=0
C* Process the ENDF file
   20 READ (LIN,695,END=90) REC,MAT0,MF0,MT0
C*      Check the MAT,MF,MT numbers
      IF(MAT0.LT.0) GO TO 90
      IF(MAT0.NE.MAT .AND. MAT.GT. 0 ) GO TO 20
      IF( MF0.NE.8) GO TO 20
      IF( MT0.NE.454  .AND.  MT0.NE.459) GO TO 20
      IF( MT0.NE.MT   .AND.  MT .GT.  0) GO TO 20
      IF( ZA.EQ.0) GO TO 32
C*      Check the ZA number
      READ (REC,696) ZA0,AWR,NE
      IF(ABS(ZA0-ZA).LT.0.5) GO TO 32
C*      In case if an incorrect ZA number skip to the end of material
   22 READ (LIN,695,END=90) REC,MAT0,MF0,MT0
      IF(MAT0.NE.0) GO TO 22
      GO TO 20
C* Fission product yields data found
   32 MAT=MAT0
      MT =MT0
      READ (REC,696) ZA,AWR,NE
      READ (LIN,696) EN,DD ,INT,II,II,NFP
      IF(NFP.GT.MXFP) STOP 'AVRFPY ERROR - Array capacity exceeded'
C* Read the data at the first energy point
      READ (LIN,698) (ZAP (I),FPS(I) ,YLD (I),DD,I=1,NFP)
      DO 41 I=1,NFP
      ZAP(I)=ZAP(I)+0.1*FPS(I)
      IF(I.LE.1) GO TO 41
      IF(ZAP(I-1).GE.ZAP(I)) WRITE(LER,803) ZAP(I-1),ZAP(I)
   41 CONTINUE
      CALL SRTBB2(NFP,ZAP,YLD,IES)
      IF(IES.GT.0) WRITE(LER,802) IES,EN
      SF=1.
      IF(NE.LE.1) GO TO 80
C* Save the data if more energy points present
      DO 42 I=1,NFP
      ZAP2(I)=ZAP(I)
      YLD2(I)=YLD(I)
      YLD (I)=0.
   42 CONTINUE
      NFP2=NFP
      SF=0.
      E2=EN
      JE=1
C* Read the data at the next energy point
   50 IF(JE.GE.NE) GO TO 80
      JE=JE+1
      E1=E2
      NFP1=NFP2
      DO 54 I=1,NFP1
      ZAP1(I)=ZAP2(I)
      YLD1(I)=YLD2(I)
   54 CONTINUE
      READ (LIN,696) E2,DD ,INT,II,II,NFP2
      IF(NFP2.GT.MXFP) STOP 'AVRFPY ERROR - Array capacity exceeded'
      READ (LIN,698) (ZAP2(I),FPS(I),YLD2(I),DD,I=1,NFP2)
      DO 56 I=1,NFP2
      ZAP2(I)=ZAP2(I)+0.1*FPS(I)
      IF(I.LE.1) GO TO 56
      IF(ZAP2(I-1).GE.ZAP2(I)) WRITE(LER,803) ZAP2(I-1),ZAP2(I)
   56 CONTINUE
      CALL SRTBB2(NFP2,ZAP2,YLD2,IES)
      IF(IES.GT.0) WRITE(LER,802) IES,E2
C*
C* Integral of the assumed spectrum (assume log-log interpolable)
C*   SG - spectrum contribution in the interval E1 - E2
C*   SF - total spectrum
      SG=0.
      DO 58 IG=1,3
      EA=MAX(E1, EGB(IG))
      EB=MIN(E2, EGB(IG+1))
      IF(EB.LE.EA) GO TO 58
      B =ALOG(FRR(IG+1)/FRR(IG))/ALOG(EGB(IG+1)/EGB(IG))
      B1=B+1.
      IF(ABS(B1).LT.1.E-4) THEN
        SG=SG+FRR(IG)*EA*ALOG(EB/EA)
      ELSE
        SG=SG+( EB*(EB/EGB(IG))**B - EA*(EA/EGB(IG))**B )*FRR(IG)/B1
      END IF
   58 CONTINUE
      SF=SF+SG
      I =1
      J =1
      K =1
C* Add the contribution to the average
   60 IF(K.GT.NFP) GO TO 50
      Y1=0.
      Y2=0.
      L =J
      IF(J.GT.NFP2) GO TO 62
      IF(ZAP2(L).GT.ZAP1(I)) GO TO 61
      ZP=ZAP2(J)
      Y2=YLD2(J)
      J =J+1
      GO TO 62
C* Print warning when yield at E2 for the current isotope is missing
   61 IF(LER.GT. 0) WRITE(LER,801) 2,IFIX(ZAP1(I)+0.1),E2
   62 IF(I.GT.NFP1) GO TO 64
      IF(ZAP1(I).GT.ZAP2(L)) GO TO 63
      ZP=ZAP1(I)
      Y1=YLD1(I)
      I =I+1
      GO TO 64
C* Print warning when yield at E1 for the current isotope is missing
   63 IF(LER.GT. 0) WRITE(LER,801) 1,IFIX(ZAP2(L)+0.1),E1
      ZP=ZAP2(L)
C* Weighted integral of the yield over the current energy interval
   64 Y =0.
      DO 68 IG=1,3
      EA=MAX(E1, EGB(IG  ))
      EB=MIN(E2, EGB(IG+1))
      IF(EB.LE.EA) GO TO 68
      IF(FRR(IG)*FRR(IG+1).LE.0) GO TO 68
C* Fission yields assumed log-log interpolable
C     B =ALOG(FRR(IG+1)/FRR(IG))/ALOG(EGB(IG+1)/EGB(IG))
C     B1=B+1.
C     B2=B+2.
C     A =FRR(IG)/EGB(IG)**B
C     G =(Y2-Y1)/(E2-E1)
C     C =Y1-E1*G
C     IF(ABS(B1).LT.1.E-4) THEN
C       Y = Y + C*A*ALOG(EB/EA)
C     ELSE IF(ABS(B2).LT.1.E-4) THEN
C       Y = Y + G*A*ALOG(EB/EA) - C*A*(1./EB - 1./EA)
C     ELSE
C       Y =Y + A*( (EB*G/(B+2.)+C/(B+1.))*EB**(B+1.)
C    1            -(EA*G/(B+2.)+C/(B+1.))*EA**(B+1.) )
C     END IF
C* Integral of the weighting function over the energy interval
      B =ALOG(FRR(IG+1)/FRR(IG))/ALOG(EGB(IG+1)/EGB(IG))
      B1=B+1.
      IF(ABS(B1).LT.1.E-4) THEN
        SG=FRR(IG)*EA*ALOG(EB/EA)
      ELSE
        SG=( EB*(EB/EGB(IG))**B - EA*(EA/EGB(IG))**B )*FRR(IG)/B1
      END IF
C* Fission yields assumed in histogram form
        Y =Y +Y1*SG
   68 CONTINUE
C* Check the isotope list in the master array
   70 IF(ZAP(K).EQ.ZP) GO TO 76
      IF(ZAP(K).LT.ZP) GO TO 77
C* Insert an entry in the list
      IF(NFP.GE.MXFP) STOP 'AVRFPY ERROR - Array capacity exceeded'
      DO 75 L=K,NFP
      ZAP(NFP+K-L+1)=ZAP(NFP+K-L)
      YLD(NFP+K-L+1)=YLD(NFP+K-L)
   75 CONTINUE
      ZAP(K)=ZP
      YLD(K)=0.
      NFP=NFP+1
C* Cae: Add the contribution for the current isotope
   76 YLD(K)=YLD(K) + Y
      K  =K+1
      GO TO 60
C* Case: No data for the current isotope in this interval
   77 K  =K+1
      IF(K.LE.NFP) GO TO 70
      NFP=K
      IF(NFP.GE.MXFP) STOP 'AVRFPY ERROR - Array capacity exceeded'
      ZAP(NFP)=ZP
      YLD(NFP)=Y
      IF(I.LE.NFP1 .OR. J.LE.NFP2) GO TO 60
C* Normalize by the integral of the spectrum and finish
   80 DO 81 I=1,NFP
      YLD(I)=YLD(I)/SF
   81 CONTINUE
      RETURN
C* End-of-file encountered
   90 IER=1
      RETURN
  695 FORMAT(A66,I4,I2,I3)
  696 FORMAT(2F11.0,4I11)
  698 FORMAT(6F11.0)
  801 FORMAT(' WARNING',I2,'  ZA',I6,' at',1P,E9.2,' eV missing.')
  802 FORMAT(' WARNING -',I4,' swaps at',1P,E9.2,' eV were necessary.')
  803 FORMAT(' WARNING - material',F8.1,' appears before',F8.1
     1      ,' in the F.P. yields data')
      END
      SUBROUTINE SRTBB2(N,X,Y,IER)
C-Title  : SRTBB2 Subroutine
C-Purpose: Bubble sort of arrays X,Y in ascending order of X
C-Description:
C-D  Element pairs of arrays X(i) and Y(i) of length N are sorted
C-D  in ascending order of X by the bubble sort method. On exit, IER
C-D  is the number of swap operations performed.
      DIMENSION X(1),Y(1)
      IER=0
      IF(N.LT.2) RETURN
      DO 40 K=2,N
      I=K-1
      DO 20 J=K,N
      IF(X(I).LE.X(J)) GO TO 20
      XI  =X(I)
      YI  =Y(I)
      X(I)=X(J)
      Y(I)=Y(J)
      X(J)=XI
      Y(J)=YI
      IER =IER+1
   20 CONTINUE
   40 CONTINUE
      RETURN
      END
      SUBROUTINE CAPBRR(NFP,ZAP,BRC)
C-Title  : CAPBRR Subroutine
C-Purpose: Assign capture product isomer branching ratio
C-Description:
C-D  The branching ratios for isomer production on capture should be
C-D  obtained from ENDF File-9 data but the relevant information is
C-D  usually lacking. This is an ad-hoc routine which defines the
C-D  branching ratios for some known cases.
      DIMENSION ZAP(1),BRC(1)
      DO 20 I=1,NFP
      BRC(I)=0.
C* 61-Pm-147 giving 43% 61-Pm-148m and 57% 61-Pm-148
      IF(ABS(ZAP(I)-61147.).LT.0.05) BRC(I)=0.43
   20 CONTINUE
      RETURN
      END
*deck chkspc 
      PROGRAM CHKSPC
C-Title  : CHKSPC Program
C-Purpose: Check weighting spectra in NJOY inputs
      PARAMETER    (MXPT=200,MXSP=5)
      CHARACTER*80  REC
      CHARACTER*40  FLNJ,FLPT,FLCH
      CHARACTER*6   LBL
      DIMENSION     NP1(MXSP),ENR1(MXSP,MXPT),WSP1(MXSP,MXPT)
     1             ,ENR2(MXPT),WSP2(MXPT)
C*
      DOUBLE PRECISION EG9(70),EG18(173)
C*
      DATA EG9/1.d-5,.005d0,.01d0,.015d0,.02d0,.025d0,.03d0,.035d0,      
     1 .042d0,.05d0,.058d0,.067d0,.08d0,.1d0,.14d0,.18d0,.22d0,.25d0,    
     2 .28d0,.3d0,.32d0,.35d0,.4d0,.5d0,.625d0,.78d0,.85d0,.91d0,.95d0,  
     3 .972d0,.996d0,1.02d0,1.045d0,1.071d0,1.097d0,1.123d0,1.15d0,      
     4 1.3d0,1.5d0,2.1d0,2.6d0,3.3d0,4.d0,9.877d0,15.968d0,27.7d0,       
     5 48.052d0,75.501d0,148.728d0,367.262d0,906.898d0,1425.1d0,         
     6 2239.45d0,3519.1d0,5530.d0,9118.d0,1.503d4,2.478d4,4.085d4,       
     7 6.734d4,1.11d5,1.83d5,3.025d5,5.d5,8.21d5,1.353d6,2.231d6,        
     8 3.679d6,6.0655d6,1.d7/                                            
      DATA EG18/                                                         
     &1.96403d+7,1.73325d+7,1.49182d+7,1.38403d+7,1.16183d+7,1.00000d+7, 
     &8.18731d+6,6.70320d+6,6.06531d+6,5.48812d+6,4.49329d+6,3.67879d+6, 
     &3.01194d+6,2.46597d+6,2.23130d+6,2.01897d+6,1.65299d+6,1.35335d+6, 
     &1.22456d+6,1.10803d+6,1.00259d+6,9.07180d+5,8.20850d+5,6.08101d+5, 
     &5.50232d+5,4.97871d+5,4.50492d+5,4.07622d+5,3.01974d+5,2.73237d+5, 
     &2.47235d+5,1.83156d+5,1.22773d+5,1.11090d+5,8.22975d+4,6.73795d+4, 
     &5.51656d+4,4.08677d+4,3.69786d+4,2.92830d+4,2.73944d+4,2.47875d+4, 
     &1.66156d+4,1.50344d+4,1.11378d+4,9.11882d+3,7.46586d+3,5.53084d+3, 
     &5.00451d+3,3.52662d+3,3.35463d+3,2.24867d+3,2.03468d+3,1.50733d+3, 
     &1.43382d+3,1.23410d+3,1.01039d+3,9.14242d+2,7.48518d+2,6.77287d+2, 
     &4.53999d+2,3.71703d+2,3.04325d+2,2.03995d+2,1.48625d+2,1.36742d+2, 
     &9.16609d+1,7.56736d+1,6.79041d+1,5.55951d+1,5.15780d+1,4.82516d+1, 
     &4.55174d+1,4.01690d+1,3.72665d+1,3.37201d+1,3.05113d+1,2.76077d+1, 
     &2.49805d+1,2.26033d+1,1.94548d+1,1.59283d+1,1.37096d+1,1.12245d+1, 
     &9.90555d+0,9.18981d+0,8.31529d+0,7.52398d+0,6.16012d+0,5.34643d+0, 
     &5.04348d+0,4.12925d+0,4.00000d+0,3.38075d+0,3.30000d+0,2.76792d+0, 
     &2.72000d+0,2.60000d+0,2.55000d+0,2.36000d+0,2.13000d+0,2.10000d+0, 
     &2.02000d+0,1.93000d+0,1.84000d+0,1.75500d+0,1.67000d+0,1.59000d+0, 
     &1.50000d+0,1.47500d+0,1.44498d+0,1.37000d+0,1.33750d+0,1.30000d+0, 
     &1.23500d+0,1.17000d+0,1.15000d+0,1.12535d+0,1.11000d+0,1.09700d+0, 
     &1.07100d+0,1.04500d+0,1.03500d+0,1.02000d+0,9.96000d-1,9.86000d-1, 
     &9.72000d-1,9.50000d-1,9.30000d-1,9.10000d-1,8.60000d-1,8.50000d-1, 
     &7.90000d-1,7.80000d-1,7.05000d-1,6.25000d-1,5.40000d-1,5.00000d-1, 
     &4.85000d-1,4.33000d-1,4.00000d-1,3.91000d-1,3.50000d-1,3.20000d-1, 
     &3.14500d-1,3.00000d-1,2.80000d-1,2.48000d-1,2.20000d-1,1.89000d-1, 
     &1.80000d-1,1.60000d-1,1.40000d-1,1.34000d-1,1.15000d-1,1.00001d-1, 
     &9.50000d-2,8.00000d-2,7.70000d-2,6.70000d-2,5.80000d-2,5.00000d-2, 
     &4.20000d-2,3.50000d-2,3.00000d-2,2.50000d-2,2.00000d-2,1.50000d-2, 
     &1.00000d-2,6.90000d-3,5.00000d-3,3.00000d-3,1.00001d-5/            
C*
      DATA LNJ,LPT,LCH,LKB,LTT / 1, 2, 3, 5, 6 /
      DATA FLNJ/'nji.src'/
     2     FLPT/'chkspc.cur'/
     3     FLCH/'chkspc.log'/
C*
      IP1=0
      ISP=0
C*
      WRITE(LTT,902)
      WRITE(LTT,902) ' CHKSPC - Check spectra in NJOY input   '
      WRITE(LTT,902) ' ------------------------------------   '
      WRITE(LTT,902)
      WRITE(LTT,902) '$Enter the source NJI filename        : '
      READ (LKB,902) FLNJ
      WRITE(LTT,902) '$Select spectrum (0=flux, 1=current)  : '
      READ (LKB,909) ISP
C*
      OPEN (UNIT=LNJ,FILE=FLNJ,STATUS='OLD')
      OPEN (UNIT=LPT,FILE=FLPT,STATUS='UNKNOWN')
      OPEN (UNIT=LCH,FILE=FLCH,STATUS='UNKNOWN')
C* Find next input
   20 READ (LNJ,901,END=80) REC
      IF(REC(1:6).EQ.'*deck ') THEN
        WRITE(LCH, * ) REC(1:12)
        GO TO 20
      END IF
      IF(REC(1:3).NE.'-- ') GO TO 20
      IF(REC(4:4).EQ.' ')   GO TO 20
      LBL=REC(4:9)
C* Find input weighting spectrum
   22 READ (LNJ,901) REC
      IF(REC(1:6).EQ.'*deck ') THEN
        WRITE(LCH, * ) REC(1:12)
        GO TO 20
      END IF
      IF(ISP.EQ.0 .AND. REC(1:6).EQ.'groupr') GO TO 40
      IF(ISP.EQ.1 .AND. REC(1:5).EQ.'wimsr' ) GO TO 50
      GO TO 22
C* Read the flux weighting spectrum in groupr
  40  READ (LNJ,901)
      READ (LNJ, * ) MAT,IGR,IGG,IWG
      IF(ABS(IWG).NE.1) GO TO 20
      READ (LNJ,901) REC
      READ (LNJ,901) REC
      READ (LNJ,901) REC
      IF(IWG.LT.0) READ (LNJ,901) REC
      READ (LNJ,904) C1,C2,L1,L2,NR,NP2
      READ (LNJ,905) NB,IT
      READ (LNJ,906) (ENR2(J),WSP2(J),J=1,NP2)
      GO TO 60
C* Read the current weighting spectrum in wimsr
  50  READ (LNJ,901)
      READ (LNJ,901)
      READ (LNJ, * ) NG,NG1,NG2
      READ (LNJ, * ) MAT,I1,AMAT,IB
      READ (LNJ, * ) NT,NS,S0,I1,R1,MT,I2,I3,I4,I5,I6,JP1
      IF(JP1.LE.1) GO TO 20
      IF(IB.GT.0) THEN
        READ (LNJ, * ) NB
        DO 51 J=1,NB
        READ (LNJ,901)
   51   CONTINUE
      END IF
      NP2=NG1+NG2
      READ (LNJ, * ,ERR=52) (WSP2(J),J=1,NG2)
   52 READ (LNJ, * ) (WSP2(J),J=1,NP2)
C* Convert total current to current per energy
      IF(NG.EQ.69) THEN
        DO 54 J=1,NP2
C*        Energy boundaries in ascending order
          JG=NG+1-J
          ENR2(J)=    0.5*(EG9(JG+1)+EG9(JG))
          WSP2(J)=WSP2(J)/(EG9(JG+1)-EG9(JG))
   54   CONTINUE
      ELSE IF(NG.EQ.172) THEN
        DO 56 J=1,NP2
C*        Energy boundaries in descending order
          JG=J
          ENR2(J)=    0.5*(EG18(JG)+EG18(JG+1))
          WSP2(J)=WSP2(J)/(EG18(JG)-EG18(JG+1))
   56   CONTINUE
      ELSE
        STOP 'CHKSPC - not yet implemented'
      END IF
C*
C* Check the spectrum against previous entries
   60 IF(IP1.LE.0)   GO TO 70
      DO 68 K=1,IP1
      IF(NP2.NE.NP1(K)) GO TO 68
      IDIF=0
      DO 64 I=1,NP2
      IF(ABS(ENR1(K,I)/ENR2(I)-1).GT.1.E-3) IDIF=1
      IF(ABS(WSP1(K,I)/WSP2(I)-1).GT.1.E-3) IDIF=1
   64 CONTINUE
C* If spectrum matched, process next set
      IF(IDIF.EQ.0) THEN
        WRITE(LCH, * ) LBL,K,' Matched'
        GO TO 20
      END IF
   68 CONTINUE
C* Write the output spectrum
   70 IP1=IP1+1
      IF(IP1.GT.MXSP) STOP 'CHKSPC ERROR - MXSP Limit exceeded'
      WRITE(LCH, * ) LBL,IP1,' New'
      WRITE(LTT, * ) LBL,IP1
      WRITE(LPT,921) LBL
      DO 72 I=1,NP2
      WRITE(LPT,922) ENR2(I),WSP2(I)*ENR2(I)
   72 CONTINUE
      WRITE(LPT,921)
      NP1(IP1)=NP2
      DO 74 I=1,NP2
      ENR1(IP1,I)=ENR2(I)
      WSP1(IP1,I)=WSP2(I)
   74 CONTINUE
      GO TO 20
C*
   80 STOP 'CHKSPC Completed'
C*
  901 FORMAT(A80)
  902 FORMAT(2A40)
  904 FORMAT(2F11.0,4I11)
  905 FORMAT(6I11)
  906 FORMAT(6F11.0)
  909 FORMAT(BN,I10)
  921 FORMAT(A6)
  922 FORMAT(1P,2E11.3)
      END
 
*deck d2oe3b 
       PROGRAM D2OE3B
C-Title  : D2OE3B Program
C-Purpose: Summarize WLUP D2O Benchmarks
C-Version: Original code.
C-Author : A.Trkov, Institute Jozef Stefan, Ljubljana, Slovenia (2000)
C-M
C-M  Manual for Program D2OSMR
C-M  =========================
C-M  A summary of results for the WLUP heavy water reactor
C-M  benchmarks is compiled from partial outputs. The output
C-M  list files are processed:
C-M    Ex.1   ZED-2  Task-1 (2 cases)
C-M                  Task-2 (2 cases)
C-M                  Task-3 (1 case)
C-M                  Task-4 (4 cases)
C-M    Ex.2   DCA    Task-1 (6 cases)
C-M
C-M  The list files are those produced by analysing the WIMS-D
C-M  outputs with post-processing codes developed within the scope
C-M  of the WIMS-D Library Update Project (IAEA-CRP 1999-2000) by
C-M  Francisco Leszczynski.
C-M
C-M  Instructions:
C-M  The filenames for the output report file and the 5 list files
C-M  for the benchmarks described above are entered in response to
C-M  the prompt from the keyboard. Individual files may be omitted
C-M  from the analysis by entering "-" for the filename.
C-M
C-
      DIMENSION AVER(6),STDEV(6),EXPER(3,6),CALCUL(3,6),DCALC(3,6)
      DIMENSION DEXPE(6)
      CHARACTER*120 REC
      CHARACTER*40  BLNK,FLNM,FLNI(8),FLNO
      CHARACTER*10  NAME(16)
C* Filenames and logical file units
      DATA LIN,LOU,LKB,LTT / 1, 2, 5, 6 /
      DATA BLNK/'                                        '/
     1    ,FLNI/'E3.lis     '
     2    ,     '           '
     3    ,     '           '
     4    ,     '           '
     1    ,     '           '
     1    ,     '           '
     1    ,     '           '
     1    ,     '           '/
     1    ,FLNO/'D2OE3B.LST'/
C*
      DATA NAME/' EXP  3250'
     1         ,' EXP  6500'
     2         ,' EXP 10800'
     2         ,'          '
     3         ,'          '
     4         ,'          '
     4         ,'          '
     4         ,'          '
     4         ,'          '
     1         ,'          '
     1         ,'          '
     1         ,'          '
     1         ,'          '
     1         ,'          '
     1         ,'          '
     4         ,'          '/
C*
C* Define input parameters - Write banner to terminal
      WRITE(LTT,693)' D2OE3B comparison AVERAGE VALUES (Ni/Nj%)(delta%)'
      WRITE(LTT,693)' ================================================='
      WRITE(LTT,692)
C*
C* Define the output file
      WRITE(LTT,691) ' Default output filename              : ',FLNO
      WRITE(LTT,692) '$          Enter new name to redefine : '
      READ (LKB,692) FLNM
      IF(FLNM.NE.BLNK) FLNO=FLNM
C*
C* Define the output file
      IC=1
   11 WRITE(LTT,691) ' Default E3 Burnup Benchmark file  :    ',FLNI(IC)
      WRITE(LTT,692) '$          Enter new name to redefine : '
      READ (LKB,692) FLNM
      IF(FLNM.NE.BLNK) FLNI(IC)=FLNM
      IF(FLNM(1:1).NE.'-') THEN
        OPEN (UNIT=LIN,FILE=FLNI(IC),STATUS='OLD',ERR=11)
        CLOSE(UNIT=LIN)
      END IF
C*
      OPEN (UNIT=LOU,FILE=FLNO,STATUS='UNKNOWN')
      WRITE(LOU,693)' D2OE3B comparison AVERAGE VALUES (Ni/Nj%)(delta%)'
      WRITE(LOU,693)' ================================================='
      WRITE(LOU,692)
      WRITE(LOU,691) ' Processed Benchmark analysis reports : '
      IF(FLNI(1).NE.'-')
     1WRITE(LOU,691) '                              1 case  : ',FLNI(1)
      WRITE(LOU,691)
C*
      WRITE(LOU,694) '       BUP N25/N28     N26/N28     N49/N28     N40
     1/N49     N41/N49     N42/N49'
      WRITE(LOU,694) ' =================================================
     1================================'
C
C* Begin processing the E3 Benchmark
      IC=1
      OPEN (UNIT=LIN,FILE=FLNI(IC),STATUS='OLD')
   20 READ (LIN,692) REC
      IF(REC(1:10).NE.'AVERAGE VA') GO TO 20
      DO ILIN=1,9
       READ (LIN,692) REC
      ENDDO
      READ (LIN,700)(EXPER(1,IEXPE),IEXPE=1,6)
      READ (LIN,700)(CALCUL(1,IEXPE),IEXPE=1,6)
      READ (LIN,701)(DCALC(1,IEXPE),IEXPE=1,6)
      DO ILIN=1,5
       READ (LIN,692) REC
      ENDDO
      READ (LIN,700)(EXPER(2,IEXPE),IEXPE=1,6)
      READ (LIN,700)(CALCUL(2,IEXPE),IEXPE=1,6)
      READ (LIN,701)(DCALC(2,IEXPE),IEXPE=1,6)
      DO ILIN=1,9
       READ (LIN,692) REC
      ENDDO
      READ (LIN,700)(EXPER(3,IEXPE),IEXPE=1,6)
      READ (LIN,700)(CALCUL(3,IEXPE),IEXPE=1,6)
      READ (LIN,701)(DCALC(3,IEXPE),IEXPE=1,6)
      DO ILIN=1,5
       READ (LIN,692) REC
      ENDDO
      DO IEXPE=1,6
       READ (LIN,705)AVER(IEXPE),STDEV(IEXPE)
      ENDDO
C* Print the resutls for this benchmark
      DEXPE= 2.0
      DO ICASO=1,3
      WRITE(LOU,702) NAME(ICASO)
     1              ,(EXPER(ICASO,IEXPE),DEXPE(IEXPE),IEXPE=1,6)
      WRITE(LOU,702)'          '
     1              ,(CALCUL(ICASO,IEXPE),DCALC(ICASO,IEXPE),IEXPE=1,6)
      WRITE(LOU,692)
      ENDDO
      CLOSE(UNIT=LIN)
C*
      WRITE(LOU,694) ' =================================================
     1================================'
      WRITE(LOU,703) ' Average  '
     1              ,    (DEXPE(IEXPE),IEXPE=1,6)
      WRITE(LOU,704) ' Dif/St.Dv'
     1              ,(AVER(IEXPE),STDEV(IEXPE),IEXPE=1,6)
C
      CLOSE(UNIT=LOU)
C* End of file processing
  80  STOP 'D2OE3B Completed'
C*
 691  FORMAT(2A40)
 692  FORMAT(A120)
 693  FORMAT(A50)
 694  FORMAT(A77)
 700  FORMAT(10X,6F8.4)
 701  FORMAT(10X,6(2X,F6.2))
 702  FORMAT(A10,F6.3,'(',F4.1,')'
     2          ,F6.3,'(',F4.1,')'
     3          ,F6.3,'(',F4.1,')'
     4          ,F6.2,'(',F4.1,')'
     5          ,F6.3,'(',F4.1,')'
     6          ,F6.3,'(',F5.1,')' )
 703  FORMAT(A10,6X,'(',F4.1,')'
     2          ,6X,'(',F4.1,')'
     3          ,6X,'(',F4.1,')'
     4          ,6X,'(',F4.1,')'
     5          ,6X,'(',F4.1,')'
     6          ,6X,'(',F5.1,')' )
 704  FORMAT(A10,F6.2,'(',F4.1,')'
     2          ,F6.2,'(',F4.1,')'
     3          ,F6.2,'(',F4.1,')'
     4          ,F6.2,'(',F4.1,')'
     5          ,F6.2,'(',F4.1,')'
     6          ,F6.2,'(',F5.1,')' )
 705  FORMAT(11X,2F5.2)
C
      END
*deck d2osmr 
       PROGRAM D2OSMR
C-Title  : D2OSMR Program
C-Purpose: Summarize WLUP D2O Benchmarks
C-Version: Original code.
C-Author : A.Trkov, Institute Jozef Stefan, Ljubljana, Slovenia (2000)
C-M
C-M  Manual for Program D2OSMR
C-M  =========================
C-M  A summary of results for the WLUP heavy water reactor
C-M  benchmarks is compiled from partial outputs. The output
C-M  list files are processed:
C-M    Ex.1   ZED-2  Task-1 (2 cases)
C-M                  Task-2 (2 cases)
C-M                  Task-3 (1 case)
C-M                  Task-4 (4 cases)
C-M    Ex.2   DCA    Task-1 (6 cases)
C-M
C-M  The list files are those produced by analysing the WIMS-D
C-M  outputs with post-processing codes developed within the scope
C-M  of the WIMS-D Library Update Project (IAEA-CRP 1999-2000) by
C-M  Francisco Leszczynski.
C-M
C-M  Instructions:
C-M  The filenames for the output report file and the 5 list files
C-M  for the benchmarks described above are entered in response to
C-M  the prompt from the keyboard. Individual files may be omitted
C-M  from the analysis by entering "-" for the filename.
C-M
C-
      CHARACTER*120 REC
      CHARACTER*40  BLNK,FLNM,FLNI(8),FLNO
      CHARACTER*10  NAME(16)
C* Filenames and logical file units
      DATA LIN,LOU,LKB,LTT / 1, 2, 5, 6 /
      DATA BLNK/'                                        '/
     1    ,FLNI/'E1T1we6.lis'
     2    ,     'E1T2we6.lis'
     3    ,     'E1T3we6.lis'
     4    ,     'E1T4we6.lis'
     1    ,     'E2T1we6.lis'
     1    ,     '           '
     1    ,     '           '
     1    ,     '           '/
     1    ,FLNO/'D2OSMR.LST'/
C*
      DATA NAME/' ZED2T1D2O'
     1         ,' ZED2T1Air'
     2         ,' ZED2T2p24'
     2         ,' ZED2T2p40'
     3         ,' ZED2T3p24'
     4         ,' ZED2T4D22'
     4         ,' ZED2T4A22'
     4         ,' ZED2T4D28'
     4         ,' ZED2T4A28'
     1         ,'  DCAT1D22'
     1         ,'  DCAT1A22'
     1         ,'  DCAT1H22'
     1         ,'  DCAT1D25'
     1         ,'  DCAT1A25'
     1         ,'  DCAT1H25'
     4         ,'          '/
C*
C* Define input parameters - Write banner to terminal
      WRITE(LTT,691) ' D2OSMR - Summarize WLUP D2O Benchmarks '
      WRITE(LTT,691) ' ====================================== '
      WRITE(LTT,691)
C*
C* Define the output file
      WRITE(LTT,691) ' Default output filename              : ',FLNO
      WRITE(LTT,691) '$          Enter new name to redefine : '
      READ (LKB,691) FLNM
      IF(FLNM.NE.BLNK) FLNO=FLNM
C*
C* Define the output file
      IC=1
   11 WRITE(LTT,691) ' Default ZED-2 Task 1 Benchmark file  : ',FLNI(IC)
      WRITE(LTT,691) '$          Enter new name to redefine : '
      READ (LKB,691) FLNM
      IF(FLNM.NE.BLNK) FLNI(IC)=FLNM
      IF(FLNM(1:1).NE.'-') THEN
        OPEN (UNIT=LIN,FILE=FLNI(IC),STATUS='OLD',ERR=11)
        CLOSE(UNIT=LIN)
      END IF
      IC=2
   12 WRITE(LTT,691) ' Default ZED-2 Task-2 Benchmark file  : ',FLNI(IC)
      WRITE(LTT,691) '$          Enter new name to redefine : '
      READ (LKB,691) FLNM
      IF(FLNM.NE.BLNK) FLNI(IC)=FLNM
      IF(FLNM(1:1).NE.'-') THEN
        OPEN(UNIT=LIN,FILE=FLNI(IC),STATUS='OLD',ERR=12)
        CLOSE(UNIT=LIN)
      END IF
      IC=3
   13 WRITE(LTT,691) ' Default ZED-2 Task 3 Benchmark file  : ',FLNI(IC)
      WRITE(LTT,691) '$          Enter new name to redefine : '
      READ (LKB,691) FLNM
      IF(FLNM.NE.BLNK) FLNI(IC)=FLNM
      IF(FLNM(1:1).NE.'-') THEN
        OPEN(UNIT=LIN,FILE=FLNI(IC),STATUS='OLD',ERR=13)
        CLOSE(UNIT=LIN)
      END IF
      IC=4
   14 WRITE(LTT,691) ' Default ZED-2 Task 4 Benchmark file  : ',FLNI(IC)
      WRITE(LTT,691) '$          Enter new name to redefine : '
      READ (LKB,691) FLNM
      IF(FLNM.NE.BLNK) FLNI(IC)=FLNM
      IF(FLNM(1:1).NE.'-') THEN
        OPEN(UNIT=LIN,FILE=FLNI(IC),STATUS='OLD',ERR=14)
        CLOSE(UNIT=LIN)
      END IF
      IC=5
   15 WRITE(LTT,691) ' Default DCA Task 1 Benchmark file    : ',FLNI(IC)
      WRITE(LTT,691) '$          Enter new name to redefine : '
      READ (LKB,691) FLNM
      IF(FLNM.NE.BLNK) FLNI(IC)=FLNM
      IF(FLNM(1:1).NE.'-') THEN
        OPEN(UNIT=LIN,FILE=FLNI(IC),STATUS='OLD',ERR=15)
        CLOSE(UNIT=LIN)
      END IF
C*
      OPEN (UNIT=LOU,FILE=FLNO,STATUS='UNKNOWN')
      WRITE(LOU,691) ' D2OSMR - Summarize WLUP D2O Benchmarks '
      WRITE(LOU,691) ' ====================================== '
      WRITE(LOU,691)
C*
      WRITE(LOU,691) ' Processed Benchmark analysis reports : '
      IF(FLNI(1).NE.'-')
     1WRITE(LOU,691) '                              2 cases : ',FLNI(1)
      IF(FLNI(2).NE.'-')
     1WRITE(LOU,691) '                              2 cases : ',FLNI(2)
      IF(FLNI(3).NE.'-')
     1WRITE(LOU,691) '                              1 case  : ',FLNI(3)
      IF(FLNI(4).NE.'-')
     1WRITE(LOU,691) '                              4 cases : ',FLNI(4)
      IF(FLNI(5).NE.'-')
     1WRITE(LOU,691) '                              6 cases : ',FLNI(5)
      WRITE(LOU,691)
C*
      WRITE(LOU,691) '   LATTICE      K-eff         Del       '
     1              ,'  ConvR          CuA          LuR       '
      WRITE(LOU,691) ' ======================================='
     1              ,'====================================    '
C* Initialize
      SRKE=0
      SDKE=0
      ADKE=0
      NDKE=0
C*
      SRRH=0
      SDRH=0
      ADRH=0
      NDRH=0
C*
      SRCR=0
      SDCR=0
      ADCR=0
      NDCR=0
C*
      SRCU=0
      SDCU=0
      ADCU=0
      NDCU=0
C*
      SRUL=0
      SDUL=0
      ADUL=0
      NDUL=0
 
C*
C* Begin processing the ZED-2 Task-1 Benchmark
      IC=1
      OPEN (UNIT=LIN,FILE=FLNI(IC),STATUS='OLD',ERR=100)
C* Multiplication factor for D2O and Air channel
      AK0=1
      RO0=0
   20 READ (LIN,692,END=100) REC
      IF(REC(1:14).NE.'COOLANT METHOD') GO TO 20
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(12:20),'(F9.0)') RO1
      AK1=1/(1-RO1/100000)
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(12:20),'(F9.0)') RO2
      AK2=1/(1-RO2/100000)
      RO1=RO1/1000
      RO2=RO2/1000
C* Fast fission factor (assembly average) from DSN calculation
   22 READ (LIN,692) REC
      IF(REC(1: 8).NE.'Coolant ') GO TO 22
      READ (LIN,692) REC
      READ (REC(40:47),'(F8.0)' ) RRH1
      READ (LIN,692) REC
      READ (REC(40:47),'(F8.0)' ) RRH2
   23 READ (LIN,692) REC
      IF(REC(1: 7).NE.'(Dexp.=' ) GO TO 23
      READ (REC( 8:11),'(F4.0)' ) DRH0
   24 READ (LIN,692) REC
      IF(REC(1:14).NE.'Coolant Method') GO TO 24
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(51:56),'(F6.0)') DRH1
      RH1=RRH1*(1+DRH1/100)
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(51:56),'(F8.0)') DRH2
      RH2=RRH2*(1+DRH2/100)
c
CD       PRINT *,'DEL',RRH1,RRH2,DRH0,RH1,DRH1,RH2,DRH2
c
C* Initial conversion factor (assembly average) from DSN calculation
   25 READ (LIN,692) REC
      IF(REC(1: 8).NE.'Coolant ') GO TO 25
      READ (LIN,692) REC
      READ (REC(40:47),'(F9.0)' ) RCR1
      READ (LIN,692) REC
      READ (REC(40:47),'(F9.0)' ) RCR2
   26 READ (LIN,692) REC
      IF(REC(1: 7).NE.'(Dexp.=' ) GO TO 26
      READ (REC( 8:12),'(F5.0)' ) DCR0
   27 READ (LIN,692) REC
      IF(REC(1:14).NE.'Coolant Method') GO TO 27
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(55:61),'(F7.0)') DCR1
      CR1=RCR1*(1+DCR1/100)
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(55:61),'(F8.0)') DCR2
      CR2=RCR2*(1+DCR2/100)
c
CD       PRINT *,'CRR',RCR1,RCR2,DCR0,CR1,DCR1,CR2,DCR2
c
C* Fission rate (not processed)
   28 READ (LIN,692) REC
      IF(REC(1: 8).NE.'Coolant ') GO TO 28
      READ (LIN,692) REC
      READ (REC(40:47),'(F9.0)' ) RFR1
      READ (LIN,692) REC
      READ (REC(40:47),'(F9.0)' ) RFR2
   29 READ (LIN,692) REC
      IF(REC(1: 7).NE.'(Dexp.=' ) GO TO 29
      READ (REC( 8:11),'(F4.0)' ) DFR0
   30 READ (LIN,692) REC
      IF(REC(1:14).NE.'Coolant Method') GO TO 30
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (LIN,692) REC
C      READ (LIN,692)
C* Copper Activity (overall average) from DSN calculation
   31 READ (LIN,692) REC
      IF(REC(1: 8).NE.'Coolant ') GO TO 31
      READ (LIN,692) REC
      READ (REC( 8:42),'(5F7.0)') RCUA,RCUB,RCUC,RCUD,RCUM
      RCU1=(RCUA+RCUB+RCUC+RCUD+RCUM)/5
      READ (LIN,692) REC
      READ (REC( 8:42),'(5F7.0)') RCUA,RCUB,RCUC,RCUD,RCUM
      RCU2=(RCUA+RCUB+RCUC+RCUD+RCUM)/5
   32 READ (LIN,692) REC
      IF(REC(1: 7).NE.'(Dexp.=' ) GO TO 32
      READ (REC( 8:11),'(F4.0)' ) DCU0
   33 READ (LIN,692) REC
      IF(REC(1:14).NE.'Coolant Method') GO TO 33
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(12:61),'(5(3X,F7.0))') CUA,CUB,CUC,CUD,CUM
      DCU1=(CUA+CUB+CUC+CUD+CUM)/5
      CU1 =RCU1*(1+DCU1/100)
      DCU1=SQRT((CUA*CUA+CUB*CUB+CUC*CUC+CUD*CUD+CUM*CUM)/5)
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(12:61),'(5(3X,F7.0))') CUA,CUB,CUC,CUD,CUM
      DCU2=(CUA+CUB+CUC+CUD+CUM)/5
      CU2 =RCU2*(1+DCU2/100)
      DCU2=SQRT((CUA*CUA+CUB*CUB+CUC*CUC+CUD*CUD+CUM*CUM)/5)
c
CD       PRINT *,'CUA',RCU1,RCU2,DCU0,CU1,DCU1,CU2,DCU2
c
C* Lutetium/Manganese ratio (overall average) from DSN calculation
   34 READ (LIN,692) REC
      IF(REC(1: 8).NE.'Coolant ') GO TO 34
      READ (LIN,692) REC
      READ (REC(36:42),'(F9.0)' ) RUL1
      READ (LIN,692) REC
      READ (REC(36:42),'(F9.0)' ) RUL2
   35 READ (LIN,692) REC
      IF(REC(1: 7).NE.'(Dexp.=' ) GO TO 35
      READ (REC( 8:11),'(F4.0)' ) DUL0
   36 READ (LIN,692) REC
      IF(REC(1:14).NE.'Coolant Method') GO TO 36
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(12:61),'(5(3X,F7.0))') ULA,ULB,ULC,ULD,DUL1
      UL1 =RUL1*(1+DUL1/100)
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(12:61),'(5(3X,F7.0))') ULA,ULB,ULC,ULD,DUL2
      UL2 =RUL2*(1+DUL2/100)
c
CD       PRINT *,'LUR',RUL1,RUL2,DUL0,UL1,DUL1,UL2,DUL2
c
C*
      SRKE=SRKE+2*RO0
      SDKE=SDKE+RO1*RO1+RO2*RO2
      ADKE=ADKE+RO1+RO2
      NDKE=NDKE+2
C*
      SRRH=SRRH+2*DRH0
      SDRH=SDRH+DRH1*DRH1+DRH2*DRH2
      ADRH=ADRH+DRH1+DRH2
      NDRH=NDRH+2
C*
      SRCR=SRCR+2*DCR0
      SDCR=SDCR+DCR1*DCR1+DCR2*DCR2
      ADCR=ADCR+DCR1+DCR2
      NDCR=NDCR+2
C*
      SRCU=SRCU+2*DCU0
      SDCU=SDCU+DCU1*DCU1+DCU2*DCU2
      ADCU=ADCU+DCU1+DCU2
      NDCU=NDCU+2
C*
      SRUL=SRUL+2*DUL0
      SDUL=SDUL+DUL1*DUL1+DUL2*DUL2
      ADUL=ADUL+DUL1+DUL2
      NDUL=NDUL+2
C* Print the resutls for this benchmark
      WRITE(LOU,601) NAME(1)
     1              ,AK0,RO0,RRH1,DRH0,RCR1,DCR0,RCU1,DCU0,RUL1,DUL0
      WRITE(LOU,601)'          '
     1              ,AK1,RO1, RH1,DRH1, CR1,DCR1, CU1,DCU1, UL1,DUL1
      WRITE(LOU,691)
      WRITE(LOU,601) NAME(2)
     1              ,AK0,RO0,RRH2,DRH0,RCR2,DCR0,RCU2,DCU0,RUL2,DUL0
      WRITE(LOU,601)'          '
     1              ,AK2,RO2, RH2,DRH2, CR2,DCR2, CU2,DCU2, UL2,DUL2
      WRITE(LOU,691)
C*
      CLOSE(UNIT=LIN)
C*
C* Begin processing the ZED-2 Task-2 Benchmark
  100 IC=2
      OPEN(UNIT=LIN,FILE=FLNI(IC),STATUS='OLD',ERR=200)
C* Multiplication factor for D2O and Air channel
      AK0=1
      RO0=0
  120 READ (LIN,692,END=200) REC
      IF(REC(1: 5).NE.'PITCH') GO TO 120
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(14:22),'(F9.0)') RO1
      AK1=1/(1-RO1/100000)
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(14:22),'(F9.0)') RO2
      AK2=1/(1-RO2/100000)
c
CD       PRINT *,'AKE',AK0,AK0,R00,AK1,RO1,AK2,RO2
c
      RO1=RO1/1000
      RO2=RO2/1000
C* Fast fission factor (assembly average) from DSN calculation
  122 READ (LIN,692) REC
      IF(REC(1: 5).NE.'PITCH') GO TO 122
      READ (LIN,692) REC
      READ (REC( 5:17),'(F13.0)' ) RRH1
      READ (LIN,692) REC
      READ (REC( 5:17),'(F13.0)' ) RRH2
  123 READ (LIN,692) REC
      IF(REC(1: 7).NE.'(Dexp.=' ) GO TO 123
      READ (REC( 8:11),'(F4.0)' ) DRH0
  124 READ (LIN,692) REC
      IF(REC(1: 5).NE.'PITCH') GO TO 124
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(14:23),'(F10.0)') DRH1
      RH1=RRH1*(1+DRH1/100)
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(14:23),'(F10.0)') DRH2
      RH2=RRH2*(1+DRH2/100)
c
CD       PRINT *,'DEL',RRH1,RRH2,DRH0,RH1,DRH1,RH2,DRH2
c
C* Initial conversion factor (assembly average) from DSN calculation
  125 READ (LIN,692) REC
      IF(REC(1: 5).NE.'PITCH') GO TO 125
      READ (LIN,692) REC
      READ (REC( 5:17),'(F13.0)' ) RCR1
      READ (LIN,692) REC
      READ (REC( 5:17),'(F13.0)' ) RCR2
  126 READ (LIN,692) REC
      IF(REC(1: 7).NE.'(Dexp.=' ) GO TO 126
      READ (REC( 8:12),'(F5.0)' ) DCR0
  127 READ (LIN,692) REC
      IF(REC(1: 5).NE.'PITCH') GO TO 127
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(14:23),'(F10.0)') DCR1
      CR1=RCR1*(1+DCR1/100)
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(14:23),'(F10.0)') DCR2
      CR2=RCR2*(1+DCR2/100)
c
CD       PRINT *,'CRR',RCR1,RCR2,DCR0,CR1,DCR1,CR2,DCR2
c
C*
      SRKE=SRKE+2*RO0
      SDKE=SDKE+RO1*RO1+RO2*RO2
      ADKE=ADKE+RO1+RO2
      NDKE=NDKE+2
C*
      SRRH=SRRH+2*DRH0
      SDRH=SDRH+DRH1*DRH1+DRH2*DRH2
      ADRH=ADRH+DRH1+DRH2
      NDRH=NDRH+2
C*
      SRCR=SRCR+2*DCR0
      SDCR=SDCR+DCR1*DCR1+DCR2*DCR2
      ADCR=ADCR+DCR1+DCR2
      NDCR=NDCR+2
C* Print the resutls for this benchmark
      WRITE(LOU,601) NAME(3)
     1              ,AK0,RO0,RRH1,DRH0,RCR1,DCR0
      WRITE(LOU,601)'          '
     1              ,AK1,RO1, RH1,DRH1, CR1,DCR1
      WRITE(LOU,691)
      WRITE(LOU,601) NAME(4)
     1              ,AK0,RO0,RRH2,DRH0,RCR2,DCR0
      WRITE(LOU,601)'          '
     1              ,AK2,RO2, RH2,DRH2, CR2,DCR2
      WRITE(LOU,691)
C*
      CLOSE(UNIT=LIN)
C*
C* Begin processing the ZED-2 Task-3 Benchmark
  200 IC=3
      OPEN(UNIT=LIN,FILE=FLNI(IC),STATUS='OLD',ERR=300)
C* Multiplication factor for D2O and Air channel
      AK0=1
      RO0=0
  220 READ (LIN,692,END=300) REC
      IF(REC(1: 6).NE.'METHOD') GO TO 220
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC( 5:12),'(F8.0)') RO1
      AK1=1/(1-RO1/100000)
c
CD      PRINT *,'AKE',AK0,AK0,R00,AK1,RO1,AK2,RO2
c
      RO1=RO1/1000
C*
      SRKE=SRKE+RO0**2
      SDKE=SDKE+RO1*RO1
      ADKE=ADKE+RO1
      NDKE=NDKE+1
C* Print the resutls for this benchmark
      WRITE(LOU,601) NAME(5)
     1              ,AK0,RO0
      WRITE(LOU,601)'          '
     1              ,AK1,RO1
      WRITE(LOU,691)
C*
      CLOSE(UNIT=LIN)
C*
C* Begin processing the ZED-2 Task-4 Benchmark
  300 IC=4
      OPEN(UNIT=LIN,FILE=FLNI(IC),STATUS='OLD',ERR=400)
C* Multiplication factor for D2O and Air channel
      AK0=1
      RO0=0
  320 READ (LIN,692,END=400) REC
      IF(REC(1: 5).NE.'PITCH') GO TO 320
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(22:30),'(F9.0)') RO1
      AK1=1/(1-RO1/100000)
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(22:30),'(F9.0)') RO2
      AK2=1/(1-RO2/100000)
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(22:30),'(F9.0)') RO3
      AK3=1/(1-RO3/100000)
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(22:30),'(F9.0)') RO4
      AK4=1/(1-RO4/100000)
c
CD      PRINT *,'AKE',AK0,AK0,R00,AK1,RO1,AK2,RO2,AK3,RO3,AK4,RO4
c
      RO1=RO1/1000
      RO2=RO2/1000
      RO3=RO3/1000
      RO4=RO4/1000
C* Fast fission factor (assembly average) from DSN calculation
  322 READ (LIN,692) REC
      IF(REC(1: 5).NE.'PITCH') GO TO 322
      READ (LIN,692) REC
      READ (REC(16:26),'(F11.0)' ) RRH1
      READ (LIN,692) REC
      READ (REC(16:26),'(F11.0)' ) RRH2
      READ (LIN,692) REC
      READ (REC(16:26),'(F11.0)' ) RRH3
      READ (LIN,692) REC
      READ (REC(16:26),'(F11.0)' ) RRH4
  323 READ (LIN,692) REC
      IF(REC(1: 7).NE.'(Dexp.=' ) GO TO 323
      READ (REC( 8:12),'(F5.0)' ) DRH0
  324 READ (LIN,692) REC
      IF(REC(1: 5).NE.'PITCH') GO TO 324
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(22:29),'(F8.0)') DRH1
      RH1=RRH1*(1+DRH1/100)
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(22:29),'(F8.0)') DRH2
      RH2=RRH2*(1+DRH2/100)
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(22:29),'(F8.0)') DRH3
      RH3=RRH3*(1+DRH3/100)
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(22:29),'(F8.0)') DRH4
      RH4=RRH4*(1+DRH4/100)
c
CD    PRINT *,'DEL',RRH1,RRH2,RRH3,RRH4,DRH0
c    1             ,RH1,DRH1,RH2,DRH2,RH3,DRH3,RH4,DRH4
c
C*
      SRKE=SRKE+4*RO0
      SDKE=SDKE+RO1*RO1+RO2*RO2+RO3*RO3+RO4*RO4
      ADKE=ADKE+RO1+RO2+RO3+RO4
      NDKE=NDKE+4
C*
      SRRH=SRRH+4*DRH0
      SDRH=SDRH+DRH1*DRH1+DRH2*DRH2+DRH3*DRH3+DRH4*DRH4
      ADRH=ADRH+DRH1+DRH2+DRH3+DRH4
      NDRH=NDRH+4
C* Print the results for this benchmark
      WRITE(LOU,601) NAME(6)
     1              ,AK0,RO0,RRH1,DRH0
      IF(RO1.LT.-.99) RO1=ABS(RO1)
      WRITE(LOU,601)'          '
     1              ,AK1,RO1, RH1,DRH1
      WRITE(LOU,691)
      WRITE(LOU,601) NAME(7)
     1              ,AK0,RO0,RRH2,DRH0
      IF(RO2.LT.-.99) RO2=ABS(RO2)
      WRITE(LOU,601)'          '
     1              ,AK2,RO2, RH2,DRH2
      WRITE(LOU,691)
      WRITE(LOU,601) NAME(8)
     1              ,AK0,RO0,RRH3,DRH0
      IF(RO3.LT.-.99) RO3=ABS(RO3)
      WRITE(LOU,601)'          '
     1              ,AK3,RO3, RH3,DRH3
      WRITE(LOU,691)
      WRITE(LOU,601) NAME(9)
     1              ,AK0,RO0,RRH4,DRH0
      IF(RO4.LT.-.99) RO4=ABS(RO4)
      WRITE(LOU,601)'          '
     1              ,AK4,RO4, RH4,DRH4
      WRITE(LOU,691)
C*
      CLOSE(UNIT=LIN)
C*
C* Begin processing the DCA Task-1 Benchmark
  400 IC=5
      OPEN(UNIT=LIN,FILE=FLNI(IC),STATUS='OLD',ERR=500)
C* Multiplication factor for D2O and Air channel
      AK0=1
      RO0=0
  420 READ (LIN,692) REC
      IF(REC(1: 5).NE.'PITCH') GO TO 420
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(22:39),'(F8.0)') RO1
      AK1=1/(1-RO1/100000)
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(22:29),'(F8.0)') RO2
      AK2=1/(1-RO2/100000)
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(22:29),'(F8.0)') RO3
      AK3=1/(1-RO3/100000)
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(22:29),'(F8.0)') RO4
      AK4=1/(1-RO4/100000)
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(22:29),'(F8.0)') RO5
      AK5=1/(1-RO5/100000)
      READ (LIN,692) REC
C      READ (LIN,692)
      READ (REC(22:29),'(F8.0)') RO6
      AK6=1/(1-RO6/100000)
c
CD      PRINT *,'AKE',AK0,AK0,R00,AK1,RO1,AK2,RO2
c    1               ,AK3,RO3,AK4,RO4,AK5,RO5,AK6,RO6
c
      RO1=RO1/1000
      RO2=RO2/1000
      RO3=RO3/1000
      RO4=RO4/1000
      RO5=RO5/1000
      RO6=RO6/1000
C*
      SRKE=SRKE+6*RO0
      SDKE=SDKE+RO1*RO1+RO2*RO2+RO3*RO3+RO4*RO4+RO5*RO5+RO6*RO6
      ADKE=ADKE+RO1+RO2+RO3+RO4+RO5+RO6
      NDKE=NDKE+6
C* Print the resutls for this benchmark
      WRITE(LOU,601) NAME(10)
     1              ,AK0,RO0
      IF(RO1.LT.-.99) RO1=ABS(RO1)
      WRITE(LOU,601)'          '
     1              ,AK1,RO1
      WRITE(LOU,691)
      WRITE(LOU,601) NAME(11)
     1              ,AK0,RO0
      IF(RO2.LT.-.99) RO2=ABS(RO2)
      WRITE(LOU,601)'          '
     1              ,AK2,RO2
      WRITE(LOU,691)
      WRITE(LOU,601) NAME(12)
     1              ,AK0,RO0
      IF(RO3.LT.-.99) RO3=ABS(RO3)
      WRITE(LOU,601)'          '
     1              ,AK3,RO3
      WRITE(LOU,691)
      WRITE(LOU,601) NAME(13)
     1              ,AK0,RO0
      IF(RO4.LT.-.99) RO4=ABS(RO4)
      WRITE(LOU,601)'          '
     1              ,AK4,RO4
      WRITE(LOU,691)
      WRITE(LOU,601) NAME(14)
     1              ,AK0,RO0
      IF(RO4.LT.-.99) RO4=ABS(RO5)
      WRITE(LOU,601)'          '
     1              ,AK5,RO5
      WRITE(LOU,691)
      WRITE(LOU,601) NAME(15)
     1              ,AK0,RO0
      IF(RO4.LT.-.99) RO6=ABS(RO6)
      WRITE(LOU,601)'          '
     1              ,AK6,RO6
      WRITE(LOU,691)
C*
      CLOSE(UNIT=LIN)
C*
  500 WRITE(LOU,691) ' ======================================='
     1              ,'====================================    '
C*
      IF(NDKE.GT.0) THEN
        SRKE=     SRKE/NDKE
        SDKE=SQRT(SDKE/NDKE)
        ADKE=     ADKE/NDKE
      END IF
      IF(NDRH.GT.0) THEN
        SRRH=     SRRH/NDRH
        SDRH=SQRT(SDRH/NDRH)
        ADRH=     ADRH/NDRH
      END IF
      IF(NDCR.GT.0) THEN
        SRCR=     SRCR/NDCR
        SDCR=SQRT(SDCR/NDCR)
        ADCR=     ADCR/NDCR
      END IF
      IF(NDCU.GT.0) THEN
        SRCU=     SRCU/NDCU
        SDCU=SQRT(SDCU/NDCU)
        ADCU=     ADCU/NDCU
      END IF
      IF(NDUL.GT.0) THEN
        SRUL=     SRUL/NDUL
        SDUL=SQRT(SDUL/NDUL)
        ADUL=     ADUL/NDUL
      END IF
C*
      WRITE(LOU,602) ' Average  '
     1              ,     SRKE,     SRRH,     SRCR,     SRCU,     SRUL
      WRITE(LOU,603) ' Dif/St.Dv'
     1              ,ADKE,SDKE,ADRH,SDRH,ADCR,SDCR,ADCU,SDCU,ADUL,SDUL
C* End of file processing
   80 STOP 'D2OSMR Completed'
C*
  601 FORMAT(A10,F8.5,'(',F4.2,')'
     2          ,F7.4,'(',F4.1,')'
     3          ,F7.4,'(',F4.1,')'
     4          ,F7.3,'(',F4.2,')'
     5          ,F7.3,'(',F4.2,')' )
  602 FORMAT(A10,8X,'(',F4.2,')'
     2          ,7X,'(',F4.1,')'
     3          ,7X,'(',F4.1,')'
     4          ,7X,'(',F4.2,')'
     5          ,7X,'(',F4.2,')' )
  603 FORMAT(A10,F8.2,'(',F4.2,')'
     2          ,F7.1,'(',F4.1,')'
     3          ,F7.1,'(',F4.1,')'
     4          ,F7.2,'(',F4.2,')'
     5          ,F7.2,'(',F4.2,')' )
  691 FORMAT(2A40)
  692 FORMAT(A120)
      END
*deck dckspl 
      PROGRAM DCKSPL
C-Title  : DCKSPL Program
C-Purpose: Split FORTRAN source file into decks
C-Author : A.Trkov, Institute J.Stefan, Ljubljana, Slovenia.
C-Version: 1993 Original code
C-V  94/02 - Write DCKLST file.
C-V  01/08 A.Trkov:
C-V        - Allow lower case "*deck" statements in the source file.
C-V        - Allow longer decknames.
C-V        - Define output deck file extension from input.
C-V        - If the output extension is not ".DCK" or ".dck"
C-V          the heading "*deck" card is omitted.
C-V  01/12 A.Trkov
C-V        - Remove special characters and trailing blanks.
C-V  02/03 A.Trkov
C-V        - Update the instructions.
C-M
C-M  Manual for Program DCKSPL
C-M  =========================
C-M    The FORTRAN source file is assumed to contain records
C-M  beginning with "*DECK dkname" where 'dkname' is the appropriate
C-M  name. Each deck is written onto a new file named 'dkname.ext'
C-M  where 'ext' is the file extension requested from input. If the
C-M  extension is not "dck" of "DCK", the record "$DECK dkname" is
C-M  not transferred to output.
C-M    An output file DCKLST.TMP is also prepared, on which all the
C-M  decknames on the source file are listed in the format
C-M  "CALL FORL dkname". This is to allow the design of batch
C-M  procedures for automatic compilation of all decks.
C-M
C-M  Instructions:
C-M  The following input parameters are requested from input:
C-M  -  Source filename
C-M  -  Extension for split deck files.
C-
      PARAMETER    (MXLN=132)
      CHARACTER*132 RECI
      CHARACTER*40  FLNM,FLDK
      CHARACTER*4   FEXT
      CHARACTER*1   A(MXLN)
      EQUIVALENCE  (A(1),RECI)
C* ASCII Codes of special characters (to be ignored)
      DATA IB,IN,IC,IL,L/32,0,13,10,137/
C*
      DATA FEXT   /'.FOR'/
      DATA FLDK   /'DCKLST.TMP'/
C* Logical file units
      DATA LIN,LOU,LKB,LTT,LDK /1,-2, 5, 6, 8 /
      NDK=0
      NRC=0
      MLN=0
      WRITE(LTT,692) ' DCKSPL - Split Source File into Decks  '
      WRITE(LTT,692) ' -------------------------------------  '
      WRITE(LTT,692)
C* Define the source filename
   10 WRITE(LTT,692) '$Enter the deck source filename       : '
      READ (LKB,692) FLNM
      OPEN(UNIT=LIN,FILE=FLNM,STATUS='OLD',ERR=10)
C* Read 3-character file extension (default=FOR)
      WRITE(LTT,692) '$Enter 3-character file extension     : '
      READ (LKB,692,END=18) FLNM
      IF(FLNM(1:3).NE.'   ') FEXT(2:4)=FLNM(1:3)
   18 CONTINUE
C* Open the file containing the list of all decks
      OPEN (UNIT=LDK,FILE=FLDK,STATUS='UNKNOWN')
C* Read the source deck file
   20 READ(LIN,694,END=91) RECI
      IF(RECI(1:6).NE.'*DECK ' .AND. RECI(1:6).NE.'*deck ') GO TO 40
      WRITE(LDK,696) RECI(7:12)
C* Open the new deck file
      IF(LOU.GT.0) THEN
        CLOSE(UNIT=LOU)
        WRITE(LTT,698) NRC,MLN,FLNM
        NRC=0
        MLN=0
      END IF
      I2=41
   22 I2=I2-1
      IF(I2.GT.7 .AND. RECI(I2:I2).EQ.' ') GO TO 22
      FLNM= RECI(7:I2)//FEXT
      LOU = ABS(LOU)
C***** VAX
C     OPEN (UNIT=LOU,FILE=FLNM,STATUS='NEW',CARRIAGECONTROL='LIST')
C***** VAX
C***** STANDARD
      OPEN (UNIT=LOU,FILE=FLNM,STATUS='UNKNOWN')
C***** STANDARD
      NDK = NDK+1
      IF(FEXT.NE.'.DCK' .AND. FEXT.NE.'.dck') GO TO 20
C* Copy the statements to the deck file
   40 IF(LOU.LE.0) GO TO 20
      K1=1
      K2=MXLN+1
C* Scan the line
   50 K2=K2-1
C* Remove line feed in column-1 if present
      IA=ICHAR(A(K1))
      IF(IA.EQ.IL) K1=K1+1
      IF(K1.GE.K2) GO TO 52
C* Remove trailing blanks, null, line-feed and carriage return
      IA=ICHAR(A(K2))
      IF(IA.EQ.IB .OR.
     1   IA.EQ.IN .OR.
     1   IA.EQ.IC .OR.
     1   IA.EQ.IL) GO TO 50
   52 WRITE(LOU,695) (A(J),J=K1,K2)
      NRC=NRC+1
      MLN=MAX(MLN,K2-K1+1)
      GO TO 20
C* Processing completed
   91 WRITE(LTT,699) NDK
      STOP 'DCKSPL Completed'
  692 FORMAT(2A40)
  694 FORMAT(A132)
  695 FORMAT(132A1)
  696 FORMAT('CALL FORL ',A6)
  698 FORMAT(I10,' Records of max.width',I4,' in deck ',A40)
  699 FORMAT(' Number of decks written :',I4)
      END
*deck DOPBEN 
       PROGRAM DOPBEN
C-Title  : DOPBEN Program
C-Purpose: Summarize WLUP DOPPLER Supplementary Benchmarks
C-Version: Original code.
C-Author : A.Trkov, Institute Jozef Stefan, Ljubljana, Slovenia (2002)
C-M
C-M  Manual for Program DOPBEN
C-M  =========================
C-M  A summary of results for the WLUP Doppler
C-M  benchmarks is compiled from dopbench.exe output DOPPLER.O
C-M
C-M  The list files are those produced by analysing the WIMS-D
C-M  outputs with post-processing code developed within the scope
C-M  of the WIMS-D Library Update Project (IAEA-CRP 1999-2000) by
C-M  Lhoussine Erradi.
C-M
C-
      DIMENSION EXPER(5),CALCUL(5),DCALC(5)
      DIMENSION DEXPE(5)
      CHARACTER*120 REC
      CHARACTER*40  BLNK,FLNM,FLNI(8),FLNO
      CHARACTER*10  NAME(16)
C* Filenames and logical file units
      DATA LIN,LOU,LKB,LTT / 1, 2, 5, 6 /
      DATA BLNK/'                                        '/
     1    ,FLNI/'DOPPLER.O  '
     2    ,     '           '
     3    ,     '           '
     4    ,     '           '
     1    ,     '           '
     1    ,     '           '
     1    ,     '           '
     1    ,     '           '/
     1    ,FLNO/'DOPBEN.LST'/
C*
      DATA NAME/' REF 0.711'
     1         ,' REF 1.600'
     2         ,' REF 2.400'
     2         ,' REF 3.100'
     3         ,' REF 3.900'
     4         ,'          '
     4         ,'          '
     4         ,'          '
     4         ,'          '
     1         ,'          '
     1         ,'          '
     1         ,'          '
     1         ,'          '
     1         ,'          '
     1         ,'          '
     4         ,'          '/
C*
C* Define input parameters - Write banner to terminal
      WRITE(LTT,693)' DOPPLER comparison DOPPLER COEFF. OF REACTIVITY  '
      WRITE(LTT,693)' ================================================='
      WRITE(LTT,692)
C*
C* Define the output file
      WRITE(LTT,691) ' Default output filename              : ',FLNO
      WRITE(LTT,692) '$          Enter new name to redefine : '
      READ (LKB,692) FLNM
      IF(FLNM.NE.BLNK) FLNO=FLNM
C*
C* Define the output file
      IC=1
   11 WRITE(LTT,691) ' Default DOPBENCH Benchmark file  :    ',FLNI(IC)
      WRITE(LTT,692) '$          Enter new name to redefine : '
      READ (LKB,692) FLNM
      IF(FLNM.NE.BLNK) FLNI(IC)=FLNM
      IF(FLNM(1:1).NE.'-') THEN
        OPEN (UNIT=LIN,FILE=FLNI(IC),STATUS='OLD',ERR=11)
        CLOSE(UNIT=LIN)
      END IF
C*
      OPEN (UNIT=LOU,FILE=FLNO,STATUS='UNKNOWN')
      WRITE(LOU,693)' DOPPLER comparison COEFF.OF REACTIVITY (pcm/K)   '
      WRITE(LOU,693)' ================================================='
      WRITE(LOU,692)
      WRITE(LOU,691) ' Processed Benchmark analysis reports : '
      IF(FLNI(1).NE.'-')
     1WRITE(LOU,691) '                              1 case  : ',FLNI(1)
      WRITE(LOU,691)
C*
      WRITE(LOU,694)'     E(wt%) DOPPLER COEF.(pcm/K)-DIF(%)           '
      WRITE(LOU,694)' ================================================='
C
C* Begin processing DOPPLER Benchmarks
      IC=1
      OPEN (UNIT=LIN,FILE=FLNI(IC),STATUS='OLD')
   20 READ (LIN,692) REC
      IF(REC(1:8).NE.' e (wt%)') GO TO 20
      DO ILIN=1,3
       READ (LIN,692) REC
      ENDDO
      DO IEX=1,4
       READ (LIN,700)EXPER(IEX),CALCUL(IEX),DCALC(IEX)
       DO ILIN=1,4
        READ (LIN,692) REC
       ENDDO
      ENDDO
      READ (LIN,700)EXPER(5),CALCUL(5),DCALC(5)
C* Print the resutls for this benchmark
      DO ICAS=1,5
       DEXPE(ICAS)= 0.0
      ENDDO
      DO ICASO=1,5
       WRITE(LOU,702) NAME(ICASO),EXPER(ICASO),DEXPE(ICASO)
       WRITE(LOU,702)'          ',CALCUL(ICASO),DCALC(ICASO)
       WRITE(LOU,692)
      ENDDO
      CLOSE(UNIT=LIN)
C*
      WRITE(LOU,694)' ================================================='
      SRDC=0.0
      SDDC=0.0
      ADDC=0.0
      DO ICAS=1,5
       SRDC=SRDC+2*DEXPE(ICAS)
       SDDC=SDDC+DCALC(ICAS)*DCALC(ICAS)
       ADDC=ADDC+DCALC(ICAS)
      ENDDO
      SRDC=SRDC/5.0
      SDDC=SQRT(SDDC/5.0)
      ADDC=ADDC/5.0
      WRITE(LOU,703) ' Average  ',SRDC
      WRITE(LOU,704) ' Dif/St.Dv',ADDC,SDDC
C
      CLOSE(UNIT=LOU)
C* End of file processing
  80  STOP 'DOPBEN Completed'
C*
 691  FORMAT(2A40)
 692  FORMAT(A50)
 693  FORMAT(A50)
 694  FORMAT(A50)
 700  FORMAT(49X,F6.3,15X,F5.2,9X,F6.2)
 702  FORMAT(A10,F6.2,'(',F6.2,')')
 703  FORMAT(A10,6X,'(',F6.2,')')
 704  FORMAT(A10,F6.2,'(',F6.2,')')
C
      END
*deck DOPBENCH 
C     Program Dopbench for calculation of Doppler coefficient
C     Authors : L.ERRADI, A.HTET, E.CHAKIR
      PROGRAM DOPBENCH
       CAll ENTETEDOP
       CALL NBDC
       CALL DOPPLER
      END
C *********************************************************
C *********************************************************
      SUBROUTINE ENTETEDOP
C *********************************************************
      OPEN(UNIT=5,file='ENTETEDOP.RES',STATUS='UNKNOWN')
      WRITE(5,1000)
1000  FORMAT (20x,44(1H*)/
     1 20x,'*       WIMS LIBRARY UPDATE PROJECT        *'/
     2 20x,'*          LIBRARIES VALIDATION            *'/
     2 20x,'*       FOR THE DOPPLER COEFFICIENT        *'/
     3 20x,44(1H*)///
     4 15x,54(1H*)/
     5 15x,'*           L.ERRADI, A.HTET AND E.CHAKIR',12x,1(1H*)/
     6 15x,'*      GROUPE DE PHYSIQUE DES REACTEURS NUCLEAIRES',3x,1H*/
     7 15x,'*           FACULTE DES SCIENCES -  RABAT',12x,1(1H*)/
     8 15x,'*                      MOROCCO',23x,1(1H*)/
     9 15x,54(1H*)////)
      RETURN
      END
C *********************************************************
C *********************************************************
      SUBROUTINE NBDC
C *********************************************************
      OPEN(UNIT=10,file='NBDC.RES',STATUS='UNKNOWN')
      WRITE(10,1400)
1400  FORMAT('NUMERICAL BENCHMARK ON DOPPLER COEFFICIENT'/
     1 42(1H*)//)
      RETURN
      END
C *********************************************************
      SUBROUTINE DOPPLER
C *********************************************************
      CHARACTER*120 RECI
      REAL XKI(10),XKE(10),DT(10),C(10),E(10), REF(10),delta(10)
      OPEN (UNIT=3,FILE='DOPPLER.OUT',STATUS='old')
      OPEN (UNIT=5,file='DOPPLER.RES',STATUS='UNKNOWN')
      OPEN (UNIT=6,FILE='DOPPLER.T',STATUS='UNKNOWN')
      OPEN (UNIT=7,FILE='DOPPLER.E',STATUS='UNKNOWN')
      OPEN (UNIT=8,FILE='DOPPLER.REF',STATUS='UNKNOWN')
C
      DO I=1,10
   20  READ (3,800) RECI
       DO WHILE (RECI(53:63).NE.'k-effective')
        GO TO 20
       ENDDO
       READ(RECI(38:49),802) XKI(i)
       READ(RECI(66:77),802) XKE(i)
       READ (3,800) RECI
      ENDDO
C*
C*
C      do i=1,10
C       WRITE(*,*)XKI(i),XKE(i)
C      enddo
      do i=1,5
       read(8,1300)ref(i)
      enddo
      read(7,*)(e(j),j=1,5)
      read(6,*)(dt(j),j=1,10)
      j=0
      do i=2,10,2
       j=j+1
       c(j)=(XKE(i)-XKE(i-1))/(XKE(i)*XKE(i-1)*(DT(i)-DT(i-1))*1.E-5)
       delta(j)=((c(j)-ref(j))/ref(j))*100
      enddo
      write(5,950)
      do 60 i=1,10
       ik = mod(i,2)
       if(ik.eq.0) then
        write(5,901)dt(i),XKE(i)
       else
        write(5,900)dt(i),XKE(i)
       endif
       jl = int(i/2)
       if(i.ne.1) then
        goto 601
       else
        write(5,1100)e(i),c(i),ref(i),delta(i)
        goto 60
       endif
  601  if(ik.eq.0) go to 60
       write(5,1100)e(jl+1),c(jl+1),ref(jl+1),delta(jl+1)
   60 continue
      write(5,1250)
      close(3)
      close(5)
      close(6)
      close(7)
      close(8)
      close(10)
C*
  800 FORMAT(A120)
  802 FORMAT(E14.7)
  950 FORMAT(1X,24X,33(1H*)/
     1 '                         *     DOPPLER COEFFICIENT       *'/
     2 25X,33(1H*)///
     3'WIMS OUTPUT AND CALCULATED DOPPLER COEFFICIENT OF REACTIVITY:'//
     412x,'TEMP. (°K)',5x,'K-EFF'/
     51x,'e (wt%)',33x,'DOPPLER COEF.(pcm/°K)',4x,'REF. (pcm/°K)'
     6,4x,'delta (%)'//)
  900 FORMAT(12x,F7.2,2x,E14.7)
  901 FORMAT(12x,F7.2,2x,E14.7//)
 1200 FORMAT(1x,F2.0,1x,F2.0,1x,F2.0,1x,F2.0)
 1100 FORMAT(F6.3,43x,F6.3,15x,F5.2,10x,F5.2)
 1250 FORMAT(55(1H-)/)
 1300 FORMAT(5(1x,F5.2))
      RETURN
      END
*deck e1t1 
C
C  PROGRAM E1T1
C
C  AUTHOR: FRANCISCO LESZCZYNSKI-INGENIERIA NUCLEAR- 1999
C                                CENTRO ATOMICO BARILOCHE
C                                ARGENTINA
C
C  PROCESS WIMS OUTPUT FOR BENCHMARK D2O EX.1)ZED-2 Task 1 FOR 1 LIBRARY
C  1) READ EXPERIMENTAL VALUES OF PARAMETERS (FOR D2O AND AIR COOLANTS)
C     <- E1T1.REF
C
C  2) READ WIMS-D RESULTS-IOW
C                          1 <-E1T1D2OD.OUT;
C                          2 <-E1T1AIRD.OUT;
C                          3 <-E1T1THER.OUT
C  2.1) READ Nu5,Nu8
C  2.2) READ Keff     (FOR IOW=1-4)
C  2.3) READ TOTAL REACTION RATES AND REACTIONS, BY MATERIAL, OF:
C       MN-55(55),CU-63(3063),LU-176(176),U-235(2235) AND U-238(8238)
C
C  3) CALCUL (Keff-1)*100000
C  4) CALCUL FAST FISSION RATIO FFR  =FIS.U8/FIS.U5 (MATERS.6-9 + F.AV.)
C  5) CALCUL RELATIVE CONVERSION RATIO C=ABS.U8/FIS.U5          "
C  6) CALCUL RELATIVE U5 FISSION RATE  RU5FR=FIS.U5        (MATERS.6-9)
C  7) CALCUL RELATIVE CU ACTIVITY RCA  =ABS.R.CU63 (MATERS.6-9 + M.AV.)
C  8) CALCUL LUTETIUM-MANGANESE RATIOS ALMR  =ABS.R.LU176/ABS.R.MN55
C                                                   (MATERS.6-9 + F.AV.)
C  9) WRITE RESULTS
C
C***********************************************************************
      DIMENSION FFRE(5,4),CE(5,4),RU5FRE(5,4),RCAE(5,4),ALMRE(5,4)
      DIMENSION FFR(5,5),C(5,5),RU5FR(5,5),RCA(5,5),ALMR(5,5)
      DIMENSION FFRR(5,5),CR(5,5),RU5FRR(5,5),RCAR(5,5),ALMRR(5,5)
      DIMENSION AU5(5),AU8(5)
      DIMENSION AKAEFF(4),AKAM1(4)
      DIMENSION ABSO(5,5,5),FIS(5,5,5)
      DIMENSION ANR(4)
      CHARACTER*3 DVOID,DINEX,DDLOW,ANA(5,4)
      CHARACTER*12 OUTW(5)
      CHARACTER*24 REFER1
      CHARACTER*28 AISOT(5)
      CHARACTER*30 REFER2
      CHARACTER*44 ADVICE
      CHARACTER*80 TIT,REF,TIT2(2)
      CHARACTER*80 LINE
C
C***********************************************************************
C  1) READ EXPERIMENTAL VALUES OF PARAMETERS (FOR D2O AND AIR COOLANTS)
C
      OPEN(UNIT=1,FILE='E1T1.REF',FORM='FORMATTED',STATUS='OLD')
      read(1,1)TIT
      read(1,1)REF
      DO IC=1,2
       read(1,1)TIT2(IC)
       read(1,2)(FFRE(I,IC),I=1,5)
       read(1,3)SDFF
       read(1,2)(CE(I,IC),I=1,5)
       read(1,3)SDC
       read(1,4)(RU5FRE(I,IC),I=1,4)
       read(1,3)SDRU5
       read(1,2)(RCAE(I,IC),I=1,5)
       read(1,3)SDRCA
       read(1,2)(ALMRE(I,IC),I=1,5)
       read(1,3)SDAL
      END DO
      CLOSE(1)
      CLOSE(2)
C
      IC=3
      DO I=1,5
      FFRE(I,IC)=FFRE(I,IC-1)
      CE(I,IC)=CE(I,IC-1)
      RU5FRE(I,IC)=RU5FRE(I,IC-1)
      RCAE(I,IC)=RCAE(I,IC-1)
      ALMRE(I,IC)=ALMRE(I,IC-1)
      END DO
C***********************************************************************
C  2) READ WIMS-D RESULTS: 1)<-E1T1D2OD.OUT
C                          3)<-E1T1AIRD.OUT
C                          5)<-E1T1THER.OUT
C
      OUTW(1)="E1T1D2OD.OUT"
      OUTW(3)="E1T1AIRD.OUT"
      OUTW(5)="E1T1THER.OUT"
C
      AISOT(1)='element    55 reaction rates'
      AISOT(2)='element  3063 reaction rates'
      AISOT(3)='element   176 reaction rates'
      AISOT(4)='element  2235 reaction rates'
      AISOT(5)='element  8238 reaction rates'
C
      OPEN(3,FILE="E1T1.TEM")
      DO IOW=1,5,2
       OPEN(1,FILE=OUTW(IOW))
C
C 2.1) READ Nu5,Nu8
C
       read(1,30)LINE
       DO WHILE(LINE(1:7).NE.'  2235 ')
        read(1,30)LINE
       END DO
       BACKSPACE(1)
       read(1,31)AU5(IOW)
       read(1,30)LINE
       DO WHILE(LINE(1:7).NE.'  8238 ')
        read(1,30)LINE
       END DO
       BACKSPACE(1)
       read(1,31)AU8(IOW)
C
       IF(IOW.LT.5)THEN
C
C  2.2) READ Keff
C
        read(1,30)LINE
        DO WHILE(LINE(53:63).NE.'k-effective')
         read(1,30)LINE
        END DO
        BACKSPACE(1)
        read(1,32)AKAEFF(IOW)
        write(3,40)AKAEFF(IOW)
       ENDIF
C
C  2.3) READ TOTAL REACTION RATES AND REACTIONS, BY MATERIAL, OF:
C       MN-55(55),CU-63(3063),LU-176(176),U-235(2235) AND U-238(8238)
C
C -------------------------------------------------------------------
       DO ISOT=1,5
C     ISOT=1: ABS.R.MN55
C     ISOT=2: ABS.R.CU63
C     ISOT=3: ABS.R.LU176
C     ISOT=4: ABS.AND FIS.R.U235
C     ISOT=5: ABS.AND FIS.R.U238
C
        read(1,30)LINE
        DO WHILE(LINE(2:29).NE.AISOT(ISOT))
         read(1,30)LINE
        END DO
C
        read(1,30)LINE
        DO WHILE(LINE(2:13).NE.'group materl')
         read(1,30)LINE
        END DO
C
        read(1,30)LINE
        DO WHILE(LINE(2:8).NE.'  total')
         read(1,30)LINE
        END DO
        IF(IOW.LT.5)THEN
         BACKSPACE(1)
         IF(ISOT.EQ.2)THEN
          read(1,33)ABSO(ISOT,5,IOW),
     1                                   (ABSO(ISOT,I,IOW),I=1,3)
         ELSE
          read(1,34)(ABSO(ISOT,I,IOW),I=1,3)
         ENDIF
        ENDIF
C
        read(1,30)LINE
        DO WHILE(LINE(2:8).NE.'  total')
         read(1,30)LINE
        END DO
        BACKSPACE(1)
        IF(IOW.LT.5)THEN
         read(1,35)ABSO(ISOT,4,IOW)
        ELSE
         BACKSPACE(1)
         read(1,36)ABSO(ISOT,1,IOW)
        ENDIF
C
        IF(ISOT.GT.3)THEN
         read(1,30)LINE
         DO WHILE(LINE(2:8).NE.'fission')
          read(1,30)LINE
         END DO
C
         read(1,30)LINE
         DO WHILE(LINE(2:8).NE.'  total')
          read(1,30)LINE
         END DO
         IF(IOW.LT.5)THEN
          BACKSPACE(1)
          read(1,34)(FIS(ISOT,I,IOW),I=1,3)
         ENDIF
C
         read(1,30)LINE
         DO WHILE(LINE(2:8).NE.'  total')
          read(1,30)LINE
         END DO
         BACKSPACE(1)
         IF(IOW.LT.5)THEN
          read(1,35)FIS(ISOT,4,IOW)
         ELSE
          BACKSPACE(1)
          read(1,36)FIS(ISOT,1,IOW)
         ENDIF
        ENDIF
C
        REWIND(1)
C
       END DO
C
       CLOSE(1)
      END DO
C***********************************************************************
C  3) CALCUL (Keff-1)*100000
C
      DO IOW=1,3,2
       AKAM1(IOW)=(AKAEFF(IOW)-1.0)*100000.0
      END DO
C***********************************************************************
C  4) CALCUL FAST FISSION RATIO FFR  =FIS.U8/FIS.U5 (MATERS.6-9 + F.AV.)
C  5) CALCUL RELATIVE CONVERSION RATIO C=ABS.U8/FIS.U5(MATERS.6-9+F.AV.)
C  6) CALCUL RELATIVE U5 FISSION RATE  RU5FR=FIS.U5        (MATERS.6-9)
C  7) CALCUL RELATIVE CU ACTIVITY RCA  =ABS.R.CU63 (MATERS.6-9 + M.AV.)
C  8) CALCUL LUTETIUM-MANGANESE RATIOS ALMR  =ABS.R.LU176/ABS.R.MN55
C                                                   (MATERS.6-9 + F.AV.)
C
      ANR(1)=1.0
      ANR(2)=6.0
      ANR(3)=12.0
      ANR(4)=18.0
      ANRT=0.0
      DO I=1,4
       ANRT=ANRT+ANR(I)
      ENDDO
C
C    THERMAL VALUES
C
      CP0   = ((ABSO(5,1,5)-FIS(5,1,5))/FIS(4,1,5))
      ALMRP = (ABSO(3,1,5)/ABSO(1,1,5))
      write(3,41)CP0,ALMRP
C
      DO IOW=1,3,2
C
       AU8DU5 = AU8(IOW)/AU5(IOW)
       write(3,42)AU5(IOW),AU8(IOW)
       FFR(5,IOW)=0.0
       C(5,IOW)=0.0
       RU5FR(5,IOW)=0.0
       RCA(5,IOW)=0.0
       ALMR(5,IOW)=0.0
C
       DO I=1,4
        write(3,43)IOW,I,(ABSO(K,I,IOW),K=1,5)
        write(3,44)IOW,I,(FIS(K,I,IOW),K=1,5)
C
        FFR(I,IOW)   = FIS(5,I,IOW)*AU8DU5/FIS(4,I,IOW)
        FFR(5,IOW)   = FFR(5,IOW)+FFR(I,IOW)*ANR(I)
        FFRR(I,IOW)  = 100.0*((FFR(I,IOW)/FFRE(I,IOW))-1.0)
C
        C(I,IOW)     = ((ABSO(5,I,IOW)-FIS(5,I,IOW))/FIS(4,I,IOW))/CP0
        C(5,IOW)     = C(5,IOW)+C(I,IOW)*ANR(I)
        CR(I,IOW)    = 100.0*((C(I,IOW)/CE(I,IOW))-1.0)
C
        RU5FR(I,IOW) = FIS(4,I,IOW)
        RU5FR(5,IOW) = RU5FR(5,IOW)+RU5FR(I,IOW)*ANR(I)
C
        RCA(I,IOW)   = ABSO(2,I,IOW)*0.692*4.5/(4.5*0.692+2.17*0.308)
        RCA(5,IOW)   = RCA(5,IOW)+RCA(I,IOW)*ANR(I)
C
        ALMR(I,IOW)  = (ABSO(3,I,IOW)/ABSO(1,I,IOW))/ALMRP
        ALMR(5,IOW)  = ALMR(5,IOW)+ALMR(I,IOW)*ANR(I)
        ALMRR(I,IOW) = 100.0*((ALMR(I,IOW)/ALMRE(I,IOW))-1.0)
C
       END DO
C
       FFR(5,IOW)   = FFR(5,IOW)/ANRT
       FFRR(5,IOW)  = 100.0*((FFR(5,IOW)/FFRE(5,IOW))-1.0)
       C(5,IOW)     = C(5,IOW)/ANRT
       CR(5,IOW)    = 100.0*((C(5,IOW)/CE(5,IOW))-1.0)
       RU5FR(5,IOW) = RU5FR(5,IOW)/ANRT
       RCA(5,IOW)   = RCA(5,IOW)/ANRT
       ALMR(5,IOW)  = ALMR(5,IOW)/ANRT
       ALMRR(5,IOW) = 100.0*((ALMR(5,IOW)/ALMRE(5,IOW))-1.0)
C
       DO I=1,4
        RU5FR(I,IOW)  = RU5FR(I,IOW)/RU5FR(5,IOW)
        RU5FRR(I,IOW) = 100.0*((RU5FR(I,IOW)/RU5FRE(I,IOW))-1.0)
        RCA(I,IOW)    = RCA(I,IOW)/RCA(5,IOW)
        RCAR(I,IOW)   = 100.0*((RCA(I,IOW)/RCAE(I,IOW))-1.0)
       END DO
C
C  MODERATOR AV.
C
       RCA5=RCA(5,IOW)
       RCA(5,IOW)  = ABSO(2,5,IOW)*0.692*4.5/(4.5*0.692+2.17*0.308)
       RCA(5,IOW)  = RCA(5,IOW)/RCA5
       RCAR(5,IOW) = 100.0*((RCA(5,IOW)/RCAE(5,IOW))-1.0)
C
      END DO
C***********************************************************************
C  9) WRITE RESULTS
C
C
      REFER1 ='(*):WITHIN EXPERIM.ERROR'
      DVOID= "   "
      DINEX= "(*)"
      DDLOW= "(v)"
C
      OPEN(2,FILE='E1T1.LIS')
      write(2,1)TIT(1:31)
      write(2,1)REF
      write(2,1)
      write(2,23)REFER1
      write(2,1)
C
C TABLE 2
C
      DO I=1,3,2
       ANA(1,I)=DVOID
      ENDDO
      write(2,6)
      WRITE(2,7)(AKAM1(IOW),ANA(1,IOW),IOW=1,3,2)
C
C TABLE 3
C
      write(2,8)
      WRITE(2,9)(FFRE(I1,1),I1=1,5),(FFRE(I3,3),I3=1,5)
C
C TABLE 4
C
      DO J=1,3,2
       DO I=1,5
        ANA(I,J)=DVOID
       ENDDO
      ENDDO
      DO J=1,3,2
       DO I=1,5
        IF(ABS(FFRR(I,J)).LT.SDFF)ANA(I,J)=DINEX
       ENDDO
      ENDDO
      write(2,10)SDFF
      WRITE(2,11)((FFRR(I,J),ANA(I,J),I=1,5),J=1,3,2)
C
C TABLE 5
C
      write(2,12)
      WRITE(2,9)(CE(I1,1),I1=1,5),(CE(I3,3),I3=1,5)
C
C TABLE 6
C
      DO J=1,3,2
       DO I=1,5
        ANA(I,J)=DVOID
       ENDDO
      ENDDO
      DO J=1,3,2
       DO I=1,5
        IF(ABS(CR(I,J)).LT.SDC)ANA(I,J)=DINEX
       ENDDO
      ENDDO
      write(2,14)SDC
      WRITE(2,15)((CR(I,J),ANA(I,J),I=1,5),J=1,3,2)
C
C TABLE 7
C
      write(2,16)
      WRITE(2,17)(RU5FRE(I1,1),I1=1,4),(RU5FRE(I3,3),I3=1,4)
C
C TABLE 8
C
      DO J=1,3,2
       DO I=1,5
        ANA(I,J)=DVOID
       ENDDO
      ENDDO
      DO J=1,3,2
       DO I=1,4
        IF(ABS(CR(I,J)).LT.SDRU5)ANA(I,J)=DINEX
       ENDDO
      ENDDO
      write(2,18)SDRU5
      WRITE(2,19)((RU5FRR(I,J),ANA(I,J),I=1,4),J=1,3,2)
C
C TABLE 9
C
      write(2,20)
      WRITE(2,21)(RCAE(I1,1),I1=1,5),(RCAE(I3,3),I3=1,5)
C
C TABLE 10
C
      DO J=1,3,2
       DO I=1,5
        ANA(I,J)=DVOID
       ENDDO
      ENDDO
      DO J=1,3,2
       DO I=1,5
        IF(ABS(RCAR(I,J)).LT.SDRCA)ANA(I,J)=DINEX
       ENDDO
      ENDDO
      write(2,22)SDRCA
      WRITE(2,15)((RCAR(I,J),ANA(I,J),I=1,5),J=1,3,2)
C
C TABLE 11
C
      write(2,24)
      WRITE(2,21)(ALMRE(I1,1),I1=1,5),(ALMRE(I3,3),I3=1,5)
C
C TABLE 12
C
      DO J=1,3,2
       DO I=1,5
        ANA(I,J)=DVOID
       ENDDO
      ENDDO
      DO J=1,3,2
       DO I=1,5
        IF(ABS(ALMRR(I,J)).LT.SDAL)ANA(I,J)=DINEX
       ENDDO
      ENDDO
      write(2,26)SDAL
      WRITE(2,15)((ALMRR(I,J),ANA(I,J),I=1,5),J=1,3,2)
C
      CLOSE(2)
      CLOSE(3)
C
  1   FORMAT(A80)
  2   FORMAT(5E13.5)
  3   FORMAT(E13.5)
  4   FORMAT(4E13.5)
  5   FORMAT(A44)
  6   FORMAT('----------------------------------------------'/
     1       'TABLE 2'/
     2       'Effective Multiplication Factor'/
     3       '(Keff-1.00000)*100000; unit:pcm'//
     4       'COOLANT METHOD')
  7   FORMAT('D2O     DSN   ',F6.0,A3/
     2       'AIR     DSN   ',F6.0,A3//)
  8   FORMAT('----------------------------------------------'/
     1       'TABLE 3'/
     2       'Fast Fission Ratio'/
     3       'Reference Experimental Values'//
     4       'Coolant    A       B       C       D       FA')
  9   FORMAT('D2O    ',5F8.4/
     1       'AIR    ',5F8.4//)
 10   FORMAT('----------------------------------------------'/
     1       'TABLE 4'/
     2       'Fast Fission Ratio'/
     3       'D=(calc/exp-1)*100'/'(Dexp.=',F4.1,' %)'//
     4       'Coolant Method     A        B        C        D       FA')
 11   FORMAT('D2O     DSN   ',5(F6.1,A3)/
     2       'AIR     DSN   ',5(F6.1,A3)//)
 12   FORMAT('----------------------------------------------'/
     1       'TABLE 5'/
     2       'Initial Conversion Ratio'/
     3       'Reference Experimental Values'//
     4       'Coolant    A       B       C       D       FA')
 14   FORMAT('----------------------------------------------'/
     1       'TABLE 6'/
     2       'Initial Conversion Ratio'/
     3       'D=(calc/exp-1)*100'/'(Dexp.=',F5.2,' %)'//
     4       'Coolant Method     A         B         C         D
     5 FA')
 15   FORMAT('D2O     DSN   ',5(F7.2,A3)/
     2       'AIR     DSN   ',5(F7.2,A3)//)
 16   FORMAT('----------------------------------------------'/
     1       'TABLE 7'/
     2       'U-235 Fission Rate'/
     3       'Reference Experimental Values'//
     4       'Coolant   A      B      C      D')
 17   FORMAT('D2O    ',4F7.3/
     1       'AIR    ',4F7.3//)
 18   FORMAT('----------------------------------------------'/
     1       'TABLE 8'/
     2       'U-235 Fission Rate'/
     3       'D=(calc/exp-1)*100'/'(Dexp.=',F4.1,' %)'//
     4       'Coolant Method     A         B         C         D')
 19   FORMAT('D2O     DSN   ',4(F7.2,A3)/
     2       'AIR     DSN   ',4(F7.2,A3)//)
 20   FORMAT('----------------------------------------------'/
     1       'TABLE 9'/
     2       'Relative Copper Activity'/
     3       'Reference Experimental Values'//
     4       'Coolant   A      B      C      D      MA')
 21   FORMAT('D2O    ',5F7.3/
     1       'AIR    ',5F7.3//)
 22   FORMAT('----------------------------------------------'/
     1       'TABLE 10'/
     2       'Relative Copper Activity'/
     3       'D=(calc/exp-1)*100'/'(Dexp.=',F4.1,' %)'//
     4       'Coolant Method    A        B        C        D        MA')
 23   FORMAT(A24)
 24   FORMAT('----------------------------------------------'/
     1       'TABLE 11'/
     2       'Lutetium-Manganese Activity Ratio'/
     3       'Reference Experimental Values'//
     4       'Coolant   A      B      C      D      FA')
 25   FORMAT(A30)
 26   FORMAT('----------------------------------------------'/
     1       'TABLE 12'/
     2       'Lutetium-Manganese Activity Ratio'/
     3       'D=(calc/exp-1)*100'/'(Dexp.=',F4.1,' %)'//
     4       'Coolant Method    A        B        C        D        FA')
 30   FORMAT(A80)
 31   FORMAT(61X,E11.4)
 32   FORMAT(64X,E13.6)
 33   FORMAT(25X,E13.5,39X,3E13.5)
 34   FORMAT(77X,3E13.5)
 35   FORMAT(12X,E13.5,26X)
 36   FORMAT(51X,E13.5)
 40   FORMAT('AKAEFF ',E13.6)
 41   FORMAT('CP0,ALMRP',2E12.5)
 42   FORMAT('AU5,AU8',2E12.5)
 43   FORMAT('IOW,I,ABSO',2I3,5E12.5)
 44   FORMAT('IOW,I,FIS',2I3,5E12.5)
C
      STOP 'Completed'
      END
*deck e1t2 
C
C  PROGRAM E1T2
C
C  AUTHOR: FRANCISCO LESZCZYNSKI-INGENIERIA NUCLEAR- 1999
C                                CENTRO ATOMICO BARILOCHE
C                                ARGENTINA
C
C  PROCESS WIMS OUTPUT FOR BENCHMARK D2O EX.1)ZED-2 Task 2 FOR 1 LIBRARY
C
C  1) READ EXPERIMENTAL VALUES OF PARAMETERS (FOR 24 AND 40 CM PITCHS)
C     <- E1T2.REF
C
C  2) READ WIMS-D RESULTS-IOW
C                          1 <-E1T2P24D.OUT;
C                          3 <-E1T2P40D.OUT;
C  2.1) READ Nu5,Nu8
C  2.2) READ Keff
C  2.3) READ TOTAL REACTION RATES BY MATERIAL, OF:
C       U-235(2235) AND U-238(8238)
C
C  3) CALCUL (Keff-1)*100000
C  4) CALCUL FAST FISSION RATIO        FFR  =FIS.U8/FIS.U5 (MATER.6)
C  5) CALCUL RELATIVE CONVERSION RATIO C    =ABS.U8/FIS.U5     "
C  6) WRITE RESULTS
C
C***********************************************************************
      DIMENSION FFRE(5,4),CE(5,4),RU5FRE(5,4),RCAE(5,4),ALMRE(5,4)
      DIMENSION FFR(5,5),C(5,5),RU5FR(5,5),RCA(5,5),ALMR(5,5)
      DIMENSION FFRR(5,5),CR(5,5),RU5FRR(5,5),RCAR(5,5),ALMRR(5,5)
      DIMENSION AU5(5),AU8(5)
      DIMENSION AKAEFF(4),AKAM1(4)
      DIMENSION ABSO(5,5,5),FIS(5,5,5)
      DIMENSION ANR(4)
      CHARACTER*3 DVOID,DINEX,DDLOW,ANA(5,4)
      CHARACTER*12 OUTW(5)
      CHARACTER*24 REFER1
      CHARACTER*28 AISOT(5)
      CHARACTER*30 REFER2
      CHARACTER*44 ADVICE
      CHARACTER*80 TIT,REF,TIT2(2)
      CHARACTER*80 LINE
C
C***********************************************************************
C  1) READ EXPERIMENTAL VALUES OF PARAMETERS (FOR 24 AND 40 CM PITCHS)
C
      OPEN(1,FILE='E1T2.REF')
      read(1,1)TIT
      read(1,1)REF
      DO IC=1,2
       read(1,1)TIT2(IC)
       read(1,2)FFRE(1,IC)
       read(1,3)SDFF
       read(1,2)CE(1,IC)
       read(1,3)SDC
      END DO
      CLOSE(1)
C
      IC=3
       FFRE(1,IC)=FFRE(1,IC-1)
       CE(1,IC)=CE(1,IC-1)
C***********************************************************************
C  2) READ WIMS-D RESULTS: 1)<-E1T2P24D.OUT
C                          3)<-E1T2P40D.OUT
C
      OUTW(1)="E1T2P24D.OUT"
      OUTW(3)="E1T2P40D.OUT"
C
      AISOT(1)='element  2235 reaction rates'
      AISOT(2)='element  8238 reaction rates'
C
      OPEN(3,FILE="E1T2.TEM")
      DO IOW=1,3,2
       OPEN(1,FILE=OUTW(IOW))
C
C 2.1) READ Nu5,Nu8
C
       read(1,35)LINE
       DO WHILE(LINE(1:7).NE.'  2235 ')
        read(1,35)LINE
       END DO
       BACKSPACE(1)
       read(1,36)AU5(IOW)
       read(1,35)LINE
       DO WHILE(LINE(1:7).NE.'  8238 ')
        read(1,35)LINE
       END DO
       BACKSPACE(1)
       read(1,36)AU8(IOW)
C
C  2.2) READ Keff
C
        read(1,35)LINE
        DO WHILE(LINE(53:63).NE.'k-effective')
         read(1,35)LINE
        END DO
        BACKSPACE(1)
        read(1,37)AKAEFF(IOW)
        write(3,38)AKAEFF(IOW)
C
C  2.3) READ TOTAL REACTION RATES BY MATERIAL, OF:
C       U-235(2235) AND U-238(8238)
C
C -------------------------------------------------------------------
       DO ISOT=1,2
C     ISOT=4: ABS.AND FIS.R.U235
C     ISOT=5: ABS.AND FIS.R.U238
C
        read(1,35)LINE
        DO WHILE(LINE(2:29).NE.AISOT(ISOT))
         read(1,35)LINE
        END DO
C
        read(1,35)LINE
        DO WHILE(LINE(2:13).NE.'group materl')
         read(1,35)LINE
        END DO
C
        read(1,35)LINE
        DO WHILE(LINE(2:8).NE.'  total')
         read(1,35)LINE
        END DO
        IF(IOW.LT.5)THEN
         BACKSPACE(1)
         read(1,39)ABSO(ISOT,1,IOW)
        ENDIF
C
        read(1,35)LINE
        DO WHILE(LINE(2:8).NE.'fission')
         read(1,35)LINE
        END DO
C
        read(1,35)LINE
        DO WHILE(LINE(2:8).NE.'  total')
         read(1,35)LINE
        END DO
         BACKSPACE(1)
         read(1,39)FIS(ISOT,1,IOW)
C
       END DO
C
       CLOSE(1)
      END DO
C***********************************************************************
C  3) CALCUL (Keff-1)*100000
C
      DO IOW=1,3,2
       AKAM1(IOW)=(AKAEFF(IOW)-1.0)*100000.0
      END DO
C***********************************************************************
C  3) CALCUL (Keff-1)*100000
C  4) CALCUL FAST FISSION RATIO        FFR  =FIS.U8/FIS.U5 (MATER.6)
C  5) CALCUL RELATIVE CONVERSION RATIO C    =ABS.U8/FIS.U5     "
C
      DO IOW=1,3,2
C
       AU8DU5 = AU8(IOW)/AU5(IOW)
       write(3,40)AU5(IOW),AU8(IOW)
C
       write(3,41)IOW,(ABSO(K,1,IOW),K=1,2)
       write(3,42)IOW,(FIS(K,1,IOW),K=1,2)
C
       FFR(1,IOW)   = FIS(2,1,IOW)*AU8DU5/FIS(1,1,IOW)
       FFRR(1,IOW)  = 100.0*((FFR(1,IOW)/FFRE(1,IOW))-1.0)
C
       C(1,IOW)  = ((ABSO(2,1,IOW)-FIS(2,1,IOW))*AU8DU5/ABSO(1,1,IOW))
       CR(1,IOW) = 100.0*((C(1,IOW)/CE(1,IOW))-1.0)
C
      END DO
C***********************************************************************
C  6) WRITE RESULTS
C
  1   FORMAT(A80)
  2   FORMAT(5E13.5)
  3   FORMAT(E13.5)
  4   FORMAT(4E13.5)
  5   FORMAT(A44)
 23   FORMAT(A24)
 25   FORMAT(A30)
 27   FORMAT('----------------------------------------------'/
     1       'TABLE 14'/
     2       'Effective Multiplication Factor'/
     3       '(Keff-1.00000)*100000; unit:pcm'//
     4       'PITCH(cm) METHOD')
 28   FORMAT('  24      DSN   ',F6.0,A3/
     2       '  40      DSN   ',F6.0,A3//)
 29   FORMAT('----------------------------------------------'/
     1       'TABLE 15'/
     2       'Fast Fission Ratio'/
     3       'Reference Experimental Values'//
     4       'PITCH(cm)    FA')
 30   FORMAT('  24     ',F8.4/
     1       '  40     ',F8.4//)
 31   FORMAT('----------------------------------------------'/
     1       'TABLE 16'/
     2       'Fast Fission Ratio'/
     3       'D=(calc/exp-1)*100'/'(Dexp.=',F4.1,' %)'//
     4       'PITCH(cm) Method    FA')
 32   FORMAT('  24      DSN   ',F7.1,A3/
     2       '  40      DSN   ',F7.1,A3//)
 33   FORMAT('----------------------------------------------'/
     1       'TABLE 17'/
     2       'Initial Conversion Ratio'/
     3       'Reference Experimental Values'//
     4       'PITCH(cm)    FA')
 34   FORMAT('----------------------------------------------'/
     1       'TABLE 18'/
     2       'Initial Conversion Ratio'/
     3       'D=(calc/exp-1)*100'/'(Dexp.=',F5.2,' %)'//
     4       'PITCH(cm) Method    FA')
 35   FORMAT(A80)
 36   FORMAT(61X,E11.4)
 37   FORMAT(64X,E13.6)
 38   FORMAT("AKAEFF ",E13.6)
 39   FORMAT(77X,E13.5)
 40   FORMAT("AU5,AU8",2E12.5)
 41   FORMAT("IOW,ABSO",I3,5E12.5)
 42   FORMAT("IOW,FIS ",I3,5E12.5)
C
      REFER1 ='(*):WITHIN EXPERIM.ERROR'
      DVOID= "   "
      DINEX= "(*)"
      DDLOW= "(v)"
C
      OPEN(2,FILE='E1T2.LIS')
      write(2,1)TIT(1:31)
      write(2,1)REF
      write(2,1)
      write(2,23)REFER1
      write(2,1)
C
C TABLE 14
C
      DO I=1,3,2
       ANA(1,I)=DVOID
      ENDDO
      write(2,27)
      WRITE(2,28)(AKAM1(IOW),ANA(1,IOW),IOW=1,3,2)
C
C TABLE 15
C
      write(2,29)
      WRITE(2,30)FFRE(1,1),FFRE(1,3)
C
C TABLE 16
C
      DO J=1,3,2
       ANA(1,J)=DVOID
      ENDDO
      DO J=1,3,2
       IF(ABS(FFRR(1,J)).LT.SDFF)ANA(1,J)=DINEX
      ENDDO
      write(2,31)SDFF
      WRITE(2,32)(FFRR(1,J),ANA(1,J),J=1,3,2)
C
C TABLE 17
C
      write(2,33)
      WRITE(2,30)CE(1,1),CE(1,3)
C
C TABLE 18
C
      DO J=1,3,2
        ANA(1,J)=DVOID
      ENDDO
      DO J=1,3,2
       IF(ABS(CR(1,J)).LT.SDC)ANA(1,J)=DINEX
      ENDDO
      write(2,34)SDC
      WRITE(2,32)(CR(1,J),ANA(1,J),J=1,3,2)
C
      CLOSE(2)
      CLOSE(3)
C
      STOP 'E1T2 Completed'
      END
*deck e1t3 
C
C  PROGRAM E1T3
C
C  AUTHOR: FRANCISCO LESZCZYNSKI-INGENIERIA NUCLEAR- 1999
C                                CENTRO ATOMICO BARILOCHE
C                                ARGENTINA
C
C  PROCESS WIMS OUTPUT FOR BENCHMARK D2O EX.1)ZED-2 Task # FOR 1 LIBRARY
C
C  1) READ WIMS-D RESULTS-IOW
C                          1 <-E1T3000D.OUT;
C  2) READ Keff
C  3) CALCUL (Keff-1)*100000
C  4) WRITE RESULTS
C
C***********************************************************************
      DIMENSION AKAEFF(4),AKAM1(4)
      CHARACTER*3 DVOID,DDLOW,ANA(5,4)
      CHARACTER*12 OUTW(5)
      CHARACTER*30 REFER2
      CHARACTER*44 ADVICE
      CHARACTER*80 TIT,REF
      CHARACTER*80 LINE
C
C***********************************************************************
C  1) READ WIMS-D RESULTS: 1)<-E1T3000D.OUT
C
      OUTW(1)="E1T3000D.OUT"
C
      OPEN(3,FILE="E1T3.TEM")
      IOW=1
      OPEN(1,FILE=OUTW(IOW))
C
C  2) READ Keff
C
        read(1,37)LINE
        DO WHILE(LINE(53:63).NE.'k-effective')
         read(1,37)LINE
        END DO
        BACKSPACE(1)
        read(1,38)AKAEFF(IOW)
        write(3,39)AKAEFF(IOW)
C
      CLOSE(1)
C***********************************************************************
C  3) CALCUL (Keff-1)*100000
C
       AKAM1(IOW)=(AKAEFF(IOW)-1.0)*100000.0
C***********************************************************************
C  4) WRITE RESULTS
C
  1   FORMAT(A80)
  2   FORMAT(5E13.5)
  3   FORMAT(E13.5)
  4   FORMAT(4E13.5)
  5   FORMAT(A44)
 25   FORMAT(A30)
 35   FORMAT('----------------------------------------------'/
     1       'TABLE 20'/
     2       'Effective Multiplication Factor'/
     3       '(Keff-1.00000)*100000; unit:pcm'//
     4       'METHOD')
 36   FORMAT(' DSN  ',F6.0,A3//)
 37   FORMAT(A80)
 38   FORMAT(64X,E13.6)
 39   FORMAT("AKAEFF ",E13.6)
C
      TIT=' BENCHMARK EX.1-ZED 2 - TASK 3'
      REF=' REF.= R.T.jones, AECL-5853,1977'
C
      DVOID= "   "
      DDLOW= "(v)"
C
      OPEN(2,FILE='E1T3.LIS')
      write(2,1)TIT
      write(2,1)REF
      write(2,1)
      write(2,1)
C
C TABLE 20
C
      ANA(1,1)=DVOID
      write(2,35)
      WRITE(2,36)AKAM1(IOW),ANA(1,IOW)
C
      CLOSE(2)
      CLOSE(3)
C
      STOP 'E1T3 Completed'
      END
*deck e1t4 
C
C  PROGRAM E1T4
C
C  AUTHOR: FRANCISCO LESZCZYNSKI-INGENIERIA NUCLEAR- 1999
C                                CENTRO ATOMICO BARILOCHE
C                                ARGENTINA
C
C  PROCESS WIMS OUTPUT FOR BENCHMARK D2O EX.1)ZED-2 Task 4 FOR 1 LIBRARY
C
C  1) READ EXPERIMENTAL VALUES OF PARAMETERS
C     (FOR PITCH 22 CM,COOLANT=D2O,AIR AND PITCH 24 CM,COOLANT=D2O,AIR)
C     <- E1T4.REF
C
C  2) READ WIMS-D RESULTS-IOW
C                          1 <-E1T4D22D.OUT;
C                          3 <-E1T4A22D.OUT;
C                          5 <-E1T4D28D.OUT;
C                          7 <-E1T4A28D.OUT;
C  2.1) READ Nth2,Nu5
C  2.2) READ Keff
C  2.3) READ TOTAL REACTION RATES BY MATERIAL, OF:
C       Th-232(2232) AND U-235(2235)
C
C  3) CALCUL (Keff-1)*100000
C  4) CALCUL FAST FISSION RATIO FFR=FIS.Th2*Nth2/FIS.U5*Nu5  (MATER.6)
C  5) CALCUL REL.CONV.RATIO C=(ABS.-FIS.)Th2*Nth2/FIS.U5*Nu5     "
C  6) WRITE RESULTS
C
C***********************************************************************
      DIMENSION FFRE(5,8),CE(5,8),RU5FRE(5,4),RCAE(5,4),ALMRE(5,4)
      DIMENSION FFR(5,8),C(5,8),RU5FR(5,5),RCA(5,5),ALMR(5,5)
      DIMENSION FFRR(5,8),CR(5,8),RU5FRR(5,5),RCAR(5,5),ALMRR(5,5)
      DIMENSION AU5(8),AU8(8)
      DIMENSION AKAEFF(8),AKAM1(8)
      DIMENSION ABSO(5,5,8),FIS(5,5,8)
      CHARACTER*3 DVOID,DINEX,DDLOW,ANA(5,8)
      CHARACTER*12 OUTW(8)
      CHARACTER*24 REFER1
      CHARACTER*28 AISOT(5)
      CHARACTER*30 REFER2
      CHARACTER*44 ADVICE
      CHARACTER*80 TIT,REF,TIT2
      CHARACTER*80 LINE
C
C***********************************************************************
C  1) READ EXPERIMENTAL VALUES OF PARAMETERS
C     (FOR PITCH 22 CM,COOLANT=D2O,AIR AND PITCH 24 CM,COOLANT=D2O,AIR)
C     <- E1T4.REF
C
      OPEN(1,FILE='E1T4.REF')
      read(1,1)TIT
      read(1,1)REF
       read(1,1)TIT2
       read(1,2)FFRE(1,1)
       read(1,3)SDFF
       read(1,2)CE(1,1)
       read(1,3)SDC
       read(1,1)TIT2
       read(1,2)FFRE(1,3)
       read(1,3)SDFF
       read(1,2)CE(1,3)
       read(1,3)SDC
       read(1,1)TIT2
       read(1,2)FFRE(1,5)
       read(1,3)SDFF
       read(1,2)CE(1,5)
       read(1,3)SDC
       read(1,1)TIT2
       read(1,2)FFRE(1,7)
       read(1,3)SDFF
       read(1,2)CE(1,7)
       read(1,3)SDC
      CLOSE(1)
C
C***********************************************************************
C  2) READ WIMS-D RESULTS-IOW
C                          1 <-E1T4D22D.OUT
C                          3 <-E1T4A22D.OUT
C                          5 <-E1T4D28D.OUT
C                          7 <-E1T4A28D.OUT
C
      OUTW(1)="E1T4D22D.OUT"
      OUTW(3)="E1T4A22D.OUT"
      OUTW(5)="E1T4D28D.OUT"
      OUTW(7)="E1T4A28D.OUT"
C
      AISOT(1)='element  2232 reaction rates'
      AISOT(2)='element  2235 reaction rates'
C
      OPEN(3,FILE="E1T4.TEM")
      DO IOW=1,7,2
       OPEN(1,FILE=OUTW(IOW))
C
C 2.1) READ Nth,Nu5
C
       read(1,47)LINE
       DO WHILE(LINE(1:7).NE.'  2232 ')
        read(1,47)LINE
       END DO
       BACKSPACE(1)
       read(1,48)AU5(IOW)
       read(1,47)LINE
       DO WHILE(LINE(1:7).NE.'  2235 ')
        read(1,47)LINE
       END DO
       BACKSPACE(1)
       read(1,48)AU8(IOW)
C
C  2.2) READ Keff
C
        read(1,47)LINE
        DO WHILE(LINE(53:63).NE.'k-effective')
         read(1,47)LINE
        END DO
        BACKSPACE(1)
        read(1,49)AKAEFF(IOW)
        write(3,50)AKAEFF(IOW)
C
C  2.3) READ TOTAL REACTION RATES BY MATERIAL, OF:
C       Th-232(2232) AND U-235(2235)
C
C -------------------------------------------------------------------
       DO ISOT=1,2
C     ISOT=1: ABS.AND FIS.R.Th232
C     ISOT=2: ABS.AND FIS.R.U235
C
        read(1,47)LINE
        DO WHILE(LINE(2:29).NE.AISOT(ISOT))
         read(1,47)LINE
        END DO
C
        read(1,47)LINE
        DO WHILE(LINE(2:13).NE.'group materl')
         read(1,47)LINE
        END DO
C
        read(1,47)LINE
        DO WHILE(LINE(2:8).NE.'  total')
         read(1,47)LINE
        END DO
         BACKSPACE(1)
         read(1,51)ABSO(ISOT,1,IOW)
C
        read(1,47)LINE
        DO WHILE(LINE(2:8).NE.'fission')
         read(1,47)LINE
        END DO
C
        read(1,47)LINE
        DO WHILE(LINE(2:8).NE.'  total')
         read(1,47)LINE
        END DO
        BACKSPACE(1)
        read(1,51)FIS(ISOT,1,IOW)
C
       END DO
C
       CLOSE(1)
      END DO
C***********************************************************************
C  3) CALCUL (Keff-1)*100000
C
      DO IOW=1,7,2
       AKAM1(IOW)=(AKAEFF(IOW)-1.0)*100000.0
      END DO
C***********************************************************************
C  4) CALCUL FAST FISSION RATIO FFR=FIS.Th2*Nth2/FIS.U5*Nu5  (MATER.6)
C  5) CALCUL REL.CONV.RATIO C=(ABS.-FIS.)Th2*Nth2/FIS.U5*Nu5     "
C
      DO IOW=1,7,2
C
       AU8DU5 = AU5(IOW)/AU8(IOW)
       write(3,52)AU5(IOW),AU8(IOW)
C
       write(3,53)IOW,(ABSO(K,1,IOW),K=1,2)
       write(3,54)IOW,(FIS(K,1,IOW),K=1,2)
C
       FFR(1,IOW)   = FIS(1,1,IOW)*AU8DU5/FIS(2,1,IOW)
       FFRR(1,IOW)  = 100.0*((FFR(1,IOW)/FFRE(1,IOW))-1.0)
C
       C(1,IOW)  = ((ABSO(1,1,IOW)-FIS(1,1,IOW))*AU8DU5/FIS(2,1,IOW))
       CR(1,IOW) = 100.0*((C(1,IOW)/CE(1,IOW))-1.0)
C
      END DO
C***********************************************************************
C  6) WRITE RESULTS
C
  1   FORMAT(A80)
  2   FORMAT(5E13.5)
  3   FORMAT(E13.5)
  4   FORMAT(4E13.5)
  5   FORMAT(A44)
 23   FORMAT(A24)
 25   FORMAT(A30)
 37   FORMAT('----------------------------------------------'/
     1       'TABLE 22'/
     2       'Effective Multiplication Factor'/
     3       '(Keff-1.00000)*100000; unit:pcm'//
     4       'PITCH(cm) COOLANT METHOD')
 38   FORMAT('  22      D2O     DSN   ',F6.0,A3/
     2       '          AIR     DSN   ',F6.0,A3/
     4       '  28      D2O     DSN   ',F6.0,A3/
     6       '          AIR     DSN   ',F6.0,A3//)
 39   FORMAT('----------------------------------------------'/
     1       'TABLE 23'/
     2       'Th232/U235 Fission Ratio'/
     3       'Reference Experimental Values'//
     4       'PITCH(cm) COOLANT    FA')
 40   FORMAT('  22        D2O  ',F9.5/
     1       '            AIR  ',F9.5/
     2       '  28        D2O  ',F9.5/
     3       '            AIR  ',F9.5//)
 41   FORMAT('----------------------------------------------'/
     1       'TABLE 24'/
     2       'Th232/U235 Fission Ratio'/
     3       'D=(calc/exp-1)*100'/'(Dexp.=',F5.1,' %)'//
     4       'PITCH(cm) COOLANT METHOD')
 42   FORMAT('  22      D2O     DSN   ',F5.1,A3/
     2       '          AIR     DSN   ',F5.1,A3/
     4       '  28      D2O     DSN   ',F5.1,A3/
     6       '          AIR     DSN   ',F5.1,A3//)
 43   FORMAT('----------------------------------------------'/
     1       'TABLE 25'/
     2       'Th232-CAPT/U235-FISS.Ratio'/
     3       'Reference Experimental Values'//
     4       'PITCH(cm) COOLANT    FA')
 44   FORMAT('  22        D2O  ',F6.3/
     1       '            AIR  ',F6.3/
     2       '  28        D2O  ',F6.3/
     3       '            AIR  ',F6.3//)
 45   FORMAT('----------------------------------------------'/
     1       'TABLE 26'/
     2       'Th232-CAPT/U235-FISS.Ratio'/
     3       'D=(calc/exp-1)*100'/'(Dexp.=',F3.1,' %)'//
     4       'PITCH(cm) COOLANT METHOD')
 46   FORMAT('  22      D2O     DSN   ',F7.2,A3/
     2       '          AIR     DSN   ',F7.2,A3/
     4       '  28      D2O     DSN   ',F7.2,A3/
     6       '          AIR     DSN   ',F7.2,A3//)
 47   FORMAT(A80)
 48   FORMAT(61X,E11.4)
 49   FORMAT(64X,E13.6)
 50   FORMAT("AKAEFF ",E13.6)
 51   FORMAT(77X,E13.5)
 52   FORMAT("ATh2,AU5",2E12.5)
 53   FORMAT("IOW,ABSO",I3,2E12.5)
 54   FORMAT("IOW,FIS ",I3,2E12.5)
C
      REFER1 ='(*):WITHIN EXPERIM.ERROR'
      DVOID= "   "
      DINEX= "(*)"
      DDLOW= "(v)"
C
      OPEN(2,FILE='E1T4.LIS')
      write(2,1)TIT(1:31)
      write(2,1)REF
      write(2,1)
      write(2,23)REFER1
      write(2,1)
C
C TABLE 22
C
      ANA(1,1)=DVOID
      ANA(1,3)=DVOID
      ANA(1,5)=DVOID
      ANA(1,7)=DVOID
      write(2,37)
      WRITE(2,38)(AKAM1(IOW),ANA(1,IOW),IOW=1,7,2)
C
C TABLE 23
C
      write(2,39)
      WRITE(2,40)FFRE(1,1),FFRE(1,3),FFRE(1,5),FFRE(1,7)
C
C TABLE 24
C
      DO J=1,7,2
       IF(ABS(FFRR(1,J)).LT.SDFF)ANA(1,J)=DINEX
      ENDDO
      write(2,41)SDFF
      WRITE(2,42)(FFRR(1,J),ANA(1,J),J=1,7,2)
C
C TABLE 25
C
      write(2,43)
      WRITE(2,44)CE(1,1),CE(1,3),CE(1,5),CE(1,7)
C
C TABLE 26
C
      DO J=1,7,2
       IF(ABS(CR(1,J)).LT.SDC)ANA(1,J)=DINEX
      ENDDO
      write(2,45)SDC
      WRITE(2,46)(CR(1,J),ANA(1,J),J=1,7,2)
C
      CLOSE(2)
      CLOSE(3)
C
      STOP 'E1T4 Completed'
      END
*deck e2t1 
C
C  PROGRAM E2T1
C
C  AUTHOR: FRANCISCO LESZCZYNSKI-INGENIERIA NUCLEAR- 1999
C                                CENTRO ATOMICO BARILOCHE
C                                ARGENTINA
C
C  PROCESS WIMS OUTPUT FOR BENCHMARK D2O EX.2)DCA Task 1 FOR ONE LIBRARY
C
C  1) READ WIMS-D RESULTS-IOW
C                          1 <-E2T1D22D.OUT;
C                          3 <-E2T1D25D.OUT;
C                          5 <-E2T1A22D.OUT;
C                          7 <-E2T1A25D.OUT;
C                          9 <-E2T1H22D.OUT;
C                         11 <-E2T1H22D.OUT;
C  2) READ Keff
C  3) CALCUL (Keff-1)*100000
C  4) WRITE RESULTS
C
C***********************************************************************
      DIMENSION AKAEFF(12),AKAM1(12)
      CHARACTER*3 DVOID,DDLOW,ANA(5,12)
      CHARACTER*12 OUTW(12)
      CHARACTER*30 REFER2
      CHARACTER*44 ADVICE
      CHARACTER*80 TIT,REF
      CHARACTER*80 LINE
C
C***********************************************************************
C  1) READ WIMS-D RESULTS
C
      OUTW(1)= "E2T1D22D.OUT"
      OUTW(3)= "E2T1A22D.OUT"
      OUTW(5)= "E2T1H22D.OUT"
      OUTW(7)= "E2T1D25D.OUT"
      OUTW(9)= "E2T1A25D.OUT"
      OUTW(11)="E2T1H25D.OUT"
C
      OPEN(3,FILE="E2T1.TEM")
      DO IOW=1,11,2
       OPEN(1,FILE=OUTW(IOW))
C
C  2) READ Keff
C
        read(1,49)LINE
        DO WHILE(LINE(53:63).NE.'k-effective')
         read(1,49)LINE
        END DO
        BACKSPACE(1)
        read(1,50)AKAEFF(IOW)
        write(3,51)AKAEFF(IOW)
C
       CLOSE(1)
      END DO
C***********************************************************************
C  3) CALCUL (Keff-1)*100000
C
      DO IOW=1,11,2
       AKAM1(IOW)=(AKAEFF(IOW)-1.0)*100000.0
      END DO
C***********************************************************************
C  4) WRITE RESULTS
C
  1   FORMAT(A80)
  2   FORMAT(5E13.5)
  3   FORMAT(E13.5)
  4   FORMAT(4E13.5)
  5   FORMAT(A44)
 25   FORMAT(A30)
 47   FORMAT('----------------------------------------------'/
     1       'TABLE 28'/
     2       'Effective Multiplication Factor'/
     3       '(Keff-1.00000)*100000; unit:pcm'//
     4       'PITCH(cm) COOLANT METHOD')
 48   FORMAT(' 22.5       D2O   DSN  ',F8.0,A3/
     2       '            AIR   DSN  ',F8.0,A3/
     4       '            H2O   DSN  ',F8.0,A3/
     6       ' 25.0       D2O   DSN  ',F8.0,A3/
     8       '            AIR   DSN  ',F8.0,A3/
     A       '            H2O   DSN  ',F8.0,A3//)
 49   FORMAT(A80)
 50   FORMAT(64X,E13.6)
 51   FORMAT("AKAEFF ",E13.6)
C
      TIT=' BENCHMARK EX.2-DCA - TASK 1'
      REF=' REF.= K.Shiba, Nucl.Sci.and Engn.65,492-507,1978'
C
      DVOID= "   "
      DDLOW= "(v)"
C
      OPEN(2,FILE='E2T1.LIS')
      write(2,1)TIT
      write(2,1)REF
      write(2,1)
      write(2,1)
C
C TABLE 28
C
      ANA(1,1)=DVOID
      ANA(1,3)=DVOID
      ANA(1,5)=DVOID
      ANA(1,7)=DVOID
      ANA(1,9)=DVOID
      ANA(1,11)=DVOID
      write(2,47)
      WRITE(2,48)(AKAM1(IOW),ANA(1,IOW),IOW=1,11,2)
C
      CLOSE(2)
      CLOSE(3)
C
      STOP 'E2T1 Completed'
      END
*deck E2T2 
C
C  PROGRAM E2T2
C
C  AUTHOR: FRANCISCO LESZCZYNSKI-INGENIERIA NUCLEAR- 1999
C                                CENTRO ATOMICO BARILOCHE
C                                ARGENTINA
C
C  PROCESS WIMS OUTPUT FOR BENCHMARK D2O EX.2)DCA Task 2 FOR ONE LIBRARY
C
C  1) READ EXPERIMENTAL VALUES OF PARAMETERS
C
C  2) READ WIMS-D RESULTS-IOW
C                          1 <-E2T2H00D.OUT;
C                          2 <-E2T2A00D.OUT;
C                          3 <-E2T2H12D.OUT;
C                          4 <-E2T2D00D.OUT;
C                          5 <-E2T2D01D.OUT;
C                          6 <-E2T2D05D.OUT;
C                          7 <-E2T2D10D.OUT;
C       READ TOTAL REACTION RATES BY MATERIAL OF Dy-164(164)
C
C  3) CALCUL THERMAL NEUTRON FLUX DISTRIBUTION FOR FUEL A1,A2,A3
C     (MATS.5,9,10,22) AND FOR MODERATOR VS. RADIUS (MATS.2,11-21)
C     FOR CLUSTER WITHOUT Gd (COOLANT=H2O and AIR) AND
C     FOR CLUSTER WITH Gd (COOLANT=H2O)
C  4) CALCUL DETAILED AND MEAN VALUE OF FINE STRUCTURE OF
C     THERMAL NEUTRON FLUX DISTRIBUTION ON A PIN ROUNDED BY D2O,
C     WITHOUT Gd AND WITH 0.1, 0.5 AND 1.0 WT% Gd
C  5) WRITE RESULTS
C
C***********************************************************************
      DIMENSION FFRE(33,8),CE(5,4),RU5FRE(5,4),RCAE(5,4),ALMRE(5,4)
      DIMENSION FFR(33,8),C(5,8),RU5FR(5,5),RCA(5,5),ALMR(5,5)
      DIMENSION FFRR(33,8),CR(5,8),RU5FRR(5,5),RCAR(5,5),ALMRR(5,5)
      DIMENSION ABSO(5,33,8),FIS(5,5,8)
      DIMENSION RADIO(33,8)
      CHARACTER*3 DVOID,DINEX,DDLOW,ANA(33,8)
      CHARACTER*12 OUTW(8)
      CHARACTER*24 REFER1
      CHARACTER*28 AISOT(5)
      CHARACTER*30 REFER2
      CHARACTER*44 ADVICE
      CHARACTER*80,TIT,REF,TIT2
      CHARACTER*120 LINE
C
C***********************************************************************
C  1) READ EXPERIMENTAL VALUES OF PARAMETERS
C
      OPEN(1,FILE='E2T2.REF')
      read(1,1)TIT
      read(1,1)REF
C
      DO J=1,2
       read(1,1)TIT2
       DO I=1,19
        read(1,3)FFRE(I,J)
       END DO
      END DO
C
      read(1,1)TIT2
      DO I=1,18
       read(1,3)FFRE(I,3)
      END DO
C
      read(1,1)TIT2
      DO I=1,8
       read(1,3)FFRE(I,7)
      END DO
C
      CLOSE(1)
  1   FORMAT(A80)
  3   FORMAT(E13.5)
C***********************************************************************
C  2) READ WIMS-D RESULTS-IOW
C                          1 <-E2T2H00D.OUT;
C                          2 <-E2T2A00D.OUT;
C                          3 <-E2T2H12D.OUT;
C                          4 <-E2T2D00D.OUT;
C                          5 <-E2T2D01D.OUT;
C                          6 <-E2T2D05D.OUT;
C                          7 <-E2T2D10D.OUT;
C
       OUTW(1)="E2T2H00D.OUT"
       OPEN(1,FILE=OUTW(1))
C
C       CHECK IF LIBRARY WIMS86
C
        read(1,'(A120)')LINE
        IW86=0
        DO WHILE(LINE(16:34).NE.'entry into chain  2')
         read(1,'(A120)')LINE
         IF(LINE(1:43).EQ.'    129    69    25    14    13    17    55')
     1    IW86=1
        END DO
        CLOSE(1)
        IF(IW86.EQ.1)GOTO 1000
C
C NORMAL
      OUTW(2)="E2T2A00D.OUT"
      OUTW(3)="E2T2H12D.OUT"
      OUTW(4)="E2T2D00D.OUT"
      OUTW(5)="E2T2D01D.OUT"
      OUTW(6)="E2T2D05D.OUT"
      OUTW(7)="E2T2D10D.OUT"
C
      AISOT(1)='element   164 reaction rates'
C
      DO IOW=1,3
       OPEN(1,FILE=OUTW(IOW))
C
C       READ TOTAL REACTION RATES BY MATERIAL OF Dy-164(164)
C
C -------------------------------------------------------------------
C
       ISOT=1
C
C      ISOT=1: ABS.R Dy164
C
        read(1,'(A120)')LINE
        DO WHILE(LINE(2:11).NE.'k-eff edit')
         read(1,'(A120)')LINE
        END DO
        read(1,'(A120)')LINE
        DO WHILE(LINE(2:29).NE.AISOT(ISOT))
         read(1,'(A120)')LINE
        END DO
        read(1,'(A120)')LINE
        DO WHILE(LINE(2:13).NE.'group materl')
         read(1,'(A120)')LINE
        END DO
         read(1,'(A120)')LINE
         DO WHILE(LINE(2:8).NE.'  total')
          read(1,'(A120)')LINE
         END DO
         BACKSPACE(1)
C         BACKSPACE(1)
         read(1,'(12X,8E13.5)')(ABSO(ISOT,J,IOW),J=1,8)
         read(1,'(A120)')LINE
         DO WHILE(LINE(2:8).NE.'  total')
          read(1,'(A120)')LINE
         END DO
         BACKSPACE(1)
C         BACKSPACE(1)
         read(1,'(12X,8E13.5)')(ABSO(ISOT,J,IOW),J=9,16)
         read(1,'(A120)')LINE
         DO WHILE(LINE(2:8).NE.'  total')
          read(1,'(A120)')LINE
         END DO
         BACKSPACE(1)
C         BACKSPACE(1)
         read(1,'(12X,6E13.5)')(ABSO(ISOT,J,IOW),J=17,22)
C
       CLOSE(1)
      END DO
C -------------------------------------------------------------------
      DO IOW=4,7
       OPEN(1,FILE=OUTW(IOW))
C
C      READ TOTAL REACTION RATES BY MESH, OF:
C      Dy-164(164)
C
C      ISOT=1: ABS.R Dy164
C
       ISOT=1
       read(1,'(A120)')LINE
       DO WHILE(LINE(2:11).NE.'k-inf edit')
        read(1,'(A120)')LINE
       END DO
C
       read(1,'(A120)')LINE
       DO WHILE(LINE(2:29).NE.AISOT(ISOT))
        read(1,'(A120)')LINE
       END DO
       read(1,'(A120)')LINE
       DO WHILE(LINE(2:8).NE.'  total')
        read(1,'(A120)')LINE
       END DO
C       BACKSPACE(1)
       BACKSPACE(1)
       read(1,'(12X,8E13.5)')(ABSO(ISOT,J,IOW),J=1,8)
       read(1,'(A120)')LINE
       DO WHILE(LINE(2:8).NE.'  total')
        read(1,'(A120)')LINE
       END DO
C       BACKSPACE(1)
       BACKSPACE(1)
       read(1,'(12X,8E13.5)')(ABSO(ISOT,J,IOW),J=9,16)
       read(1,'(A120)')LINE
       DO WHILE(LINE(2:8).NE.'  total')
        read(1,'(A120)')LINE
       END DO
C       BACKSPACE(1)
       BACKSPACE(1)
       read(1,'(12X,8E13.5)')(ABSO(ISOT,J,IOW),J=17,24)
       read(1,'(A120)')LINE
       DO WHILE(LINE(2:8).NE.'  total')
        read(1,'(A120)')LINE
       END DO
C       BACKSPACE(1)
       BACKSPACE(1)
       read(1,'(12X,8E13.5)')(ABSO(ISOT,J,IOW),J=25,32)
C
       CLOSE(1)
      END DO
      GOTO 1001
C***********************************************************************
C***********************************************************************
C  WIMS86
C  2) READ WIMS-D RESULTS-IOW
C                          1 <-E2T2H00D.OUT;
C                          2 <-E2T2A00D.OUT;
C                          3 <-E2T2H12D.OUT;
C                          4 <-E2T2D00D.OUT;
C                          5 <-E2T2D01D.OUT;
C                          6 <-E2T2D05D.OUT;
C                          7 <-E2T2D10D.OUT;
C
1000  OUTW(1)="E2T2H00D.OUT"
      OUTW(2)="E2T2A00D.OUT"
      OUTW(3)="E2T2H12D.OUT"
      OUTW(4)="E2T2D00D.OUT"
      OUTW(5)="E2T2D01D.OUT"
      OUTW(6)="E2T2D05D.OUT"
      OUTW(7)="E2T2D10D.OUT"
C
      AISOT(1)='element   164 reaction rates'
C
      DO IOW=1,3
       OPEN(1,FILE=OUTW(IOW))
C
C       READ TOTAL REACTION RATES BY MATERIAL OF Dy-164(164)
C
C -------------------------------------------------------------------
       ISOT=1
C
C      ISOT=1: ABS.R Dy164
C
        read(1,'(A120)')LINE
        DO WHILE(LINE(2:11).NE.'k-eff edit')
         read(1,'(A120)')LINE
        END DO
        read(1,'(A120)')LINE
        DO WHILE(LINE(2:29).NE.AISOT(ISOT))
         read(1,'(A120)')LINE
        END DO
        read(1,'(A120)')LINE
        DO WHILE(LINE(2:13).NE.'group materl')
         read(1,'(A120)')LINE
        END DO
         read(1,'(A120)')LINE
         DO WHILE(LINE(2:8).NE.'  total')
          read(1,'(A120)')LINE
         END DO
         BACKSPACE(1)
C         BACKSPACE(1)
         read(1,'(12X,8E13.5)')(ABSO(ISOT,J,IOW),J=1,8)
         read(1,'(A120)')LINE
         DO WHILE(LINE(2:8).NE.'  total')
          read(1,'(A120)')LINE
         END DO
         BACKSPACE(1)
C         BACKSPACE(1)
         read(1,'(12X,8E13.5)')(ABSO(ISOT,J,IOW),J=9,16)
         read(1,'(A120)')LINE
         DO WHILE(LINE(2:8).NE.'  total')
          read(1,'(A120)')LINE
         END DO
         BACKSPACE(1)
C         BACKSPACE(1)
         read(1,'(12X,6E13.5)')(ABSO(ISOT,J,IOW),J=17,22)
C
       CLOSE(1)
      END DO
C -------------------------------------------------------------------
      DO IOW=4,7
       OPEN(1,FILE=OUTW(IOW))
C
C      READ TOTAL REACTION RATES BY MESH, OF:
C      Dy-164(164)
C
C      ISOT=1: ABS.R Dy164
C
       ISOT=1
       read(1,'(A120)')LINE
       DO WHILE(LINE(2:11).NE.'k-inf edit')
        read(1,'(A120)')LINE
       END DO
C
       read(1,'(A120)')LINE
       DO WHILE(LINE(2:29).NE.AISOT(ISOT))
        read(1,'(A120)')LINE
       END DO
       read(1,'(A120)')LINE
       DO WHILE(LINE(2:8).NE.'  total')
        read(1,'(A120)')LINE
       END DO
C       BACKSPACE(1)
       BACKSPACE(1)
       read(1,'(12X,8E13.5)')(ABSO(ISOT,J,IOW),J=1,8)
       read(1,'(A120)')LINE
       DO WHILE(LINE(2:8).NE.'  total')
        read(1,'(A120)')LINE
       END DO
C       BACKSPACE(1)
       BACKSPACE(1)
       read(1,'(12X,8E13.5)')(ABSO(ISOT,J,IOW),J=9,16)
       read(1,'(A120)')LINE
       DO WHILE(LINE(2:8).NE.'  total')
        read(1,'(A120)')LINE
       END DO
C       BACKSPACE(1)
       BACKSPACE(1)
       read(1,'(12X,8E13.5)')(ABSO(ISOT,J,IOW),J=17,24)
       read(1,'(A120)')LINE
       DO WHILE(LINE(2:8).NE.'  total')
        read(1,'(A120)')LINE
       END DO
C       BACKSPACE(1)
       BACKSPACE(1)
       read(1,'(12X,8E13.5)')(ABSO(ISOT,J,IOW),J=25,32)
C
       CLOSE(1)
      END DO
C **********************************************************************
C **********************************************************************
C  3) CALCUL THERMAL NEUTRON FLUX DISTRIBUTION FOR FUEL A1,A2,A3
C     (MATS.5,9,10,22), FOR P.TUBE, GAP AND CAL.TUBE (MATS. 3,4,8),
C     AND FOR MODERATOR VS. RADIUS (MATS.2,11-21)
C     FOR CLUSTER WITHOUT Gd (COOLANT=H2O and AIR) AND
C     FOR CLUSTER WITH Gd (COOLANT=H2O)
C
1001  DO IOW=1,2
       ABSO2=ABSO(1,3,IOW)
       FFR(1,IOW)=ABSO(1,5,IOW)/ABSO2
       FFRR(1,IOW)=FFR(1,IOW)-FFRE(1,IOW)
       FFR(2,IOW)=ABSO(1,9,IOW)/ABSO2
       FFRR(2,IOW)=FFR(2,IOW)-FFRE(2,IOW)
       FFR(3,IOW)=ABSO(1,10,IOW)
       FFR(3,IOW)=(0.5*FFR(3,IOW)+0.5*ABSO(1,22,IOW))/ABSO2
       FFRR(3,IOW)=FFR(3,IOW)-FFRE(3,IOW)
       FFR(4,IOW)=1.0
       FFRR(4,IOW)=0.0
       FFR(5,IOW)=ABSO(1,4,IOW)/ABSO2
       FFRR(5,IOW)=FFR(5,IOW)-FFRE(5,IOW)
       FFR(6,IOW)=ABSO(1,8,IOW)/ABSO2
       FFRR(6,IOW)=FFR(6,IOW)-FFRE(6,IOW)
C
       FFR(7,IOW)=ABSO(1,2,IOW)/ABSO2
       FFRR(7,IOW)=FFR(7,IOW)-FFRE(7,IOW)
       DO I=8,18
        FFR(I,IOW)=ABSO(1,I+3,IOW)/ABSO2
        FFRR(I,IOW)=FFR(I,IOW)-FFRE(I,IOW)
       END DO
       DR=1.0
       RADIO(1,IOW)=3.825
       RADIO(2,IOW)=5.76
       RADIO(3,IOW)=7.68
       RADIO(4,IOW)=9.25
       RADIO(5,IOW)=9.75
       RADIO(6,IOW)=10.25
       RADIO(7,IOW)=11.0
       DO I=8,18
        RADIO(I,IOW)=RADIO(I-1,IOW)+DR
       END DO
      END DO
C
      ABSO2=ABSO(1,3,3)
      FFR(1,3)=ABSO(1,5,3)/ABSO2
      FFRR(1,3)=FFR(1,3)-FFRE(1,3)
      FFR(2,3)=ABSO(1,9,3)/ABSO2
      FFRR(2,3)=FFR(2,3)-FFRE(2,3)
      FFR(3,3)=ABSO(1,10,3)/ABSO2
      FFRR(3,3)=FFR(3,3)-FFRE(3,3)
      FFR(4,3)=ABSO(1,22,3)/ABSO2
      FFRR(4,3)=FFR(4,3)-FFRE(4,3)
      FFR(5,3)=1.0
      FFRR(5,3)=0.0
      FFR(6,3)=ABSO(1,4,3)/ABSO2
      FFRR(6,3)=FFR(6,3)-FFRE(6,3)
      FFR(7,3)=ABSO(1,8,3)/ABSO2
      FFRR(7,3)=FFR(7,3)-FFRE(7,3)
      FFR(8,3)=ABSO(1,2,3)/ABSO2
      FFRR(8,3)=FFR(8,3)-FFRE(8,3)
      DO I=9,17
       FFR(I,3)=ABSO(1,I+2,3)/ABSO2
       FFRR(I,3)=FFR(I,3)-FFRE(I,3)
      ENDDO
C
      DR=1.0
      RADIO(1,3)=3.825
      RADIO(2,3)=5.76
      RADIO(4,3)=7.68
      RADIO(5,3)=9.25
      RADIO(6,3)=9.75
      RADIO(7,3)=10.25
      RADIO(8,3)=11.0
      DO I=9,17
       RADIO(I,3)=RADIO(I-1,3)+DR
      END DO
C
C  4) CALCUL MEAN VALUE OF FINE STRUCTURE OF THERMAL NEUTRON FLUX DIST.
C     ON A PIN WITHOUT Gd AND WITH 0.1,0.5 AND 1.0 WT% Gd
C
      DO IOW=4,7
       ABSO32=ABSO(1,32,IOW)
       FFR(33,IOW)=0.0
       DO I=1,32
        FFR(I,IOW)=ABSO(1,I,IOW)/ABSO32
        FFR(33,IOW)=FFR(33,IOW)+FFR(I,IOW)
       ENDDO
       FFR(33,IOW)=FFR(33,IOW)/32.0
       FFRR(33,IOW)=FFR(33,IOW)-FFRE(IOW-3,7)
      END DO
C***********************************************************************
C***********************************************************************
C  6) WRITE RESULTS
C
      OPEN(2,FILE='E2T2.LIS')
C **********************************
C
C TABLE 1
C
      WRITE(2,400)' Thermal Neutron Flux Distribution'
      WRITE(2,400)' Ai:Annulus i;Mj:Moderator (j:cm) '
      WRITE(2,400)' ================================='
      WRITE(2,401)' Case  COO  A1   DIF.%  A2   DIF.% A3NG  DIF.% A3WG
     1DIF.%  M11  DIF.%  M16  DIF.%  M22  DIF.% '
      WRITE(2,401)' ====================================================
     1=========================================='
      WRITE(2,500)(FFRE(I,1),(FFRE(19,1)*100.0/FFRE(I,1)),I=1,3),
     1 FFRE(7,1),(FFRE(19,1)*100.0/FFRE(7,1)),
     2 FFRE(12,1),(FFRE(19,1)*100.0/FFRE(12,1)),
     3 FFRE(18,1),(FFRE(19,1)*100.0/FFRE(18,1))
      WRITE(2,503)(FFR(I,1),(FFRR(I,1)*100.0/FFR(I,1)),I=1,3),
     1 FFR(7,1),(FFRR(7,1)*100.0/FFR(7,1)),
     2 FFR(12,1),(FFRR(12,1)*100.0/FFR(12,1)),
     3 FFR(18,1),(FFRR(18,1)*100.0/FFR(18,1))
      WRITE(2,402)'          '
C
      WRITE(2,501)(FFRE(I,2),(FFRE(19,1)*100.0/FFRE(I,2)),I=1,3),
     1 FFRE(7,2),(FFRE(19,1)*100.0/FFRE(7,2)),
     2 FFRE(12,2),(FFRE(19,1)*100.0/FFRE(12,2)),
     3 FFRE(18,2),(FFRE(19,1)*100.0/FFRE(18,2))
      WRITE(2,503)(FFR(I,2),(FFRR(I,2)*100.0/FFR(I,2)),I=1,3),
     1 FFR(7,2),(FFRR(7,2)*100.0/FFR(7,2)),
     2 FFR(12,2),(FFRR(12,2)*100.0/FFR(12,2)),
     3 FFR(18,2),(FFRR(18,2)*100.0/FFR(18,2))
      WRITE(2,402)'          '
C
      WRITE(2,502)(FFRE(I,3),(FFRE(18,3)*100.0/FFRE(I,3)),I=1,2),
     1 FFRE(4,3),(FFRE(18,3)*100.0/FFRE(4,3)),
     2 FFRE(8,3),(FFRE(18,3)*100.0/FFRE(8,3)),
     3 FFRE(13,3),(FFRE(18,3)*100.0/FFRE(13,3)),
     4 FFRE(17,3),(FFRE(18,3)*100.0/FFRE(17,3))
      WRITE(2,504)(FFR(I,3),(FFRR(I,3)*100.0/FFR(I,3)),I=1,2),
     1 FFR(4,3),(FFRR(4,3)*100.0/FFR(4,3)),
     2 FFR(8,3),(FFRR(8,3)*100.0/FFR(8,3)),
     3 FFR(13,3),(FFRR(13,3)*100.0/FFR(13,3)),
     4 FFR(17,3),(FFRR(17,3)*100.0/FFR(17,3))
      WRITE(2,402)'          '
      WRITE(2,401)' ====================================================
     1=========================================='
C
 400  FORMAT(A34)
 401  FORMAT(A95)
 402  FORMAT(A10)
 500  FORMAT(' Gd:NO  H2O',3(F5.2,'(',F6.1,')'),12X,3(F5.2,'(',F5.1,')')
     1)
 501  FORMAT(' Gd:NO  AIR',3(F5.2,'(',F6.1,')'),12X,3(F5.2,'(',F5.1,')')
     1)
 502  FORMAT(' Gd:YES H2O',2(F5.2,'(',F6.1,')'),12X,4(F5.2,'(',F5.1,')')
     1)
 503  FORMAT('           ',3(F5.2,'(',F6.1,')'),12X,3(F5.2,'(',F5.1,')')
     1)
 504  FORMAT('           ',2(F5.2,'(',F6.1,')'),12X,4(F5.2,'(',F5.1,')')
     1)
C *****************************
C
C FIGURE 1A
C
      EXPERR=FFRE(19,1)
      WRITE(2,600)' Therm.Flux Distr.H2O coolant-cluster without poison'
      WRITE(2,600)' ==================================================='
      WRITE(2,601)' R(cm)     FLUX   DIF.% '
      WRITE(2,601)' ======================='
      DO I=1,18
       WRITE(2,700)RADIO(I,1),FFRE(I,1),(EXPERR*100.0/FFRE(I,1))
       WRITE(2,701)FFR(I,1),(FFRR(I,1)*100.0/FFR(I,1))
       WRITE(2,402)'          '
      END DO
      WRITE(2,601)' ======================='
C
C FIGURE 1B
C
      WRITE(2,600)' Therm.Flux Distr.AIR coolant-cluster without poison'
      WRITE(2,600)' ==================================================='
      WRITE(2,601)' R(cm)     FLUX   DIF.% '
      WRITE(2,601)' ======================='
      DO I=1,18
       WRITE(2,700)RADIO(I,1),FFRE(I,2),(EXPERR*100.0/FFRE(I,2))
       WRITE(2,701)FFR(I,2),(FFRR(I,2)*100.0/FFR(I,2))
       WRITE(2,402)'          '
      END DO
      WRITE(2,601)' ======================='
C
 600  FORMAT(A52)
 601  FORMAT(A24)
 700  FORMAT(F7.2,3X,F7.2,'(',F7.2,')')
 701  FORMAT(10X,F7.2,'(',F7.2,')')
C *****************************
C
C FIGURE 2
C
      WRITE(2,600)' Therm.Flux Distr.12 poisoned fuel pins on 3rd.layer'
      WRITE(2,600)' ==================================================='
      WRITE(2,601)' R(cm)     FLUX   DIF.% '
      WRITE(2,601)' ======================='
      DO I=1,2
       WRITE(2,700)RADIO(I,3),FFRE(I,3),(EXPERR*100.0/FFRE(I,3))
       WRITE(2,701)FFR(I,3),(FFRR(I,3)*100.0/FFR(I,3))
       WRITE(2,402)'          '
      END DO
      DO I=4,17
       WRITE(2,700)RADIO(I,3),FFRE(I,3),(EXPERR*100.0/FFRE(I,3))
       WRITE(2,701)FFR(I,3),(FFRR(I,3)*100.0/FFR(I,3))
       WRITE(2,402)'          '
      END DO
      WRITE(2,601)' ======================='
C *****************************
C
C TABLE 32A
C
      WRITE(2,600)' Therm.Flux Distr.-Average Dy-reaction rate on pins '
      WRITE(2,600)' ==================================================='
      WRITE(2,601)' Case      Dy-RR  DIF.% '
      WRITE(2,601)' ======================='
C
      WRITE(2,801)FFRE(1,7),(FFRE(5,7)*100.0/FFRE(1,7))
      WRITE(2,805)FFR(33,4),(FFRR(33,4)*100.0/FFR(33,4))
      WRITE(2,402)'          '
C
      WRITE(2,802)FFRE(2,7),(FFRE(6,7)*100.0/FFRE(2,7))
      WRITE(2,805)FFR(33,5),(FFRR(33,5)*100.0/FFR(33,5))
      WRITE(2,402)'          '
C
      WRITE(2,803)FFRE(3,7),(FFRE(7,7)*100.0/FFRE(3,7))
      WRITE(2,805)FFR(33,6),(FFRR(33,6)*100.0/FFR(33,6))
      WRITE(2,402)'          '
C
      WRITE(2,804)FFRE(4,7),(FFRE(8,7)*100.0/FFRE(4,7))
      WRITE(2,805)FFR(33,7),(FFRR(33,7)*100.0/FFR(33,7))
      WRITE(2,402)'          '
C
      WRITE(2,601)' ======================='
C
 801  FORMAT(' Gd:NO    ',F7.3,'(',F7.3,')')
 802  FORMAT(' Gd:0.1wt%',F7.3,'(',F7.3,')')
 803  FORMAT(' Gd:0.5wt%',F7.3,'(',F7.3,')')
 804  FORMAT(' Gd:1.0wt%',F7.3,'(',F7.3,')')
 805  FORMAT('          ',F7.3,'(',F7.3,')')
C
      CLOSE(2)
C
      STOP 'Completed'
      END
*deck E2T2P 
       PROGRAM E2T2P
C-Title  : E2T2P Program
C-Purpose: Summarize WLUP E2T2 Benchmark (54 pin-cluster with Gd)
C-Version: Original code.
C-Author : A.Trkov, Institute Jozef Stefan, Ljubljana, Slovenia (2000)
C-M
C-M  Manual for Program E2T2P
C-M  ========================
C-M  A summary of results for the WLUP E2T2 benchmark
C-M
C-M  The list files are those produced by analysing the WIMS-D
C-M  outputs with post-processing codes developed within the scope
C-M  of the WIMS-D Library Update Project (IAEA-CRP 1999-2000) by
C-M  Francisco Leszczynski.
C-M
C-M  Instructions:
C-M  The filenames for the output report file and the 5 list files
C-M  for the benchmarks described above are entered in response to
C-M  the prompt from the keyboard. Individual files may be omitted
C-M  from the analysis by entering "-" for the filename.
C-M
C-
      DIMENSION AVER(6),STDEV(6),EXPER(17,1),CALCUL(17,1),DCALC(17,1)
      CHARACTER*120 REC
      CHARACTER*40  BLNK,FLNM,FLNI(8),FLNO
      CHARACTER*10  NAME(17)
C* Filenames and logical file units
      DATA LIN,LOU,LKB,LTT / 1, 2, 5, 6 /
      DATA BLNK/'                                        '/
     1    ,FLNI/'E2T2.lis   '
     2    ,     '           '
     3    ,     '           '
     4    ,     '           '
     1    ,     '           '
     1    ,     '           '
     1    ,     '           '
     1    ,     '           '/
     1    ,FLNO/'E2T2.LST   '/
C*
      DATA NAME/' EXP     1'
     1         ,' EXP     2'
     2         ,' EXP     3'
     3         ,' EXP     4'
     4         ,' EXP     5'
     5         ,' EXP     6'
     6         ,' EXP     7'
     7         ,' EXP     8'
     8         ,' EXP     9'
     9         ,' EXP    10'
     A         ,' EXP    11'
     B         ,' EXP    12'
     C         ,' EXP    13'
     D         ,' EXP    14'
     E         ,' EXP    15'
     F         ,' EXP    16'
     G         ,' EXP    17'/
C*
C* Define input parameters - Write banner to terminal
      WRITE(LTT,693)' E2T2 PROCESS - Gd D2O/AIR COOL.Gd 54 PIN CLUSTER '
      WRITE(LTT,693)' ================================================='
      WRITE(LTT,692)
C*
C* Define the output file
      WRITE(LTT,691) ' Default output filename              : ',FLNO
      WRITE(LTT,692) '$          Enter new name to redefine : '
      READ (LKB,692) FLNM
      IF(FLNM.NE.BLNK) FLNO=FLNM
C*
C* Define the output file
      IC=1
   11 WRITE(LTT,691) ' Default E2  Burnup Benchmark file  :   ',FLNI(IC)
      WRITE(LTT,692) '$          Enter new name to redefine : '
      READ (LKB,692) FLNM
      IF(FLNM.NE.BLNK) FLNI(IC)=FLNM
      IF(FLNM(1:1).NE.'-') THEN
        OPEN (UNIT=LIN,FILE=FLNI(IC),STATUS='OLD',ERR=11)
        CLOSE(UNIT=LIN)
      END IF
C*
      IC=1
      OPEN (UNIT=LIN,FILE=FLNI(IC),STATUS='OLD')
      OPEN (UNIT=LOU,FILE=FLNO,STATUS='UNKNOWN')
      DO ILIN=1,3
       READ (LIN,692) REC
       WRITE (LOU,692) REC
      ENDDO
      WRITE(LOU,692)
      WRITE(LOU,691) ' Processed Benchmark analysis reports : '
      IF(FLNI(1).NE.'-')
     1WRITE(LOU,691) '                              1 case  : ',FLNI(1)
      WRITE(LOU,691)
C*
      DO ILIN=1,2
       READ (LIN,692) REC
       WRITE (LOU,692) REC
      ENDDO
C
C* Begin processing the E2T2 Benchmark
C
C TABLE 1
C
      DO ILIN=1,10
       READ (LIN,692) REC
       WRITE (LOU,692) REC
      ENDDO
      WRITE(LOU,719)' Average  '
      WRITE(LOU,719)' Dif/St.Dv'
      WRITE(LOU,718)' # '
C *************
C
C FIG.1A
C
      DO ILIN=1,2
       READ (LIN,692) REC
       WRITE (LOU,692) REC
      ENDDO
      WRITE(LOU,692)
      WRITE(LOU,691) ' Processed Benchmark analysis reports : '
      IF(FLNI(1).NE.'-')
     1WRITE(LOU,691) '                              1 case  : ',FLNI(1)
      WRITE(LOU,691)
C*
      DO ILIN=1,2
       READ (LIN,692) REC
       WRITE (LOU,692) REC
      ENDDO
C
      DO ILIN=1,55
       READ (LIN,692) REC
       WRITE (LOU,692) REC
      ENDDO
      WRITE(LOU,719)' Average  '
      WRITE(LOU,719)' Dif/St.Dv'
      WRITE(LOU,718)' # '
C *************
C
C FIG.1B
C
      DO ILIN=1,2
       READ (LIN,692) REC
       WRITE (LOU,692) REC
      ENDDO
      WRITE(LOU,692)
      WRITE(LOU,691) ' Processed Benchmark analysis reports : '
      IF(FLNI(1).NE.'-')
     1WRITE(LOU,691) '                              1 case  : ',FLNI(1)
      WRITE(LOU,691)
C*
      DO ILIN=1,2
       READ (LIN,692) REC
       WRITE (LOU,692) REC
      ENDDO
C
      DO ILIN=1,55
       READ (LIN,692) REC
       WRITE (LOU,692) REC
      ENDDO
      WRITE(LOU,719)' Average  '
      WRITE(LOU,719)' Dif/St.Dv'
      WRITE(LOU,718)' # '
C *************
C
C FIG.2
C
      DO ILIN=1,2
       READ (LIN,692) REC
       WRITE (LOU,692) REC
      ENDDO
      WRITE(LOU,692)
      WRITE(LOU,691) ' Processed Benchmark analysis reports : '
      IF(FLNI(1).NE.'-')
     1WRITE(LOU,691) '                              1 case  : ',FLNI(1)
      WRITE(LOU,691)
C*
      DO ILIN=1,2
       READ (LIN,692) REC
       WRITE (LOU,692) REC
      ENDDO
C
      DO ILIN=1,49
       READ (LIN,692) REC
       WRITE (LOU,692) REC
      ENDDO
      WRITE(LOU,719)' Average  '
      WRITE(LOU,719)' Dif/St.Dv'
      WRITE(LOU,718)' # '
C *************
C
C TAB.32A
C
      DO ILIN=1,2
       READ (LIN,692) REC
       WRITE (LOU,692) REC
      ENDDO
      WRITE(LOU,692)
      WRITE(LOU,691) ' Processed Benchmark analysis reports : '
      IF(FLNI(1).NE.'-')
     1WRITE(LOU,691) '                              1 case  : ',FLNI(1)
      WRITE(LOU,691)
C*
      DO ILIN=1,2
       READ (LIN,692) REC
       WRITE (LOU,692) REC
      ENDDO
C
      DO ILIN=1,13
       READ (LIN,692) REC
       WRITE (LOU,692) REC
      ENDDO
      WRITE(LOU,719)' Average  '
      WRITE(LOU,719)' Dif/St.Dv'
C ***************************************************
 300  CLOSE(UNIT=LIN)
      CLOSE(UNIT=LOU)
C* End of file processing
  80  STOP 'E2T2P Completed'
C*
 691  FORMAT(2A40)
 692  FORMAT(A120)
 693  FORMAT(A50)
 694  FORMAT(A45)
 700  FORMAT(10X,F6.1)
 701  FORMAT(10X,2F6.1)
 702  FORMAT(A10,F6.1,'(',F4.1,')')
 715  FORMAT(A10,1X,E9.2,2X,E9.2)
 716  FORMAT(11X,E9.2,2X,E9.2)
 717  FORMAT(A10,1X,1PE9.2,'(',1PE9.2,')')
 718  FORMAT(A4)
 719  FORMAT(A10)
C
      END
*deck E2T2W86 
C
C  PROGRAM E2T2
C
C  AUTHOR: FRANCISCO LESZCZYNSKI-INGENIERIA NUCLEAR- 1999
C                                CENTRO ATOMICO BARILOCHE
C                                ARGENTINA
C
C  PROCESS WIMS OUTPUT FOR BENCHMARK D2O EX.2)DCA Task 2 FOR ONE LIBRARY
C
C  1) READ EXPERIMENTAL VALUES OF PARAMETERS
C
C  2) READ WIMS-D RESULTS-IOW
C                          1 <-E2T2H00D.OUT;
C                          2 <-E2T2A00D.OUT;
C                          3 <-E2T2H12D.OUT;
C                          4 <-E2T2D00D.OUT;
C                          5 <-E2T2D01D.OUT;
C                          6 <-E2T2D05D.OUT;
C                          7 <-E2T2D10D.OUT;
C       READ TOTAL REACTION RATES BY MATERIAL OF Dy-164(164)
C
C  3) CALCUL THERMAL NEUTRON FLUX DISTRIBUTION FOR FUEL A1,A2,A3
C     (MATS.5,9,10,22) AND FOR MODERATOR VS. RADIUS (MATS.2,11-21)
C     FOR CLUSTER WITHOUT Gd (COOLANT=H2O and AIR) AND
C     FOR CLUSTER WITH Gd (COOLANT=H2O)
C  4) CALCUL DETAILED AND MEAN VALUE OF FINE STRUCTURE OF
C     THERMAL NEUTRON FLUX DISTRIBUTION ON A PIN ROUNDED BY D2O,
C     WITHOUT Gd AND WITH 0.1, 0.5 AND 1.0 WT% Gd
C  5) WRITE RESULTS
C
C***********************************************************************
      DIMENSION FFRE(33,8),CE(5,4),RU5FRE(5,4),RCAE(5,4),ALMRE(5,4)
      DIMENSION FFR(33,8),C(5,8),RU5FR(5,5),RCA(5,5),ALMR(5,5)
      DIMENSION FFRR(33,8),CR(5,8),RU5FRR(5,5),RCAR(5,5),ALMRR(5,5)
      DIMENSION ABSO(5,33,8),FIS(5,5,8)
      DIMENSION RADIO(33,8)
      CHARACTER*3 DVOID,DINEX,DDLOW,ANA(33,8)
      CHARACTER*12 OUTW(8)
      CHARACTER*24 REFER1
      CHARACTER*28 AISOT(5)
      CHARACTER*30 REFER2
      CHARACTER*44 ADVICE
      CHARACTER*80,TIT,REF,TIT2
      CHARACTER*120 LINE
C
C***********************************************************************
C  1) READ EXPERIMENTAL VALUES OF PARAMETERS
C
      OPEN(1,FILE='E2T2.REF')
      read(1,1)TIT
      read(1,1)REF
C
      DO J=1,2
       read(1,1)TIT2
       DO I=1,19
        read(1,3)FFRE(I,J)
       END DO
      END DO
C
      read(1,1)TIT2
      DO I=1,18
       read(1,3)FFRE(I,3)
      END DO
C
      read(1,1)TIT2
      DO I=1,8
       read(1,3)FFRE(I,7)
      END DO
C
      CLOSE(1)
  1   FORMAT(A80)
  3   FORMAT(E13.5)
C***********************************************************************
C  2) READ WIMS-D RESULTS-IOW
C                          1 <-E2T2H00D.OUT;
C                          2 <-E2T2A00D.OUT;
C                          3 <-E2T2H12D.OUT;
C                          4 <-E2T2D00D.OUT;
C                          5 <-E2T2D01D.OUT;
C                          6 <-E2T2D05D.OUT;
C                          7 <-E2T2D10D.OUT;
C
      OUTW(1)="E2T2H00D.OUT"
      OUTW(2)="E2T2A00D.OUT"
      OUTW(3)="E2T2H12D.OUT"
      OUTW(4)="E2T2D00D.OUT"
      OUTW(5)="E2T2D01D.OUT"
      OUTW(6)="E2T2D05D.OUT"
      OUTW(7)="E2T2D10D.OUT"
C
      AISOT(1)='element   164 reaction rates'
C
      DO IOW=1,3
       OPEN(1,FILE=OUTW(IOW))
C
C       READ TOTAL REACTION RATES BY MATERIAL OF Dy-164(164)
C
C -------------------------------------------------------------------
       ISOT=1
C
C      ISOT=1: ABS.R Dy164
C
        read(1,'(A120)')LINE
        DO WHILE(LINE(2:11).NE.'k-eff edit')
         read(1,'(A120)')LINE
        END DO
        read(1,'(A120)')LINE
        DO WHILE(LINE(2:29).NE.AISOT(ISOT))
         read(1,'(A120)')LINE
        END DO
        read(1,'(A120)')LINE
        DO WHILE(LINE(2:13).NE.'group materl')
         read(1,'(A120)')LINE
        END DO
         read(1,'(A120)')LINE
         DO WHILE(LINE(2:8).NE.'  total')
          read(1,'(A120)')LINE
         END DO
         BACKSPACE(1)
C         BACKSPACE(1)
         read(1,'(12X,8E13.5)')(ABSO(ISOT,J,IOW),J=1,8)
         read(1,'(A120)')LINE
         DO WHILE(LINE(2:8).NE.'  total')
          read(1,'(A120)')LINE
         END DO
         BACKSPACE(1)
C         BACKSPACE(1)
         read(1,'(12X,8E13.5)')(ABSO(ISOT,J,IOW),J=9,16)
         read(1,'(A120)')LINE
         DO WHILE(LINE(2:8).NE.'  total')
          read(1,'(A120)')LINE
         END DO
         BACKSPACE(1)
C         BACKSPACE(1)
         read(1,'(12X,6E13.5)')(ABSO(ISOT,J,IOW),J=17,22)
C
       CLOSE(1)
      END DO
C -------------------------------------------------------------------
      DO IOW=4,7
       OPEN(1,FILE=OUTW(IOW))
C
C      READ TOTAL REACTION RATES BY MESH, OF:
C      Dy-164(164)
C
C      ISOT=1: ABS.R Dy164
C
       ISOT=1
       read(1,'(A120)')LINE
       DO WHILE(LINE(2:11).NE.'k-inf edit')
        read(1,'(A120)')LINE
       END DO
C
       read(1,'(A120)')LINE
       DO WHILE(LINE(2:29).NE.AISOT(ISOT))
        read(1,'(A120)')LINE
       END DO
       read(1,'(A120)')LINE
       DO WHILE(LINE(2:8).NE.'  total')
        read(1,'(A120)')LINE
       END DO
C       BACKSPACE(1)
       BACKSPACE(1)
       read(1,'(12X,8E13.5)')(ABSO(ISOT,J,IOW),J=1,8)
       read(1,'(A120)')LINE
       DO WHILE(LINE(2:8).NE.'  total')
        read(1,'(A120)')LINE
       END DO
C       BACKSPACE(1)
       BACKSPACE(1)
       read(1,'(12X,8E13.5)')(ABSO(ISOT,J,IOW),J=9,16)
       read(1,'(A120)')LINE
       DO WHILE(LINE(2:8).NE.'  total')
        read(1,'(A120)')LINE
       END DO
C       BACKSPACE(1)
       BACKSPACE(1)
       read(1,'(12X,8E13.5)')(ABSO(ISOT,J,IOW),J=17,24)
       read(1,'(A120)')LINE
       DO WHILE(LINE(2:8).NE.'  total')
        read(1,'(A120)')LINE
       END DO
C       BACKSPACE(1)
       BACKSPACE(1)
       read(1,'(12X,8E13.5)')(ABSO(ISOT,J,IOW),J=25,32)
C
       CLOSE(1)
      END DO
C***********************************************************************
C  3) CALCUL THERMAL NEUTRON FLUX DISTRIBUTION FOR FUEL A1,A2,A3
C     (MATS.5,9,10,22), FOR P.TUBE, GAP AND CAL.TUBE (MATS. 3,4,8),
C     AND FOR MODERATOR VS. RADIUS (MATS.2,11-21)
C     FOR CLUSTER WITHOUT Gd (COOLANT=H2O and AIR) AND
C     FOR CLUSTER WITH Gd (COOLANT=H2O)
C
      DO IOW=1,2
       ABSO2=ABSO(1,3,IOW)
       FFR(1,IOW)=ABSO(1,5,IOW)/ABSO2
       FFRR(1,IOW)=FFR(1,IOW)-FFRE(1,IOW)
       FFR(2,IOW)=ABSO(1,9,IOW)/ABSO2
       FFRR(2,IOW)=FFR(2,IOW)-FFRE(2,IOW)
       FFR(3,IOW)=ABSO(1,10,IOW)
       FFR(3,IOW)=(0.5*FFR(3,IOW)+0.5*ABSO(1,22,IOW))/ABSO2
       FFRR(3,IOW)=FFR(3,IOW)-FFRE(3,IOW)
       FFR(4,IOW)=1.0
       FFRR(4,IOW)=0.0
       FFR(5,IOW)=ABSO(1,4,IOW)/ABSO2
       FFRR(5,IOW)=FFR(5,IOW)-FFRE(5,IOW)
       FFR(6,IOW)=ABSO(1,8,IOW)/ABSO2
       FFRR(6,IOW)=FFR(6,IOW)-FFRE(6,IOW)
C
       FFR(7,IOW)=ABSO(1,2,IOW)/ABSO2
       FFRR(7,IOW)=FFR(7,IOW)-FFRE(7,IOW)
       DO I=8,18
        FFR(I,IOW)=ABSO(1,I+3,IOW)/ABSO2
        FFRR(I,IOW)=FFR(I,IOW)-FFRE(I,IOW)
       END DO
       DR=1.0
       RADIO(1,IOW)=3.825
       RADIO(2,IOW)=5.76
       RADIO(3,IOW)=7.68
       RADIO(4,IOW)=9.25
       RADIO(5,IOW)=9.75
       RADIO(6,IOW)=10.25
       RADIO(7,IOW)=11.0
       DO I=8,18
        RADIO(I,IOW)=RADIO(I-1,IOW)+DR
       END DO
      END DO
C
      ABSO2=ABSO(1,3,3)
      FFR(1,3)=ABSO(1,5,3)/ABSO2
      FFRR(1,3)=FFR(1,3)-FFRE(1,3)
      FFR(2,3)=ABSO(1,9,3)/ABSO2
      FFRR(2,3)=FFR(2,3)-FFRE(2,3)
      FFR(3,3)=ABSO(1,10,3)/ABSO2
      FFRR(3,3)=FFR(3,3)-FFRE(3,3)
      FFR(4,3)=ABSO(1,22,3)/ABSO2
      FFRR(4,3)=FFR(4,3)-FFRE(4,3)
      FFR(5,3)=1.0
      FFRR(5,3)=0.0
      FFR(6,3)=ABSO(1,4,3)/ABSO2
      FFRR(6,3)=FFR(6,3)-FFRE(6,3)
      FFR(7,3)=ABSO(1,8,3)/ABSO2
      FFRR(7,3)=FFR(7,3)-FFRE(7,3)
      FFR(8,3)=ABSO(1,2,3)/ABSO2
      FFRR(8,3)=FFR(8,3)-FFRE(8,3)
      DO I=9,17
       FFR(I,3)=ABSO(1,I+2,3)/ABSO2
       FFRR(I,3)=FFR(I,3)-FFRE(I,3)
      ENDDO
C
      DR=1.0
      RADIO(1,3)=3.825
      RADIO(2,3)=5.76
      RADIO(4,3)=7.68
      RADIO(5,3)=9.25
      RADIO(6,3)=9.75
      RADIO(7,3)=10.25
      RADIO(8,3)=11.0
      DO I=9,17
       RADIO(I,3)=RADIO(I-1,3)+DR
      END DO
C
C  4) CALCUL MEAN VALUE OF FINE STRUCTURE OF THERMAL NEUTRON FLUX DISTRIBUTION
C     ON A PIN WITHOUT Gd AND WITH 0.1,0.5 AND 1.0 WT% Gd
C
      DO IOW=4,7
       ABSO32=ABSO(1,32,IOW)
       FFR(33,IOW)=0.0
       DO I=1,32
        FFR(I,IOW)=ABSO(1,I,IOW)/ABSO32
        FFR(33,IOW)=FFR(33,IOW)+FFR(I,IOW)
       ENDDO
       FFR(33,IOW)=FFR(33,IOW)/32.0
       FFRR(33,IOW)=FFR(33,IOW)-FFRE(IOW-3,7)
      END DO
C***********************************************************************
C  6) WRITE RESULTS
C
      OPEN(2,FILE='E2T2.LIS')
C **********************************
C
C TABLE 1
C
      WRITE(2,400)' Thermal Neutron Flux Distribution'
      WRITE(2,400)' ================================='
      WRITE(2,401)' Case  COO  A1   DIFF.  A2   DIFF. A3SG  DIFF. A3CG
     1DIFF.  M11  DIFF.  M16  DIFF.  M22  DIFF. '
      WRITE(2,401)' ====================================================
     1=========================================='
      WRITE(2,500)(FFRE(I,1),FFRE(19,1),I=1,3),FFRE(7,1),FFRE(19,1),
     1 FFRE(12,1),FFRE(19,1),FFRE(18,1),FFRE(19,1)
      WRITE(2,503)(FFR(I,1),FFRR(I,1),I=1,3),FFR(7,1),FFRR(7,1),
     1 FFR(12,1),FFRR(12,1),FFR(18,1),FFRR(18,1)
      WRITE(2,402)'          '
C
      WRITE(2,501)(FFRE(I,2),FFRE(19,1),I=1,3),FFRE(7,2),FFRE(19,1),
     1 FFRE(12,2),FFRE(19,1),FFRE(18,2),FFRE(19,1)
      WRITE(2,503)(FFR(I,2),FFRR(I,2),I=1,3),FFR(7,2),FFRR(7,2),
     1 FFR(12,2),FFRR(12,2),FFR(18,2),FFRR(18,2)
      WRITE(2,402)'          '
C
      WRITE(2,502)(FFRE(I,3),FFRE(18,3),I=1,2),FFRE(4,3),FFRE(18,3),
     1 FFRE(8,3),FFRE(18,3),FFRE(13,3),FFRE(18,3),FFRE(17,3),FFRE(18,3)
      WRITE(2,504)(FFR(I,3),FFRR(I,3),I=1,2),FFR(4,3),FFRR(4,3),
     1 FFR(8,3),FFRR(8,3),FFR(13,3),FFRR(13,3),FFR(17,3),FFRR(17,3)
      WRITE(2,402)'          '
      WRITE(2,401)' ====================================================
     1=========================================='
C
 400  FORMAT(A34)
 401  FORMAT(A95)
 402  FORMAT(A10)
 500  FORMAT('Gd:NO  H2O ',3(F5.2,'(',F5.2,')'),12X,3(F5.2,'(',F5.2,')')
     1)
 501  FORMAT('Gd:NO  AIR ',3(F5.2,'(',F5.2,')'),12X,3(F5.2,'(',F5.2,')')
     1)
 502  FORMAT('Gd:YES H2O ',2(F5.2,'(',F5.2,')'),12X,4(F5.2,'(',F5.2,')')
     1)
 503  FORMAT('           ',3(F5.2,'(',F5.2,')'),12X,3(F5.2,'(',F5.2,')')
     1)
 504  FORMAT('           ',2(F5.2,'(',F5.2,')'),12X,4(F5.2,'(',F5.2,')')
     1)
C *****************************
C
C FIGURE 1A
C
      EXPERR=0.0
      WRITE(2,600)' Therm.Flux Distr.H2O coolant-cluster without poison'
      WRITE(2,600)' ==================================================='
      WRITE(2,601)' R(cm)     FLUX   DIFF. '
      WRITE(2,601)' ======================='
      DO I=1,18
       WRITE(2,700)RADIO(I,1),FFRE(I,1),EXPERR
       WRITE(2,701)FFR(I,1),FFRR(I,1)
       WRITE(2,402)'          '
      END DO
      WRITE(2,601)' ======================='
C
C FIGURE 1B
C
      WRITE(2,600)' Therm.Flux Distr.AIR coolant-cluster without poison'
      WRITE(2,600)' ==================================================='
      WRITE(2,601)' R(cm)     FLUX   DIFF. '
      WRITE(2,601)' ======================='
      DO I=1,18
       WRITE(2,700)RADIO(I,1),FFRE(I,2),EXPERR
       WRITE(2,701)FFR(I,2),FFRR(I,2)
       WRITE(2,402)'          '
      END DO
      WRITE(2,601)' ======================='
C
 600  FORMAT(A52)
 601  FORMAT(A24)
 700  FORMAT(F7.2,3X,F7.2,'(',F7.2,')')
 701  FORMAT(10X,F7.2,'(',F7.2,')')
C *****************************
C
C FIGURE 2
C
      WRITE(2,600)' Therm.Flux Distr.12 poisoned fuel pins on 3rd.layer'
      WRITE(2,600)' ==================================================='
      WRITE(2,601)' R(cm)     FLUX   DIFF. '
      WRITE(2,601)' ======================='
      DO I=1,2
       WRITE(2,700)RADIO(I,3),FFRE(I,3),EXPERR
       WRITE(2,701)FFR(I,3),FFRR(I,3)
       WRITE(2,402)'          '
      END DO
      DO I=4,17
       WRITE(2,700)RADIO(I,3),FFRE(I,3),EXPERR
       WRITE(2,701)FFR(I,3),FFRR(I,3)
       WRITE(2,402)'          '
      END DO
      WRITE(2,601)' ======================='
C *****************************
C
C TABLE 32A
C
      WRITE(2,600)' Therm.Flux Distr.-Average Dy-reaction rate on pins '
      WRITE(2,600)' ==================================================='
      WRITE(2,601)' Case      Dy-RR  DIFF. '
      WRITE(2,601)' ======================='
C
      WRITE(2,801)FFRE(1,7),FFRE(5,7)
      WRITE(2,805)FFR(33,4),FFRR(33,4)
      WRITE(2,402)'          '
C
      WRITE(2,802)FFRE(2,7),FFRE(6,7)
      WRITE(2,805)FFR(33,5),FFRR(33,5)
      WRITE(2,402)'          '
C
      WRITE(2,803)FFRE(3,7),FFRE(7,7)
      WRITE(2,805)FFR(33,6),FFRR(33,6)
      WRITE(2,402)'          '
C
      WRITE(2,804)FFRE(4,7),FFRE(8,7)
      WRITE(2,805)FFR(33,7),FFRR(33,7)
      WRITE(2,402)'          '
C
      WRITE(2,601)' ======================='
C
 801  FORMAT('Gd:NO     ',F7.3,'(',F7.3,')')
 802  FORMAT('Gd:0.1wt% ',F7.3,'(',F7.3,')')
 803  FORMAT('Gd:0.5wt% ',F7.3,'(',F7.3,')')
 804  FORMAT('Gd:1.0wt% ',F7.3,'(',F7.3,')')
 805  FORMAT('          ',F7.3,'(',F7.3,')')
C
      CLOSE(2)
C
      STOP 'Completed'
      END
*deck e3 
C
C  PROGRAM E3
C
C  AUTHOR: FRANCISCO LESZCZYNSKI-INGENIERIA NUCLEAR- 1999
C                                CENTRO ATOMICO BARILOCHE
C                                ARGENTINA
C
C  PROCESS WIMS OUTPUT FOR BENCHMARK D2O EX.3)NPD FOR ONE LIBRARY
C
C  1) READ EXPERIMENTAL VALUES OF PARAMETERS
C
C  2) READ WIMS-D RESULTS-IOW
C                          1 <-E300D2OD.OUT;
C      READ Nu5,Nu6,Nu8,NPu9,NPu0,NPu1,NPu2 vs.Burnup
C
C  3) CALCUL ISOTOPIC CONCENTRATION RATIOS FOR THE FUEL PINS OF EACH 
C     RING AND BUNDLE AVERAGES AND WRITE RESULTS
C
C***********************************************************************
      DIMENSION R25A28(8,4,2),AN25(8,4,2),AN28(8,4,2)
      DIMENSION R26A28(8,4,2),AN26(8,4,2),R49A28(8,4,2),AN49(8,4,2)
      DIMENSION R40A49(8,4,2),AN40(8,4,2),R41A49(8,4,2),AN41(8,4,2)
      DIMENSION R42A49(8,4,2),AN42(8,4,2),QQ(8)
      DIMENSION R25A28E(8,4)
      DIMENSION R26A28E(8,4),R49A28E(8,4)
      DIMENSION R40A49E(8,4),R41A49E(8,4)
      DIMENSION R42A49E(8,4),QQE(8)
      DIMENSION DR25A28(8,4,2)
      DIMENSION DR26A28(8,4,2),DR49A28(8,4,2)
      DIMENSION DR40A49(8,4,2),DR41A49(8,4,2)
      DIMENSION DR42A49(8,4,2),DQQ(8)
      DIMENSION xmid(6),dxmid(6)
      DIMENSION IQQ(8),IQQE(8)
      DIMENSION IAA(3)
      DIMENSION ANN(3)
C
      CHARACTER*6 AA
      CHARACTER*8 BB
      CHARACTER*12 OUTW(8)
      CHARACTER*44 ADVICE
      CHARACTER*80,TIT,REF,TIT2
      CHARACTER*120 LINE
C
C***********************************************************************
      QQ(1) =   980.000
      QQ(2) =  1500.000
      QQ(3) =  3250.000
      QQ(4) =  5000.000
      QQ(5) =  6500.000
      QQ(6) =  7900.000
      QQ(7) =  9100.000
      QQ(8) = 10800.000
C
      IQQ(1) =   980
      IQQ(2) =  1500
      IQQ(3) =  3250
      IQQ(4) =  5000
      IQQ(5) =  6500
      IQQ(6) =  7900
      IQQ(7) =  9100
      IQQ(8) = 10800
C
      I25=2235
      I26= 236
      I28=8238
      I49=6239
      I40=1240
      I41=1241
      I42=1242
C
C  1) READ EXPERIMENTAL VALUES OF PARAMETERS
C
      OPEN(1,FILE='E3.REF')
      read(1,1)TIT
      read(1,1)REF
C
      read(1,1)TIT2
      READ(1,6)(QQE(N),N=1,8)
      DO M=1,4
       read(1,1)TIT2
       DO N=1,8
        READ(1,7)R25A28E(N,M),R26A28E(N,M),
     1   R49A28E(N,M),R40A49E(N,M),R41A49E(N,M),R42A49E(N,M)
       ENDDO
      ENDDO
      CLOSE(1)
C
      DO N=1,8
       DQQ(N)=((QQ(N)/QQE(N))-1.0)*100.0
       IQQE(N)=QQE(N)
      ENDDO
C***********************************************************************
C  2) READ WIMS-D RESULTS
C
      OUTW(1)="E300D2OD.OUT"
      DQ=0.01
      IOW=1
      OPEN(1,FILE=OUTW(IOW))
C
C  READ Nu5,Nu6,Nu8,NPu9,NPu0,NPu1,NPu2 vs.Burnup
C
  98  N=0
 100  IF(N.EQ.8)GOTO 300
      READ(1,8,END=300)AA
      IF(AA.EQ.'MWd/te')THEN
       BACKSPACE(1)
       READ(1,9)Q
       IF((QQ(N+1)-Q).LT.DQ)THEN
        N=N+1
        M=0
 200    IF(M.EQ.3)GOTO 100
        READ(1,10,END=300)BB
        IF(BB.EQ.'material')THEN
         M=M+1
         NIAN=0
 250     READ(1,12)(IAA(IAN),ANN(IAN),IAN=1,3)
         DO IAN=1,3
          IF(IAA(IAN).EQ.I25)THEN
           AN25(N,M,IOW)=ANN(IAN)
           NIAN=NIAN+1
          ENDIF
          IF(IAA(IAN).EQ.I26)THEN
           AN26(N,M,IOW)=ANN(IAN)
           NIAN=NIAN+1
          ENDIF
          IF(IAA(IAN).EQ.I28)THEN
           AN28(N,M,IOW)=ANN(IAN)
           NIAN=NIAN+1
          ENDIF
          IF(IAA(IAN).EQ.I49)THEN
           AN49(N,M,IOW)=ANN(IAN)
           NIAN=NIAN+1
          ENDIF
          IF(IAA(IAN).EQ.I40)THEN
           AN40(N,M,IOW)=ANN(IAN)
           NIAN=NIAN+1
          ENDIF
          IF(IAA(IAN).EQ.I41)THEN
           AN41(N,M,IOW)=ANN(IAN)
           NIAN=NIAN+1
          ENDIF
          IF(IAA(IAN).EQ.I42)THEN
           AN42(N,M,IOW)=ANN(IAN)
           NIAN=NIAN+1
          ENDIF
         ENDDO
         IF(NIAN.LT.7)GOTO 250
        ENDIF
        GOTO 200
       ENDIF
      ENDIF
      GOTO 100
 300  continue
      CLOSE(1)
C
C***********************************************************************
C  3) CALCUL ISOTOPIC CONCENTRATION RATIOS FOR THE FUEL PINS OF EACH 
C     RING AND BUNDLE AVERAGES AND WRITE RESULTS
C
C
C     R025A28=AU5(IOW)/AU8(IOW)
C      write(3,17)IOW,AU5(IOW),AU8(IOW)
C
      OPEN(3,FILE="E3.TEM")
C
       DO M=1,3
        WRITE(3,18)M
        WRITE(3,19)(AN25(N,M,IOW),N=1,8)
        WRITE(3,20)(AN28(N,M,IOW),N=1,8)
        WRITE(3,21)(AN26(N,M,IOW),N=1,8)
        WRITE(3,22)(AN49(N,M,IOW),N=1,8)
        WRITE(3,24)(AN40(N,M,IOW),N=1,8)
        WRITE(3,25)(AN41(N,M,IOW),N=1,8)
        WRITE(3,26)(AN42(N,M,IOW),N=1,8)
       END DO
      CLOSE(3)
C
C
      OPEN(2,FILE='E3.LIS')
      write(2,2)TIT(1:31)
      write(2,1)REF
      write(2,1)
C
      DO M=1,4
       WRITE(2,27)
       IF(M.LT.4)THEN
        WRITE(2,28)M
       ELSE
        WRITE(2,29)
       ENDIF
       WRITE(2,30)
C
       DO N=1,8
        IA=1
C
         IF(M.LT.4)THEN
          R25A28(N,M,IA)=(AN25(N,M,IA)/AN28(N,M,IA))*100.0
          R26A28(N,M,IA)=(AN26(N,M,IA)/AN28(N,M,IA))*100.0
          R49A28(N,M,IA)=(AN49(N,M,IA)/AN28(N,M,IA))*100.0
          R40A49(N,M,IA)=(AN40(N,M,IA)/AN49(N,M,IA))*100.0
          R41A49(N,M,IA)=(AN41(N,M,IA)/AN49(N,M,IA))*100.0
          R42A49(N,M,IA)=(AN42(N,M,IA)/AN49(N,M,IA))*100.0
         ENDIF
C
         IF(M.EQ.1)THEN
          R25A28(N,4,IA)= R25A28(N,M,IA)
          R26A28(N,4,IA)= R26A28(N,M,IA)
          R49A28(N,4,IA)= R49A28(N,M,IA)
          R40A49(N,4,IA)= R40A49(N,M,IA)
          R41A49(N,4,IA)= R41A49(N,M,IA)
          R42A49(N,4,IA)= R42A49(N,M,IA)
         ENDIF
C
         IF(M.GT.1.AND.M.LT.4)THEN
          R25A28(N,4,IA)= R25A28(N,4,IA)+ R25A28(N,M,IA)*(M*M+M)
          R26A28(N,4,IA)= R26A28(N,4,IA)+ R26A28(N,M,IA)*(M*M+M)
          R49A28(N,4,IA)= R49A28(N,4,IA)+ R49A28(N,M,IA)*(M*M+M)
          R40A49(N,4,IA)= R40A49(N,4,IA)+ R40A49(N,M,IA)*(M*M+M)
          R41A49(N,4,IA)= R41A49(N,4,IA)+ R41A49(N,M,IA)*(M*M+M)
          R42A49(N,4,IA)= R42A49(N,4,IA)+ R42A49(N,M,IA)*(M*M+M)
         ENDIF
C
         IF(M.EQ.4)THEN
          R25A28(N,4,IA)= R25A28(N,4,IA)/19.0
          R26A28(N,4,IA)= R26A28(N,4,IA)/19.0
          R49A28(N,4,IA)= R49A28(N,4,IA)/19.0
          R40A49(N,4,IA)= R40A49(N,4,IA)/19.0
          R41A49(N,4,IA)= R41A49(N,4,IA)/19.0
          R42A49(N,4,IA)= R42A49(N,4,IA)/19.0
         ENDIF
C
         DR25A28(N,M,IA)=((R25A28(N,M,IA)/R25A28E(N,M))-1.0)*100
         DR26A28(N,M,IA)=((R26A28(N,M,IA)/R26A28E(N,M))-1.0)*100
         DR49A28(N,M,IA)=((R49A28(N,M,IA)/R49A28E(N,M))-1.0)*100
         DR40A49(N,M,IA)=((R40A49(N,M,IA)/R40A49E(N,M))-1.0)*100
         DR41A49(N,M,IA)=((R41A49(N,M,IA)/R41A49E(N,M))-1.0)*100
         DR42A49(N,M,IA)=((R42A49(N,M,IA)/R42A49E(N,M))-1.0)*100
C
        WRITE(2,31)IQQE(N),R25A28E(N,M),
     1   R26A28E(N,M),R49A28E(N,M),R40A49E(N,M),R41A49E(N,M),
     2   R42A49E(N,M)
        WRITE(2,32)IQQ(N),R25A28(N,M,1),
     1   R26A28(N,M,1),R49A28(N,M,1),R40A49(N,M,1),R41A49(N,M,1),
     2   R42A49(N,M,1)
        WRITE(2,33)DQQ(N),
     1   DR25A28(N,M,1),DR26A28(N,M,1),DR49A28(N,M,1),DR40A49(N,M,1),
     2   DR41A49(N,M,1),DR42A49(N,M,1)
        WRITE(2,34)
C
       ENDDO
C
C      Averages and standard deviations of the discrepancies
C
       WRITE(2,35)
       WRITE(2,36)
       WRITE(2,37)
C
       MET=1
C
        do NV=1,6
         xmid(NV)=0.0
        enddo
C
        do N=1,8
         xmid(1)= xmid(1)+DR25A28(N,M,MET)
         if(N.GT.1)xmid(2)= xmid(2)+DR26A28(N,M,MET)
         xmid(3)= xmid(3)+DR49A28(N,M,MET)
         if(N.GT.2)then
          xmid(4)= xmid(4)+DR40A49(N,M,MET)
          xmid(5)= xmid(5)+DR41A49(N,M,MET)
          xmid(6)= xmid(6)+DR42A49(N,M,MET)
         endif
        enddo
C
        do NV=1,6
         NTOTB=8
         if(NV.EQ.2)NTOTB=7
         if(NV.GT.3)NTOTB=6
         xmid(NV)= xmid(NV)/NTOTB
        enddo
C
        do NV=1,6
         dxmid(NV)=0.0
        enddo
C
        do N=1,8
         dxmid(1)=dxmid(1)+(DR25A28(N,M,MET)-xmid(1))**2.0
         if(N.GT.1)dxmid(2)=dxmid(2)+(DR26A28(N,M,MET)-xmid(2))**2.0
         dxmid(3)= dxmid(3)+(DR49A28(N,M,MET)-xmid(3))**2.0
         if(N.GT.2)then
          dxmid(4)=dxmid(4)+(DR40A49(N,M,MET)-xmid(4))**2.0
          dxmid(5)=dxmid(5)+(DR41A49(N,M,MET)-xmid(5))**2.0
          dxmid(6)=dxmid(6)+(DR42A49(N,M,MET)-xmid(6))**2.0
         endif
        enddo
C
        do NV=1,6
         NTOTB=8
         if(NV.EQ.2)NTOTB=7
         if(NV.GT.3)NTOTB=6
         dxmid(NV)=sqrt(dxmid(NV)/NTOTB)
        enddo
C
        WRITE(2,38)
        WRITE(2,39)xmid(1),dxmid(1)
        WRITE(2,40)xmid(2),dxmid(2)
        WRITE(2,41)xmid(3),dxmid(3)
        WRITE(2,42)xmid(4),dxmid(4)
        WRITE(2,43)xmid(5),dxmid(5)
        WRITE(2,44)xmid(6),dxmid(6)
C
      ENDDO
C
      CLOSE(2)
C
  1   FORMAT(A80)
  2   FORMAT(A31)
  3   FORMAT(E13.5)
  5   FORMAT(A44)
  6   FORMAT(F8.1)
  7   FORMAT(6F8.4)
  8   FORMAT(37X,A6)
  9   FORMAT(27X,F9.3)
 10   FORMAT(1X,A8)
 11   FORMAT(A6)
 12   FORMAT(3(I6,2X,E15.7))
 17   FORMAT("IOW,AU5,AU8 ",I3,2E12.5)
 18   FORMAT("PIN=",I4)
 19   FORMAT("N25=",8E10.3)
 20   FORMAT("N28=",8E10.3)
 21   FORMAT("N26=",8E10.3)
 22   FORMAT("N49=",8E10.3)
 23   FORMAT(A24)
 24   FORMAT("N40=",8E10.3)
 25   FORMAT("N41=",8E10.3)
 26   FORMAT("N42=",8E10.3)
 27   FORMAT("****************************************")
 28   FORMAT("RING",I5)
 29   FORMAT("AVERAGE VALUES")
 30   FORMAT("       BUP N25/N28 N26/N28 N49/N28 N40/N49 N41/N49 N42/N49
     1")
 31   FORMAT("EXP ",I6,6F8.4)
 32   FORMAT("DSN ",I6,6F8.4)
 33   FORMAT("DDSN",F6.2,6(2X,F6.2))
 34   FORMAT(" ")
 35   FORMAT("AVERAGES AND STANDARD DEVIATIONS in %")
 36   FORMAT(" N26/28: cases 2 to 8")
 37   FORMAT(" Ni/49 : cases 3 to 8")
 38   FORMAT("METHOD DSN")
 39   FORMAT(" N25/N28 = ",2F5.2)
 40   FORMAT(" N26/N28 = ",2F5.2)
 41   FORMAT(" N49/N28 = ",2F5.2)
 42   FORMAT(" N40/N49 = ",2F5.2)
 43   FORMAT(" N41/N49 = ",2F5.2)
 44   FORMAT(" N42/N49 = ",2F5.2)
C
      STOP 'Completed'
C Error trap
  900 STOP 'E3 ERROR - Unrecognozed library in WIMS-D output'
      END
*deck enfiss
      PROGRAM ENFISS
C-Title  : Program ENFISS
C-Purpose: Retrieve Energy/Mole from fission [J/mole] from an ENDF file
C-M
C-M  Manual for Porgram ENFISS
C-M
C-M  The energy release per fission is extracted from FM 1, MT 458
C-M  data in an ENDF file. The following assumptions are made:
C-M  - The total energy released is equal to the total available
C-M    minus the part carried away by neutrinos (ER).
C-M  - The kinetic energy of the incident neutron is defined
C-M    internally in the code. The values are obtained by
C-M    approximately averaging the energy with the fission
C-M    reaction rate [3]. Averaging is done  based on the constants
C-M    in the updated WIMS-D library based on ENDF/B-VI data.
C-M    The average energy is the simple mean of the group boundary
C-M    values, except for the first three groups where more
C-M    accurate values are taken (7.2747, 4.5933, 2.8615 MeV,
C-M    respectively, which is the average energy in a Maxwellian
C-M    fission spectrum at a temperature corresponding to 1.4 MeV:
C-M             Int( E* sqrt(E)*exp(-E/Temp) *dE )
C-M       Ea =  ----------------------------------
C-M             Int(    sqrt(E)*exp(-E/Temp) *dE )
C-M  - The additional energy released due to gamma activation is
C-M    calculated form
C-M                     Qc = (nubar - 1)*Qbar
C-M    where nubar is the average number of neutrons per fission
C-M    and Qbar=6.1MeV [1,2]. The value of nubar is calculated from
C-M    the constants in the updated WIMS-D library based on ENDF/B-VI
C-M    data [3]. Condensation to one group is done assuming a typical
C-M    light water reactor spectrum used in NJOY for averaging the
C-M    cross sections (IWT option 5).
C-M
C-M  Instructions:
C-M  The name of the evaluated nuclear data file is requested from
C-M  input. The data for the energy released per fission for the
C-M  actinides is processed (MF1, MT 458). The report is written
C-M  to ENFISS.LST file.
C-M
C-References:
C-R [1] M.F.James: Energy Released in Fission, Jou.Nucl.Energy,23(1969).
C-R [2] M.F.James: Energy Released in Fission of Th-232, U-233, U-234,
C-R     U-236, Np-237, Pu-238, Pu-240 and Pu-242,
C-R     Jou.Nucl.Energy,25(1971).
C-R [3] A.Persic, A.Trkov: The energy Released by Neutron Capture in
C-R     Thermal Reactors, International Conference on Nuclear Energy
C-R     in Central Europe '99, Portotoz, 6-9 September 1999.
C-
      CHARACTER*66     REC
      CHARACTER*40     FLNI,FLNO
C*         Avogadro's No., eV to Joules
      DATA AVG/ 0.6022 / , EV/1.60219E-19/
C*
C* Default energy from gamma capture [eV]
      DATA EGAM/ 9.15E6 /
C*
      DATA LIN,LOU,LTT,LKB / 1, 2, 6, 5 /
C*      DATA FLNI/'TAPE20.'/
      DATA FLNO/'ENFISS.LST'/
      DIMENSION ER(10)
C*
      WRITE(LTT, 15)
      WRITE(LTT, 15) ' ENFISS - Energy released per fission   '
      WRITE(LTT, 15) ' ====================================   '
      WRITE(LTT, 15)
    1 WRITE(LTT, 15) '$   Define Evaluated Nuclear Data Lib.: '
      READ(LKB,15)FLNI
      OPEN(UNIT=LIN, FILE=FLNI, STATUS='OLD',ERR=1)
 
      OPEN (UNIT=LOU,FILE=FLNO,STATUS='UNKNOWN')
 
      WRITE(LOU, 15)
      WRITE(LOU, 15) ' ENFISS - Energy released per fission   '
      WRITE(LOU, 15) ' ====================================   '
      WRITE(LOU, 15)
      WRITE(LOU, 15) ' Source evaluated nuclear data file   : ',FLNI
      WRITE(LOU, 15)
      WRITE(LOU, 15) ' Etot=Fission energy excluding neutrinos'
      WRITE(LOU, 15) ' Eeff=Including capt.product decay      '
      WRITE(LOU, 15)
      WRITE(LOU, 15) '   MAT       ZA       AWR        Etot   '
     1              ,'     Eeff        Eeff                   '
      WRITE(LOU, 15) '                                [MeV]   '
     1              ,'    [MeV]    [J/mole]                   '
 
   20 READ (LIN,801,END=90) REC,MAT,MF,MT
 
      IF(MAT.LT.  0) GO TO 90
      IF(MF .NE.  1) GO TO 20
      IF(MT .EQ. 451)THEN
        READ(LIN,803)LIS,LIS0
   25   READ (LIN,801,END=90) REC,MAT,MF,MT
        IF (MT. EQ. 451) GOTO 25       
      ENDIF  
      IF(MT .NE.458) GO TO 20
C* Section giving energy released per fission
      READ (REC,802) ZA,AWR
      READ (LIN,803) NN,NPLY,NPLY18,NPLY9
      NN=NPLY+1
      DO I=1,NN
        READ (LIN,802)
        READ (LIN,802)        
C*      ER=total energy less neutrinos
        READ (LIN,802) ENU,ENUD,ER(I),ERDD,ET,ETDD
      END DO
      READ (LIN,802)  
C* Define the energy released by capture EG
C* and kinetic energy of the incoming neutron EN. In lie of other
C* data set: therm.fiss.=0.0025, fast fiss=2MeV.
      EG=EGAM
      EN=0.0025
      IZA=NINT(ZA)
      IF     (IZA.EQ.90230) THEN
        EN= 2.E6
      ELSE IF(IZA.EQ.90232) THEN
        EN= 2.E6
      ELSE IF(IZA.EQ.91233) THEN
        EG=10.1E6
        EN= 3.1E6
      ELSE IF(IZA.EQ.92233) THEN
        EG= 9.1E6
        EN=20000.
      ELSE IF(IZA.EQ.92234) THEN
        EG= 9.7E6
        EN= 1.8E6
      ELSE IF(IZA.EQ.92235) THEN
        EG= 8.8E6
        EN=10000.
      ELSE IF(IZA.EQ.92236) THEN
        EG= 9.4E6
        EN= 1.7E6
      ELSE IF(IZA.EQ.92237) THEN
        EG= 9.4E6
        EN=700000.
      ELSE IF(IZA.EQ.92238) THEN
        EG=10.9E6
        EN= 3.1E6
      ELSE IF(IZA.EQ.93237) THEN
        EG=11.9E6
        EN= 1.9E6
      ELSE IF(IZA.EQ.93239) THEN
        EG=12.1E6
        EN= 1.92E6
      ELSE IF(IZA.EQ.94236) THEN
        EN= 1.E6
      ELSE IF(IZA.EQ.94238) THEN
        EG=11.9E6
        EN=500000.
      ELSE IF(IZA.EQ.94239) THEN
        EG=11.4E6
        EN=8000.
      ELSE IF(IZA.EQ.94240) THEN
        EG=12.7E6
        EN= 1.8E6
      ELSE IF(IZA.EQ.94241) THEN
        EG=11.9E6
        EN=6000.
      ELSE IF(IZA.EQ.94242) THEN
        EG=13.1E6
        EN= 2.2E6
      ELSE IF(IZA.EQ.94244) THEN
        EN=1.E6        
      ELSE IF(IZA.EQ.95241) THEN
        EG=14.2E6
        EN=800000.
      ELSE IF(IZA.EQ.95242) THEN
        EG=13.8E6
        EN=1000.
      ELSE IF(IZA.EQ.95243) THEN
        EG=16.5E6
        EN= 2.0E6
      ELSE IF(IZA.EQ.96242) THEN
        EN=1.E6
      ELSE IF(IZA.EQ.96244) THEN
        EN=1.E6
      ELSE IF(IZA.EQ.96246) THEN
        EN=1.E6
      ELSE IF(IZA.EQ.96248) THEN
        EN=1.E6
      ELSE IF(IZA.EQ.98250) THEN
        EN=500000.
      ELSE IF(IZA.EQ.98252) THEN
        EN=500000.
      ELSE IF(IZA.EQ.98254) THEN
        EN=500000.      
      END IF
C*
C*      ERT=ER(1)
C*      IF (NN.GT.1) THEN
C*        DO I=2,NN
C*         J=I-1
C*         ERT=(EN**J)*ER(I)+ERT
C*        ENDDO
C*      ELSE
C*        ERT=ERT+EN
C*      ENDIF
C*      EE=ERT+EG
C*
      ERT=ER(1)
      EE=ERT+EN+EG
C*      
C* Convert to [Joules/mole *10**-24] (factor included in AVG definition)
      EM=EV*AVG*EE
 
      WRITE(LOU,804) MAT,ZA+0.1*LIS0,AWR,ERT*1.E-6,EE*1.E-6,EM
 
      GO TO 20
 
   90 STOP 'ENFISS Done'
C*
   15 FORMAT(2A40)
  801 FORMAT(A66,I4,I2,I3)
  802 FORMAT(6F11.0)
  803 FORMAT(22X,4I11)
  804 FORMAT(I6,F10.1,F10.4,2F12.4,1P,E12.4)
      END
*deck fidlam 
      PROGRAM FIDLAM
C-Title  : Program FIDLAM
C-Purpose: Fiddle the Am-241 fission cross section
C-Author : A.Trkov, IAEA
C-Version: Sept.2000
C-V  06/09 - Fix thermal fission loop index (lowest energy groups
C-V          were not corrected).
C-V        - Leave fission yield unchanged (unphysical nu-bar but
C-V          correct fission yield for criticality).
C-V        - Change logic to save original file on scratch.
C-M
C-M  Manual for Program FIDLAM
C-M  =========================
C-M
C-M  The program redefines the fission cross section to be
C-M  proportional to the absorption cross section such that the
C-M  capture to fission ratio is equal to CFR, defined in the
C-M  DATA statement in the programs.
C-M    The fission channel in Am-241 has a threshold, therefore
C-M  the capture to fission ratio is strongly spectrum
C-M  dependent. The ratio may reach a value 124 for well
C-M  thermalised lattices and may be as low as 42 for lattices
C-M  with a high content of degraded plutonium. For a typical
C-M  PWR lattice the ratio is about 92.
C-M    Burnup of Am-241 in the WIMS-D library with branching
C-M  to Am-242g and Am-242m can not a be represented accurately
C-M  because the WIMS-D library allows a single capture product
C-M  to be specified. The Am-242m nuclide is considered more
C-M  important from the reactivity point of view, therefore
C-M  its branch is treated explicitly. However, Am-242g is
C-M  important due to the decay into Cm-242 which in turn decays
C-M  into Pu-238. Am-242g production can only be dealt with by
C-M  treating it as a fission product of Am-241 with a yield
C-M  equal to the capture to fission ratio. To avoid spectrum
C-M  dependence of the effective Am-242g production the shape
C-M  of the fission cross section is forced to be proportional
C-M  to the absorption cross section such that the capture to
C-M  fission ratio of 92 is approximately conserved for an average
C-M  lattice. This crude adjustment is tolerable because Am-241
C-M  is not very important from the reactivity point of view.
C-M  Note that the fission yield is left intact, which is
C-M  important for criticality calculation. The effective
C-M  number of neutrons per fission is unphysical. The power
C-M  calculated from the fission cross section may be incorrect.
C-M
C-M  Instructions
C-M  The filename "Am241g.xsw" is fixed. The original contents of
C-M  the file is copied to scratch "FidlAm.tmp" and the corrected
C-M  file is written back to the original file. No other input is
C-M  necessary.
C-
      PARAMETER   (MXGR=200)
      CHARACTER*75 REC
      CHARACTER*40 FLNI,FLSC
C*
      DIMENSION    SGP(MXGR),XSI(MXGR),XXX(MXGR),ALM(MXGR)
     1            ,SGA(MXGR),STR(MXGR),SGF(MXGR),VSF(MXGR)
     2            ,TEMP(10)
C* File units
      DATA FLNI/'Am241g.xsw'/
     1     FLSC/'FidlAm.tmp'/
      DATA LIN,LSC,LTT/ 1, 3, 6 /
C* Default 69-group structure (fast/resonance/thermal)
      DATA NG1,NG2,NG3/ 14, 13, 42 /
C* Alternative 172-group structure (fast/resonance/thermal)
      DATA MG1,MG2,MG3/ 45, 47, 80 /
C*
C* Capture/fission ratio (consistent with reduced Am-242g yield)
      DATA CFR/ 92. /
C*
      IER=0
C*
      WRITE(LTT,900) ' FIDLAM - Adjust Am-241 Fiss. X-sect.   '
      WRITE(LTT,900) ' ====================================   '
      WRITE(LTT,900)
C*
      OPEN (UNIT=LIN,FILE=FLNI,STATUS='OLD')
      OPEN (UNIT=LSC,FILE=FLSC,STATUS='UNKNOWN')
C*
C* Save copy of the original file to scratch
   14 READ (LIN,901,END=16) REC
      WRITE(LSC,901)        REC
      GO TO 14
   16 REWIND LIN
      REWIND LSC
      GO TO 20
C*
C* Try alternative group structure if read-error occurs
   18 IER=IER+1
      IF(IER.GT.1)
     1STOP 'FIDLAM ERROR - Unrecognised format or group structure'
      NG1=MG1
      NG2=MG2
      NG3=MG3
      REWIND LIN
      REWIND LSC
      WRITE(LTT,900) ' FIDLAM has problems reading the file - '
     1              ,'Try alternative 172-group structure     '
C*
C* Copy the burnup data to scratch
   20 READ (LSC,901) REC
      IF(REC(1:15).NE.'      999999999') GO TO 30
   22 WRITE(LIN,901) REC
      READ (LSC,901) REC
      IF(REC(1:15).NE.'      999999999') GO TO 22
      WRITE(LIN,901) REC
      READ (LSC,901) REC
C*
C* Begin processing the cross sections
   30 READ (REC,912) MAT,AWT,IZ,NF,NT
      IF(NF.LT.3) STOP 'FIDLAM is confused - no Fiss.x-sect'
      WRITE(LIN,901) REC
C* Copy the fast cross sections
      N12=NG1+NG2
      READ (LSC,914) (SGP(J),J=1,NG2),(XSI(J),J=1,NG2)
     1              ,(STR(J),J=1,N12),(SGA(J),J=1,N12)
     2              ,(XXX(J),J=1,NG2),(ALM(J),J=1,NG2)
      WRITE(LIN,914) (SGP(J),J=1,NG2),(XSI(J),J=1,NG2)
     1              ,(STR(J),J=1,N12),(SGA(J),J=1,N12)
     2              ,(XXX(J),J=1,NG2),(ALM(J),J=1,NG2)
C* Process the fast fission and fission yield
      READ (LSC,914) (VSF(J),J=1,N12),(SGF(J),J=1,N12)
      RR=1/(CFR+1)
      DO J=1,N12
C...    VV=2.55
C...    IF(SGF(J).GT.0) VV=VSF(J)/SGF(J)
        SGF(J)=RR*SGA(J)
C...    VSF(J)=VV*SGF(J)
      END DO
      WRITE(LIN,914) (VSF(J),J=1,N12),(SGF(J),J=1,N12)
C* Copy the fast scattering matrix
      READ (LSC,915,ERR=18) LSM
      WRITE(LIN,915)        LSM
      LSM=(LSM+4)/5
      DO I=1,LSM
        READ (LSC,901) REC
        WRITE(LIN,901) REC
      END DO
C* Copy the temperatures
      READ (LSC,914) (TEMP(J),J=1,NT)
      WRITE(LIN,914) (TEMP(J),J=1,NT)
C*
C* Process the thermal cross section
      DO IT=1,NT
C* Copy the absorption and transport cross sections
        READ (LSC,914) (STR(J),J=1,NG3),(SGA(J),J=1,NG3)
        WRITE(LIN,914) (STR(J),J=1,NG3),(SGA(J),J=1,NG3)
C* Process the thermal fission and fission yield
        READ (LSC,914) (VSF(J),J=1,NG3),(SGF(J),J=1,NG3)
        RR=1/(CFR+1)
        DO J=1,NG3
C...      VV=2.55
C...      IF(SGF(J).GT.0) VV=VSF(J)/SGF(J)
          SGF(J)=RR*SGA(J)
C...      VSF(J)=VV*SGF(J)
        END DO
        WRITE(LIN,914) (VSF(J),J=1,NG3),(SGF(J),J=1,NG3)
C* Copy the thermal scattering matrix
        READ (LSC,915,ERR=18) LSM
        WRITE(LIN,915)        LSM
        LSM=(LSM+4)/5
        DO I=1,LSM
          READ (LSC,901) REC
          WRITE(LIN,901) REC
        END DO
      END DO
C*
C* Copy the rest of the file
   74 READ (LSC,901,END=90) REC
      WRITE(LIN,901)        REC
      GO TO 74
C*
   90 STOP 'FIDLAM Completed'
C*
  900 FORMAT(2A40)
  901 FORMAT(A75)
  912 FORMAT(I6,F15.0,5I6)
  914 FORMAT(1P,5E15.8)
  915 FORMAT(5I15)
      END
*deck getmf2 
      PROGRAM GETMF2
C-Title  : Program GETMF2
C-Purpose: Get relevant data from file 2 to prepare NJOY inputs
C-Author : D. L. Aldama
C-Version: 03/1999 Original code (named GETDATA)
C-V  01/2000 Add upper unresolved res. range threshold.
C-V  09/2000 Simple average of E-dep. AP (1/E caused problems
C-V          on coarse mesh starting at 1E-5 eV, case: Cl-nat
C-V          from JENDL-3.2) (A.Trkov).
C-V  12/2001 A.Trkov, IAEA
C-V          - Rename to GETMF2.
C-V          - Fix bug when no MF2 data present.
C-V          - Normalise scattering radius by sum of weights
C-V            to fix processing of some BROND evaluations, which
C-V            contain pseudo-isotopes in isotopic evaluations.
C-V  11/2004 D. L. Aldama, IAEA
C-V          - Correction to read MF=1/MT=451 in ENDF-5 format
C-M
C-M  Manual for Program GETMF2
C-M  =========================
C-M  The AP value and other parameters are read from the MF2/151 and
C-M  MF1/451 sections. An average potential sigma is calculated in the
C-M  WIMS resonance range (4.00eV to 9.118KeV) for each material on
C-M  the endfb tape. Parameters, which are relevant for preparing NJOY
C-M  inputs are printed on the output file:
C-M   Col.  Description
C-M   1- 4  Material MAT number.
C-M   5-16  Chemical symbol from ENDF file MF1, MT451.
C-M  17-26  Material ZA designation.
C-M  27-38  Atomic weight ratio.
C-M  39-50  Average potential cross section [barns].
C-M  51-63  Upper energy of the resolved resonance range [eV].
C-M  64-76  Upper energy of the unresolved resonance range,
C-M         zero if no unresolved resonance parameters present [eV].
C-M
C-M  The details of the processing are saved on the log file.
C-M
C-M  Instructions
C-M  The following parameters are entered from keyboard:
C-M   - Source evaluated nuclear data filename.
C-M   - Output filename.
C-M   - Log filename that contains additional processing information.
C-M
C-M  Files used:
C-M       Input file:
C-M          1. Evaluated nuclear data file
C-M       Output files:
C-M          1.  Output file (ENDF MF2 summary)
C-M          3.  Log file
C-
       PARAMETER(LIB=1,NOUT=2,NLOG=3,LKB=5,LTT=6,NI=10,NMAX=30)
       PARAMETER(PI=3.141593)
       DIMENSION NRR(NI),ZAI(NI),AWI(NI),ABNI(NI)
       DIMENSION EHIGH(NI,NMAX),AP(NI,NMAX),RRF(NI,NMAX)
       CHARACTER*66 LINE,TAPE
       CHARACTER*40 FLI,FOU,FLO,FLNM,BLNK
       CHARACTER*11 ZSYMAM
       DATA BLNK/'                                        '/
       DATA FLI/'ENDF.DAT'/
       DATA FOU/'ENDF.MF2'/
       DATA FLO/'GETMF2.LOG'/
C*
       WRITE(LTT,15) ' GETMF2: Retrieve data from From File 2 '
       WRITE(LTT,15) ' ======================================='
       WRITE(LTT,15)
C*
C*    Open I/O files
       FLNM=BLNK
    1  WRITE(LTT,15) '    Define Evaluated Nuclear Data Lib.: '
       WRITE(LTT,15) '    ----------------------------------  '
       WRITE(LTT,15) '                     Default file name: ',FLI
       WRITE(LTT,15) '$       Enter new name (enter=default): '
       READ (LKB,15) FLNM
       IF(FLNM.NE.BLNK) FLI=FLNM
       OPEN(UNIT=LIB, FILE=FLI, STATUS='OLD',ERR=1)
       FLNM=BLNK
    2  WRITE(LTT,15) '    Define Output File Name (MF2 file): '
       WRITE(LTT,15) '    ----------------------------------  '
       WRITE(LTT,15) '                     Default file name: ',FOU
       WRITE(LTT,15) '$       Enter new name (enter=default): '
       READ (LKB,15) FLNM
       IF(FLNM.NE.BLNK) FOU=FLNM
       OPEN(UNIT=NOUT,FILE=FOU,ERR=2)
       FLNM=BLNK
    3  WRITE(LTT,15) '    Define   LOG  File Name (LOG file): '
       WRITE(LTT,15) '    ----------------------------------  '
       WRITE(LTT,15) '                     Default file name: ',FLO
       WRITE(LTT,15) '$       Enter new name (enter=default): '
       READ (LKB,15) FLNM
       IF(FLNM.NE.BLNK) FLO=FLNM
       OPEN(UNIT=NLOG,FILE=FLO,ERR=3)
C*
C*    Process Evaluated Nuclear Data Library
       CALL RDHEAD(LIB,TAPE,MAT,MF,MT,NS)
       WRITE(NOUT,*)' MAT   Nuclide        ZA        Awt'
     1             ,'         SigPot      Eru          Euu'
       WRITE(NLOG,*)TAPE
       IMF=0
       DO WHILE (MAT.NE.-1)
         CALL RDHEAD(LIB,LINE,MAT,MF,MT,NS)
         IF(IMF.EQ.0) THEN
           IF(MF.EQ.1.AND.MT.EQ.451)THEN
             BACKSPACE(LIB)
             CALL GETZSA(LIB,ZSYMAM)
             IMF=1
           END IF
         ELSE IF (IMF.EQ.1) THEN
           IF(MF.EQ.2.AND.MT.EQ.151) THEN
             BACKSPACE(LIB)
             CALL GETAPS(LIB,ZA0,AW,NIS,NRR,ZAI,ABNI,AWI,EHIGH,AP,RRF,
     &                   IERR)
             IMF=0
             IF (IERR.EQ.0) THEN
              WRITE(NLOG,20)' MAT=',MAT,' SYM=',ZSYMAM,'  ZA=',ZA0,
     &                     '  AW=',AW,' NIS=',NIS
              APMAT=0.0
              EHMAT=2.0E7
              EUMAT=0
              ABNSU=0
              DO I=1,NIS
               ABNSU=ABNSU+ABNI(I)
               WRITE(NLOG,30)' I=',I,' ZAI=',ZAI(I),' AWI=',AWI(I),
     &                       ' ABN=',ABNI(I),' NRR=',NRR(I)
               WRITE(NLOG,40)' UPPER BOUND.',' SCAT. RADIUS',' LRU.LRF'
               NER=NRR(I)
               DO IE=1,NER
                 WRITE(NLOG,50)EHIGH(I,IE),AP(I,IE),RRF(I,IE)
               END DO
               CALL EHAPI(I,NER,EHIGH,AP,RRF,EHI,API,EUR)
               WRITE(NLOG,60)'ISO. AP:',API,' ISO. RRR/URR:',EHI
               APMAT=ABNI(I)*API+APMAT
               IF (EHI.LT.EHMAT) EHMAT=EHI
               IF (EUR.GT.EUMAT) EUMAT=EUR
              END DO
              APMAT=APMAT/ABNSU
              WRITE(NLOG,60)'MAT. AP:',APMAT,' MAT. RRR/URR:',EHMAT
              SIGPOT=4.0*PI*APMAT*APMAT
              WRITE(NOUT,70)MAT,ZSYMAM,ZA0,AW,SIGPOT,EHMAT,EUMAT
             ELSE
              WRITE(NOUT,70)MAT,ZSYMAM,ZA0,AW
             ENDIF 
           ELSE IF(MF.GT.2) THEN
             IMF=0
           ENDIF
         ENDIF
       END DO
       CLOSE(LIB)
       CLOSE(NOUT)
       CLOSE(NLOG)
      STOP
15    FORMAT(2A40)
20    FORMAT(A5,I5,A5,A12,A5,F7.1,A5,F10.6,A5,I3)
30    FORMAT(A3,I2,A5,F7.1,A5,F10.6,A5,F8.6,A5,I3)
40    FORMAT(5X,A13,2X,A13,2X,A8)
50    FORMAT(5X,1PE13.6,2X,1PE13.6,2X,0PF7.2)
60    FORMAT(5X,A8,2X,1PE13.6,2X,A14,2X,1PE13.6)
70    FORMAT(I4,2X,A11,F9.1,F12.6,F12.4,1P,2E13.6)
      END
C
C   GETAPS
C
      SUBROUTINE GETAPS(LIB,ZA0,AW,NIS,NRR,ZAI,ABNI,AWI,EHIGH,AP,RRF,
     &                   IERR)
       PARAMETER(XMASS=1.008665,NI=10,NPP=10000)
       DIMENSION X(NPP),Y(NPP),NB(NPP),IT(NPP),RRF(NI,*)
       DIMENSION NRR(NI),ZAI(NI),AWI(NI),ABNI(NI),EHIGH(NI,*),AP(NI,*)
       IERR=0
       CALL RDCONT(LIB,ZA,AWR,L1,L2,NIS,N2,MAT,MF,MT,NS)
       ZA0=ZA
       AW=AWR*XMASS
       CALL RDCONT(LIB,ZAII,ABN,L1,LFW,NER,N2,MAT,MF,MT,NS)
       CALL RDCONT(LIB,C1,EH,LRU,LRF,NRO,NAPS,MAT,MF,MT,NS)
       IF (LRU.EQ.0.AND.NIS.EQ.1.AND.NER.EQ.1) THEN
C  ONLY SCATTERING RADIUS IS GIVEN
        CALL RDCONT(LIB,C1,C2,L1,L2,N1,N2,MAT,MF,MT,NS)
        ZAI(1)=ZAII
        ABNI(1)=ABN
        NRR(1)=NER
        EHIGH(1,1)=EH
        AWI(1)=AW
        AP(1,1)=C2
        RRF(1,1)=FLOAT(LRU)+0.1*FLOAT(LRF)
       ELSE
C  RESO DATA
        BACKSPACE(LIB)
        BACKSPACE(LIB)
        DO II=1,NIS
         CALL RDCONT(LIB,ZAII,ABN,L1,LFW,NER,N2,MAT,MF,MT,NS)
         ZAI(II)=ZAII
         ABNI(II)=ABN
         NRR(II)=NER
         DO IE=1,NER
          CALL RDCONT(LIB,C1,EH,LRU,LRF,NRO,NAPS,MAT,MF,MT,NS)
          EHIGH(II,IE)=EH
          RRF(II,IE)=FLOAT(LRU)+0.1*FLOAT(LRF)
          IF (LRU.EQ.1) THEN
C            RESOLVED RESONANCES
           IF (LRF.LT.4) THEN
             IF (NRO.NE.0) THEN
               CALL RDTAB1(LIB,C1,C2,L1,L2,N1,N2,NB,IT,X,Y,MAT,MF,MT,NS)
               SUM=0.0
               SEN=0.0
               DO I=2,N2
                 SUM=SUM+0.5*(X(I)-X(I-1))*(Y(I)+Y(I-1))
                 SEN=SEN+    (X(I)-X(I-1))
               END DO
               SUM=SUM/SEN
               AP(II,IE)=SUM
               CALL RDCONT(LIB,C1,C2,L1,L2,NLS,N2,MAT,MF,MT,NS)
             ELSE
               CALL RDCONT(LIB,C1,C2,L1,L2,NLS,N2,MAT,MF,MT,NS)
               IF (LRF.EQ.3.AND.C2.EQ.0.) THEN
                 READ(LIB,'(11X,F11.0)')C2
                 BACKSPACE LIB
               ENDIF
               AP(II,IE)=C2
             ENDIF
             DO K=1,NLS
              CALL RDLIST(LIB,C1,C2,L1,L2,N1,N2,X,MAT,MF,MT,NS)
              AWI(II)=C1*XMASS
             END DO
           ELSE IF(LRF.EQ.4) THEN
             IF (NRO.NE.0) THEN
               CALL RDTAB1(LIB,C1,C2,L1,L2,N1,N2,NB,IT,X,Y,MAT,MF,MT,NS)
               SUM=0.0
               DO I=2,N2
                 SUM=0.5*(X(I)-X(I-1))*(Y(I)/X(I)+Y(I-1)/X(I-1))+SUM
               END DO
               AP(II,IE)=SUM/LOG(X(N2)/X(1))
               CALL RDCONT(LIB,C1,C2,L1,L2,NLS,N2,MAT,MF,MT,NS)
             ELSE
               CALL RDCONT(LIB,C1,C2,L1,L2,NLS,N2,MAT,MF,MT,NS)
               AP(II,IE)=C2
             ENDIF
             CALL RDLIST(LIB,C1,C2,L1,L2,N1,N2,X,MAT,MF,MT,NS)
             AWI(II)=C1*XMASS
             DO JJ=1,NLS
              CALL RDCONT(LIB,C1,C2,L1,L2,NJS,N2,MAT,MF,MT,NS)
              DO K=1,NJS
               CALL RDLIST(LIB,C1,C2,L1,L2,N1,N2,X,MAT,MF,MT,NS)
              END DO
             END DO
           ELSE 
C             CASE OF Cl-35 for ENDFB-VII.1 (PATCH)                 
             IF (ZA0.EQ.17035.0.AND.LRF.EQ.7)THEN
               AP(II,IE)=0.36680
               AWI(II)=AW
             ELSE
               WRITE(*,*)' THIS PROGRAM CAN NOT WORK WITH'
               WRITE(*,*)' LRF=5, LRF=6 or LRF=7'
               WRITE(*,*)' ZA0=',ZA0, ' AW=',AW, ' LRF=',LRF
               IERR=1  
             ENDIF  
           ENDIF
          ELSE IF (LRU.EQ.2) THEN
C            UNRESOLVED RESONANCES
           IF(LRF.EQ.1) THEN
             IF(LFW.EQ.0) THEN
               CALL RDCONT(LIB,C1,C2,L1,L2,NLS,N2,MAT,MF,MT,NS)
               AP(II,IE)=C2
               DO K=1,NLS
                CALL RDLIST(LIB,C1,C2,L1,L2,N1,N2,X,MAT,MF,MT,NS)
                AWI(II)=C1*XMASS
               END DO
             ELSE
               CALL RDLIST(LIB,C1,C2,L1,L2,N1,NLS,X,MAT,MF,MT,NS)
               AP(II,IE)=C2
               DO K=1,NLS
                 CALL RDCONT(LIB,C1,C2,L1,L2,NJS,N2,MAT,MF,MT,NS)
                 AWI(II)=C1*XMASS
                 DO JJ=1,NJS
                   CALL RDLIST(LIB,C1,C2,L1,L2,N1,N2,X,MAT,MF,MT,NS)
                 END DO
               END DO
             ENDIF
           ELSE
             CALL RDCONT(LIB,C1,C2,L1,L2,NLS,N2,MAT,MF,MT,NS)
             AP(II,IE)=C2
             DO K=1,NLS
               CALL RDCONT(LIB,C1,C2,L1,L2,NJS,N2,MAT,MF,MT,NS)
               AWI(II)=C1*XMASS
               DO JJ=1,NJS
                 CALL RDLIST(LIB,C1,C2,L1,L2,N1,N2,X,MAT,MF,MT,NS)
               END DO
             END DO
           ENDIF
          ELSE IF (LRU.EQ.0.AND.NIS.GT.1)THEN
           CALL RDCONT(LIB,C1,C2,L1,L2,NLS,N2,MAT,MF,MT,NS)
           AP(II,IE)=C2
          ENDIF
         END DO
        END DO
       ENDIF
       RETURN
      END
C
C    GETZSA
C
      SUBROUTINE GETZSA(LIB,ZSYMAM)
       CHARACTER*66 TEXT
       CHARACTER*12 ZSYMAM
       DO I=1,2
        CALL RDHEAD(LIB,TEXT,MAT,MF,MT,NS)
       END DO
       IF (TEXT(56:66).EQ.'          6') THEN
         NV=3
       ELSE
         NV=2
       ENDIF
       DO I=1,NV
        CALL RDHEAD(LIB,TEXT,MAT,MF,MT,NS)
       END DO
       READ(TEXT,10)ZSYMAM
       RETURN
10     FORMAT(A11)
      END
C
C     RDHEAD, RDCONT, RDLIST, RDTAB1
C
      SUBROUTINE RDHEAD(LIB,TEXT,MAT,MF,MT,NS)
       CHARACTER*66 TEXT
       READ(LIB,10)TEXT,MAT,MF,MT,NS
       RETURN
10     FORMAT(A66,I4,I2,I3,I5)
      END
      SUBROUTINE RDCONT(LIB,C1,C2,L1,L2,N1,N2,MAT,MF,MT,NS)
       READ(LIB,10)C1,C2,L1,L2,N1,N2,MAT,MF,MT,NS
       RETURN
10     FORMAT(2E11.0,4I11,I4,I2,I3,I5)
      END
      SUBROUTINE RDLIST(LIB,C1,C2,L1,L2,N1,N2,X,MAT,MF,MT,NS)
       DIMENSION X(*)
       READ(LIB,10)C1,C2,L1,L2,N1,N2,MAT,MF,MT,NS
       READ(LIB,20)(X(I),I=1,N1)
       RETURN
10     FORMAT(2E11.0,4I11,I4,I2,I3,I5)
20     FORMAT(6E11.0)
      END
      SUBROUTINE RDTAB1(LIB,C1,C2,L1,L2,N1,N2,NB,ITL,X,Y,MAT,MF,MT,NS)
       DIMENSION NB(*),ITL(*),X(*),Y(*)
       READ(LIB,10)C1,C2,L1,L2,N1,N2,MAT,MF,MT,NS
       READ(LIB,20)(NB(I),ITL(I),I=1,N1)
       READ(LIB,30)(X(I),Y(I),I=1,N2)
       RETURN
10     FORMAT(2E11.0,4I11,I4,I2,I3,I5)
20     FORMAT(6I11)
30     FORMAT(6E11.0)
      END
C
C      EHAPI
C
      SUBROUTINE EHAPI(I,NER,EHIGH,AP,RRF,EHI,API,EUR)
       PARAMETER(ELW=4.0,EHW=9118.0,NI=10)
       DIMENSION EHIGH(NI,*),AP(NI,*),RRF(NI,*)
       EUR=0
       IF (NER.EQ.1) THEN
         API=AP(I,1)
       ELSE IF (EHIGH(I,NER).LT.ELW) THEN
         API=AP(I,NER)
       ELSE IF (EHIGH(I,1).GT.EHW) THEN
         API=AP(I,1)
       ELSE
         IF (EHIGH(I,1).GT.ELW) THEN
           IMIN=1
         ELSE
           IMIN=1
           DO WHILE(EHIGH(I,IMIN).LE.ELW)
             IMIN=IMIN+1
           END DO
         ENDIF
         IF (EHIGH(I,NER).LT.EHW) THEN
           IMAX=NER
           EHIGH(I,NER)=EHW
         ELSE
           IMAX=IMIN
           DO WHILE(EHIGH(I,IMAX).LT.EHW)
             IMAX=IMAX+1
           END DO
           EHIGH(I,IMAX)=EHW
         ENDIF
         SUM=0.0
         EL=ELW
         DO IE=IMIN,IMAX
           SUM=AP(I,IE)*LOG(EHIGH(I,IE)/EL)+SUM
           EL=EHIGH(I,IE)
         END DO
         API=SUM/LOG(EHW/ELW)
       END IF
C       II=0
C       IE=1
C       DO WHILE (II.EQ.0)
        DO IE=1,NER
        LRU=INT(RRF(I,IE))
        IF (LRU.LT.2) THEN
          EHI=EHIGH(I,IE)
C          IE=IE+1
        ELSE
          EUR=EHIGH(I,IE)
C          II=1
        ENDIF
C        IF (IE.GT.NER) II=1
       END DO
       RETURN
      END
*deck getzam 
       PROGRAM GETZAM
C-Title  : GETZAM Program
C-Purpose: Extract one or more materials from an ENDF file
C-Author : A.Trkov, Institute Jozef Stefan, Ljubljana
C-Version: April 2000 - original code
C-M
C-M  Manual for Program GETZAM
C-M  =========================
C-M  The program retrieves material files from an evaluated nuclear
C-M  data library. The retrieval is done either by the ZA or the
C-M  MAT number. The definition ZA=1000*Z+A applies, where Z is the
C-M  atomic number and A is the mass number.
C-M
C-M  Instructions
C-M  The parameters listed below are read from the default input.
C-M  They may be entered interactively from the keyboard in response
C-M  to the prompts printed on the default output (usually the
C-M  terminal screen):
C-M  - Output ENDF filename, which is to contain the extracted data.
C-M  - Source ENDF filename, which is to be processed.
C-M  - Requested material range. Two entries IM1, IM2 are read
C-M    assuming 10 columns width for each (blanks are ignored).
C-M    The remaining part of the record (from column 21 onwards)
C-M    may be used for comments.
C-M      The requested range implies all materials with identifiers
C-M    in the range between IM1 and IM2, inclusive. The identifiers
C-M    are the material ZA of the MAT designation. Selection by the
C-M    MAT designation is flagged by negative ident numbers.
C-M      If Abs(IM2) is less than Abs(IM1) then IM2 is assumed equal
C-M    to IM1, implying a single material request on this record.
C-M    NOTE: When specifying the range of materials, both entries
C-M          defining the range must imply either the ZA designation
C-M          (positive entries) or MAT designation (negative entries).
C-M  - Any number of additional requests as above may be specified.
C-M    The maximum limit on the number of retrieved materials is
C-M    MXMT, defined in the PARAMETER statement in the code. The list
C-M    of requests is terminated by a blank record or zero.
C-M
C-
      PARAMETER   (MXMT=100)
      CHARACTER*66 C66,H66
      CHARACTER*40 BLNK,FLNM,FLIN,FLOU
      DIMENSION    AMT1(MXMT),AMT2(MXMT)
C* Filenames and logical file units
      DATA LIN,LOU,LKB,LTT / 1, 2, 5, 6 /
      DATA BLNK/'                                        '/
     1    ,FLIN/'ENDF.dat'/
     2    ,FLOU/'ENDF.OUT'/
C*
C* Define input parameters - Write banner to terminal
      WRITE(LTT,901) ' GETZAM - Extract materials from ENDF   '
      WRITE(LTT,901) ' ====================================   '
      WRITE(LTT,901)
C* Define the output file
   14 WRITE(LTT,901) ' Default output ENDF filename         : ',FLOU
      WRITE(LTT,901) '$          Enter new name to redefine : '
      READ (LKB,901) FLNM
      IF(FLNM.NE.BLNK) FLOU=FLNM
      OPEN (UNIT=LOU,FILE=FLOU,STATUS='UNKNOWN')
C* Define the source file
   16 WRITE(LTT,901) ' Default source ENDF filename         : ',FLIN
      WRITE(LTT,901) '$          Enter new name to redefine : '
      READ (LKB,901) FLNM
      IF(FLNM.NE.BLNK) FLIN=FLNM
      OPEN(UNIT=LIN,FILE=FLIN,STATUS='OLD',ERR=16)
C* Define materials to be extracted
      NMT=0
      GO TO 22
C* Warn of illegal requests
C* Read the requests
   22 WRITE(LTT,901) '$Request material (MAT<0,ZA>0,End=0)  : '
      READ (LKB,922,END=40,ERR=22) IM1,IM2
      IF(IM1.EQ.0) GO TO 40
      IF(ABS(IM2).LT.ABS(IM1)) IM2=IM1
C* Check entry validity (watch for integer overflow)
      I12=(IM1/ABS(IM1))*(IM2/ABS(IM2))
      IF(I12.LT.0) THEN
        WRITE(LTT,901) ' Illegal request - please redo          '
        GO TO 22
      END IF
      NMT=NMT+1
      IF(NMT.GT.MXMT) STOP 'GETZAM ERROR - MXMT limit exceeded'
      AMT1(NMT)=IM1
      AMT2(NMT)=IM2
      GO TO 22
C*
C* Print processing information
   40 WRITE(LTT,901)
      WRITE(LTT,901) '                     Output ENDF file : ',FLOU
      WRITE(LTT,901) '                     Source ENDF file : ',FLIN
      WRITE(LTT,902) '                  Number of materials : ',NMT
      WRITE(LTT,901)
C*
C* Begin processing the data
      READ (LIN,940) C66,MAT,MF,MT
      WRITE(LOU,940) C66,MAT,MF,MT
C* Next material
   60 READ (LIN,940) C66,MAT,MF,MT
      IF(MAT.LT.0) GO TO 80
      READ (LIN,940) H66,MAT,MF,MT
      READ (C66,924) ZA
      READ (H66,924) DM,DM,ID,LIS0
      ZA=ZA+0.1*LIS0
C* Check if material is to be copied
      CALL MATCHK(MAT,ZA,NMT,AMT1,AMT2,ISEL)
      IF     (ISEL.LT.0) THEN
        GO TO 80
      ELSE IF(ISEL.GT.0) THEN
C* Copy current material to output
        WRITE(LTT,961) MAT,ZA
        WRITE(LOU,940) C66,MAT,MF,MT
        WRITE(LOU,940) H66,MAT,MF,MT
   62   READ (LIN,940) C66,MAT,MF,MT
        WRITE(LOU,940) C66,MAT,MF,MT
        IF(MAT.GT.0) GO TO 62
      ELSE
C* Skip to next material
   64   READ (LIN,940) C66,MAT,MF,MT
        IF(MAT.GT.0) GO TO 64
        END IF
      GO TO 60
C* End of file processing
   80 C66=BLNK//BLNK(1:26)
      MAT=-1
      MF = 0
      MT = 0
      WRITE(LOU,940) C66,MAT,MF,MT
      STOP 'GETZAM Completed'
C*
  901 FORMAT(2A40)
  902 FORMAT(A40,I10)
  922 FORMAT(BN,2I10)
  924 FORMAT(2F11.0,4I11)
  940 FORMAT(A66,I4,I2,I3)
  961 FORMAT(' Copy MAT',I6,'  ZA',F9.1)
      END
      SUBROUTINE MATCHK(MAT,ZA,NMT,AMT1,AMT2,ISEL)
C-Title  : Matchk Subroutine
C-Purpose: Check if MAT/MT is in specified range
      DIMENSION AMT1(NMT),AMT2(NMT)
      ISEL=0
      IALL=0
      DO 20 M=1,NMT
      IF(AMT1(M).EQ.0) THEN
        GO TO 20
      ELSE IF(AMT1(M).LT.0) THEN
C* Check by MAT number
        IALL=1
        MAT1=NINT(-AMT1(M))
        MAT2=NINT(-AMT2(M))
        IF(MAT.LT.MAT1 .OR. MAT.GT.MAT2) GO TO 20
      ELSE
C* Check by ZA number
        IALL=1
        MAT1=NINT(10*AMT1(M))
        MAT2=NINT(10*AMT2(M))
        IZA =NINT(10*ZA)
        IF(IZA.LT.MAT1 .OR. IZA.GT.MAT2) GO TO 20
      END IF
C* Case: Material matching successful
      IF(AMT1(M).EQ.AMT2(M)) THEN
        AMT1(M)=0
        AMT2(M)=0
      END IF
      ISEL=1
      RETURN
   20 CONTINUE
C* Case: Material not matching
      IF(IALL.EQ.0) ISEL=-1
      RETURN
      END
*deck mrgmat 
      PROGRAM MRGMAT
C-Title  : MRGMAT Program
C-Purpose: Merge ENDF material files into a single library
C-Author : A.Trkov, Institute J.Stefan, Ljubljana, Slovenia
C-Version: 2000 - Original code
C-V  01/04 Increase MXMT from 800 to 2000 (A.Trkov)
C-V  01/11 Improve diagnostics for duplicate materials (A.Trkov)
C-V  02/05 Process Windows-NT directory listing (A.Trkov)
C-V  03/01 Fix bug in interactive input (A.Trkov)
C-M
C-M  Manual for Program MRGMAT
C-M  =========================
C-M    The program reads the list of filenames containing
C-M  nuclear data in ENDF format and copies them to a scratch
C-M  file MRGMAT.TMP (fixed filename). The MAT numbers are stored.
C-M  The scratch file is then processed, writing the data sorted
C-M  by ascending MAT numbers onto MRGMAT.OUT (fixed filename).
C-M  Data sets with duplicate MAT numbers are skipped (the data
C-M  that appear first on the list are copied to output).
C-M    The list of filenames may be typed from keyboard input
C-M  and is terminated by "-" or an end-of-file mark.
C-M  Alternatively, the default input may be redirected to a
C-M  list file. The list file format from the DIR command of
C-M  Windows-DOS (95,98,NT) is recognised automatically and can
C-M  be used instead.
C-
      PARAMETER    (MXMT=5000)
      CHARACTER*80  RECI
      CHARACTER*66  CH66,HH66
      CHARACTER*40  BLNK,PATH,FLTM,FLNM,FLOU,FLER
      DIMENSION     MTLS(MXMT),IZLS(MXMT)
C*
      DATA BLNK/'                                        '/
     1     FLTM/'MRGMAT.TMP'/
     1     FLOU/'MRGMAT.OUT'/
     9     FLER/'MRGMAT.LOG'/
C*
      DATA LIN,LTT,LOU,LTM,LEN,LER/ 5, 6, 1, 3, 2, 7 /
C*
      WRITE(LTT,91) ' MRGMAT - ENDF Material Merging Utility '
      WRITE(LTT,91) ' ====================================== '
      WRITE(LTT,91)
      PATH=BLNK
      LPTH=0
      IDOS=0
      IFL =0
      NMT =0
      IDU =0
      JS  =0
      KMT =MXMT
      OPEN (UNIT=LTM,FILE=FLTM,STATUS='UNKNOWN')
      OPEN (UNIT=LOU,FILE=FLOU,STATUS='UNKNOWN')
      OPEN (UNIT=LER,FILE=FLER,STATUS='UNKNOWN')
      WRITE(LER,91) ' MRGMAT - ENDF Material Merging Utility '
      WRITE(LER,91) ' ====================================== '
      WRITE(LER,91)
C* Read the directory listing
   20 WRITE(LTT,91) '$Enter the source ENDF file           : '
   21 READ (LIN,93,END=60) RECI
      IF(RECI(1:1).EQ.'-') GO TO 60
C* Allow piping DIR listing of Dos (Windows 95,98,NT):
C* Skip header records in the DIR list of DOS
      IF(RECI(1:20).EQ.BLNK(1:20)) GO TO 21
C* Skip "Volume" information from a directory listing
      IF(RECI( 1: 8).EQ.' Volume ') GO TO 21
C* End of directory record in the DIR list of DOS
      IF(RECI(12:18).EQ.'file(s)' .OR.
     1   RECI(18:24).EQ.'File(s)' ) GO TO 60
C* Identify directory path in the DIR list of DOS
      IF(RECI(1:8).EQ.' Directo') THEN
        WRITE(LOU,95) ' MRGMAT files on  '//RECI, 0, 0, 0
        PATH=RECI(15:40)
   22   IF(PATH(LPTH+1:LPTH+1).NE.' ') THEN
          LPTH=LPTH+1
          GO TO 22
        END IF
        IF(PATH(LPTH:LPTH).NE.'\') THEN
          LPTH=LPTH+1
          PATH(LPTH:LPTH)='\'
        END IF
        IDOS=1
        GO TO 20
      END IF
C* Extract the filenames but skip directories
      IF(IDOS.NE.0) THEN
        IF(RECI(25:29).EQ.'<DIR>') THEN
C*        Windows-NT directory listing
          IDOS=2
          GO TO 21
        END IF
        IF(RECI(15:15).EQ.':') IDOS=2
        IF(RECI(16:20).EQ.'<DIR>') GO TO 21
        IF(IDOS.EQ.1) THEN
          RECI(9:9)='.'
          LNAM=0
          DO 24 I=1,12
          IF(RECI(I:I).EQ.' ') GO TO 24
          LNAM=LNAM+1
          IF(LNAM.EQ.I) GO TO 24
            RECI(LNAM:LNAM)=RECI(I:I)
            RECI(I:I)=' '
   24     CONTINUE
          FLNM=PATH(1:LPTH)//RECI(1:LNAM)
        ELSE
C* Case: Windows-NT directory listing
          FLNM=PATH(1:LPTH)//RECI(40:80)
        END IF
      ELSE
C* Simple ASCII file list
        FLNM=RECI(1:40)
      END IF
C* Open the file
      WRITE(LTT,91) ' Processing ENDF file                 : ',FLNM
      WRITE(LER,91) ' Processing ENDF file                 : ',FLNM
      OPEN (UNIT=LEN,FILE=FLNM,STATUS='OLD')
      IFL =IFL+1
C* Header card
      READ (LEN,95) CH66,MAT,MF,MT,IS
      WRITE(LTT,95) ' '//CH66(1:65)
      WRITE(LTT,95)
      WRITE(LER,95) ' '//CH66(1:65)
      WRITE(LER,95)
      IF(MAT.GT. 0 .AND. (MF.EQ.1 .AND. MT.EQ.451)) THEN
C* Fix case when header record is missing
        READ (CH66,94,ERR=40) ZA0,AWR,IDM,IDM,IDM,IDM
        GO TO 42
      END IF
C* Merge files to a scrathc file recording MAT and ZA numbers
   40 READ (LEN,95,END=43) CH66,MAT,MF,MT,IS
   42 IF(MAT.LT. 0) GO TO 44
      WRITE(LTM,95) CH66,MAT,MF,MT
      IF(MAT.GT. 0) THEN
        IF(MA0.NE.MAT) THEN
          MA0=MAT
          READ (CH66,94) ZA0
          READ (LEN,95) CH66,MAT,MF,MT,IS
          READ (CH66,94) DMY,DMY,LIS,LIS0
          IZ0=10*NINT(ZA0)+LIS0
          WRITE(LTM,95) CH66,MAT,MF,MT
        END IF
      ELSE
        NMT=NMT+1
        IF(NMT.GT.MXMT) STOP 'MRGMAT ERROR - MXMT Limit exceeded'
        MTLS(NMT)=MA0
        IZLS(NMT)=IZ0
      END IF
      GO TO 40
C* Trap incomplete files
   43 WRITE(LTT,91) ' WARNING - Incomplete file (No MEND)  : ',FLNM
      WRITE(LER,91) ' WARNING - Incomplete file (No MEND)  : ',FLNM
C* One ENDF file processed - try next one
   44 CLOSE(UNIT=LEN)
      GO TO 20
C* All files written to temporary file
   60 KM1 =KMT
      KMT =0
      JMT =10000
      IF(IDOS.EQ.0)
     1WRITE(LOU,99) 0, 0, 0, 0
      IDOS=1
C* Find the next material to be written
      DO 62 I=1,NMT
      IF(MTLS(I).EQ.JMT) THEN
        WRITE(LTT,97) JMT,0.1*IZ0
        WRITE(LER,97) JMT,0.1*IZ0
        IF(IZLS(I).NE.IZ0) THEN
          WRITE(LTT,98) 0.1*IZLS(I)
          WRITE(LER,98) 0.1*IZLS(I)
        END IF
        MTLS(I)=-JMT
        IDU =IDU+1
        GO TO 62
      END IF
      IF(MTLS(I).GT.0 .AND. IZLS(I).EQ.IZ0) THEN
        WRITE(LTT,96) 0.1*IZ0,MTLS(I)
        WRITE(LER,96) 0.1*IZ0,MTLS(I)
        MTLS(I)=-JMT
        IDU =IDU+1
        GO TO 62
      END IF
      IF(MTLS(I).LT.  0) GO TO 62
      IF(MTLS(I).GT.JMT) GO TO 62
        KMT=I
        JMT=MTLS(I)
        IZ0=IZLS(I)
   62 CONTINUE
      IF(KMT.LE.0) GO TO 80
      IF(KMT.LT.KM1) REWIND(UNIT=LTM)
      MTLS(KMT)=-JMT
C* Copy the file to output
   70 READ (LTM,95) CH66,MAT,MF,MT,IS
      IF(MAT.NE.JMT) GO TO 70
   72 JS  =JS+1
      IF(JS.GT.99999) JS=0
      WRITE(LOU,95) CH66,MAT,MF,MT,JS
      READ (LTM,95,END=60) CH66,MAT,MF,MT,IS
      IF(MAT.GT. 0) GO TO 72
      JS  =0
      WRITE(LOU,95) CH66,MAT,MF,MT,JS
      GO TO 60
C*
   80 CH66=BLNK//BLNK(1:26)
      WRITE(LOU,95) CH66,-1, 0, 0, 0
      CLOSE(UNIT=LOU)
      WRITE(LTT,92)
      WRITE(LTT,92) ' Number of ENDF files processed       : ',IFL
      WRITE(LTT,92) ' Number of materials processed        : ',NMT
      WRITE(LTT,92) ' Number of duplicate materials skipped: ',IDU
      WRITE(LER,92)
      WRITE(LER,92) ' Number of ENDF files processed       : ',IFL
      WRITE(LER,92) ' Number of materials processed        : ',NMT
      WRITE(LER,92) ' Number of duplicate materials skipped: ',IDU
      CLOSE(UNIT=LER)
      STOP 'MRGMAT Completed'
C*
   91 FORMAT(2A40)
   92 FORMAT(A40,I5)
   93 FORMAT(A80)
   94 FORMAT(2F11.0,4I11)
   95 FORMAT(A66,I4,I2,I3,I5)
   96 FORMAT(' WARNING - Duplicate ZA',F9.1,'  MAT',I6)
   97 FORMAT(' WARNING - Duplicate MAT',I6,'  ZA',F9.1)
   98 FORMAT('           ERROR   -    Skipped ZA',F9.1)
   99 FORMAT(' MRGMAT merge ENDF files from list      '
     1      ,'                          ',I4,I2,I3,I5)
C*
      END
*deck Mtrb2 
       PROGRAM MTRB2
C-Title  : MTRB2 Program
C-Purpose: Summarize WLUP MTR-OWR Benchmark
C-Version: Original code.
C-Author : A.Trkov, Institute Jozef Stefan, Ljubljana, Slovenia (2000)
C-M
C-M  Manual for Program MTRB2
C-M  ========================
C-M  A summary of results for the WLUP MTR-OWR benchmark
C-M
C-M  The list files are those produced by analysing the WIMS-D
C-M  outputs with post-processing codes developed within the scope
C-M  of the WIMS-D Library Update Project (IAEA-CRP 1999-2000) by
C-M  Francisco Leszczynski.
C-M
C-M  Instructions:
C-M  The filenames for the output report file and the 5 list files
C-M  for the benchmarks described above are entered in response to
C-M  the prompt from the keyboard. Individual files may be omitted
C-M  from the analysis by entering "-" for the filename.
C-M
C-
      DIMENSION AVER(6),STDEV(6),EXPER(17,1),CALCUL(17,1),DCALC(17,1)
      CHARACTER*120 REC
      CHARACTER*40  BLNK,FLNM,FLNI(8),FLNO
      CHARACTER*10  NAME(17)
C* Filenames and logical file units
      DATA LIN,LOU,LKB,LTT / 1, 2, 5, 6 /
      DATA BLNK/'                                        '/
     1    ,FLNI/'MTRBURN.lis'
     2    ,     '           '
     3    ,     '           '
     4    ,     '           '
     1    ,     '           '
     1    ,     '           '
     1    ,     '           '
     1    ,     '           '/
     1    ,FLNO/'MTRBURN.LST'/
C*
      DATA NAME/' E-CYCLE 1'
     1         ,' E-CYCLE 2'
     2         ,' E-CYCLE 3'
     3         ,' E-CYCLE 4'
     4         ,' E-CYCLE 5'
     5         ,' E-CYCLE 6'
     6         ,' E-CYCLE 7'
     7         ,' E-CYCLE 8'
     8         ,' E-CYCLE 9'
     9         ,' E-CYCLE10'
     A         ,' E-CYCLE11'
     B         ,' E-CYCLE12'
     C         ,' E-CYCLE13'
     D         ,' E-CYCLE14'
     E         ,' E-CYCLE15'
     F         ,' E-CYCLE16'
     G         ,' E-CYCLE17'/
C*
C* Define input parameters - Write banner to terminal
      WRITE(LTT,693)' MTR-OWR comparison AVERAGE VALUES (W%U235)(DIFF.)'
      WRITE(LTT,693)' ================================================='
      WRITE(LTT,692)
C*
C* Define the output file
      WRITE(LTT,691) ' Default output filename              : ',FLNO
      WRITE(LTT,692) '$          Enter new name to redefine : '
      READ (LKB,692) FLNM
      IF(FLNM.NE.BLNK) FLNO=FLNM
C*
C* Define the output file
      IC=1
   11 WRITE(LTT,691) ' Default MTR Burnup Benchmark file  :   ',FLNI(IC)
      WRITE(LTT,692) '$          Enter new name to redefine : '
      READ (LKB,692) FLNM
      IF(FLNM.NE.BLNK) FLNI(IC)=FLNM
      IF(FLNM(1:1).NE.'-') THEN
        OPEN (UNIT=LIN,FILE=FLNI(IC),STATUS='OLD',ERR=11)
        CLOSE(UNIT=LIN)
      END IF
C*
      OPEN (UNIT=LOU,FILE=FLNO,STATUS='UNKNOWN')
      WRITE(LOU,693)' MTR-OWR comparison AVERAGE VALUES (W%U235)(DIFF.)'
      WRITE(LOU,693)' ================================================='
      WRITE(LOU,692)
      WRITE(LOU,691) ' Processed Benchmark analysis reports : '
      IF(FLNI(1).NE.'-')
     1WRITE(LOU,691) '                              1 case  : ',FLNI(1)
      WRITE(LOU,691)
C*
      WRITE(LOU,694) '       CYC W%U235                            '
      WRITE(LOU,694) ' ============================================'
C
C* Begin processing the MTR Benchmark
      IC=1
      OPEN (UNIT=LIN,FILE=FLNI(IC),STATUS='OLD')
      DO ILIN=1,3
       READ (LIN,692) REC
      ENDDO
      DO N=1,17
      READ (LIN,700)EXPER(N,1)
      READ (LIN,701)CALCUL(N,1),DCALC(N,1)
      ENDDO
C* Print the results for this benchmark
      DEXPE= 2.0
      DO ICASO=1,17
       WRITE(LOU,702) NAME(ICASO),EXPER(ICASO,1),DEXPE
       WRITE(LOU,702)'          ',CALCUL(ICASO,1),DCALC(ICASO,1)
       WRITE(LOU,692)
      ENDDO
      WRITE(LOU,694) ' ============================================'
      WRITE(LOU,719)' Average  '
      WRITE(LOU,719)' Dif/St.Dv'
      WRITE(LOU,718)' # '
 
C
C ACTINIDE ATOMIC DENSITIES
C
      WRITE(LOU,693)' MTR-OWR comparison Atomic Densities for Actinides'
      WRITE(LOU,693)' ================================================='
      WRITE(LOU,692)
      WRITE(LOU,691) ' Processed Benchmark analysis reports : '
      IF(FLNI(1).NE.'-')
     1WRITE(LOU,691) '                              1 case  : ',FLNI(1)
      WRITE(LOU,691)
      DO ILIN=1,2
       READ (LIN,692) REC
      ENDDO
      WRITE (LOU,692) REC
      WRITE(LOU,694) ' ============================================'
      DO ILIN=1,17
       READ(LIN,715,END=300) NAME(ICASO),EXPER(ICASO,1),DEXPE
       WRITE(LOU,717) NAME(ICASO),EXPER(ICASO,1),DEXPE
       READ(LIN,716,END=300) CALCUL(ICASO,1),DCALC(ICASO,1)
       WRITE(LOU,717)'          ',CALCUL(ICASO,1),DCALC(ICASO,1)
       WRITE(LOU,692)
      ENDDO
 300  CLOSE(UNIT=LIN)
      WRITE(LOU,694) ' ============================================'
      WRITE(LOU,719)' Average  '
      WRITE(LOU,719)' Dif/St.Dv'
C
      CLOSE(UNIT=LOU)
C* End of file processing
  80  STOP 'MTRB2 Completed'
C*
 691  FORMAT(2A40)
 692  FORMAT(A120)
 693  FORMAT(A50)
 694  FORMAT(A45)
 700  FORMAT(10X,F6.1)
 701  FORMAT(10X,2F6.1)
 702  FORMAT(A10,F6.1,'(',F4.1,')')
 715  FORMAT(A10,1X,E9.2,2X,E9.2)
 716  FORMAT(11X,E9.2,2X,E9.2)
 717  FORMAT(A10,1X,1PE9.2,'(',1PE9.2,')')
 718  FORMAT(A4)
 719  FORMAT(A10)
C
      END
*deck Mtrburn 
C
C  PROGRAM MTRBURN
C
C  AUTHOR: FRANCISCO LESZCZYNSKI-INGENIERIA NUCLEAR- 2001
C                                CENTRO ATOMICO BARILOCHE
C                                ARGENTINA
C
C  PROCESS WIMS OUTPUT FOR BENCHMARK MTR-BURN FOR ONE LIBRARY
C
C  1) READ EXPERIMENTAL VALUES OF PARAMETERS FROM MTRBURN.REF;
C
C  2) READ WIMS-D RESULTS FROM MTRBURN.OUT:
C      READ percent of U235(2235) vs.Burnup;
C
C  3) WRITE RESULTS ON MTRBURN.LST
C
C***********************************************************************
      DIMENSION IDAYS(17),IDENT(17),IPOS(17),IDD(100)
      DIMENSION PU5E(17),PU5C(17),ATDEN(17),ATDENC(17),ADD(100)
C
      CHARACTER*5 AA
      CHARACTER*6 NAME(17)
      CHARACTER*16 BB
      CHARACTER*80,TIT,REF,TIT2
      CHARACTER*120 LINE
C
C***********************************************************************
C
      I25=2235
      TIT2=''
C
C  1) READ EXPERIMENTAL VALUES OF PARAMETERS
C
      OPEN(1,FILE='MTRBURN.REF')
      read(1,1)TIT
      DO I=1,9
       read(1,1)REF
      ENDDO
C
      DO N=1,17
       READ(1,2)IDAYS(N),PU5E(N)
      ENDDO
C
      DO I=1,4
       read(1,1)REF
      ENDDO
C
      DO N=1,17
       READ(1,10)NAME(N),IDENT(N),ATDEN(N)
      ENDDO
      CLOSE(1)
C
C***********************************************************************
C  2) READ WIMS-D RESULTS
C
      OPEN(1,FILE='MTRBURN.OUT')
      OPEN(2,FILE='MTRBURN.LIS')
C
C  READ percent of U235(2235) vs.Burnup;
C
      N=0
 100  IF(N.EQ.17)GOTO 300
      READ(1,3,END=300)AA
      IF(AA.EQ.' days')THEN
       BACKSPACE(1)
       READ(1,4)IBUR
       IF(IDAYS(N+1).EQ.IBUR)THEN
        N=N+1
 200    READ(1,5,END=300)BB
        NIAN2=0
        IF(BB.EQ.' weight percents')THEN
         NIAN2=1
         READ(1,1)REF
         NIAN=0
 250     READ(1,6)IAA,ANN
         IF(IAA.EQ.I25)THEN
          PU5C(N)=ANN
          NIAN=1
         ENDIF
         IF(NIAN.EQ.0)GOTO 250
        ENDIF
        IF(NIAN2.EQ.0)GOTO 200
       ENDIF
      ENDIF
      GOTO 100
 300  CONTINUE
      N=0
      DO I=1,17
       IPOS(I)=0
      ENDDO
 301  BACKSPACE(1)
      BACKSPACE(1)
      READ(1,11)LINE
      IF(LINE(2:17).EQ.'number densities')THEN
       I1=1
       I2=10
       NLIN=0
 302   READ(1,11)LINE
       IF(LINE(1:3).EQ.'   ')THEN
        BACKSPACE(1)
        READ(1,12)(IDD(I),I=I1,I2)
        NLIN=NLIN+1
        DO II=I1,I2
         DO J=1,17
          IF(IDD(II).EQ.IDENT(J))THEN
           IPOS(J)=II
           N=N+1
          ENDIF
         ENDDO
        ENDDO
        I1=I2+1
        I2=I2+10
        GO TO 302
       ENDIF
      ENDIF
      IF(N.EQ.0)GOTO 301
      BACKSPACE(1)
      NLIN1=NLIN*10
      READ(1,13)(ADD(IJ),IJ=1,NLIN1)
      NNN=N
      DO IK=1,17
       IF(IPOS(IK).NE.0) THEN
         ATDENC(IK)=ADD(IPOS(IK))
       ELSE
         ATDENC(IK)=0.0
       ENDIF
      ENDDO
      CLOSE(1)
C
C***********************************************************************
C  3) WRITE RESULTS
C
      write(2,1)TIT
      WRITE(2,1)
      write(2,9)
C
      DO N=1,17
       WRITE(2,7)N,PU5E(N)
       DIFP=PU5C(N)-PU5E(N)
       WRITE(2,8)PU5C(N),DIFP
      ENDDO
C
      WRITE(2,1)
      WRITE(2,14)
      DIFN=0.0
      DO N=1,17
       WRITE(2,15)NAME(N),ATDEN(N),DIFN
       IF(IPOS(N).NE.0)THEN
        DIFE=ATDENC(N)-ATDEN(N)
       ELSE
        DIFE=0.0
       ENDIF
       WRITE(2,16)ATDENC(N),DIFE
      ENDDO
C
      CLOSE(2)
C
  1   FORMAT(A80)
  2   FORMAT(25X,I5,7X,F5.1)
  3   FORMAT(13X,A5)
  4   FORMAT(3X,I6)
  5   FORMAT(A16)
  6   FORMAT(I6,E12.5)
  7   FORMAT(' EXP  ',I4,F6.1)
  8   FORMAT(10X,2F6.1)
  9   FORMAT(5X,'Cycle %U235 DIFF.')
 10   FORMAT(A6,1X,I5,2X,E9.2)
 11   FORMAT(A120)
 12   FORMAT(I8,9I12)
 13   FORMAT(10E12.5)
 14   FORMAT('NAME       AT.DENS.(EOCycle17) CALC.-REF.')
 15   FORMAT(A6,5X,1PE9.2,2X,F9.2)
 16   FORMAT(11X,1PE9.2,2X,1PE9.2)
C
      STOP 'Mtrburn Completed'
      END
*deck njbfp 
      PROGRAM NJBFP
C-Tile: Program NJBFP
C-T
C-Purpose: Prepare NJOY fission product yields
C-P
C-Usage: NJBFP
C-U
C-U   Input filenames:
C-U    Input files
C-U        1. List file for the explicitly represented F. Ps
C-U        2. List File for all the F. Ps.
C-U        3. Evaluated nuclear data library Summary File
C-U           (GETDATA output file *.MF2)
C-U        4. *.NJB file for the explicitly represented F. Ps.
C-U           (AVRFPY output)
C-U        5. *.NJB file for all F. Ps.
C-U           (AVRFPY output)
C-U
C-U    Output Files
C-U        1. *.NJB file with the fission yields needed for NJOY input.
C-U
C-Description:
C-D   The code reads the input files and checks them for consistency.
C-D   Afterwards the pseudo fission product yield is calculated and
C-D   included on the output file (*.NJB) as required by the WIMSR
C-D   module of NJOY.
C-D     The yield of Pm-147 is split into two separate products, the
C-D   first being the precursor of Pm-188g (fraction X4147 defined in
C-D   the parameter statement) and the second the precursor of Pm-148m.
C-D
C-Author: D. L. Aldama
C-A
C-Version: 03/1999
C-V        04/2001  No. of explicit f.p. NFPE increased from 50 to 80
C-V
       PARAMETER(LTT=6,LKB=5,LLE=1,LLL=2,LIB=3,LNB=4,LNJ=7)
       PARAMETER(NFPE=80,NFP=150,NMAT=1024,N4902=4902)
C*       X4147=0.4667, ref EAF99, rounded to 0.47
       PARAMETER(N4147=4147, X4147=0.47,N5147=5147)
       CHARACTER*80 LINE
       CHARACTER*40 FLNM,FLE,FLL,BLNK,FLIB,FNAME
       CHARACTER*11 ZASYM(NMAT)
       DIMENSION AZE(NFPE),RIDE(NFPE),YE(NFPE)
       DIMENSION AZ(NFP),RID(NFP),Y(NFP)
       DIMENSION IPYP(NFP)
       DIMENSION AZL(NMAT)
       DATA BLNK/'                                        '/
       DATA FLE/'FpLstExp.dat'/
       DATA FLL/'FpLstAll.dat'/
       DATA FLIB/'ENDF.MF2'/
       WRITE(LTT,15) '     NJBFP - Prepare NJOY F.P. Yields   '
       WRITE(LTT,15) '     =================================  '
       WRITE(LTT,15)
C*
C*       Reading input files
       FLNM=BLNK
    1  WRITE(LTT,15) '     Define list file for explicit F.P: '
       WRITE(LTT,15) '     ---------------------------------  '
       WRITE(LTT,15) '                     Default file name: ',FLE
       WRITE(LTT,15) '$       Enter new name (enter=default): '
       READ (LKB,15) FLNM
       IF(FLNM.NE.BLNK) FLE=FLNM
       OPEN (UNIT=LLE,FILE=FLE,STATUS='OLD',ERR=1)
       I=1
       READ(LLE,20) LINE
       READ(LLE,20) LINE
       DO WHILE (LINE(1:8).NE.'        ')
         READ(LINE,30) AZE(I), RIDE(I)
         IF (RIDE(I).LE.0.0) RIDE(I)=AZE(I)
         I=I+1
         READ(LLE,20,END=2) LINE
         IF(I.GT.NFPE) THEN
           STOP ' Fatal error: More than 80 explicitly represented F.Ps'
         ENDIF
       END DO
    2  CLOSE(LLE)
       KFPE=I-1
       FLNM=BLNK
    3  WRITE(LTT,15) '     Define list file for   ALL    F.P: '
       WRITE(LTT,15) '     ---------------------------------  '
       WRITE(LTT,15) '                     Default file name: ',FLL
       WRITE(LTT,15) '$       Enter new name (enter=default): '
       READ (LKB,15) FLNM
       IF(FLNM.NE.BLNK) FLL=FLNM
       OPEN (UNIT=LLL,FILE=FLL,STATUS='OLD',ERR=3)
       I=1
       READ(LLL,20) LINE
       READ(LLL,20) LINE
       DO WHILE (LINE(1:8).NE.'        ')
         READ(LINE,30) AZ(I), RID(I)
         IF (RID(I).LE.0.0) RID(I)=AZ(I)
         I=I+1
         READ(LLL,20,END=4) LINE
         IF(I.GT.NFP) THEN
           STOP ' Fatal error: More than 150 F.Ps'
         ENDIF
       END DO
    4  CLOSE(LLL)
       KFP=I-1
       KPDO=KFP-KFPE
       IF (KPDO.LE.0) THEN
         STOP ' Fatal Error:  KFP-all  .LE.  KFP-explicit '
       ENDIF
       FLNM=BLNK
    5  WRITE(LTT,15) '      Define ENDF Library Summary file: '
       WRITE(LTT,15) '     ---------------------------------  '
       WRITE(LTT,15) '                     Default file name: ',FLIB
       WRITE(LTT,15) '$       Enter new name (enter=default): '
       READ (LKB,15) FLNM
       IF(FLNM.NE.BLNK) FLIB=FLNM
       OPEN (UNIT=LIB,FILE=FLIB,STATUS='OLD',ERR=5)
       I=1
       READ(LIB,20) LINE
       READ(LIB,20) LINE
       DO WHILE (LINE(1:8).NE.'        ')
         READ(LINE,40) NNN,ZASYM(I),AZL(I)
         I=I+1
         READ(LIB,20,END=6) LINE
         IF(I.GT.NMAT) THEN
           STOP ' Fatal error: More than 1024 ENDF materials'
         ENDIF
       END DO
    6  KMAT=I-1
       CLOSE(LIB)
C*
C*       Process *.njb files
       DO IT=1,2
        FLNM=BLNK
        IF (IT.EQ.1) THEN
         NNN=KFPE
         WRITE(LTT,15) ' Define fiss. yields for explicit F.Ps  '
        ELSE
         NNN=KFP
         WRITE(LTT,15) '     Define fiss. yields for all F.Ps   '
        ENDIF
    8   WRITE(LTT,15) '     Define the yield (*.NJB) file for: '
        WRITE(LTT,17) '              Number of F.P. should be: ',NNN
        WRITE(LTT,15) '     ---------------------------------  '
        WRITE(LTT,15) '                     Default file name: ',FLNM
        WRITE(LTT,15) '$       Enter new name (enter=default): '
        READ (LKB,15) FLNM
        IF(FLNM.EQ.BLNK) GO TO 8
        OPEN (UNIT=LNB,FILE=FLNM,STATUS='OLD',ERR=8)
        DO I=1,NNN
          IF (IT.EQ.1) THEN
            YE(I)=0.0
          ELSE
            Y(I)=0.0
          ENDIF
        END DO
        READ(LNB,60)KKK
        KKK=KKK-4
        DO KK=1,KKK
          READ(LNB,60)IDUMMY,FPY
          KTRI=-1
          DO I=1,NNN
            IF(IT.EQ.1) THEN
              IF ((NINT(RIDE(I)).EQ.IDUMMY)) THEN
                YE(I)=FPY
                KTRI=1
              ENDIF
            ELSE IF (IT.EQ.2) THEN
              IF ((NINT(RID(I)).EQ.IDUMMY)) THEN
                 Y(I)=FPY
                 KTRI=1
              ENDIF
            ENDIF
          END DO
          IF(KTRI.LT.0) THEN
            WRITE(LTT,*)' Error: Lst & Yields files are not compatible'
     &                  , ' IT= ', IT, ' I= ', I
            STOP
          END IF
        END DO
        CLOSE(LNB)
       END DO
       DO I=1,KFP
        IF (Y(I).LT.0.0) IPYP(I)=-3
       END DO
C*
C*       Checking if NFP and NFPE yields are compatible.
C*       Selecting isotopes for pseudo fission
       YESUM=0.0
       DO I=1,KFP
         IAZ=NINT(RID(I))
         II=-1
         K=1
         DO WHILE (II.LT.0)
          KAZ=NINT(RIDE(K))
          IF (IAZ.NE.KAZ) THEN
            K=K+1
          ELSE
            II=1
            RID(I)=RIDE(K)
            IPYP(I)=-1
            YESUM=YESUM+YE(K)
            IF (YE(K) .EQ. 0.0) THEN
              IF (Y(I). EQ. 0.0) THEN
                DIF=0.0
              ELSE
                DIF=1.0
              ENDIF
            ELSE
              DIF=ABS(Y(I)/YE(K)-1.0)
            ENDIF
            IF (DIF.GT.1.0E-6) THEN
              WRITE(LTT,90)' Warning: Fission yields do not match ',
     &                       IAZ,Y(I),YE(K),' : check FP list files'
            ENDIF
          ENDIF
          IF (K.GT.KFPE) II=2
         END DO
       END DO
C*
C*       Open OUTPUT file
C*
C*        NJOY
       FLNM=BLNK
    9  WRITE(LTT,15) '     Define NJOY burnup data block file:'
       WRITE(LTT,15) '     ---------------------------------- '
       WRITE(LTT,15) '                     Default file name: ',FNAME
       WRITE(LTT,15) '$       Enter new name (enter=default): '
       READ (LKB,15) FLNM
       IF(FLNM.NE.BLNK) FNAME=FLNM
       OPEN (UNIT=LNJ,FILE=FNAME,ERR=9)
C*
C*      Check if the fission products are on the library
C*      and calculate the yield of the pseudo fission product
       YPSUM=0.0
       DO J=1,KFP
       IF(IPYP(J).GE.0) THEN
        JAZ=NINT(10.0*AZ(J))
        I=1
        II=-1
        DO WHILE (II.LT.0)
          IF (ZASYM(I)(11:11).EQ.'M'.OR.ZASYM(I)(11:11).EQ.'m') THEN
            IAZ=NINT(10.0*AZL(I))+1
          ELSE
            IAZ=NINT(10.0*AZL(I))
          ENDIF
          IF (JAZ.EQ.IAZ) THEN
            II=1
            YPSUM=YPSUM+Y(J)
          ELSE
            I=I+1
          ENDIF
          IF (I.GT.KMAT) II=2
        END DO
        IF (II.EQ.2) THEN
          WRITE(LTT,*)' Warning: F.P with ZA= ',AZ(J),
     &                ' not found on the library file'
        ENDIF
       ENDIF
       END DO
C*
       DO I=1,KFPE
         IF (RIDE(I).EQ.N4147) THEN
           WRITE(LNJ,70)N4147,X4147*YE(I)
           WRITE(LNJ,70)N5147,(1.0-X4147)*YE(I)
         ELSE
           WRITE(LNJ,70)IFIX(RIDE(I)+0.01),YE(I)
         ENDIF
       END DO
       WRITE(LNJ,70)N4902,YPSUM
       YTOT=YESUM+YPSUM
       WRITE(LTT,* )
       WRITE(LTT,* )'***************************************'
       WRITE(LTT,75)'    Actinide file : ',FNAME
       WRITE(LTT,80)' TOTAL F.Ps YIELD : ',YTOT
       WRITE(LTT,80)'    EXPLICIT F.Ps : ',YESUM
       WRITE(LTT,80)'       PSEUDO F.P : ',YPSUM
       WRITE(LTT,* )'***************************************'
       WRITE(LTT,*)
       CLOSE(LNJ)
       STOP 'NORMAL END'
   15  FORMAT(2A40)
   16  FORMAT(A40,A11)
   17  FORMAT(A40,I5)
   20  FORMAT(A80)
   30  FORMAT(2F11.0)
   40  FORMAT(I4,2X,A11,F9.0,F12.0,F12.0,1PE13.0)
   50  FORMAT(A28,F8.1,A30)
   60  FORMAT(I6,E11.0)
   70  FORMAT(I6,1PE11.4)
   75  FORMAT(A20,A40)
   80  FORMAT(A20,1PE11.5)
   90  FORMAT(A38,I8,1x,1P2E11.4)
      END
*deck njinjb 
      PROGRAM NJINJB
C-Title  : NJINJB Program
C-Purpose: Edit the F.P. yields data in NJOY input
C-Author : A.Trkov, Institute Jozef Stefan, Ljubljana, Slovenia
C-Version: October 1999
C-V  01/12 A.Trkov: Fix bug when MAT ID missing from the list
C-M
C-M  Manual for Program NJINJB
C-M  =========================
C-M
C-M  The program searches the NJOY input for the WIMSR module
C-M  input instructions. If burnup data are present, if they
C-M  refer to a fissile material and if new yields for this
C-M  material are available, the yields are replaced.
C-M
C-M  The program reads the energy released per fission and the
C-M  capture and decay data, from the original NJOY input file.
C-M  It then adds all new fission product yield data. Finally,
C-M  any nuclide on the original NJOY input that is not yet
C-M  present on the list is appended. Care is taken that the
C-M  total number of nuclides on the list is corrected as
C-M  necessary.
C-M
C-M  Instructions
C-M  ------------
C-M  The input directives can be entered from keyboard in
C-M  response to the prompts on the terminal screen. The requested
C-M  input parameters are the following:
C-M    FLLS  - WIMS-D material ident to ZA designation conversion
C-M            table filename (see format description below).
C-M    FLNJ  - Source NJOY input filename.
C-M    FLNO  - Updated NJOY input filename.
C-M
C-M  It is implicitly assumed that the fission product yields
C-M  data for the fissile actinides are available on files with
C-M  filenames of the form:
C-M    "zzaaa???.njb"
C-M  where "zzaaa" is the ZA designation of the fissile nuclide.
C-M  Usually these files are produced in a batch procedure of WLUP.
C-M  The first record in the file contains the number of fission
C-M  products, which are given on the records that follow. Each
C-M  record contains a pair of numbers, giving the WIMS-D isotope
C-M  identification number and the corresponding yield. Free format
C-M  may be used.
C-M
C-M  FLLS File Format Specifications
C-M  -------------------------------
C-M  The first record is interpreted as comment and is ignored.
C-M  The following records contain pairs of numbers:
C-M    ZA    material za designation, 1000*Z + A
C-M          where Z is the atomic number and A is the mass number.
C-M    WMT   WIMS-D material identifier.
C-M  Pairs of numbers are read until a blank line or an end-of-file
C-M  is encountered.
C-
      PARAMETER    (MXMT=200)
C*
      CHARACTER*80  REC
      CHARACTER*40  BLNK,FLNM,FLNJ,FLNO,FLLS,FLLG
      CHARACTER*6   FNAME
      DIMENSION     ZA(MXMT),WMT(MXMT),FPID(MXMT),FPYL(MXMT)
C*
      DATA BLNK/'                                        '/
     1     FLNJ/'ENDFB6.NJI'/
     2     FLNO/'WLUP.NJI'/
     3     FLLS/'ACTLST.DAT'/
     4     FLLG/'NJINJB.LST'/
      DATA LNI,LNO,LLS,LBI,LKB,LTT,LLG / 1, 2, 3, 4, 5, 6, 7 /
C*
      WRITE(LTT,991) ' NJINJB - Edit F.P.Yields in NJOY input '
      WRITE(LTT,991) ' ====================================== '
      WRITE(LTT,991)
C*
C* Define the material ZA to WIMS-D ident conversion table file
   40 WRITE(LTT,991) '$Enter MAT ID to ZA table filename    : '
      READ (LKB,991) FLNM
      IF(FLNM.NE.BLNK) FLLS=FLNM
      OPEN (UNIT=LLS,FILE=FLLS,STATUS='OLD',ERR=40)
      READ (LLS,801) REC
      NAC=0
      NFY=0
      MFY=0
   42 READ (LLS,801,END=44) REC
      IF(REC(1:22).EQ.'                      ') GO TO 44
      NAC=NAC+1
      IF(NAC.GT.MXMT) STOP 'NJINJB ERROR - MXMT limit exceeded'
      READ (REC, * ) ZA(NAC),WMT(NAC)
      GO TO 42
   44 CLOSE(UNIT=LLS)
      IF(NAC.LE.0) STOP 'NJINJB ERROR - WIMS-D MAT table empty'
C*
C* Define the source NJOY input file to be edited
   60 WRITE(LTT,991) '$Enter the source NJOY input filename : '
      READ (LKB,991) FLNM
      IF(FLNM.NE.BLNK) FLNJ=FLNM
      OPEN (UNIT=LNI,FILE=FLNJ,STATUS='OLD',ERR=60)
C*
C* Define the updated NJOY input filename
   80 WRITE(LTT,991) '$Enter the updated NJOY input filename: '
      READ (LKB,991) FLNM
      IF(FLNM.NE.BLNK) FLNO=FLNM
      OPEN (UNIT=LNO,FILE=FLNO,STATUS='UNKNOWN',ERR=80)
C* Define the log file
      OPEN (UNIT=LLG,FILE=FLLG,STATUS='UNKNOWN')
      WRITE(LLG,991) ' NJINJB - Edit F.P.Yields in NJOY input '
      WRITE(LLG,991) ' ====================================== '
      WRITE(LLG,991)
      WRITE(LLG,991) ' Material ID / ZA table file          : ',FLLS
      WRITE(LLG,991) ' Source  NJOY input file              : ',FLNJ
      WRITE(LLG,991) ' Updated NJOY input file              : ',FLNO
      WRITE(LLG,991)
C*
C* Copy records in the NJOY input file
  200 READ (LNI,801,END=600) REC
      IF (REC(1:2).EQ.'--' .AND. REC(4:9).NE.'      ') THEN
        FNAME=REC(4:9)
        WRITE(LTT,*) ' Processing material deck: ',FNAME
      ENDIF
      WRITE(LNO,801) REC
C* Identify the beginning of WIMSR input
      IF(REC(1:5).NE.'wimsr') GO TO 200
C* Copy next 4 records
      READ (LNI,801) REC
      WRITE(LNO,801) REC
      READ (LNI,801) REC
      WRITE(LNO,801) REC
      READ (LNI,801) REC
      WRITE(LNO,801) REC
      READ (LNI,801) REC
      WRITE(LNO,801) REC
C* Interpret the 4-th WIMSR input record with MAT ident and burnup flag
      READ (REC, * ) MAT,DMY,RMT,JBU
      IF(JBU.NE.1) GO TO 200
C* Copy next record as is
      READ (LNI,801) REC
      WRITE(LNO,801) REC
C* Check if fissile material data exist
      READ (LNI,801) REC
      READ (REC, * ) KFPR,EFIS
      IF(KFPR.LE.2 .AND. EFIS.LE.0) THEN
        WRITE(LNO,801) REC
        GO TO 200
      END IF
C* Check if new yields for this isotope exist
      MFY=MFY+1
      DO 220 I=1,NAC
      JAC=I
      IF(ABS(RMT-WMT(I)).LT.0.01) GO TO 240
  220 CONTINUE
      IRMT=RMT+0.01
      WRITE(LTT, * ) ' WARNING - Fissile material ident not found',IRMT
      WRITE(LLG, * ) ' WARNING - Fissile material ident not found',IRMT
      WRITE(LLG, * ) ' Valid list:'
      WRITE(LLG, * ) (NINT(WMT(J)),J=1,NAC)
      WRITE(LNO,801) REC
      GO TO 200
C* Construct the default yields filename for this isotope
  240 WRITE(FLNM,890) NINT(ZA(JAC)),FNAME(6:6)
      OPEN (UNIT=LBI,FILE=FLNM,STATUS='OLD',ERR=242)
      GO TO 244
C*
  242 WRITE(LTT, * ) ' WARNING - F.P. yields file missing : ',FLNM
      WRITE(LLG, * ) ' WARNING - F.P. yields file missing : ',FLNM
      WRITE(LNO,801) REC
      GO TO 200
C*
  244 WRITE(LTT, * ) ' Processing ZA MAT ID',ZA(JAC),MAT,NINT(RMT)
      WRITE(LLG, * ) ' Processing ZA MAT ID',ZA(JAC),MAT,NINT(RMT)
      NFY=NFY+1
C*
C* Read in the new fission product yields
      LFPR=2
  250 READ (LBI,801,END=260) REC
      IF(REC(1:20).EQ.'                    ') GO TO 260
      LFPR=LFPR+1
      IF(LFPR.GT.MXMT) STOP 'NJINJB ERROR - MXMT limit exceeded'
      READ (REC, * ,ERR=252) FPID(LFPR),FPYL(LFPR)
      GO TO 250
  252 STOP 'NJINJB ERROR - Reading NJB file'
  260 WRITE(LTT, * ) '         No.of F.P',LFPR
      CLOSE(UNIT=LBI)
C*
C* Begin replacement the burnup data
C* Read the capture and decay products
      READ (LNI, * ) FPID(1),FPYL(1)
      READ (LNI, * ) FPID(2),FPYL(2)
C* Check the remaining nuclides from the original input
      DO 340 I=3,KFPR
      READ (LNI, * ) FPJ,YLJ
      DO 330 J=1,LFPR
      IF(ABS(FPJ-FPID(J)).LT.0.01) GO TO 340
  330 CONTINUE
C* Add the nuclide to the list
      LFPR=LFPR+1
      FPID(LFPR)=FPJ
      FPYL(LFPR)=YLJ
  340 CONTINUE
C* Write updated data to the new NJOY input file
      WRITE(LNO,802) LFPR,EFIS
      DO 360 I=1,LFPR
      WRITE(LNO,802) NINT(FPID(I)),FPYL(I)
  360 CONTINUE
      GO TO 200
C*
  600 WRITE(LTT,992) NFY,MFY
      WRITE(LLG,992) NFY,MFY
      STOP 'NJINJB Completed'
C*
  801 FORMAT(A80)
  802 FORMAT(I6,1P,E11.4)
  890 FORMAT(I5,A1,'I.NJB')
  991 FORMAT(2A40)
  992 FORMAT(' F.P. yields changed for ',I3,' out of',I3,' materials')
      END
*deck njispl 
      PROGRAM NJISPL
C-Title  : NJISPL Program
C-Purpose: Split Merged NJOY input into separate files
C-Author : A.Trkov, Institute J.Stefan, Ljubljana, Slovenia (1998).
C-M
C-M  Manual for Program NJISPL
C-M  =========================
C-M
C-M  For the convenience of maintaining a set of NJOY97 input files,
C-M  all files are copied onto a single file named 'wlupnji.inp'.
C-M  Separate Njoy input files are delimited with a record beginning
C-M  with the string:
C-M    "-- name  "
C-M  where 'name' is the separate NJOY input generic filename to
C-M  which the extension '.nji' is appended. This is consistent
C-M  with the NJOY-97.45+ input convention which interprets such
C-M  records as comments.
C-M
C-M  Instructions:
C-M  The following input is expected from keyboard:
C-M  - Master NJOY input filename (default: wlupnji.inp).
C-M  - Specific NJOY input file fo be extracted (default: blank to
C-M    process all files).
C-M
C-M  Note: The specific NJOY input generic filenames must be
C-M        typed exactly. The list can be extracted from the
C-M        master input with a system search utility,
C-M        displaying all records beginning with "-- ".
C-M        For example:
C-M          find   "-- " wlupnji.inp >wlupnji.lst      (Dos)
C-M          grep   "-- " wlupnji.inp >wlupnji.lst      (Unix)
C-M          search wlupnji.inp "-- " /out=wlupnji.lst  (Vax/VMS)
C-M
C-
      CHARACTER*6    FM
      CHARACTER*80   REC
      CHARACTER*40   BLNK,FLNM,FLAL,FLNJ
 
      DATA LIN,LNJ,LKB,LTT
     1    /  1,  2,  5,  6 /
      DATA BLNK/'                                        '/
     1     FLAL/'wlupnji.inp'/
C*
C*
      WRITE(LTT,92) ' NJISPL - Split Merged NJOY Input File  '
      WRITE(LTT,92) ' =====================================  '
      WRITE(LTT,92)
      WRITE(LTT,92) ' Default Master NJOY input file       : ',FLAL
      WRITE(LTT,92) '$         Enter a new name to redefine: '
      READ (LKB,92) FLNM
      IF(FLNM.NE.BLNK) FLAL=FLNM
      WRITE(LTT,92) ' Enter NJOY input filename to extract   '
      WRITE(LTT,92) '$              (Blank to extract all) : '
      READ (LKB,92) FLNM
C*
      OPEN (UNIT=LIN,FILE=FLAL,STATUS='OLD',ERR=82)
      WRITE(LTT,92)
      WRITE(LTT,92) ' Opened merged NJOY input file        : ',FLAL
      NFL=0
C*
C* Read a record from the main input file
 20   READ (LIN,98,END=60) REC
      IF(REC(1:3).EQ.'-- ') THEN
C* Skip comment lines beginning with blanks
        IF(REC(4:9).EQ.'      ') GO TO 20
C* Begin a new Njoy input file
        LN=4
 22     LN=LN+1
        IF(REC(LN:LN).NE.' ') GO TO 22
        FLNJ=REC(4:LN-1)//'.nji'
        IF(LNJ.GT.0) CLOSE(UNIT=LNJ)
        IF(FLNM.NE.BLNK .AND. REC(4:LN).NE.FLNM(1:LN-3)) THEN
          LNJ=-ABS(LNJ)
          GO TO 20
        ELSE
          LNJ =ABS(LNJ)
        END IF
        OPEN (UNIT=LNJ,FILE=FLNJ,STATUS='UNKNOWN')
        WRITE(LTT,92) '                         Writing file : ',FLNJ
        NFL=NFL+1
        WRITE(LNJ,98) REC
      ELSE
C* Check if an output file is open
        IF(LNJ.LT.0) GO TO 20
C* Determine the record length
        LN=80
 24     IF(REC(LN:LN).NE.' ') GO TO 26
        LN=LN-1
        IF(LN.GT.1) GO TO 24
C* Write a record to the NJOY input file
 26     WRITE(FM ,99) LN
        WRITE(LNJ,FM) REC(1:LN)
      END IF
C* Process the next record from the main input file
      GO TO 20
C*
C* All files written
 60   IF(LNJ.GT.0) THEN
        CLOSE(UNIT=LNJ)
C*     WRITE(LTT,92) '                         Written file : ',FLNJ
      END IF
      WRITE(LTT,92)
      WRITE(LTT,93) '        Total number of files written : ',NFL
      STOP 'NJISPL Completed'
C*
C* Error trap
 82   WRITE(LTT,92) ' NJISPL ERROR - No Merged NJOY input  : ',FLAL
C*
 92   FORMAT(2A40)
 93   FORMAT(A40,I4)
 98   FORMAT(A80)
 99   FORMAT('(A',I3.3,')')
      END
*deck njrrat 
      PROGRAM NJRRAT
C-Title  : NJRRAT Program
C-Purpose: Calculate Reaction Rate Ratios from NJOY Output
C-Author : A.Trkov, Institute Jozef Stefan, Ljubljana, Slovenia (1998)
C-Version:
C-V  00/04 Implement search for isotope production.
C-V  00/08 Fix minor bugs (A.Trkov).
C-V  01/04 Increase max.No. of groups (A.Trkov)
C-M
C-M  Manual for Program NJRRAT
C-M  =========================
C-M
C-M  The GROUPR printout from the NJOY output is processed. The
C-M  flux values are read from MF 3, MT 1. The group constants for
C-M  the specified reactions are read. The total reaction rate is
C-M  calculated and the ratio printed.
C-M
C-M  Instructions
C-M  ------------
C-M  The following are read from the keyboard:
C-M  - NJOY output filename to be processed
C-M  - Numerator MT number
C-M  - Denominator MT number
C-M
C-M  To allow calculation of isotope production ratios, instead
C-M  of the MT number the reaction string as it appears on the
C-M  NJOY output may be specified
C-M
C-M  Example: "(n,g) 61148m1 production"
C-M
C-M  The calculated reaction rate ratio is printed to the terminal
C-M  screen and to the NJRRAT.LOG file.
C-
      CHARACTER*40  SRCH,FLNI,FLNO,MTX(2)
      CHARACTER*132 REC
      PARAMETER    (MXG=1000)
      DIMENSION     FLX(MXG),XSR(MXG,2),FF(10),MTN(2),SS(2)
C*
      DATA LIN,LOU,LKB,LTT/ 1, 2, 5, 6 /
      DATA FLNI/'AM1.OUT'/
     1     FLNO/'NJRRAT.LOG'/
C*
      DO 2 I=1,2
      DO 2 J=1,MXG
      XSR(J,I)=0.
      FLX(J)  =0.
    2 CONTINUE
C*
      WRITE(LTT,91) ' NJRRAT - Calculate Reaction Rate Ratios'
      WRITE(LTT,91) ' ======================================='
      WRITE(LTT,91)
   12 WRITE(LTT,91) ' Enter NJOY Outputfile to be processed: '
      READ (LKB,91) FLNI
      OPEN (UNIT=LIN,FILE=FLNI,STATUS='OLD',ERR=12)
C*
      MTN(1)=0
      WRITE(LTT,91) '          Enter Numerator   MT number : '
      READ (LKB,91) MTX(1)
      READ(MTX(1),93,ERR=14) MTN(1)
      WRITE(MTX(1),'('' for mf  3 and mt'',I3)') MTN(1)
   14 MTN(2)=0
      WRITE(LTT,91) '          Enter Denominator MT number : '
      READ (LKB,91) MTX(2)
      READ(MTX(2),93,ERR=15) MTN(2)
      WRITE(MTX(2),'('' for mf  3 and mt'',I3)') MTN(2)
C*
C* Define the first cross section
   15 IS1=1
      IS2=2
      IF(MTN(1).GE.1. AND. MTN(2).GE.1) THEN
        IF(MTN(1).GT.MTN(2)) THEN
          SRCH  =MTX(1)
          MTX(1)=MTX(2)
          MTX(2)=SRCH
          MT    =MTN(1)
          MTN(1)=MTN(2)
          MTN(2)=MT
          IS1=2
          IS2=1
        END IF
      END IF
C*
      OPEN (UNIT=LOU,FILE=FLNO,STATUS='UNKNOWN')
      WRITE(LOU,91) ' NJRRAT - Calculate Reaction Rate Ratios'
      WRITE(LOU,91) ' ======================================='
      WRITE(LOU,91)
      WRITE(LOU,91) ' NJOY Output file processed           : ',FLNI
      WRITE(LOU,91)
C* Clear the array
      DO 18 I=1,MXG
      XSR(I,1)=0.
      XSR(I,2)=0.
   18 CONTINUE
C*
C* Find the GROUPR output
   20 READ (LIN,92,END=60) REC
      IF(REC(1:10).NE.' groupr...') go to 20
C* Read the flux values from the total cross section
   22 READ (LIN,92,END=60) REC
      IF(REC(1:20).NE.' for mf  3 and mt  1') go to 22
      READ (LIN,92,END=82)
      READ (LIN,92,END=82)
      READ (LIN,92,END=82) REC
      READ (LIN,92,END=82)
      REC(14:24)='  999999999'
C* Determine the number of Sigma-zero values
      READ(REC,95) (FF(J),J=1,10)
      NS=11
   26 NS=NS-1
      IF(FF(NS).LE.0) GO TO 26
      IF(NS.GT.1) THEN
        WRITE(LTT,97) ' Number of Sigma-0 values is          : ',NS
        DO 28 J=1,NS
          WRITE(LTT,99) J,NINT(FF(J))
   28   CONTINUE
        WRITE(LTT,91) ' By default the last value is chosen    '
        WRITE(LTT,91) '             Choose index to redefine : '
        READ (LKB,93) IDM
        IF(IDM.GT.0 .AND.IDM.LT.NS) NS=IDM
      END IF
 
      NG=0
   29 READ (LIN,92,END=60) REC
      IF(REC(1:10).EQ.'          ') GO TO 30
      READ (REC,94,ERR=82) JG,LG
      IF(JG.GT.MXG) STOP 'NJRRAT ERROR - MXG Limit exceeded'
      READ (LIN,92,END=60) REC
      READ (REC,95,ERR=82) FF
C* Take the value of the last (or selected) Sigma-zero
      IF(LG.EQ.0) THEN
        IF(JG.NE.NG+1) THEN
C...      STOP 'NJRRAT ERROR - Incorrect group sequence'
          WRITE(LTT,97) ' NJRRAT WARNING - Bad sequence at group ',JG
        END IF
        FLX(JG)=FF(NS)
        NG=JG
      END IF
      GO TO 29
C*
   30 IX=0
   32 IX=IX+1
      JS=1
      IF(MTN(IX).EQ.2 .OR. MTN(IX).EQ.18 .OR. MTN(IX).EQ.102) JS=NS
C* Read the self-shielded cross sections
   40 READ (LIN,92,END=60) REC
      IF(MTN(IX).GE.1) THEN
        IF(REC( 1:20).NE.MTX(IX)( 1:20)) GO TO 40
      ELSE
        IF(REC(22:35).NE.MTX(IX)( 1:14)) GO TO 40
      END IF
      READ (LIN,92,END=82)
      READ (LIN,92,END=82)
      READ (LIN,92,END=82)
      READ (LIN,92,END=82)
 
   42 READ (LIN,92,END=82) REC
      IF(REC(1:20).EQ.'                    ') GO TO 44
      READ (REC,96,ERR=82) JG,(FF(J),J=1,JS)
      XSR(JG,IX)=FF(JS)
      IF(JG.LT.NG) GO TO 42
   44 IF(IX.LT. 2) GO TO 32
C*
   60 IF(NG.LT.1) GO TO 86
      S1=0.
      S2=0.
      DO 62 IG=1,NG
      SS(1)=SS(1)+FLX(IG)*XSR(IG,1)
      SS(2)=SS(2)+FLX(IG)*XSR(IG,2)
   62 CONTINUE
      IF(SS(1).LE.0 .OR. SS(2).LE.0) GO TO 84
      RAT=SS(IS1)/SS(IS2)
      WRITE(LTT,98) MTX(IS1),MTX(IS2),RAT
      WRITE(LOU,98) MTX(IS1),MTX(IS2),RAT
      STOP 'NJRRAT Completed'
c*
   82 STOP 'NJRRAT ERROR - Reading NJOY output file'
   84 STOP 'NJRRAT ERROR - Zero reaction rate'
   86 STOP 'NJRRAT ERROR - No data found'
C*
   91 FORMAT(2A40)
   92 FORMAT(A132)
   93 FORMAT(BN,I10)
   94 FORMAT(I4,I7)
   95 FORMAT(13X,10F11.0)
   96 FORMAT(I4,2X,10F11.0)
   97 FORMAT(A40,I6)
   98 FORMAT(1X,A20,' / ',A20,' Ratio =',G14.4)
   99 FORMAT(I6,I12)
      END
*deck pintcr 
C     Program for calculation of temperature coefficient
C     Authors : L.ERRADI, A.HTET, E.CHAKIR
      PROGRAM TEMPERATURE
       CAll ENTETETCR
       CAll EBTCR
       CALL NORA
       CALL KRITZ1
       CALL KRITZ21
       CALL KRITZ213
       CALL KRITZ219
       CALL R1100H
       CALL VVER1
       CALL VVER2
       CALL VVER3
       CALL VVER4
      END
C *********************************************************
      SUBROUTINE ENTETETCR
C *********************************************************
      OPEN(UNIT=5,file='ENTETETCR.RES',STATUS='UNKNOWN')
      WRITE(5,1000)
1000  FORMAT (20x,44(1H*)/
     1 20x, '*       WIMS LIBRARY UPDATE PROJECT        *'/
     2 20x, '*          LIBRARIES VALIDATION            *'/
     2 20x, '*      FOR THE REACTIVITY TEMPERATURE      *'/
     2 20X, '*          COEFFICIENT (RTC)               *'/
     3 20x,44(1H*)///
     4 15x,54(1H*)/
     5 15x,'*           L.ERRADI, A.HTET AND E.CHAKIR',12x,1(1H*)/
     6 15x,'*      GROUPE DE PHYSIQUE DES REACTEURS NUCLEAIRES',3x,1H*/
     7 15x,'*           FACULTE DES SCIENCES -  RABAT',12x,1(1H*)/
     8 15x,'*                      MOROCCO',23x,1(1H*)/
     9 15x,54(1H*)////)
      close(5)
      RETURN
      END
C *********************************************************
C *********************************************************
      SUBROUTINE EBTCR
C *********************************************************
      OPEN(UNIT=8,file='EBTCR.RES',STATUS='UNKNOWN')
      write(8,1300)
1300  FORMAT('EXPERIMENTAL BENCHMARKS ON REACTIVITY TEMPERATURE '/
     1 49(1H*)/
     2 'COEFFICIENT '/
     3 11(1H*)//)
      close(8)
      RETURN
      END
C *********************************************************
      SUBROUTINE NORA
C *********************************************************
      CHARACTER*120 RECI
      REAL XKI(8),XKE(8),DT(8),C(8),nc(3)
      OPEN (UNIT=3,FILE='NORA.OUT',STATUS='old')
      OPEN (UNIT=5,file='NORA.RES',STATUS='UNKNOWN')
      OPEN (UNIT=6,FILE='NORA.t',STATUS='UNKNOWN')
      OPEN (UNIT=7,FILE='NORA.c',STATUS='UNKNOWN')
C
      DO I=1,4
   20  READ (3,800) RECI
       DO WHILE (RECI(53:63).NE.'k-effective')
        GO TO 20
       ENDDO
       READ(RECI(38:49),802) XKI(i)
       READ(RECI(66:77),802) XKE(i)
       READ (3,800) RECI
      ENDDO
C*
C      DO i=1,4
C       WRITE(*,*)XKI(i),XKE(i)
C      ENDDO
      read(6,*)(DT(i),i=1,4)
      read(7,1200)(nc(i),i=1,2)
      j=0
      do i=2,4,2
       j=j+1
       c(j)=(XKE(i)-XKE(i-1))/(XKE(i)*XKE(i-1)*(DT(i)-DT(i-1))*1.E-5)
      enddo
C
      write(5,950)
      do 60 i=1,4
       ik = mod(i,2)
       if(ik.eq.0) then
        write(5,901)DT(i),XKI(i),XKE(i)
       else
        write(5,900)DT(i),XKI(i),XKE(i)
       endif
       jl = int(i/2)
       if(i.ne.1) then
        goto 601
       else
        write(5,1100)nc(i),c(i)
        goto 60
       endif
 601   if(ik.eq.0) go to 60
       write(5,1100)nc(jl+1),c(jl+1)
  60  continue
C
      write(5,1250)
C*
 800  FORMAT(A120)
 802  FORMAT(E14.7)
 950  FORMAT(1X,24X,33(1H*)/
     1 '                         *        NORA EXPERIMENTS       *'/
     2 25X,33(1H*)///
     3'WIMS OUTPUT AND DISCREPANCIES BETWEEN CALCULATIONS '/
     4'AND MEASUREMENTS FOR THE RTC :'//
     6 17X,'TEMP. (°C)',9x,'K-INF',10x,'K-EFF'/
     7'  Vm/Vf     ',51x,'D-ALPHA (pcm/°C)'//)
 900  FORMAT(16x,F7.2,7x,E14.7,1x,E14.7)
 901  FORMAT(16x,F7.2,7x,E14.7,1x,E14.7//)
 1200 FORMAT(1x,F4.2,1x,F4.2,1x,F4.2,1x,F4.2)
 1100 FORMAT(3x,F4.2,55x,F14.8)
 1250 FORMAT(55(1H-)//)
      close(3)
      close(5)
      close(6)
      close(7)
      RETURN
      END
C *********************************************************
      SUBROUTINE KRITZ1
C *********************************************************
      CHARACTER*120 RECI
      REAL XKI(8),XKE(8),DT(8),C(8)
      OPEN (UNIT=3,FILE='KRITZ1.OUT',STATUS='old')
      OPEN(UNIT=5,file='KRITZ1.RES',STATUS='UNKNOWN')
      OPEN (UNIT=6,FILE='KRITZ1.t',STATUS='UNKNOWN')
C
      DO I=1,2
  20   READ (3,800) RECI
       DO WHILE (RECI(53:63).NE.'k-effective')
        GO TO 20
       ENDDO
       READ(RECI(38:49),802) XKI(i)
       READ(RECI(66:77),802) XKE(i)
       READ (3,800) RECI
      ENDDO
C*
C      do 30 i=1,2
C  30   WRITE(*,*)XKI(i),XKE(i)
      read(6,*)(dt(i),i=1,2)
      i=1
      IF ((XKE(i+1)*XKE(i)).NE.0)THEN
       c(i)=(XKE(i+1)-XKE(i))/(XKE(i+1)*XKE(i)*(DT(i+1)-DT(i))*1.E-5)
      ENDIF
      write(5,950)
      do 60 i=1,2
       IF(i.lt.2) THEN
c         write (5,1000)
         write(5,900)DT(i),XKI(i),XKE(i),C(i)
       ELSE
        write(5,900)DT(i),XKI(i),XKE(i)
       ENDIF
60    continue
      write(5,1250)
C*
 800  FORMAT(A120)
 802  FORMAT(E14.7)
 950  FORMAT(25x,33(1H*)/
     1 '                         *       KRITZ1  EXPERIMENTS     *'/
     2 25x,33(1H*)////
     3'WIMS OUTPUT AND DISCREPANCIES BETWEEN CALCULATIONS '/
     4'AND MEASUREMENTS FOR THE RTC :'//
     6 1x,'TEMP.(°C)',6x,'K-INF',12x,'K-EFF',6x,'D-ALPHA(pcm/°C)'//)
 900  FORMAT(F7.2,3x,E14.7,3x,E14.7,/41x,F14.7)
 1250 FORMAT(55(1H-)//)
 1300 FORMAT (/'  TEMPERATURES EN °C: '/)
      close(3)
      close(5)
      close(6)
      RETURN
      END
C *********************************************************
      SUBROUTINE KRITZ21
C *********************************************************
      CHARACTER*120 RECI
      REAL XKI(8),XKE(8),DT(8),C(8)
      OPEN (UNIT=3,FILE='KRITZ21.OUT',STATUS='old')
      OPEN(UNIT=5,file='KRITZ21.RES',STATUS='UNKNOWN')
      OPEN (UNIT=6,FILE='KRITZ21.t',STATUS='UNKNOWN')
C
      DO I=1,2
   20  READ (3,800) RECI
       DO WHILE (RECI(53:63).NE.'k-effective')
        GO TO 20
       ENDDO
       READ(RECI(38:49),802) XKI(i)
       READ(RECI(66:77),802) XKE(i)
       READ (3,800) RECI
      ENDDO
C*
C     do 30 i=1,2
C  30   WRITE(*,*)XKI(i),XKE(i)
      read(6,*)(dt(i),i=1,2)
      i=1
      IF ((XKE(i+1)*XKE(i)).NE.0)THEN
       c(i)=(XKE(i+1)-XKE(i))/(XKE(i+1)*XKE(i)*(DT(i+1)-DT(i))*1.E-5)
      ENDIF
      write(5,950)
      do 60 i=1,2
       IF(i.lt.2) THEN
        write(5,900)DT(i),XKI(i),XKE(i),C(i)
       ELSE
        write(5,900)DT(i),XKI(i),XKE(i)
       ENDIF
 60   continue
      write(5,1250)
C*
 800  FORMAT(A120)
 802  FORMAT(E14.7)
 950  FORMAT(25x,33(1H*)/
     1 '                         *       KRITZ21 EXPERIMENT      *'/
     2 25x,33(1H*)////
     3'WIMS OUTPUT AND DISCREPANCIES BETWEEN CALCULATIONS '/
     4'AND MEASUREMENTS FOR THE RTC : '//
     6 1x,'TEMP.(°C)',6x,'K-INF',12x,'K-EFF',6x,'D-ALPHA(pcm/°C)'//)
 900  FORMAT(F7.2,3x,E14.7,3x,E14.7,/41x,F14.7)
 1250 FORMAT(55(1H-)//)
      close(3)
      close(5)
      close(6)
      RETURN
      END
C *********************************************************
      SUBROUTINE KRITZ213
C *********************************************************
      CHARACTER*120 RECI
      REAL XKI(8),XKE(8),DT(8),C(8)
      OPEN (UNIT=3,FILE='KRITZ213.OUT',STATUS='old')
      OPEN(UNIT=5,file='KRITZ213.RES',STATUS='UNKNOWN')
      OPEN (UNIT=6,FILE='KRITZ213.t',STATUS='UNKNOWN')
C
      DO I=1,2
   20  READ (3,800) RECI
       DO WHILE (RECI(53:63).NE.'k-effective')
        GO TO 20
       ENDDO
       READ(RECI(38:49),802) XKI(i)
       READ(RECI(66:77),802) XKE(i)
       READ (3,800) RECI
      ENDDO
C*
C      do 30 i=1,2
C  30   WRITE(*,*)XKI(i),XKE(i)
      read(6,*)(dt(i),i=1,2)
      i=1
      IF ((XKE(i+1)*XKE(i)).NE.0.)THEN
       c(i)=(XKE(i+1)-XKE(i))/(XKE(i+1)*XKE(i)*(DT(i+1)-DT(i))*1.E-5)
      ENDIF
      write(5,950)
      do 60 i=1,2
       IF(i.lt.2) THEN
        write(5,900)DT(i),XKI(i),XKE(i),C(i)
       ELSE
        write(5,900)DT(i),XKI(i),XKE(i)
       ENDIF
 60   continue
      write(5,1250)
C*
 800  FORMAT(A120)
 802  FORMAT(E14.7)
 950  FORMAT(25x,33(1H*)/
     1 '                         *       KRITZ213 EXPERIMENT     *'/
     2 25x,33(1H*)////
     3'WIMS OUTPUT AND DISCREPANCIES BETWEEN CALCULATIONS '/
     4'AND MEASUREMENTS FOR THE RTC : '//
     6 1x,'TEMP.(°C)',6x,'K-INF',12x,'K-EFF',6x,'D-ALPHA(pcm/°C)'//)
 900  FORMAT(F7.2,3x,E14.7,3x,E14.7,/41x,F14.7)
 1250 FORMAT(55(1H-)//)
      close(3)
      close(5)
      close(6)
      RETURN
      END
C *********************************************************
C *********************************************************
      SUBROUTINE KRITZ219
C *********************************************************
      CHARACTER*120 RECI
      REAL XKI(8),XKE(8),DT(8),C(8)
      OPEN (UNIT=3,FILE='KRITZ219.OUT',STATUS='old')
      OPEN(UNIT=5,file='KRITZ219.RES',STATUS='UNKNOWN')
      OPEN (UNIT=6,FILE='KRITZ219.t',STATUS='UNKNOWN')
C
      DO I=1,2
   20  READ (3,800) RECI
       DO WHILE (RECI(53:63).NE.'k-effective')
        GO TO 20
       ENDDO
       READ(RECI(38:49),802) XKI(i)
       READ(RECI(66:77),802) XKE(i)
       READ (3,800) RECI
      ENDDO
C*
C       do 30 i=1,2
C  30   WRITE(*,*)XKI(i),XKE(i)
      read(6,*)(dt(i),i=1,2)
      i=1
      IF ((XKE(i+1)*XKE(i)).NE.0.)THEN
       c(i)=(XKE(i+1)-XKE(i))/(XKE(i+1)*XKE(i)*(DT(i+1)-DT(i))*1.E-5)
      ENDIF
      write(5,950)
      do 60 i=1,2
       IF(i.lt.2) THEN
c         write (5,1000)
        write(5,900)DT(i),XKI(i),XKE(i),C(i)
       ELSE
        write(5,900)DT(i),XKI(i),XKE(i)
       ENDIF
 60   continue
      write(5,1250)
C*
 800  FORMAT(A120)
 802  FORMAT(E14.7)
 950  FORMAT(25x,33(1H*)/
     1 '                         *       KRITZ219 EXPERIMENT     *'/
     2 25x,33(1H*)////
     3'WIMS OUTPUT AND DISCREPANCIES BETWEEN CALCULATIONS '/
     4'AND MEASUREMENTS FOR THE RTC : '/
     6 1x,'TEMP.(°C)',6x,'K-INF',12x,'K-EFF',6x,'D-ALPHA(pcm/°C)'//)
 900  FORMAT(F7.2,3x,E14.7,3x,E14.7,/41x,F14.7)
 1250 FORMAT(55(1H-)//)
      close(3)
      close(5)
      close(6)
      RETURN
      END
C *********************************************************
      SUBROUTINE R1100H
C *********************************************************
      CHARACTER*120 RECI
      REAL XKI(8),XKE(8),DT(8),C(8)
      OPEN (UNIT=3,FILE='R1100H.OUT',STATUS='old')
      OPEN(UNIT=5,file='R1100H.RES',STATUS='UNKNOWN')
      OPEN (UNIT=6,FILE='R1100H.t',STATUS='UNKNOWN')
C
      DO I=1,2
   20  READ (3,800) RECI
       DO WHILE (RECI(53:63).NE.'k-effective')
        GO TO 20
       ENDDO
       READ(RECI(38:49),802) XKI(i)
       READ(RECI(66:77),802) XKE(i)
       READ (3,800) RECI
      ENDDO
C*
C      do 30 i=1,2
C  30   WRITE(*,*)XKI(i),XKE(i)
      read(6,*)(dt(i),i=1,2)
      i=1
      IF ((XKE(i+1)*XKE(i)).NE.0)THEN
       c(i)=(XKE(i+1)-XKE(i))/(XKE(i+1)*XKE(i)*(DT(i+1)-DT(i))*1.E-5)
      ENDIF
      write(5,950)
      do 60 i=1,2
       IF(i.lt.2) THEN
        write(5,900)DT(i),XKI(i),XKE(i),C(i)
       ELSE
        write(5,900)DT(i),XKI(i),XKE(i)
       ENDIF
 60   continue
      write(5,1250)
C*
 800  FORMAT(A120)
 802  FORMAT(E14.7)
 950  FORMAT(25x,33(1H*)/
     1 '                         *       R1-100H EXPERIMENT      *'/
     2 25x,33(1H*)////
     3'WIMS OUTPUT AND DISCREPANCIES BETWEEN CALCULATIONS '/
     4'AND MEASUREMENTS FOR THE RTC :'//
     6 1x,'TEMP.(°C)',6x,'K-INF',12x,'K-EFF',6x,'D-ALPHA(pcm/°C)'//)
 900  FORMAT(F7.2,3x,E14.7,3x,E14.7,/41x,F14.7)
 1250 FORMAT(55(1H-)///)
      close(3)
      close(5)
      close(6)
      RETURN
      END
C *********************************************************
C *********************************************************
      SUBROUTINE VVER1
C *********************************************************
      CHARACTER*120 RECI
      REAL XKI(8),XKE(8),C2
      OPEN (UNIT=3,FILE='vver1.OUT',STATUS='old')
      OPEN(UNIT=5,file='VVER1.RES',STATUS='UNKNOWN')
      OPEN (UNIT=6,FILE='VVER.t',STATUS='UNKNOWN')
C
      DO I=1,2
   20  READ (3,800) RECI
       DO WHILE (RECI(53:63).NE.'k-effective')
        GO TO 20
       ENDDO
       READ(RECI(38:49),802) XKI(i)
       READ(RECI(66:77),802) XKE(i)
       READ (3,800) RECI
      ENDDO
C
      do i=1,2
       c2=((XKE(2)-XKE(1))/(XKE(2)*XKE(1)*109.0))*1.E+5
      enddo
      write(5,950)
      write(5,901)XKI(1),XKE(1)
      write(5,1100)c2
      write(5,904)XKI(2),XKE(2)
      write(5,1250)
C*
800   FORMAT(A120)
 802  FORMAT(E14.7)
 950  FORMAT(1X,24X,33(1H*)/
     1 '                         *        VVER1 EXPERIMENTS      *'/
     2 25X,33(1H*)///
     3'WIMS OUTPUT AND DISCREPANCIES BETWEEN CALCULATIONS '/
     4'AND MEASUREMENTS FOR THE RTC :'//
     6 1X,'TEMP. (°C)',10x,'K-INF',10x,'K-EFF'/
     7 51x,'D-ALPHA (pcm/°C)'//)
 900  FORMAT(1x,F7.2,7x,E14.7,1x,E14.7)
 901  FORMAT(1x,'21.0',7x,E14.7,1x,E14.7)
 902  FORMAT(1x,'80.0',7x,E14.7,1x,E14.7)
 904  FORMAT(1x,'130.0',6x,E14.7,1x,E14.7)
 1200 FORMAT(1x,F4.2,1x,F4.2,1x,F4.2,1x,F4.2)
 1100 FORMAT(51x,F14.8)
 1250 FORMAT(55(1H-)//)
      close(3)
      close(5)
      close(6)
      RETURN
      END
C *********************************************************
C *********************************************************
      SUBROUTINE VVER2
C *********************************************************
      CHARACTER*120 RECI
      REAL XKI(8),XKE(8),C2
      OPEN (UNIT=3,FILE='vver2.OUT',STATUS='old')
      OPEN(UNIT=5,file='VVER2.RES',STATUS='UNKNOWN')
      OPEN (UNIT=6,FILE='VVER.t',STATUS='UNKNOWN')
C
      DO I=1,2
   20  READ (3,800) RECI
       DO WHILE (RECI(53:63).NE.'k-effective')
        GO TO 20
       ENDDO
       READ(RECI(38:49),802) XKI(i)
       READ(RECI(66:77),802) XKE(i)
       READ (3,800) RECI
      ENDDO
C
      do i=1,2
       c2=((XKE(2)-XKE(1))/(XKE(2)*XKE(1)*109.0))*1.E+5
      enddo
      write(5,950)
      write(5,901)XKI(1),XKE(1)
      write(5,1100)c2
      write(5,904)XKI(2),XKE(2)
      write(5,1250)
C*
 800  FORMAT(A120)
 802  FORMAT(E14.7)
 950  FORMAT(1X,24X,33(1H*)/
     1 '                         *        VVER2 EXPERIMENTS      *'/
     2 25X,33(1H*)///
     3'WIMS OUTPUT AND DISCREPANCIES BETWEEN CALCULATIONS '/
     4'AND MEASUREMENTS FOR THE RTC :'//
     6 1X,'TEMP. (°C)',10x,'K-INF',10x,'K-EFF'/
     7 51x,'D-ALPHA (pcm/°C)'//)
 900  FORMAT(1x,F7.2,7x,E14.7,1x,E14.7)
 901  FORMAT(1x,'21.0',7x,E14.7,1x,E14.7)
 902  FORMAT(1x,'80.0',7x,E14.7,1x,E14.7)
 904  FORMAT(1x,'130.0',6x,E14.7,1x,E14.7)
 1200 FORMAT(1x,F4.2,1x,F4.2,1x,F4.2,1x,F4.2)
 1100 FORMAT(51x,F14.8)
 1250 FORMAT(55(1H-)//)
      close(3)
      close(5)
      close(6)
      RETURN
      END
C *********************************************************
C *********************************************************
      SUBROUTINE VVER3
C *********************************************************
      CHARACTER*120 RECI
      REAL XKI(8),XKE(8),C2
      OPEN (UNIT=3,FILE='vver3.OUT',STATUS='old')
      OPEN(UNIT=5,file='VVER3.RES',STATUS='UNKNOWN')
      OPEN (UNIT=6,FILE='VVER.t',STATUS='UNKNOWN')
C
      DO I=1,2
   20  READ (3,800) RECI
       DO WHILE (RECI(53:63).NE.'k-effective')
        GO TO 20
       ENDDO
       READ(RECI(38:49),802) XKI(i)
       READ(RECI(66:77),802) XKE(i)
       READ (3,800) RECI
      ENDDO
C
      do i=1,2
       c2=((XKE(2)-XKE(1))/(XKE(2)*XKE(1)*109.0))*1.E+5
      enddo
      write(5,950)
      write(5,901)XKI(1),XKE(1)
      write(5,1100)c2
      write(5,904)XKI(2),XKE(2)
      write(5,1250)
C*
 800  FORMAT(A120)
 802  FORMAT(E14.7)
 950  FORMAT(1X,24X,33(1H*)/
     1 '                         *        VVER3 EXPERIMENTS      *'/
     2 25X,33(1H*)///
     3'WIMS OUTPUT AND DISCREPANCIES BETWEEN CALCULATIONS '/
     4'AND MEASUREMENTS FOR THE RTC :'//
     6 1X,'TEMP. (°C)',10x,'K-INF',10x,'K-EFF'/
     7 51x,'D-ALPHA (pcm/°C)'//)
 900  FORMAT(1x,F7.2,7x,E14.7,1x,E14.7)
 901  FORMAT(1x,'21.0',7x,E14.7,1x,E14.7)
 902  FORMAT(1x,'80.0',7x,E14.7,1x,E14.7/)
 904  FORMAT(1x,'130.0',6x,E14.7,1x,E14.7)
 1200 FORMAT(1x,F4.2,1x,F4.2,1x,F4.2,1x,F4.2)
 1100 FORMAT(51x,F14.8)
 1250 FORMAT(55(1H-)//)
      close(3)
      close(5)
      close(6)
      RETURN
      END
C *********************************************************
C *********************************************************
      SUBROUTINE VVER4
C *********************************************************
      CHARACTER*120 RECI
      REAL XKI(8),XKE(8),C2
      OPEN (UNIT=3,FILE='vver4.OUT',STATUS='old')
      OPEN(UNIT=5,file='VVER4.RES',STATUS='UNKNOWN')
      OPEN (UNIT=6,FILE='VVER.t',STATUS='UNKNOWN')
C
      DO I=1,2
   20  READ (3,800) RECI
       DO WHILE (RECI(53:63).NE.'k-effective')
        GO TO 20
       ENDDO
       READ(RECI(38:49),802) XKI(i)
       READ(RECI(66:77),802) XKE(i)
       READ (3,800) RECI
      ENDDO
      do i=1,2
       c2=((XKE(2)-XKE(1))/(XKE(2)*XKE(1)*109.0))*1.E+5
      enddo
      write(5,950)
      write(5,901)XKI(1),XKE(1)
      write(5,1100)c2
      write(5,904)XKI(2),XKE(2)
      write(5,1250)
C*
 800  FORMAT(A120)
 802  FORMAT(E14.7)
 950  FORMAT(1X,24X,33(1H*)/
     1 '                         *        VVER4 EXPERIMENTS      *'/
     2 25X,33(1H*)///
     3'WIMS OUTPUT AND DISCREPANCIES BETWEEN CALCULATIONS '/
     4'AND MEASUREMENTS FOR THE RTC :'//
     6 1X,'TEMP. (°C)',10x,'K-INF',10x,'K-EFF'/
     7 51x,'D-ALPHA (pcm/°C)'//)
 900  FORMAT(1x,F7.2,7x,E14.7,1x,E14.7)
 901  FORMAT(1x,'21.0',7x,E14.7,1x,E14.7)
 902  FORMAT(1x,'80.0',7x,E14.7,1x,E14.7)
 904  FORMAT(1x,'130.0',6x,E14.7,1x,E14.7)
 1200 FORMAT(1x,F4.2,1x,F4.2,1x,F4.2,1x,F4.2)
 1100 FORMAT(51x,F14.8)
 1250 FORMAT(55(1H-)//)
      close(3)
      close(5)
      close(6)
      RETURN
      END
*deck pltwli 
      PROGRAM PLTWLI
C-Title  : Program PLTWLI
C-Purpose: Prepare WILLIE input to plot WIMS-D cross sections
C-Author : A.Trkov, Institute J.Stefan, Ljubljana, Slovenia (1999)
C-Version: 1999 original code.
C-V  00/11 Convert Mat.ID to explicit label from "matlst" file.
C-M
C-M  Manual for Program PLTWLI
C-M  =========================
C-M
C-M  WILLIE input to plot the cross sections from a WIMS-D library
C-M  is prepared. One or more WIMS-D library filenames can be
C-M  specified. The reaction cross sections can also be selected.
C-M  When several libraries are specified, a single reaction
C-M  cross section can be chosen for comparison between different
C-M  libraries. If a single library is specified, several reaction
C-M  cross sections are processed for each material.
C-M
C-M  Apart from the WILLIE input, an input file for the PLOTTAB
C-M  graphics package is also prepared.
C-M
C-M  Instructions
C-M  ------------
C-M  In response to the prompt, define:
C-M  - WIMS-D library filenames list terminated by blank.
C-M  - Label for each file (by default the label is equal to
C-M    the filename). This label is transferred to the WILLIE
C-M    input to appear in the PLOTTAB curves file and is used
C-M    to label curves in the legend box of the plots.
C-M  - Filename containing material designation labels (columns
C-M    1-12) and the corresponding ID numbers (columns 13-18).
C-M    Records preceeding the one beginning with ' ---------'
C-M    are assumed to be comments and are ignored.
C-M  - Reaction number code:
C-M    POTENTIAL CROSS SECTION                                    1
C-M    SLOWING DOWN POWER                                         2
C-M    TRANSPORT CROSS SECTION                                    3
C-M    ABSORPTION CROSS SECTION                                   4
C-M    FISSION YIELD (FISS.CROSS SECT TIMES NU-BAR)               5
C-M    FISSION CROSS SECTION                                      6
C-M    OUTSCATTERING CROSS SECTION                                7
C-M    SCATTERING CROSS SECTION                                   8
C-M    DIFFERENTIAL SCATERING CROSS SECTION (SCATT.MATRIX ROW)    9
C-M    ABSORPTION RESONANCE INTEGRAL                             10
C-M    FISSION RESONANCE INTEGRAL                                11
C-M    FISSION SPECTRUM                                          12
C-M When more than one WIMS-D libraries are processed, the label for
C-M each library can be redefined. By default, the filename is used.
C-M
C-M  Two output files with fixed filenames are written:
C-M    PLTWLI.WLI - WILLIE input instructions to extract cross
C-M                 sections from the specified WIMS-D libraries
C-M                 onto the PLTWLI.CUR file.
C-M    PLTWLI.P92 - PLOTTAB input file to plot the cross sections.
C-M
C-M  Note that the cross section curves file PLTWLI.CUR file is
C-M  produced after running WILLIE with PLTWLI.WLI as input.
C-
      PARAMETER      (MXWL=10,MXSL=12,MXMT=400)
      CHARACTER*10    MSEL(MXSL)
      CHARACTER*12    ISOT
      CHARACTER*40    BLNK,FLNM,FLMA,FLWI,FCUR,FP92
     1               ,FLWL(MXWL),LABL(MXWL)
      DIMENSION       MAT(2*MXMT),ISEL(MXSL)
C* Plot area specifications
C*  IXA - Abscisa offset of the plot area
C*  IXB - Abscisa upper limit of plot area (-ve for portrait orientation)
C*  IYA - Ordinate offset of the plot area
C*  IYB - Ordinate upper limit of plot area
C*  IXP - Number of plots in the x-direction
C*  IYP - Number of plots in the y-direction
C*  ISZ - Character size scaling factor
      DATA IXA,IXB,IYA,IYB,IXP,IYP,ISZ
     1    /  2, 24,  2, 16,  2,  2,  2 /
C*
      DATA LIB,LWI,L92,LMA,LKB,LTT/ 1, 2, 3,-4, 5, 6 /
      DATA BLNK   /'                                        '/
     1     FLWI   /'PLTWLI.WLI'/
     2     FCUR   /'PLTWLI.CUR'/
     3     FP92   /'PLTWLI.P92'/
     4     FLMA   /'MATLST.TXT'/
     1     FLWL(1)/'JENDL32.LIB'/
 
      DATA LABL(1)/'JENDL-3.2'/
      DATA ISEL/ 4, 3, 8, 6, 0, 0, 0, 0, 0, 0, 0, 0 /
 
      DATA MSEL/
     1 'POTENTIAL ','SLOW.DN.PW','TRANSPORT ','ABSORPTION','FISS.YIELD'
     1,'FISSION   ','OUTSCATT. ','SCATTERING','DIFF.SCAT.','ABSORPT.RI'
     2,'FISSION RI','FISS.SPECT'/
 
C*
      NLIB=0
      NSEL=0
C*
      WRITE(LTT,691) ' PLTWLI - WIMS-D library WILLIE Pre-Pro.'
      WRITE(LTT,691) ' ======================================='
      WRITE(LTT,691)
      WRITE(LTT,691) ' To compare cross sections, enter a sing'
     1              ,'le WIMS-D library filename              '
      WRITE(LTT,691) ' To compare libraries, enter several fil'
     1              ,'enames.                                 '
      WRITE(LTT,691) ' Terminate list by blank or "-".        '
      WRITE(LTT,691)
      GO TO 22
   20 WRITE(LTT,691) ' ERROR - Incorrect or illegal filename  ',FLNM
   22 WRITE(LTT,691) '$       Enter WIMS-D library filename : '
      READ (LKB,691) FLNM
      IF(FLNM.EQ.BLNK .OR. FLNM(1:1).EQ.'-') GO TO 30
C* Check that the file exists
      OPEN (UNIT=LIB,FILE=FLNM,STATUS='OLD',ERR=20)
      CLOSE(UNIT=LIB)
      NLIB=NLIB+1
      IF(NLIB.GT.MXWL) STOP 'PLTWLI ERROR - MXWL limit exceeded'
      FLWL(NLIB)=FLNM
      LABL(NLIB)=FLNM
      GO TO 22
C* Re-assign labels if several libraries present
   30 IF(NLIB.LE.1) GO TO 34
      DO 32 I=1,NLIB
      WRITE(LTT,691) '        Default label is the filename : ',FLWL(I)
      WRITE(LTT,691) '$         Enter new label to redefine : '
      READ (LKB,691,END=40) FLNM
      IF(FLNM.NE.BLNK) LABL(I)=FLNM
   32 CONTINUE
C*
   34 WRITE(LTT,691) '$   Enter WIMS-D Material ID filename : '
      READ (LKB,691,END=40) FLMA
      IF(FLMA.EQ.BLNK) GO TO 40
      LMA=ABS(LMA)
      OPEN (UNIT=LMA,FILE=FLMA,STATUS='OLD',ERR=34)
C* All WIMS-D library filenames entered
   40 IF(NLIB.LT.1) GO TO 600
      WRITE(LTT,691) ' Select the reaction from the list    : '
      DO 42 I=1,MXSL
      WRITE(LTT,693) BLNK(1:30)//MSEL(I),I
   42 CONTINUE
   44 WRITE(LTT,691) '$Enter the reaction cross section flag: '
      READ (LKB,603) JSEL
      IF(JSEL.GT.0) THEN
        IF(JSEL.GT.12) GO TO 44
        NSEL=NSEL+1
        ISEL(NSEL)=JSEL
        IF(NLIB.EQ.1) GO TO 44
      END IF
      IF(NSEL.LT.1) NSEL=1
C*
      WRITE(LTT,691)
      WRITE(LTT,693) '            WIMS-D Libraries selected : ',NLIB
      DO 62 I=1,NLIB
      WRITE(LTT,691) BLNK(1:20)//LABL(I),FLWL(I)
   62 CONTINUE
      WRITE(LTT,691)
      WRITE(LTT,693) '                   Reactions selected : ',NSEL
      DO 64 I=1,NSEL
      WRITE(LTT,691) BLNK(1:30)//MSEL(ISEL(I))
   64 CONTINUE
C*
C* Open the file to write the WILLIE input instructions
      OPEN (UNIT=LWI,FILE=FLWI,STATUS='UNKNOWN')
C*
C* Use material list from the first WIMS-D library
      OPEN (UNIT=LIB,FILE=FLWL(1),STATUS='OLD')
      READ (LIB,605) NEL,NG,NG0,NG1,NG2,NG3,NNFD,NNFPD
      IF(NEL.GT.MXMT) STOP 'PLTWLI ERROR - MXMT limit exceeded'
      READ (LIB,605) (MAT(J),J=1,NEL)
      CLOSE (UNIT=LIB)
      IF(NLIB.LE.1) GO TO 80
C* Make material list a union of MAT numbers from all files
      KEL=NEL
      DO 79 L=2,NLIB
      OPEN (UNIT=LIB,FILE=FLWL(L),STATUS='OLD')
      READ (LIB,605) JEL,NG,NG0,NG1,NG2,NG3,NNFD,NNFPD
      IF(KEL+JEL.GT.MXMT) STOP 'PLTWLI ERROR - MXMT limit exceeded'
      READ (LIB,605) (MAT(KEL+J),J=1,JEL)
      CLOSE (UNIT=LIB)
      IEL=0
   74 IEL=IEL+1
      IF(IEL.GT.NEL) GO TO 79
   75 DO 76 I=1,JEL
      IF(MAT(KEL+I).EQ.MAT(IEL)) GO TO 74
   76 CONTINUE
C* Material not found - eliminate from the comparison list
      WRITE(LTT,691) ' WARNING : Processing WIMS-D library    ',FLWL(L)
      WRITE(LTT,693) '             Exclude from comparison MAT',MAT(IEL)
      NEL=NEL-1
      DO 78 I=IEL,NEL
      MAT(I)=MAT(I+1)
   78 CONTINUE
      IF(IEL.LT.NEL) GO TO 75
   79 CONTINUE
C*
C* Write PLOTTAB input general information
   80 OPEN (UNIT=L92,FILE=FP92,STATUS='UNKNOWN')
      WRITE(L92,611) IXA,IXB,IYA,IYB,IXP,IYP,ISZ
      WRITE(L92,611) MAX(NSEL,NLIB),0,1,0,0,0,0
      WRITE(L92,691) 'Energy                                  '
     1              ,'eV                                      '
      WRITE(L92,691) 'Cross Section                           '
     1              ,'barns                                   '
C*
      DO 400 I=1,NEL
      WRITE(LWI,693)
      WRITE(LWI,693) '                    Process material MAT',MAT(I)
C*
      WRITE(LWI,610) 'PTAB'
      WRITE(LWI,691) FLWL(1)
      DO 210 J=1,NLIB
      WRITE(LWI,691) FLWL(J)
  210 CONTINUE
      WRITE(LWI,691)
      DO 220 J=1,NLIB
      WRITE(LWI,691) LABL(J)
  220 CONTINUE
C* Select cross sections
      JSEL=1
      WRITE(LWI,601) ISEL(JSEL)
      WRITE(LWI,691) FCUR
C* Select MAT Number
      DO 222 J=1,NLIB
      WRITE(LWI,601) MAT(I)
      WRITE(LWI,601) 0
  222 CONTINUE
  230 JSEL=JSEL+1
      IF(JSEL.GT.NSEL .OR. ISEL(JSEL).LE.0) GO TO 240
C* Select next cross section
      WRITE(LWI,601) ISEL(JSEL)
      WRITE(LWI,691)
      WRITE(LWI,601) 296
      GO TO 230
C* Finish the selection
  240 WRITE(LWI,601)-1
C*
      IF(NLIB.EQ.1) THEN
        WRITE(L92,691) 'WIMS-D Library Cross Section Comparison '
        WRITE(L92,620) MAT(I),FLWL(1)
        WRITE(L92,691)
        WRITE(L92,691)
      ELSE
        CALL MATISO(LMA,MAT(I),ISOT)
        WRITE(L92,691) 'WIMS-D Library Cross Section Comparison '
        WRITE(L92,630) MSEL(ISEL(1)),ISOT
        WRITE(L92,691)
        WRITE(L92,691)
      END IF
  400 CONTINUE
 
      WRITE(LWI,610) 'END '
      WRITE(L92,691)
C*
  600 STOP 'PLTWLI Completed'
C*
  601 FORMAT(I5)
  603 FORMAT(BN,I10)
  605 FORMAT(5I15)
  610 FORMAT(A4)
  611 FORMAT(6I11,I4)
  620 FORMAT('MAT ID',I5,' FROM ',A40)
  630 FORMAT(A10,' For Material ',A12)
  691 FORMAT(2A40)
  693 FORMAT(A40,I5)
C*
      END
      SUBROUTINE MATISO(LMA,MAT,ISOT)
C-Title  : Subroutine MATISO
C-Purpose: Extract Isotope name form MAT Ident on file unit LMA
C-Description:
C-D  The material ident table is given on unit LMA, consisting of:
C-D  Column Description
C-D    1-10 material or nuclide label given in terms of zz-XX-aaa
C-D         where zz is the atomic number, XX the chemical symbol
C-D         and aaa the mass number, which is zero to flag natural
C-D         elements.
C-D   11-18 Material ID number (WIMS-D convention).
C-D  The material ident table needs to be read once. After the
C-D  first pass the unit number LMA is flagged negative.
C-D    Given the input MAT ident number, this is compared agains
C-D  input table and the material label is placed into ISOT string.
C-
      PARAMETER   (MXLS=200)
      CHARACTER*80 REC
      CHARACTER*12 ISOT,ILST(MXLS)
      DIMENSION    ALST(MXLS)
      DATA NMA/0/
      SAVE
C* Read material ID table
      IF(LMA.LE.0) GO TO 40
      NMA=0
      REWIND LMA
C* Skip heading text
   20 READ (LMA,910,ERR=40) REC
      IF(REC(1:10).NE.' ---------') GO TO 20
C* Process the table
   22 READ (LMA,910,ERR=40,END=40) REC
      IF(REC(1:10).EQ.'          ') GO TO 40
      READ (REC,912,ERR=40) ILST(NMA+1),ALST(NMA+1)
      NMA=NMA+1
      GO TO 22
C* Define material string from the given ident
   40 LMA=-ABS(LMA)
      WRITE(ISOT,901) MAT
      IF(NMA.LE.0) RETURN
      DO 60 I=1,NMA
      MLST=ALST(I)+0.01
      IF(MAT.NE.MLST) GO TO 60
      ISOT=ILST(I)
      GO TO 80
   60 CONTINUE
   80 RETURN
C*
  901 FORMAT(I6,6X)
  910 FORMAT(A80)
  912 FORMAT(A12,F6.0)
      END
*deck pseudo 
      PROGRAM PSEUDO
C-Title  : Program PSEUDO
C-Purpose: Prepare the files needed to generate pseudo fission product.
C-Author : D. L. Aldama
C-Version:
C-V  03/1999 Original code
C-V  10/1999 Oscar Cabellos: Unix compatibility (implemented by A.Trkov)
C-V  06/2001 Uma Kannan: Extensions for 172-group library.
C-Usage: PSEUDO
C-U
C-U  Input filenames:
C-U    Input files
C-U        1.     List file for the explicitly represented F. Ps.
C-U        2.     List File for all the F. Ps.
C-U        3.     Evaluated nuclear data library Summary File
C-U               (GETDATA output file *.MF2)
C-U        4,5,6. The U-235, U-238 and Pu-239 NJB files for the
C-U               explicitly represented fission products.
C-U               (AVRFPY output)
C-U        7,8,9. The U-235, U-238 and Pu-239 NJB files for all
C-U               the fission products.
C-U               (AVRFPY output)
C-U
C-U    Output Files
C-U     1. ?.nji   Containing the NJOY input options for Pseudo F.P.
C-U                (ie. endfb6fp.nji, jef22fp.nji, cendlfp.nji, etc)
C-U     2. ?.wli   Containing the WILLIE input options for Pseudo F.P.
C-U                (ie. endfb6fp.wli, jef22fp.wli, cendlfp.wli, etc)
C-U     3. ?.bat   BATCH file to run NJOY and WILLIE for Pseudo F.P.
C-U                (ie. endfb6fp.bat, jef22fp.bat, cendlfp.bat, etc)
C-U
C-U  Running ?.bat (endfb6fp.bat, jef22fp.bat, cendlfp.bat, etc) the
C-U  file ?.xsw (endfb6fp.xsw, jef22fp.xsw, cendlfp.xsw, etc) is
C-U  generated on the %WLUPI% directory. A copy of the file named
C-U  PFP4902.xsw is also saved on your work directory.
C-U  This later file can be included in the WIMS Library running the
C-U  wimslib option of the BATCH runall for the corresponding evaluated
C-U  nuclear data library or directly using the program WILLIE.
C-U
C-Description:
C-D   The code reads the input files and checks them for consistency.
C-D   Afterwards the output files are generated according to the
C-D   evaluated nuclear data library. The average fission product is
C-D   calculated using the weights given in the corresponding data
C-D   statement for XF.
C-D
C-V        04/2001  No. of explicit f.p. NFPE increased from 50 to 80
 
       PARAMETER(LTT=6,LKB=5,LLE=1,LLL=2,LIB=3,LNJ=4,LNB=7,LWI=8,LBT=9)
       PARAMETER(NFPE=80,NFP=150,NMAT=1024,NFIS=3,SREF0=5.0E3)
       CHARACTER*80 LINE
       CHARACTER*40 FLNM,FLE,FLL,BLNK,FLIB,FNJ,FWLI,FBAT
       CHARACTER*11 ZASYM(NMAT),FZASYM(NFIS)
       CHARACTER*6  FMAT(NFP)
       DIMENSION AZE(NFPE),RIDE(NFPE),YE(NFIS,NFPE)
       DIMENSION AZ(NFP),RID(NFP),Y(NFIS,NFP)
       DIMENSION IPYP(NFP)
       DIMENSION XF(NFIS),YPSUM(NFIS),XP(NFIS,NFP)
       DIMENSION MAT(NMAT),AZL(NMAT),AWR(NMAT),SPOT(NMAT),EH(NMAT)
       DATA BLNK/'                                        '/
       DATA FLE/'FpLstExp.dat'/
       DATA FLL/'FpLstAll.dat'/
       DATA FLIB/'ENDF.MF2'/
       DATA FNJ/'PSEUDOFP.NJI'/
       DATA FWLI/'PSEUDOFP.WLI'/
       DATA FBAT/'RUNPFP.BAT'/
       DATA FZASYM/' 92-U -235 ',' 92-U -238 ',' 94-Pu-239 '/
       DATA XF/        57.0,          8.0,          35.0/
       DATA NGND/69/,NFG/14/,NRG/13/,IGREF/10/
C*
       WRITE(LTT,15) '     PSEUDO - Prepare pseudo F. P. Files'
       WRITE(LTT,15) '     ==================================='
       WRITE(LTT,15)
C*
C*       Reading input files
       FLNM=BLNK
    1  WRITE(LTT,15) '     Define list file for explicit F.P: '
       WRITE(LTT,15) '     ---------------------------------  '
       WRITE(LTT,15) '                     Default file name: ',FLE
       WRITE(LTT,15) '$       Enter new name (enter=default): '
       READ (LKB,15) FLNM
       IF(FLNM.NE.BLNK) FLE=FLNM
       OPEN (UNIT=LLE,FILE=FLE,STATUS='OLD',ERR=1)
       I=1
       READ(LLE,20) LINE
       READ(LLE,20) LINE
       DO WHILE (LINE(1:8).NE.'        ')
         READ(LINE,30) AZE(I), RIDE(I)
         IF (RIDE(I).LE.0.0) RIDE(I)=AZE(I)
         I=I+1
         READ(LLE,20,END=2) LINE
         IF(I.GT.NFPE) THEN
           STOP 'PSEUDO ERROR - NFPE limit exceeded'
         ENDIF
       END DO
    2  CLOSE(LLE)
       KFPE=I-1
       FLNM=BLNK
    3  WRITE(LTT,15) '     Define list file for   ALL    F.P: '
       WRITE(LTT,15) '     ---------------------------------  '
       WRITE(LTT,15) '                     Default file name: ',FLL
       WRITE(LTT,15) '$       Enter new name (enter=default): '
       READ (LKB,15) FLNM
       IF(FLNM.NE.BLNK) FLL=FLNM
       OPEN (UNIT=LLL,FILE=FLL,STATUS='OLD',ERR=3)
       I=1
       READ(LLL,20) LINE
       READ(LLL,20) LINE
       DO WHILE (LINE(1:8).NE.'        ')
         READ(LINE,30) AZ(I), RID(I)
         IF (RID(I).LE.0.0) RID(I)=AZ(I)
         I=I+1
         READ(LLL,20,END=4) LINE
         IF(I.GT.NFP) THEN
           STOP ' Fatal error: More than 150 F.Ps'
         ENDIF
       END DO
    4  CLOSE(LLL)
       KFP=I-1
       KPDO=KFP-KFPE
       IF (KPDO.LE.0) THEN
         STOP ' Fatal Error:  KFP-all  .LE.  KFP-explicit '
       ENDIF
       FLNM=BLNK
    5  WRITE(LTT,15) '      Define ENDF Library Summary file: '
       WRITE(LTT,15) '     ---------------------------------  '
       WRITE(LTT,15) '                     Default file name: ',FLIB
       WRITE(LTT,15) '$       Enter new name (enter=default): '
       READ (LKB,15) FLNM
       IF(FLNM.NE.BLNK) FLIB=FLNM
       OPEN (UNIT=LIB,FILE=FLIB,STATUS='OLD',ERR=5)
       I=1
       READ(LIB,20) LINE
       READ(LIB,20) LINE
       DO WHILE (LINE(1:8).NE.'        ')
         READ(LINE,40) MAT(I),ZASYM(I),AZL(I),AWR(I),SPOT(I),EH(I)
         I=I+1
         READ(LIB,20,END=6) LINE
         IF(I.GT.NMAT) THEN
           STOP ' Fatal error: More than 1024 ENDF materials'
         ENDIF
       END DO
    6  KMAT=I-1
       CLOSE(LIB)
C*
C* Define the group structure
    7  WRITE(LTT,15) '$        Enter total number of groups : '
       READ (LKB,90) NGI
       IF(NGI.NE.0)   NGND =NGI
       IF(NGND.EQ.69) THEN
         NFG=14
         NRG=13
         IGREF=10
       ELSE IF(NGND.EQ.172) THEN
         NFG=45
         NRG=47
         IGREF=34
       ELSE
         WRITE(LTT,15) ' Invalid number of groups (69 or 172)   '
         GO TO 7
       END IF
C*
C*       Process *.njb files for U-235, u-238 and Pu-239
       FLNM=BLNK
       DO IT=1,2
        IF (IT.EQ.1) THEN
         NNN=KFPE
         WRITE(LTT,15) ' Define fiss. yields for explicit F.Ps  '
        ELSE
         NNN=KFP
         WRITE(LTT,15) '     Define fiss. yields for all F.Ps   '
        ENDIF
        DO KF=1,NFIS
    8    WRITE(LTT,16) '     Define the yield (*.NJB) file for: ',
     &                                                     FZASYM(KF)
         WRITE(LTT,17) '              Number of F.P. should be: ',NNN
         WRITE(LTT,15) '     ---------------------------------  '
         WRITE(LTT,15) '                     Default file name: ',FLNM
         WRITE(LTT,15) '$       Enter new name (enter=default): '
         READ (LKB,15) FLNM
         IF(FLNM.EQ.BLNK) GO TO 8
         OPEN (UNIT=LNB,FILE=FLNM,STATUS='OLD',ERR=8)
         DO I=1,NNN
          IF (IT.EQ.1) THEN
            YE(KF,I)=0.0
          ELSE
            Y(KF,I)=0.0
          ENDIF
         END DO
         READ(LNB,60)KKK
         KKK=KKK-4
         DO KK=1,KKK
           READ(LNB,60)IDUMMY,FPY
           KTRI=-1
           DO I=1,NNN
             IF((IT.EQ.1).AND.((NINT(RIDE(I)).EQ.IDUMMY))) THEN
               YE(KF,I)=FPY
               KTRI=1
             ELSE IF((IT.EQ.2).AND.((NINT(RID(I)).EQ.IDUMMY))) THEN
               Y(KF,I)=FPY
               KTRI=1
             ENDIF
           END DO
           IF(KTRI.LT.0) THEN
            WRITE(LTT,*)' Error: Lst & Yields files are not compatible'
     &                  , ' IT= ', IT, ' I= ', I, ' KF= ', KF
            STOP
           END IF
         END DO
         CLOSE(LNB)
        END DO
       END DO
C*
C*       Checking if NFP and NFPE yields are compatible.
C*       Selecting isotopes for pseudo fission product generation
       DO I=1,KFP
         IPYP(I)=0
         IAZ=NINT(RID(I))
         II=-1
         K=1
         DO WHILE (II.LT.0)
          KAZ=NINT(RIDE(K))
          IF (IAZ.NE.KAZ) THEN
            K=K+1
          ELSE
            II=1
            RID(I)=RIDE(K)
            IPYP(I)=-1
            DO KF=1,NFIS
              IF (YE(KF,K) .EQ. 0.0) THEN
                IF (Y(KF,I) .EQ. 0.0 ) THEN
                  DIF=0.0
                ELSE
                  DIF=1.0
                ENDIF
              ELSE
                DIF=ABS(Y(KF,I)/YE(KF,K)-1.0)
              ENDIF
              IF (DIF.GT.1.0E-6) THEN
              WRITE(LTT,91)' Warning: Fission yields do not match ',
     &                       IAZ,Y(KF,I),YE(KF,K),KF
              ENDIF
            END DO
          ENDIF
          IF (K.GT.KFPE) II=2
         END DO
       END DO
       DO I=1,KFP
        IF (IPYP(I).GE.0) THEN
         KK=-1
         DO KF=1,NFIS
           IF(Y(KF,I).GT.0.0) KK=1
         END DO
         IF (KK.LT.0) THEN 
           IPYP(I)=-3
           WRITE(LTT,92)
     &     ' Warning: Fission Product with ZA= ',RID(I),
     &     ' has null fission yield for U-235, U-238 and Pu-239'           
         ENDIF  
        ENDIF
       END DO
C*
C*       Open OUTPUT files
C*
C*        NJOY
       FLNM=BLNK
   10  WRITE(LTT,15) '         Define NJOY input option file: '
       WRITE(LTT,15) '         -----------------------------  '
       WRITE(LTT,15) '                     Default file name: ',FNJ
       WRITE(LTT,15) '$       Enter new name (enter=default): '
       READ (LKB,15) FLNM
       IF(FLNM.NE.BLNK) FNJ=FLNM
       OPEN (UNIT=LNJ,FILE=FNJ,ERR=10)
C*
C*        WILLIE
       FLNM=BLNK
   11  WRITE(LTT,15) '       Define WILLIE input option file: '
       WRITE(LTT,15) '       -------------------------------  '
       WRITE(LTT,15) '                     Default file name: ',FWLI
       WRITE(LTT,15) '$       Enter new name (enter=default): '
       READ (LKB,15) FLNM
       IF(FLNM.NE.BLNK) FWLI=FLNM
       OPEN (UNIT=LWI,FILE=FWLI,ERR=11)
C*
C*        BATCH FILE
       FLNM=BLNK
   12  WRITE(LTT,15) '         Define command filename      : '
       WRITE(LTT,15) '         -----------------------------  '
       WRITE(LTT,15) '                     Default file name: ',FBAT
       WRITE(LTT,15) '$       Enter new name (enter=default): '
       READ (LKB,15) FLNM
       IF(FLNM.NE.BLNK) FBAT=FLNM
       OPEN (UNIT=LBT,FILE=FBAT,ERR=12)
C* Default Unix script file (arbitrary extension --> ISYS=1)
       ISYS=1
       DO J=1,40
         IF(FBAT(J:J).EQ.'.') THEN
C* Check if DOS Batch file is required (extension ".bat" --> ISYS=0)
           IF( (FBAT(J+1:J+1).EQ.'B' .OR. FBAT(J+1:J+1).EQ.'b') .AND.
     2         (FBAT(J+2:J+2).EQ.'A' .OR. FBAT(J+2:J+2).EQ.'a') .AND.
     3         (FBAT(J+3:J+3).EQ.'T' .OR. FBAT(J+3:J+3).EQ.'t')) ISYS=0
         END IF
       END DO
C*
C*      Check if the fission products are on the library
       DO KF=1,NFIS
         YPSUM(KF)=0.0
       END DO
       DO J=1,KFP
       IF(IPYP(J).GE.0) THEN
        JAZ=NINT(10.0*AZ(J))
        I=1
        II=-1
        DO WHILE (II.LT.0)
          IF (ZASYM(I)(11:11).EQ.'M'.OR.ZASYM(I)(11:11).EQ.'m') THEN
            IAZ=NINT(10.0*AZL(I))+1
          ELSE
            IAZ=NINT(10.0*AZL(I))
          ENDIF
          IF (JAZ.EQ.IAZ) THEN
            II=1
            IPYP(J)=I
            DO KF=1,NFIS
              YPSUM(KF)=YPSUM(KF)+Y(KF,J)
            END DO
          ELSE
            I=I+1
          ENDIF
          IF (I.GT.KMAT) II=2
        END DO
        IF (II.EQ.2) THEN
          IPYP(J)=-2
          WRITE(LTT,*)' Warning: Material with ZA= ',AZ(J),
     &                ' not found on the library file'
        ENDIF
       ENDIF
       END DO
       DO J=1,KFP
        I=IPYP(J)
        IF (I.GT.0) THEN
          XX=0.0
          DO KF=1,NFIS
            XP(KF,J)=Y(KF,J)/YPSUM(KF)
            XX=XX+XP(KF,J)*XF(KF)/100.0
          END DO
          IF (XX.GT.5.0E-7) THEN
            XX=SREF0/XX
          ELSE
            XX=1.0E10
          ENDIF
          CALL PNJ(LNJ,MAT(I),ZASYM(I),AWR(I),SPOT(I),
     &             EH(I),XX,RID(J),FMAT(J),NGND,NFG,NRG,IGREF)
        ENDIF
       END DO
       CALL PWL(LWI,NFIS,KFP,IPYP,FMAT,XP,YPSUM,XF,FZASYM)
       IF     (ISYS.EQ.0) THEN
C* Write DOS Batch file
         CALL PBTDOS(LBT,KFP,IPYP,FMAT,NGND)
       ELSE IF(ISYS.EQ.1) THEN
C* Write Unix script file
         CALL PBTUNX(LBT,KFP,IPYP,FMAT)
       END IF
       CLOSE(LNJ)
       CLOSE(LWI)
       CLOSE(LBT)
       STOP 'PSEUDO NORMAL END'
   15  FORMAT(2A40)
   16  FORMAT(A40,A11)
   17  FORMAT(A40,I5)
   20  FORMAT(A80)
   30  FORMAT(2F11.0)
   40  FORMAT(I4,2X,A11,F9.0,F12.0,F12.0,1PE13.0)
   50  FORMAT(A28,F8.1,A30)
   60  FORMAT(I6,E11.0)
   90  FORMAT(BN,I10)
   91  FORMAT(A38,I8,1P2E12.4,I8)
   92  FORMAT(A35,F9.1,A51)
      END
      SUBROUTINE PNJ(LNJ,MAT,ZASYM,AWR,SPOT,EH,SREF,WMAT,FNAME
     1              ,NGND,NFG,NRG,IGREF)
C*
C*    Prepare NJOY input
C*
      PARAMETER (NS0=10,NT=10,NMAX=178,N7=7,N28=28,I2=2,NP2=92)
      PARAMETER (Z0=0.0,N0=0,N1=1,N5=5,NPFLX=20000,NP1=27,NR=10)
      CHARACTER*68 LINE
      CHARACTER*11 ZASYM
      CHARACTER*9  LNAME
      CHARACTER*6  FNAME
      DIMENSION TEMP(NT),SIG0(NS0),WGHT(NMAX),P1FLX(NP1),ERW(NR)
      DIMENSION AI(N7),XLBD(N7),WSPACE(N28),P2FLX(NP2)
C*
C*    Lambda values according to F. Leszczynski using 0.98 for Be.
      DATA AI/1.007828,  9.012199,  15.990527, 26.981535,
     &       55.934505, 91.219620, 238.050980/
      DATA XLBD/ 1.000,     0.980,      0.957,     0.807,
     &           0.524,     0.372,      0.200/
C*
C*    END Library
      DATA LNAME/'ENDF/B-VI'/
C*
C*    Group boundaries for the lower 9 resonance groups in the
C*    69 energy group structure.
      DATA ERW/1425.1  , 906.898, 367.262, 148.728, 75.501,
     &           48.052,  27.7,    15.968,   9.877,  4.000/
C*
C*    General NJOY input options for fission products.
      DATA KT/1/,KS0/2/
      DATA TEMP/700.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0/
      DATA SIG0/1.0E10,1.0E5,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0/
      DATA ERR/0.002/,TEMPR/0.0/,ERRMAX/0.005/
      DATA ERRTHN/0.002/
      DATA NBIN/12/,IINC/1/,ICOH/0/,NATOM/1/,MTREF/221/
      DATA TOL/0.005/,EMAX/4.0/
      DATA IGN/9/,IGG/0/,IWT/-1/,LORD/1/,MT252/252/,MF3/3/,MF6/6/
C* Neutron spectrum weighting function
      DATA WGHT/
     & 1.0000E-5, 5.250E-04, 9.0000E-3, 3.550E-01, 1.6000E-2, 5.520E-01
     &,2.4000E-2, 7.120E-01, 2.9000E-2, 7.850E-01, 3.3000E-2, 8.290E-01
     &,4.3000E-2, 8.980E-01, 5.0000E-2, 9.180E-01, 5.4000E-2, 9.210E-01
     &,5.9000E-2, 9.180E-01, 7.0000E-2, 8.920E-01, 9.0000E-2, 7.990E-01
     &,1.1200E-1, 6.860E-01, 1.4000E-1, 5.200E-01, 1.7000E-1, 3.830E-01
     &,2.1000E-1, 2.520E-01, 3.0000E-1, 1.080E-01, 4.0000E-1, 6.870E-02
     &,4.9000E-1, 5.100E-02, 5.7000E-1, 4.370E-02, 6.0000E-1, 4.130E-02
     &,1.0000E+0, 2.491E-02, 4.0000E+0, 6.786E-03, 9.1180E+3, 2.977E-06
     &,2.0000E+4, 1.413E-06, 3.0700E+4, 9.884E-07, 6.0700E+4, 5.814E-07
     &,1.2000E+5, 3.677E-07, 2.0100E+5, 2.770E-07, 2.8300E+5, 2.432E-07
     &,3.5600E+5, 2.344E-07, 3.7700E+5, 2.160E-07, 3.9900E+5, 1.738E-07
     &,4.4200E+5, 6.395E-08, 4.7400E+5, 1.381E-07, 5.0200E+5, 1.672E-07
     &,5.4000E+5, 1.936E-07, 6.5000E+5, 1.872E-07, 7.7000E+5, 1.587E-07
     &,9.0000E+5, 1.363E-07, 9.4100E+5, 1.134E-07, 1.0000E+6, 7.268E-08
     &,1.0500E+6, 9.139E-08, 1.1200E+6, 1.083E-07, 1.1900E+6, 1.228E-07
     &,1.2100E+6, 1.192E-07, 1.3100E+6, 5.451E-08, 1.4000E+6, 9.666E-08
     &,2.2200E+6, 4.684E-08, 2.3500E+6, 5.814E-08, 2.6300E+6, 3.807E-08
     &,3.0000E+6, 2.965E-08, 4.0000E+6, 1.626E-08, 5.0000E+6, 8.634E-09
     &,6.0000E+6, 4.490E-09, 8.0000E+6, 1.169E-09, 1.0000E+7, 2.947E-10
     &,1.2570E+7, 2.304E-11, 1.2600E+7, 2.236E-11, 1.2700E+7, 2.024E-11
     &,1.2800E+7, 1.832E-11, 1.2900E+7, 1.658E-11, 1.3000E+7, 1.501E-11
     &,1.3100E+7, 1.358E-11, 1.3200E+7, 1.229E-11, 1.3300E+7, 1.112E-11
     &,1.3400E+7, 1.006E-11, 1.3500E+7, 9.108E-12, 1.3600E+7, 8.242E-12
     &,1.3700E+7, 7.458E-12, 1.3800E+7, 6.748E-12, 1.3900E+7, 6.106E-12
     &,1.4070E+7, 5.151E-12, 1.4200E+7, 4.522E-12, 1.4300E+7, 4.091E-12
     &,1.4400E+7, 3.702E-12, 1.4500E+7, 3.349E-12, 1.4600E+7, 3.030E-12
     &,1.4700E+7, 2.741E-12, 1.4800E+7, 2.479E-12, 1.4900E+7, 2.243E-12
     &,1.5000E+7, 2.029E-12, 1.5100E+7, 1.835E-12, 1.5200E+7, 1.660E-12
     &,1.5300E+7, 1.501E-12, 1.5400E+7, 1.358E-12, 1.5500E+7, 1.228E-12
     &,1.5676E+7, 1.029E-12, 2.0000E+7, 1.317E-14 /
      DATA IPRW/2/,IVERW/4/,IGROUP/9/
      DATA IBURN/1/
      DATA IRES/0/,SIGP/0.0/,MTC/0/
      DATA IP1/1/,INORF/1/,IFFP/1/,ISOF/0/
      DATA NTIS/2/,EFIS/0.0/
      DATA IDCAP/0/,BR/0.0/,IDDY/0/,DY/0.0/
C*
C*     69-group British current spectrum
      DATA P1FLX/
     & 1.1800,2.763 ,4.9220,3.964 ,2.517 ,2.121 ,1.199 ,0.964 ,0.7172,
     & 0.5436,0.4331,0.3631,0.3168,0.2871,0.2677,0.231 ,0.2214,0.2143,
     & 0.2105,0.4124,0.4056,0.3008,0.2002,0.2432,0.2416,0.2094,0.3891/
C*    172-group BAPL-2 current spectrum (F.Leszczynski)
      DATA P2FLX/
     &  0.0006,0.0030,0.0054,0.0409,0.0861,0.3949,1.1086,0.7586
     & ,1.2618,3.2357,3.9678,4.9636,6.9212,4.2661,3.3180,6.0327
     & ,5.7817,2.4843,2.3472,1.8506,1.8450,1.8449,6.3888,1.7717
     & ,1.7717,0.9957,1.0067,3.1545,0.9850,0.9497,2.4542,2.5402
     & ,0.5742,1.4315,0.9019,0.8264,1.1311,0.3177,0.7200,0.2163
     & ,0.3165,1.1857,0.2828,0.8154,0.5261,0.5161,0.7468,0.2470
     & ,0.8418,0.1176,0.9349,0.2302,0.6852,0.1147,0.3433,0.4453
     & ,0.2211,0.4504,0.2174,0.8891,0.4404,0.4383,0.8372,0.6683
     & ,0.1785,0.7976,0.3989,0.2204,0.3925,0.1561,0.1384,0.1194
     & ,0.2399,0.1302,0.1512,0.1918,0.2048,0.2020,0.1953,0.2095
     & ,0.3896,0.2982,0.3914,0.2455,0.1451,0.1876,0.1864,0.2603
     & ,0.2357,0.1057,0.3682,0.0590/
C*
      IF     (NGND.EQ. 69) THEN
	      JP1= NFG+NRG
        IGN= 9
      ELSE IF(NGND.EQ.172) THEN
	      JP1= NFG+NRG
        IGN=18
      ELSE
        JP1= 0
      END IF
C*
C*     Interpolate Lambda values using cubic Spline functions.
      CALL FINSP3(AI,XLBD,N7,AWR,XLBDA,DER,1,0.0,0.0,WSPACE)
C*
C*      Select Ehigh for the flux calculator of NJOY
       II=-1
       I=1
       DO WHILE(II.LT.0)
         IF(EH.GE.ERW(I)) THEN
           EFLUX=ERW(I)
           II=1
         ELSE
           I=I+1
         END IF
         IF (I.GT.NR) THEN
          EFLUX=EH
          II=1
         ENDIF
       END DO
C*
C*      Select reference sigma0
       ISGREF=1
       KS0=1
       IF (SREF.LT.1.0E9) THEN
         SIG0(I2)=SREF
         ISGREF=I2
         KS0=I2
       ENDIF
C*
C*      Generate the file name
       IF (ZASYM(4:4).EQ.'-') THEN
         IZ=5
       ELSE IF (ZASYM(5:5).EQ.'-') THEN
         IZ=6
       ELSE
         STOP ' Fatal error: ZASYM format ERROR'
       ENDIF
       FNAME='      '
       K=1
       DO IK=IZ,11
        IF (ZASYM(IK:IK).NE.'-'.AND.ZASYM(IK:IK).NE.' ') THEN
          FNAME(K:K)=ZASYM(IK:IK)
          K=K+1
        ELSE IF (ZASYM(IK:IK).EQ.' '.AND.K.NE.1.AND.K.NE.6) THEN
          FNAME(K:K)='_'
          K=K+1
        ENDIF
       END DO
       IF(FNAME(6:6).EQ.' ') FNAME(6:6)='p'
C*
C*    Write the NJOY INPUT FILE
       WRITE(LNJ,10)'--        PSEUDO FISSION      ---          '
       WRITE(LNJ,20)'-- ',FNAME,'  PROCESS  ',ZASYM
C*   moder
       WRITE(LNJ,10)'moder  / Convert data to binary on Unit-21 '
       WRITE(LNJ,30)1,-21
       WRITE(LNJ,40)'''',LNAME,ZASYM,'''',' /'
       WRITE(LNJ,50)20,MAT
       WRITE(LNJ,60)'0 /'
C*   reconr
       WRITE(LNJ,10)'reconr / Reconstruct xs on Unit-22         '
       WRITE(LNJ,30)-21,-22
       WRITE(LNJ,65)'''',' PEND TAPE FOR ',ZASYM,' FROM ',
     &              LNAME,'''',' /'
       WRITE(LNJ,68)MAT,2,' /'
       WRITE(LNJ,80)ERR,TEMPR,ERRMAX,' /'
       WRITE(LNJ,90)'''',ZASYM,' FROM ',LNAME,'''',' /'
       WRITE(LNJ,100)'''',' PROCESSED BY NJOY-99.90+','''',' /'
       WRITE(LNJ,60)'0 /'
C*   broadr
       WRITE(LNJ,10)'broadr / Doppler broaden on Unit-23        '
       WRITE(LNJ,30)-21,-22,-23
       WRITE(LNJ,110)MAT,KT,N0,N1,TEMPR,' /'
       WRITE(LNJ,120)ERRTHN,' /'
       WRITE(LNJ,130)(TEMP(K),K=1,KT)
       WRITE(LNJ,60)'0 /'
C*   unresr
       WRITE(LNJ,10)'unresr / UR. Dopp. & Self-shield on Unit-24'
       WRITE(LNJ,30)-21,-23,-24
       WRITE(LNJ,110)MAT,KT,KS0,N1
       WRITE(LNJ,130)(TEMP(K),K=1,KT)
       WRITE(LNJ,140)(SIG0(K),K=1,KS0)
       WRITE(LNJ,60)'0 /'
C*   thermr
       WRITE(LNJ,10)'thermr / Add thermal scattering on Unit-26 '
       WRITE(LNJ,30)0,-24,-26
       WRITE(LNJ,50)N0,MAT,NBIN,KT,IINC,ICOH,NATOM,MTREF,N1
       WRITE(LNJ,130)(TEMP(K),K=1,KT)
       WRITE(LNJ,150)TOL,EMAX
C*   groupr
       WRITE(LNJ,10)'groupr / Generate GENDF tape on Unit-25    '
       WRITE(LNJ,30)-21,-26,0,-25
       WRITE(LNJ,70)MAT,IGN,IGG,IWT,LORD,KT,KS0,N1
       WRITE(LNJ,160)'''',ZASYM,' FROM ',LNAME,'''',' /'
       WRITE(LNJ,130)(TEMP(K),K=1,KT)
       WRITE(LNJ,140)(SIG0(K),K=1,KS0)
       IF (IWT.LT.0) WRITE(LNJ,170)EFLUX,SPOT,NPFLX,' / Homogeneous'
       IF (IABS(IWT).EQ.1)THEN
         WRITE(LNJ,180)Z0,Z0,N0,N0,N1,NMAX/2
         WRITE(LNJ,190)NMAX/2,N5
         IROW=NMAX/6
         ILAST=NMAX-IROW*6
         IF (ILAST.EQ.0) THEN
           IROW=IROW-1
           ILAST=6
         ENDIF
         IROW=6*IROW
         WRITE(LNJ,200)(WGHT(K),K=1,IROW)
         WRITE(LINE,200)(WGHT(IROW+K),K=1,ILAST)
         LINE(ILAST*11+1:ILAST*11+2)=' /'
         WRITE(LNJ,205)LINE
       ENDIF
       DO K=1,KT
        WRITE(LNJ,210)MF3,' /'
        WRITE(LNJ,220)MF3,MTREF,' /'
        WRITE(LNJ,220)MF3,MT252,' /'
        WRITE(LNJ,210)MF6,' /'
        WRITE(LNJ,220)MF6,MTREF,' /'
        WRITE(LNJ,60)'0 /'
       END DO
       WRITE(LNJ,60)'0 /'
C*   wimsr
       WRITE(LNJ,10)'wimsr / Process data for WIMS              '
       WRITE(LNJ,30)-25,27
       WRITE(LNJ,30)IPRW,IVERW,IGROUP
       WRITE(LNJ,30)NGND,NFG,NRG,IGREF
       WRITE(LNJ,230)MAT,N0,WMAT,IBURN
       WRITE(LNJ,240)N0,N0,SIG0(ISGREF),IRES,SIGP,MTREF,MTC,
     &               IP1,INORF,ISOF,IFFP,JP1
       WRITE(LNJ,250)NTIS,EFIS
       WRITE(LNJ,250)IDCAP,BR
       WRITE(LNJ,250)IDDY,DY
       WRITE(LNJ,260)(XLBDA,K=1,NRG)
         IF (JP1.GT.27) THEN
           WRITE(LNJ,270)(P2FLX(K),K=1,JP1)
           GO TO 300
         ENDIF
       WRITE(LNJ,270)(P1FLX(K),K=1,JP1)
C*    stop
300    WRITE(LNJ,10)'stop                                       '
       RETURN
   10  FORMAT(A43)
   20  FORMAT(A3,A6,A11,A11)
   30  FORMAT(I3,3I4)
   40  FORMAT(A1,1X,A9,1X,A11,A1,A2)
   50  FORMAT(I3,I5,5I3,I4,I3)
   60  FORMAT(A3)
   65  FORMAT(A1,A15,A11,A6,A9,A1,A2)
   68  FORMAT(I4,I3,A2)
   70  FORMAT(I4,7I3)
   80  FORMAT(F5.3,F4.1,F6.3,A2)
   90  FORMAT(A1,A11,A6,A9,A1,A2)
  100  FORMAT(A1,A25,A1,A2)
  110  FORMAT(I4,3I3,F4.1,A2)
  120  FORMAT(F5.3,A2)
  130  FORMAT(F6.1,9F7.1)
  140  FORMAT(1P,E7.1,9E8.1)
  150  FORMAT(F5.3,F6.2)
  160  FORMAT(A1,A11,A6,A9,A1,A2)
  170  FORMAT(F8.2,F8.4,I6,A14)
  180  FORMAT(2F11.4,4I11)
  190  FORMAT(2I11)
  200  FORMAT(3(1PE11.4,1PE11.3))
  205  FORMAT(A68)
  210  FORMAT(I3,A2)
  220  FORMAT(I3,I4,A2)
  230  FORMAT(I4,I3,F9.1,I3)
  240  FORMAT(I2,I3,1PE8.1,I3,0PF8.4,2I4,4I3,I4)
  250  FORMAT(I6,1PE11.4)
  260  FORMAT(13F5.2)
  270  FORMAT(9F7.4)
      END
      SUBROUTINE FINSP3(XI,YI,N,XO,YO,Y1,M,F1,F2,SC)
C-Title  : FINSP3 Subroutine
C-Purpose: Interpolate a set of points using cubic spline
C-Description:
C-D  Interpolate a set of points using cubic splines. The parameters
C-D  are the following:
C-D    N   number of points on input argument mesh
C-D   XI   input argument mesh (array of N values in momotonic order)
C-D   YI   function values corresponding to XI(i)
C-D    M   number of points in the output mesh
C-D   XO   output argument mesh (array of M values in monotonic order)
C-D   YO   interpolated function values corresponding to XO(i) (Output)
C-D   Y1   interpolated derivative values corresponding to XO(i) (Output)
C-D        NOTE: if derivatives ara not required, the same array may be
C-D              specified for Y0 and Y1 (i.e.: implicit equivalence)
C-D   F1   second derivative in the first interval (usually zero)
C-D   F2   second derivative in the last  interval (usually zero)
C-D   SC   scratch array of length 3N+Max(N,M) (or more)
C-D
C-Extern.: MTXDG3
C-Literat: K.E.Atkinson, An Introduction to Numerical Analysis,
C-L        John Wiley and Sons, New York, (1978)
C-Author : A.Trkov, Institute J.Stefan, Ljubljana, Slovenia (1991)
      DIMENSION XI(*), YI(*), XO(*), YO(*), Y1(*), SC(*)
      IF(N.LT.3) GO TO 80
C* Define the function and the tri-diagonal matrix
      N3 = N*3
      N2 = N-2
      HO = XO(2) - XO(1)
      H2 = XI(2) - XI(1)
      Z2 = YI(2) - YI(1)
      K  = 1
      IF(HO*H2.LT.0) K =-1
      DO 30 I=1,N2
      H1 = H2
      H2 = XI(I+2) - XI(I+1)
      IF(H1*H2.LT.0) STOP 'FINSP3 non-monotonic argument'
      Z1 = Z2
      Z2 = YI(I+2) - YI(I+1)
      I3 =(I-1)*3
      SC(1+I3) = H1     / 6.
      SC(2+I3) =(H1+H2) / 3.
      SC(3+I3) =    H2  / 6.
      SC(I+N3) = Z2/H2  - Z1/H1
   30 CONTINUE
C* Solve for the second derivatives of the interpolated function
      CALL MTXDG3 (SC,SC(N3+1),SC(N3+2),N2,0)
      SC(N3+1)=F1
      SC(N3+N)=F2
C* Interpolate to the specified output grid
      L = 1
      IF(K.LT.0) L = N-1
      DO 60 I=1,M
      X = XO(I)
C* Find the appropriate input argument mesh interval
   62 X1 = XI(L+1) - X
      X0 = X       - XI(L)
      IF(X0*X1.GE.0) GO TO 64
      L = L + K
      IF(L.GE.1 .AND. L.LT.N) GO TO 62
C* Calculate the interpolated derivative and function
   64 H1 = XI(L+1) - XI(L)
      Y1(I)= (  - X1*X1*SC(N3+L) +    X0*X0*SC(N3+L+1) ) / (H1 * 2.)
     1     - (          YI(   L) -          YI(   L+1) ) /  H1
     2     + (          SC(N3+L) -          SC(N3+L+1) ) *  H1 / 6.
      YO(I)= ( X1*X1*X1*SC(N3+L) + X0*X0*X0*SC(N3+L+1) ) / (H1 * 6.)
     1     + (    X1 *  YI(   L) +    X0 *  YI(   L+1) ) /  H1
     2     - (       X1*SC(N3+L) +       X0*SC(N3+L+1) ) *  H1 / 6.
   60 CONTINUE
      RETURN
C* Special case when less than 3 input points
   80 C0 = YI(1)
      C1 = 0.
      IF(N.LT.2) GO TO 81
      C1 = (YI(2)-YI(1))/(XI(2)-XI(1))
      C0 = C0 - C1*XI(1)
   81 DO 82 I=1,M
      Y1(I) =      C1
      YO(I) = C0 + C1*XO(I)
   82 CONTINUE
      RETURN
      END
      SUBROUTINE MTXDG3(A,F,X,N,IF)
C-Title  : MTXDG3 subroutine
C-Purpose: Tridiagonal Matrix solver, Gauss elimination, no pivoting
C-Description:
C-D Solve a set of linear simultaneous equations  A x = F  (order n)
C-D assuming matrix A is tridiagonal, rows stored in first index of A.
C-D Crout-Choleski matrix decomposition, no pivoting (A = LU).
C-D Options: if=0  -decompose matrix and solve
C-D             1  -decompose matrix only
C-D             2  -solve for new F assuming matrix is decomposed
C-Author : A.Trkov , Institute J.Stefan Ljubljana, 1986
      DIMENSION A(3,N),F(N),X(N)
      N1=N-1
      IF(IF.GT.1) GO TO 45
C* Matrix decomposition - forward sweep  (A = LU)
      IF(N.LT.2) GO TO 42
      A(3,1)=-A(3,1) /  A(2,1)
      DO 40 I=2,N1
      A(2,I)= A(2,I) + A(1,I)*A(3,I-1)
   40 A(3,I)=-A(3,I) / A(2,I)
      A(2,N)= A(2,N) + A(1,N)*A(3,N1)
   42 IF(IF.GT.0) RETURN
C* Forward sweep (p = L-1 F)
   45 F(1)=  F(1)                / A(2,1)
      DO 50 I=2,N
   50 F(I)= (F(I)-A(1,I)*F(I-1)) / A(2,I)
C* Backward sweep (x = U-1 p)
      X(N)=F(N)
      DO 60 I=1,N1
      NI=N-I
   60 X(NI)= F(NI) + A(3,NI)*X(NI+1)
      RETURN
      END
      SUBROUTINE PWL(LWI,NFIS,KFP,IPYP,FMAT,XP,YPSUM,XF,FZASYM)
C*
C*      Prepare WILLIE input
C*
        CHARACTER*12 FFF(10)
        CHARACTER*11 FZASYM
        CHARACTER*6  FMAT
        DIMENSION FMAT(*),XP(NFIS,*),IPYP(*)
        DIMENSION XF(NFIS),FZASYM(NFIS),YPSUM(NFIS)
        WRITE(LWI,10)' 10. Pseudo Fission Product '
        WRITE(LWI,10)'     ---------------------- '
        WRITE(LWI,*)
        WRITE(LWI,*)
        WRITE(LWI,*)
        DO KF=1,NFIS
          FFF(KF)(1:1)=FZASYM(KF)(5:5)
          IF (FZASYM(KF)(6:6).EQ.' ') THEN
            FFF(KF)(2:2)='_'
          ELSE
            FFF(KF)(2:2)=FZASYM(KF)(6:6)
          ENDIF
          FFF(KF)(3:5)=FZASYM(KF)(8:10)
          FFF(KF)(6:12)='PFP.XSW'
          NWID=4900+KF
          WRITE(LWI,20)' Process Pseudo Fission Product for ',FZASYM(KF)
          WRITE(LWI,30)'                           XSW file ',FFF(KF)
          WRITE(LWI,35)'                 Total fission yield',YPSUM(KF)
          WRITE(LWI,*)
          WRITE(LWI,40)'MIXM'
          WRITE(LWI,50) FFF(KF)
          WRITE(LWI,55) NWID
          DO J=1,KFP
            IF (IPYP(J).GT.0) THEN
              XX=XP(KF,J)*100.00
              WRITE(LWI,60)FMAT(J),'.XSW'
              WRITE(LWI,70)XX
            END IF
          END DO
          WRITE(LWI,*)
          WRITE(LWI,*)
        END DO
        WRITE(LWI,*)
        WRITE(LWI,20)' Create Pseudo Fission Product 4902 '
        WRITE(LWI,30)'                           XSW file ',
     &               'PFP4902.XSW '
        WRITE(LWI,20)' Relative composition in percent [%]'
        DO KF=1,NFIS
          WRITE(LWI,36)FZASYM(KF),XF(KF)
        END DO
        WRITE(LWI,*)
        WRITE(LWI,40)'MIXM'
        WRITE(LWI,50)'PFP4902.XSW '
        WRITE(LWI,55) 4902
        DO KF=1,NFIS
          WRITE(LWI,50)FFF(KF)
          WRITE(LWI,70)XF(KF)
        END DO
        WRITE(LWI,*)
        WRITE(LWI,*)
        WRITE(LWI,40)'END '
        RETURN
   10   FORMAT(6X,A28)
   20   FORMAT(6X,A36,1X,A11)
   30   FORMAT(6X,A36,1X,A12)
   35   FORMAT(6X,A36,1X,1PE11.5)
   36   FORMAT(12X,A11,1X,F10.4)
   40   FORMAT(A4)
   50   FORMAT(A12)
   55   FORMAT(I6)
   60   FORMAT(A6,A4)
   70   FORMAT(1PE11.5)
      END
      SUBROUTINE PBTDOS(LBT,KFP,IPYP,FMAT,NGND)
C*
C*      Prepare DOS batch file to run NJOY and WILLIE
C*
      CHARACTER*6 FMAT(*)
      DIMENSION IPYP(*)
      WRITE(LBT,10)'@echo off'
      WRITE(LBT,10)'ECHO.    '
      WRITE(LBT,20)'ECHO     NJOY PROCESSING OF PSEUDO F. P. FOR WLUP  '
      WRITE(LBT,20)'ECHO     ----------------------------------------  '
      WRITE(LBT,10)'REM      '
      WRITE(LBT,20)'REM  Usage: BATCHNAME  %1                          '
      WRITE(LBT,20)'REM    BATCHNAME: This batch file name.            '
      WRITE(LBT,20)'REM      (Usually: endfb6fp, jef22fp, cendlfp, etc)'
      WRITE(LBT,20)'REM    %1: Evaluated Nuclear Data Library          '
      WRITE(LBT,20)'REM      (6 character string)                      '
      WRITE(LBT,20)'REM      (ie., endfb6, jef22, cendl , etc)         '
      WRITE(LBT,20)'REM  Examples:                                     '
      WRITE(LBT,20)'REM    endfb6fp   endfb6                           '
      WRITE(LBT,20)'REM    jef22fp    jef22                            '
      WRITE(LBT,10)'REM      '
      WRITE(LBT,20)'IF .%WLUPP%==.        GOTO  ERR                    '
      WRITE(LBT,20)'IF NOT EXIST  TAPE20  GOTO  ERR                    '
      WRITE(LBT,10)'ECHO.    '
      WRITE(LBT,20)'ECHO %WLUPI%%1fp.NJI    >INP.                      '
      WRITE(LBT,20)'ECHO.                >>INP.                        '
      WRITE(LBT,20)'   %WLUPP%NJISPL<INP.                              '
      DO J=1,KFP
        IF(IPYP(J).GT.0) THEN
          WRITE(LBT,30)'CALL %WLUPP%runone ',FMAT(J)
        ENDIF
      END DO
      WRITE(LBT,20)'%WLUPP%willie<%WLUPI%%1fp.WLI                      '
      IF(NGND.EQ.69) THEN
       WRITE(LBT,20)'COPY PFP4902.XSW  %WLUPI%%1fp.XSW                 '
      ELSE
       WRITE(LBT,20)'COPY PFP4902.XSW  %WLUPI%%1gx.XSW                 '
      END IF
      WRITE(LBT,20)'ECHO  *****  NORMAL ENDING  *****                  '
      WRITE(LBT,10)'GOTO EXIT'
      WRITE(LBT,10)':ERR     '
      WRITE(LBT,20)'ECHO  ***** ABNORMAL ENDING *****                  '
      WRITE(LBT,10)':EXIT    '
      WRITE(LBT,20)'DEL INP.                                           '
   10 FORMAT(A9)
   20 FORMAT(A51)
   30 FORMAT(A19,A6)
      RETURN
      END
      SUBROUTINE PBTUNX(LBT,KFP,IPYP,FMAT)
C*
C*      Prepare UNIX script file to run NJOY aand WILLIE
C*
      CHARACTER*6 FMAT(*)
      DIMENSION IPYP(*)
      WRITE(LBT,20)"#!/bin/tcsh                                        "
      WRITE(LBT,20)"echo  '  ======================================= ' "
      WRITE(LBT,20)"echo  '  NJOY PROCESS. OF PSEUDO F. P. FOR WLUP  ' "
      WRITE(LBT,20)"echo  '  ======================================= ' "
      WRITE(LBT,20)"echo \\\\n                                         "
      WRITE(LBT,20)"echo 'Usage: BATCHNAME  %1                        '"
      WRITE(LBT,20)"echo '  BATCHNAME: This batch file name.          '"
      WRITE(LBT,20)"echo '  (Usually: endfb6fp, jef22fp, cendlfp, etc)'"
      WRITE(LBT,20)"echo '  %1: Evaluated Nuclear Data Library        '"
      WRITE(LBT,20)"echo '    (6 character string)                    '"
      WRITE(LBT,20)"echo '    (ie., endfb6, jef22, cendl , etc)       '"
      WRITE(LBT,20)"echo 'Examples:                                   '"
      WRITE(LBT,20)"echo '  endfb6fp   endfb6                         '"
      WRITE(LBT,20)"echo '  jef22fp    jef22                          '"
      WRITE(LBT,20)"echo '                                            '"
      WRITE(LBT,20)"if ( $?U_D == 0 ) setenv  U_D  ../..               "
      WRITE(LBT,20)"if ( $?WLUPP == 0 )setenv WLUPP $U_D/WLUP/PROGRAMS "
      WRITE(LBT,20)"if ( $?WLUPS == 0 )setenv WLUPS $U_D/WLUP/SCRIPTS  "
      WRITE(LBT,20)"if ( $?WLUPI == 0 )setenv WLUPI $U_D/WLUP/INPUTS   "
      WRITE(LBT,20)"if ( $?WLUPN == 0 )setenv WLUPN $U_D/NJOY97        "
      WRITE(LBT,20)"set lb1 = $<                                       "
      WRITE(LBT,20)"if ( ! -e tape20 ) goto ERR                        "
      WRITE(LBT,20)"if ( -e INP. ) rm INP.                             "
      WRITE(LBT,20)"echo $WLUPI/{$lb1}.NJI  >INP.                      "
      WRITE(LBT,20)"echo ' '    >>INP.                                 "
      WRITE(LBT,20)"$WLUPP/njispl<INP.                                 "
      DO J=1,KFP
        IF(IPYP(J).GT.0) THEN
      WRITE(LBT,20)"if ( -e  nji.file ) rm nji.file                    "
      WRITE(LBT,80)"echo ",FMAT(J)," >> nji.file                       "
      WRITE(LBT,20)"$WLUPS/runone.unx < nji.file                       "
        ENDIF
      END DO
      WRITE(LBT,20)"$WLUPP/willie<$WLUPI/{$lb1}.WLI                    "
      WRITE(LBT,20)"cp   PFP4902.XSW  $WLUPI/{$lb1}.XSW                "
      WRITE(LBT,20)"echo '*****  NORMAL ENDING  *****'                 "
      WRITE(LBT,10)"GOTO EXIT                                          "
      WRITE(LBT,10)"ERR:                                               "
      WRITE(LBT,20)"echo '***** ABNORMAL ENDING *****'                 "
      WRITE(LBT,10)"EXIT:                                              "
      WRITE(LBT,20)"rm  INP.                                           "
   10 FORMAT(A9)
   20 FORMAT(A51)
   30 FORMAT(A19,A6)
   80 FORMAT(A5,A6,A38)
      RETURN
      END
*deck qval_k 
      PROGRAM QVAL_K
C-Title  : Program QVAL_K
C-Purpose: Tabulate distribution of deviations in Keff from QVALUE output
C-Version: August 2002
C-Author : A.Trkov, International Atomic Energy Agency, Vienna, Austria
C-M
C-M  Manual for Program QVAL_K
C-M  =========================
C-M
C-M  The program complements the QVALUE program for analysing WLUP
C-M  benchmark results. It reads summary results files, grouping
C-M  calculated and measured K-eff values as a function of the
C-M  slowing down density, sorting them in ascending order of "q",
C-M  fitting a second order polynomial and tabulating them in
C-M  PLOTTAB format. The "points" file contains point data for
C-M  each library in the summary file (without error bars), followed
C-M  by the measured values (usually 1) with error bars. The "curves"
C-M  file contains the fitted curve for each library. The set
C-M  is repeated for each ebnchmark set.
C-M    The list of benchmark files is read from QVALUE.LST, if it
C-M  exists, otherwise an internally defined default is assumed.
C-
      PARAMETER   (MXPT=200,MXLB=10,MXFL=16,MXRW=2000)
      CHARACTER*10 LABL(10)
      CHARACTER*40 BLNK,FLNM,FLCU,FLPN,FLQL,FLQV(MXFL)
      CHARACTER*120 REC
C*
      DIMENSION    AKEF(MXPT,MXLB),QQ(MXPT),LID(MXPT)
     &            ,WGT(MXPT),PAR(10),RWO(MXRW)
C*
      DATA BLNK/'                                        '/
     1     FLQL/'QVALUE.LST'/
     1     FLQV/'CRIUME1.DAT'
     1         ,'CRIUME2.DAT'
     1         ,'CRIUOX1.DAT'
     1         ,'CRIUOX2.DAT'
     1         ,'CRIUOX3.DAT'
     1         ,'WWER1.DAT'
     1         ,'WWER2.DAT'
     1         ,'WWER3.DAT'
     1         ,'CRIMOX1.DAT'
     1         ,'CRIMOX2.DAT'
     1         ,'CRITISP.DAT'
     1         ,'BNLTH2O.DAT'
     1         ,'BNLTD2O.DAT'
     1         ,'D2OUO2.DAT'
     1         ,'D2OTHU5.DAT'
     1         ,'IRPhE.DAT'/
     2     FLCU/'QVAL_K.CUR'/
     3     FLPN/'QVAL_K.PNT'/
      DATA LQV,LCU,LPN,LQL,LKB,LTT/ 1, 2, 3, 4, 5, 6 /
C*
      WRITE(LTT,940) ' QVAL_K - Tabulate QVALUE output        '
      WRITE(LTT,940) ' ===============================        '
      WRITE(LTT,940)
C*
      NFL=16
      JFL=0
C* Try reading the list of benchmark sets from QVALUE.LST
      OPEN (UNIT=LQL,FILE=FLQL,STATUS='OLD',ERR=14)
   12 READ (LQL,940,END=14) FLNM
      IF(FLNM.EQ.BLNK) GO TO 12
      JFL=JFL+1
      IF(JFL.GT.MXFL) STOP 'QVAL_K ERROR - MXFL limit exceeded'
      FLQV(JFL)=FLNM
      GO TO 12
   14 IF(JFL.GT.0) NFL=JFL
C*
C* Ouptut curves and points files
      OPEN (UNIT=LCU,FILE=FLCU,STATUS='UNKNOWN')
      OPEN (UNIT=LPN,FILE=FLPN,STATUS='UNKNOWN')
C*
C* Loop over all QVALUE output files
      DO KFL=1,NFL
C*
C* Open the QVALUE output file for processing
        FLNM=FLQV(KFL)
        WRITE(LTT,940) ' Begin processing the file            : ',FLNM
        OPEN (UNIT=LQV,FILE=FLNM,STATUS='OLD')
C*
C* Interpret the library names from the header
        READ (LQV,980,END=60) REC
        NL =0
        I2 =6
   20   I1=I2+1
        I2=I2+10
        IF(REC(I1:I2).NE.'          ') THEN
          NL=NL+1
          IF(NL.GT.MXLB) STOP 'K ERROR - MXLB limit exceeded'
          LABL(NL)=REC(I1:I2)
          GO TO 20
        END IF
        WRITE(LTT,942) '                  Number of libraries : ',NL-2
C* Read the data
        NP =0
   30   READ (LQV,901,END=60) QQ(NP+1),(AKEF(NP+1,J),J=1,NL)
        NP=NP+1
C* Weights are inversely proportional to the relative uncertainty
          IF(AKEF(NP,NL).GT.0) THEN
            WGT(NP)=AKEF(NP,NL-1)/AKEF(NP,NL)
          ELSE
            WGT(NP)=1
          END IF
        IF(NP.GE.MXPT) STOP 'K ERROR - MXPT limit exceeded'
        GO TO 30
C*
   60   CONTINUE
        WRITE(LTT,942) '                  Number of points    : ',NP
C* Generate index to sort the data
        CALL SRTINM(NP,LID,QQ)
C*
C* Write the calculated values to the "points" file (no error bars)
        DO I=3,NL
C...      WRITE(LCU,910) LABL(I-2)
          WRITE(LPN,910) LABL(I-2)
          DO J=1,NP
            L=LID(J)
C...        WRITE(LCU,911) QQ(L),AKEF(L,I-2)
            WRITE(LPN,921) QQ(L),AKEF(L,I-2)
          END DO
C...      WRITE(LCU,940)
          WRITE(LPN,940)
C* Fit parabola through the calculated points
          L1=LID(1)
          L2=LID(NP)
          QL=QQ(L1)
          QH=QQ(L2)
          NC=2
          IF(NP.LE.8) NC=1
          CALL LSQPLN(NP,QQ,AKEF(1,I-2),WGT,NC,PAR,RWO,MXRW,IER)
          NN=21
          WRITE(LCU,910) LABL(I-2)
          DO J=1,NN
            XX=QL+(J-1)*(QH-QL)/(NN-1)
            YY=POLYNX(XX,PAR,NC)
            WRITE(LCU,911) XX,YY
          END DO
          WRITE(LCU,940)
        END DO
C* Write the measured values to the "points" file (with error bars)
        WRITE(LPN,910) FLNM(1:10)
        DO J=1,NP
          L=LID(J)
c...      IF(L.LT.1 .OR. L.GT.NP) PRINT *,'EROR J,L',J,L
          WRITE(LPN,921) QQ(L),AKEF(L,NL-1),AKEF(L,NL),AKEF(L,NL)
        END DO
        WRITE(LPN,940)
C* Tabulation for this reactor group completed
        CLOSE(UNIT=LQV)
      END DO
C*
      STOP 'QVAL_K COMPLETED'
C*
  901 FORMAT(F6.0,10F10.0)
  910 FORMAT(A10)
  911 FORMAT(2F11.8)
  921 FORMAT(1P,E11.4,22X,3E11.4)
  940 FORMAT(2A40)
  942 FORMAT( A40,I6)
  980 FORMAT(A120)
      END
      SUBROUTINE SRTINM(N,M,X)
C-Title  : SRTINM subroutine
C-Purpose: Perform a sort (on array indices) by Insertion method
C-Description:
C-D Sort the vector of N real numbers in X in ascending order
C-D The actual entries in X remain unaffected, but on exit,
C-D M (integer array) contains the addresses of the consecutive
C-D array entries to produce a sorted sequence,
C-Author : A.Trkov, Institute J.Stefan, Ljubljana, Slovenia (1990)
      DIMENSION M(1),X(1)
      M(1)=1
      DO 20 J=2,N
      M(J)=J
      K = J
      T = X(J)
   10 L = M(K-1)
      IF(X(L).LE.T) GO TO 12
      M(K)=L
      K   = K-1
      IF(K.GT.1) GO TO 10
   12 M(K)=J
   20 CONTINUE
      RETURN
      END
      SUBROUTINE LSQPLN(NP, XI, YI, WI, NC, QQ, RWO, LRW, IER)
C-Title  : LSQPLN Subroutine
C-Purpose: Calculate LSQ fit polynomial coefficients for a data set
      DIMENSION XI(1),YI(1),WI(1),QQ(1),RWO(1)
      IER=0
      NQ =NC+1
      NQ2=NQ*2
      LA =1
      LF =LA+NQ*NQ
      LC =LF+NQ
      LB =LC+NQ2
      IF(LB.GT.LRW) GO TO 90
      DO 14 J=LF,LB
      RWO(J)=0.
   14 CONTINUE
C* Generate solution matrix ans RHS vector coefficients
      DO 26 J=1,NP
      CC=WI(J)
      CF=CC*YI(J)
      DO 22 I=1,NQ2
      RWO(LC-1+I)=RWO(LC-1+I)+CC
      CC=CC*XI(J)
   22 CONTINUE
      DO 24 I=1,NQ
      RWO(LF-1+I)=RWO(LF-1+I)+CF
      CF=CF*XI(J)
   24 CONTINUE
   26 CONTINUE
C* Fill solution matrix elements with precalculated coefficients
      DO 40 I=1,NQ
      DO 40 J=I,NQ
      CC =RWO(LC-2+I+J)
      RWO(LA-1+(I-1)*NQ+J)=CC
      RWO(LA-1+(J-1)*NQ+I)=CC
   40 CONTINUE
C* Solve by gaussiona elimination with partial pivoting
      CALL MTXGUP(RWO(LA),RWO(LF),QQ,NQ,LDIG,DET)
      IF(DET.NE.0) RETURN
C* Error condition - determinant zero
      IER=1
      RETURN
C* Error condition - insufficient work array length
   90 IER=2
      RETURN
      END
      FUNCTION POLYNX(X,C,NC)
C-Title  : POLINX function
C-Purpose: Polynomial Pn(x) of order NC with NC+1 coefficients C(i)
      DIMENSION C(1)
      NC1=NC+1
      F  =C(NC1)
      IF(NC.LT.1) GO TO 20
      DO 10 I=1,NC
      F  =F*X + C(NC1-I)
   10 CONTINUE
   20 POLYNX = F
      RETURN
      END
      SUBROUTINE MTXGUP(A,F,X,N,LDIG,DET)
C-Title  : MTXGUP subroutine
C-Purpose: Matrix solver, Gauss elimination, part.pivoting
C-Description:
C-D Decompose matrix A, calculate determinant and/or solve a set of
C-D linear simultaneous equations  A x = F  (order n) using Gauss
C-D elimination technique with partial pivoting by rows.
C-D   Matrix elements are sequentially stored by rows (i.e. the
C-D first index refers to the column number).
C-Author : A.Trkov , Institute J.Stefan, Ljubljana, Slovenia
C-Version: 1984 Original coding
C-V 93/03 - improved zero-determinant trapping
C-V 00/11 - further refinement of zero-determinant trapping (A.Trkov)
C-
      DIMENSION A(N,N),F(N),X(N)
      DET=1.
      ER =1.
      DO 40 I=2,N
      I1=I-1
C* Find the pivot
      A1=0.
      DO 10 K=I1,N
      IF(ABS(A(K,I1)).LT.A1) GO TO 10
      A1=ABS(A(K,I1))
      K1=K
   10 CONTINUE
      IF(I1.LT.2) GO TO 12
      IF(ABS(A1/A0) .GT.1.E-5) GO TO 12
      DET=0.
      RETURN
   12 A0 =A1
      DET=DET*A1
      IF(K1.LT.I) GO TO 20
      A1=A(K1,I1)
      A(K1,I1)=A(I1,I1)
      A(I1,I1)=A1
      A1=F(K1)
      F(K1)=F(I1)
      F(I1)=A1
   20 DO 30 J=I,N
      X(J)=A(J,I1)/A(I1,I1)
      A(J,I1)=0.
   30 F(J)=F(J)-F(I1)*X(J)
      DO 40 J=I,N
      IF(K1.LT.I) GO TO 35
      A1=A(K1,J)
      A(K1,J)=A(I1,J)
      A(I1,J)=A1
   35 DO 40 K=I,N
      A1=A(K,J)
      A2=A1-A(I1,J)*X(K)
      IF(ABS(A1).GT.0.) ER=MIN(ER,ABS(A2/A1))
      A(K,J)=A2
   40 CONTINUE
C* Estimate number of digits lost due to subtraction
      LDIG=-LOG10(ER+1.E-33)+1.
C* Solve by backward substitution
   45 DO 60 I=2,N
      I1=N-I+2
      X(I1)=F(I1)/A(I1,I1)
      J1=N+1-I
      DO 60 J=1,J1
      F(J)=F(J)-X(I1)*A(J,I1)
   60 CONTINUE
      X(1)=F(1)/A(1,1)
      RETURN
      END
*deck qvalue 
      PROGRAM QVALUE_
C-Title  : Program QVALUE_
C-Purpose: Analyse WLUP benchmarks by slowing-down density q(E)
C-Author : F.Leszczynski, Ingenieria Nuclear
C-A                       Centro Atomico Bariloche, ARGENTINA
C-A        A.Trkov,       International Atomic Energy Agency
C-A                       Wagramerstrasse 5, Vienna, AUSTRIA
C-Version: August 2001, first release, (F.Leszczynski)
C-V  01/11 A.Trkov
C-V        - Sort results by ascending q(E)
C-V        - Add printout in PLOTTAB format
C-V  05/07 D.L. Aldama, IAEA/NDS Consultant
C-V        - Correction to skip " Average  " lines
C-M
C-M  QVALUE Program Users Guide
C-M  ==========================
C-M
C-M  The purpose of the program is
C-M  1. To calculate the q-value for each WLUP-benchmark lattice
C-M     by processing WIMS-D outputs for one library, and
C-M  2. To write tables for plotting Keff vs. q.
C-M     The Keff values are extracted from the SMRLIB output file.
C-M
C-M  The "q" is defined as the number of fission neutrons
C-M  reaching an arbitrarily chosen threshold energy. It is chosen
C-M  arbitrarily, but the value 2.6 eV is generaly agreed upon for
C-M  easier comparison of results). The "q" value characterises the
C-M  hardness of the spectrum. It is close to 1 for soft spectra
C-M  with little absorption and small for hard spectra. It is
C-M  formally defined by:
C-M
C-M      sum_g(g>2.6 eV)[ Phi(g) sum_h(h<2.6eV) Sig(g-->h) ]
C-M  q = ----------------------------------------------------
C-M                sum_g( Phi(g) nue(g) Sigf(g) )
C-M
C-M  where Phi is the cell spectrum read from the region edit.
C-M  Sig(g-->h) is the scattering matrix. Summation is performed
C-M  over matrix elements "h" corresponding to groups <2.6 eV (i.e.
C-M  scattering source to any anergy below 2.6 eV). Outer summation
C-M  has to be done over all groups "g" corresponding to energies
C-M  above 2.6 eV.
C-M  Reference: Dr.Andrej Trkov-IAEA-NDS (personal communication)
C
C In this program, the value of the threshold energy can be choosen, 
C giving on input file QVALUE.INP the number of "epithermal" 
C groups( ngep).
C The lower energy limit of this group will be the threshold energy.
C The value for this energy = 2.6 eV, corresponds to ngep = 29 for the
C standard 69-group WIMS-D library.
C The number of groups (ng) of the WIMS-D library can be changed on 
C QVALUE.INP C file. This value, ng and ngep cannot be exactly the 
C number of groups of the
C libraries but the main groups on WIMS-D calculations associated with
C q-calculation.
C
C
C INPUT FILES:
C
C 1) QVALUE.INP : See the file included on the package for explanation 
C      of this input. It is a standard file. It must be changed only if
C      the user wish to change some parameters included on it.
C      WARNING: This file is strongly dependent of the
C      other input files (names and order of data).
C
C     Rec. Parameter Content                                 Format
C      1    ng        Number of energy groups                  2I5
C           ngep      Number of epithermal groups
C      2    nlib      Number of libraries with Keff             I5
C     k=1,nlib:
C      3k   NOMLIBk   Names of libs (= smrlib.lst)             A10
C      4    nben      Number of benchmarks                      I5
C     i=1,nben:
C      5i   NOMBENi   Name of i-benchmark                       A7
C      6i   NOUTi     Number of WIMS-outp files f.bench.i       I5
C     j=1,NOUTi
C      7ij  NOMOUTij  Name of j-WIMS outp f.bench.i            A12
C      8ij  NCASij    Number of cases on j-WIMS outp f.bench.i  I5
C
C 2) SMRLIB.LST   This file is used for retrieving the Keff's of
C          WLUP-benchmarks calculated with  several libraries,
C          for output of tables ready for graph Keff vs.q.
C          It can be the output file of SMRLIB program or any file
C          containing Keff values of benchmarks after the names of
C          the libraries (a record for each lib. Format: A10,F8.5).
C          Before the Keff for the first lib, a record must be present
C          with the name of the present lattice (format: A10).
C
C 3) wimsX.OUT  : WIMS-D outputs of all the X-benchmarks included in 
C          SMRLIB.LST for any of the WIMS-D libraries (the 
C          q-value is not strongly dependent on WIMS-library).
C          These WIMS-output files are used for reading the needed
C          parameters for calculating the "q" value for each case.
C          The names wimsX must be the names given on QVALUE.INP file.
C
C
C OUTPUT FILES
C
C benchY.DAT    : Tables of Keff vs.q-value for all benchmarks given in
C           QVALUE.INP. A file for each benchmark type, with the name
C           of each file equal to the benchmark-type name given in
C           QVALUE.INP.
C           Two columns are added to the graphs: ExpKeff (=1.0) and
C           ExpError (absolute) extraced from SMRLIB.LST file,
C           for plotting experimental error bars.
C           For graphing the content of these files, use the MSDOS
C           SORT command before, to put the q-values in ascending order.
C           There is an SORTALL.BAT file to sort all results.
C
C STEPS FOR GRAPHING Keff vs.q:
C
C 1. Run BNCHALL.BAT for all WIMS-libraries wished (do not delete wims
C    output files for one lib to be used as reference for q-value 
C    calculations)
C 2. Run SMRLIB.EXE for including results of all libraries
C 3. Edit QVALUE.INP for adjusting to the actual case.
C 4. Run QVALUE.EXE.
C 5. Sort benchY.DAT QVALUE-output files.
C 6. Enter to the desired graph program and import each benchY.DAT file 
C    as source of data.
C 7. Enjoy with the nice graphs that you will obtain.
C
C LIMITATIONS:
C Number of libs:  <=MXLI
C Number of groups:<=MXGR
C***********************************************************************
      PARAMETER    (MXLI=10, MXGR=200)
C***********************************************************************
      DIMENSION AK(MXLI),FLUX(MXGR),ANUXSF(MXGR),XSGGP(MXGR,MXGR)
C
      CHARACTER*10  NOMLIB(MXLI)
      CHARACTER*2   NN(MXLI)
      CHARACTER*7   NOMBEN
      CHARACTER*12  NOMOUT
      CHARACTER*10  NOMCAS
      CHARACTER*80  LINE
      CHARACTER*6   TIT1
      CHARACTER*10  TIT2,TIT3
      CHARACTER*11  FORMAT1
      CHARACTER*130 FORMAT2
C
      DO I=1,MXLI
        WRITE(NN(I),'(I2)') I
      END DO
C
C***********************************************************************
C 1) OPEN QVALUE.INP AND READ GENERAL DATA
C
      OPEN(UNIT=1,FILE='QVALUE.INP',FORM='FORMATTED',STATUS='OLD')
      READ(1,1)NG,NGEP
      READ(1,2)NLIB
      READ(1,3)(NOMLIB(I),I=1,NLIB)
      READ(1,2)NBEN
C
C***********************************************************************
C 2) OPEN SMRLIB.LST
C
      OPEN(UNIT=2,FILE='SMRLIB.LST',FORM='FORMATTED',STATUS='OLD')
C
C***********************************************************************
C 3) LOOP OVER THE BENCHMARKS
C
      DO I1=1,NBEN
C
C    >READ BENCHMARK NAME AND NUMBER OF OUTPUTS FOR BENCH.,I1 FROM 
C     QVALUE.INP
C
       READ(1,4)NOMBEN
       READ(1,2)NOUT
C
C    >OPEN OUTPUT FILE NOMBEN.DAT FOR BENCHMARK I1
C
       OPEN(UNIT=4,FILE=TRIM(NOMBEN)//'.DAT',FORM='FORMATTED',
     1  STATUS='UNKNOWN')
C
C    >WRITE TITLE ON (NOMBEN).DAT FOR BENCH.,I1
C
       TIT1="     q"
       TIT2="   EXPKeff"
       TIT3="  EXPerror"
       FORMAT1="(A6,"//NN(NLIB)//"3A10)"
       WRITE(4,FORMAT1)TIT1,(NOMLIB(LN),LN=1,NLIB),TIT2,TIT3
C
C    >LOOP OVER NOUT WIMS-OUTPUTS OF BENCH I1
C
       DO J1=1,NOUT
C
C    >READ WIMS-OUTP NAME AND NUMB.OF CASES FOR BENH I1, OUT J1 FROM 
C     QVALUE.INP
C
        READ(1,5)NOMOUT
        READ(1,2)NCAS
C
C    >OPEN WIMS-OUTPUT NOMOUT FILE FOR BENCH I1, OUT J1
C
        OPEN(UNIT=3,FILE=NOMOUT,FORM='FORMATTED',STATUS='OLD')
C
C    >LOOP OVER NCAS CASES OF BENCH I1, OUT J1
C
        DO K1=1,NCAS
C
C    >READ Keff VALUES FOR BENCH I1,OUT J1,CASE K1 FOR ALL LIBS 
C     FROM SMRLIB.LST
C
  70     read(2,11)LINE
         DO WHILE(LINE(1:10).NE.NOMLIB(1))
          read(2,11,END=80)LINE
         END DO
         BACKSPACE(2)
         BACKSPACE(2)
         READ(2,3)NOMCAS
         IF(NOMCAS.EQ."   Average".or.NOMCAS.EQ." Average  ")
     &       read(2,11)LINE
         IF(NOMCAS.EQ."   Average".or.NOMCAS.EQ." Average  ")GOTO 70
         BACKSPACE(2)
         READ(2,6)NOMCAS,AKEXP,DKPEXP
         DKEXP=DKPEXP/100.0
         DO L=1,NLIB
          read(2,12)AK(L)
         ENDDO
         GOTO 81
C
  80     CLOSE(1)
         CLOSE(2)
         CLOSE(3)
         CLOSE(4)
         STOP "PROBLEM WITH SMRLIB.LST FILE"
C
C    >READ SCATTERING MATRIX FOR BENCH I1, OUT J1, CASE K1
C
  81     read(3,11)LINE
         DO WHILE(LINE(2:38).NE.'CELL AVERAGE SCATTERING CROSS SECTION')
          read(3,11,END=90)LINE
         END DO
         GOTO 91
C
  90     CLOSE(1)
         CLOSE(2)
         CLOSE(3)
         CLOSE(4)
         PRINT *,'PROBLEM WITH SCAT.XS MATRIX ON OUTPUT FILE ',NOMOUT
         STOP "PROBLEM WITH SCAT.XS MATRIX ON OUTPUT FILE"
C
  91     L1=1
         L10=10
         NJ=NG/10+1
         DO J=1,NJ
          DO I=1,4
           read(3,11)LINE
          ENDDO
          read(3,11)LINE
          IF(J.LT.NJ)THEN
           DO IG=1,NG
            read(3,21)(XSGGP(IG,IJ),IJ=L1,L10)
           ENDDO
          ELSE
           L11=10*NJ-NG
           DO IG=1,NG
            read(3,21)(XSGGP(IG,IJ),IJ=L1,L10-L11)
           ENDDO
          ENDIF
          L1=L10+1
          L10=L1+9
         ENDDO
C
C    >READ nu*XSf AND FLUXeff FOR BENCH I1, OUT J1, CASE K1
C
         read(3,11)LINE
         DO WHILE(LINE(2:33).NE.'GROUP     DIFFUSION    DIFFUSION')
          read(3,11)LINE
         END DO
         DO IG=1,NG
          read(3,22)ANUXSF(IG),FLUX(IG)
         ENDDO
C
C    >CALCUL Q-VALUE FOR BENCH I1, OUT J1, CASE K1
C
C     NUMERATOR
C
         Q1=0.0
         DO IG=1,NGEP
          Q2=0.0
          DO IJ=NGEP+1,NG
           Q2=Q2+XSGGP(IG,IJ)
          ENDDO
          Q1=Q1+Q2*FLUX(IG)
         ENDDO
C
C     DENOMINATOR
C
         Q3=0.0
         DO IG=1,NG
          Q3=Q3+FLUX(IG)*ANUXSF(IG)
         ENDDO
C
C     Q-VALUE
C
         QVALUE=Q1/Q3
C
C    >WRITE RESULTS FOR BENCH I1, OUT J1, CASE K1
C
         FORMAT2="(F6.3,"//NN(NLIB)//"F10.5,2F10.5,2X,A10)"
         WRITE(4,FORMAT2)QVALUE,(AK(NL),NL=1,NLIB),AKEXP,DKEXP,NOMCAS
C
        ENDDO
       ENDDO
       CLOSE(4)
      ENDDO
      CLOSE(1)
      CLOSE(2)
      CLOSE(3)
 
C
C***********************************************************************
  1   FORMAT(2I5)
  2   FORMAT(I5)
  3   FORMAT(A10)
  4   FORMAT(A7)
  5   FORMAT(A12)
  6   FORMAT(A10,F8.5,2X,F3.2)
C
 11   FORMAT(A80)
 12   FORMAT(10X,F8.5)
C
 21   FORMAT(3X,10(1X,E11.4))
 22   FORMAT(64X,E13.6,1X,E13.6)
C
      STOP 'Qvalue Completed'
      END
*deck qvalue_w 
      PROGRAM QVALUE_W
C-Title  : Program QVALUE_W
C-Purpose: Analyse WLUP benchmarks by slowing-down density q(E)
C-Author : F.Leszczynski, Ingenieria Nuclear
C-A                       Centro Atomico Bariloche, ARGENTINA
C-A        A.Trkov,       International Atomic Energy Agency
C-A                       Wagramerstrasse 5, Vienna, AUSTRIA
C-Version: August 2001, first release, (F.Leszczynski)
C-V  01/11 A.Trkov
C-V        - Sort results by ascending q(E)
C-V        - Add printout in PLOTTAB format
C-V  05/07 D.L. Aldama, IAEA/NDS Consultant
C-V        - Correction to skip " Average  " lines
C-M
C-M  QVALUE Program Users Guide
C-M  ==========================
C-M
C-M  The purpose of the program is
C-M  1. To calculate the q-value for each WLUP-benchmark lattice
C-M     by processing WIMS-D outputs for one library, and
C-M  2. To write tables for plotting Keff vs. q.
C-M     The Keff values are extracted from the SMRLIB output file.
C-M
C-M  The "q" is defined as the number of fission neutrons
C-M  reaching an arbitrarily chosen threshold energy. It is chosen
C-M  arbitrarily, but the value 2.6 eV is generaly agreed upon for
C-M  easier comparison of results). The "q" value characterises the
C-M  hardness of the spectrum. It is close to 1 for soft spectra
C-M  with little absorption and small for hard spectra. It is
C-M  formally defined by:
C-M
C-M      sum_g(g>2.6 eV)[ Phi(g) sum_h(h<2.6eV) Sig(g-->h) ]
C-M  q = ----------------------------------------------------
C-M                sum_g( Phi(g) nue(g) Sigf(g) )
C-M
C-M  where Phi is the cell spectrum read from the region edit.
C-M  Sig(g-->h) is the scattering matrix. Summation is performed
C-M  over matrix elements "h" corresponding to groups <2.6 eV (i.e.
C-M  scattering source to any anergy below 2.6 eV). Outer summation
C-M  has to be done over all groups "g" corresponding to energies
C-M  above 2.6 eV.
C-M  Reference: Dr.Andrej Trkov-IAEA-NDS (personal communication)
C
C In this program, the value of the threshold energy can be choosen, 
C giving on input file QVALUE.INP the number of "epithermal" 
C groups(ngep).
C The lower energy limit of this group will be the threshold energy.
C The value for this energy = 2.6 eV, corresponds to ngep = 29 for the
C standard 69-group WIMS-D library.
C The number of groups (ng) of the WIMS-D library can be changed on 
C QVALUE.INP C file. This value, ng and ngep cannot be exactly the 
C  number of groups of the
C  libraries but the main groups on WIMS-D calculations associated with
C  q-calculation.
C
C
C INPUT FILES:
C
C 1) QVALUE.INP : See the file included on the package for explanation
C      of this input. It is a standard file. It must be changed only if
C      the user wish to change some parameters included on it.
C      WARNING: This file is strongly dependent of the
C      other input files (names and order of data).
C
C        Rec. Parameter Content                                 Format
C        1    ng        Number of energy groups                  2I5
C             ngep      Number of epithermal groups
C        2    nlib      Number of libraries with Keff             I5
C      k=1,nlib:
C        3k   NOMLIBk   Names of libs (= smrlib.lst)             A10
C        4    nben      Number of benchmarks                      I5
C      i=1,nben:
C        5i   NOMBENi   Name of i-benchmark                       A7
C        6i   NOUTi     Number of WIMS-outp files f.bench.i       I5
C       j=1,NOUTi
C        7ij  NOMOUTij  Name of j-WIMS outp f.bench.i            A12
C        8ij  NCASij    Number of cases on j-WIMS outp f.bench.i  I5
C
C 2) SMRLIB.LST   This file is used for retrieving the Keff's of
C          WLUP-benchmarks calculated with  several libraries,
C          for output of tables ready for graph Keff vs.q.
C          It can be the output file of SMRLIB program or any file
C          containing Keff values of benchmarks after the names of
C          the libraries (a record for each lib. Format: A10,F8.5).
C          Before the Keff for the first lib, a record must be present
C          with the name of the present lattice (format: A10).
C
C 3) wimsX.OUT:WIMS-D outputs of all the X-benchmarks included in 
C          SMRLIB.LST for any of the WIMS-D libraries (the q-value is 
C          not strongly dependent on WIMS-library).
C          These WIMS-output files are used for reading the needed
C          parameters for calculating the "q" value for each case.
C          The names wimsX must be the names given on QVALUE.INP file.
C
C
C OUTPUT FILES
C
C benchY.DAT    : Tables of Keff vs.q-value for all benchmarks given in
C           QVALUE.INP. A file for each benchmark type, with the name
C           of each file equal to the benchmark-type name given in
C           QVALUE.INP.
C           Two columns are added to the graphs: ExpKeff (=1.0) and
C           ExpError (absolute) extraced from SMRLIB.LST file,
C           for plotting experimental error bars.
C           For graphing the content of these files, use the MSDOS
C           SORT command before, to put the q-values in ascending order.
C           There is an SORTALL.BAT file to sort all results.
C
C STEPS FOR GRAPHING Keff vs.q:
C
C 1. Run BNCHALL.BAT for all WIMS-libraries wished (do not delete the 
C    wims output files for one lib to be used as reference for q-value 
C    calculations)
C 2. Run SMRLIB.EXE for including results of all libraries
C 3. Edit QVALUE.INP for adjusting to the actual case.
C 4. Run QVALUE.EXE.
C 5. Sort benchY.DAT QVALUE-output files.
C 6. Enter to the desired graph program and import each benchY.DAT file 
C    as source of data.
C 7. Enjoy with the nice graphs that you will obtain.
C
C LIMITATIONS:
C Number of libs:  <=MXLI
C Number of groups:<=MXGR
C***********************************************************************
      PARAMETER    (MXLI=10, MXGR=200)
C***********************************************************************
      DIMENSION AK(MXLI),FLUX(MXGR),ANUXSF(MXGR),XSGGP(MXGR,MXGR)
C
      CHARACTER*10  NOMLIB(MXLI)
      CHARACTER*2   NN(MXLI)
      CHARACTER*7   NOMBEN
      CHARACTER*12  NOMOUT
      CHARACTER*10  NOMCAS
      CHARACTER*80  LINE
      CHARACTER*6   TIT1
      CHARACTER*10  TIT2,TIT3
      CHARACTER*11  FORMAT1
      CHARACTER*130 FORMAT2
C
      DO I=1,MXLI
        WRITE(NN(I),'(I2)') I
      END DO
C
C***********************************************************************
C 1) OPEN QVALUE.INP AND READ GENERAL DATA
C
      OPEN(UNIT=1,FILE='QVALUE.INP',FORM='FORMATTED',STATUS='OLD')
      READ(1,1)NG,NGEP
      READ(1,2)NLIB
      READ(1,3)(NOMLIB(I),I=1,NLIB)
      READ(1,2)NBEN
C
C***********************************************************************
C 2) OPEN SMRLIB.LST
C
      OPEN(UNIT=2,FILE='SMRLIB.LST',FORM='FORMATTED',STATUS='OLD')
C
C***********************************************************************
C 3) LOOP OVER THE BENCHMARKS
C
      DO I1=1,NBEN
C
C    >READ BENCHMARK NAME AND NUMBER OF OUTPUTS FOR BENCH.,I1 FROM QVALUE.INP
C
       READ(1,4)NOMBEN
       READ(1,2)NOUT
C
C    >OPEN OUTPUT FILE NOMBEN.DAT FOR BENCHMARK I1
C
       OPEN(UNIT=4,FILE=TRIM(NOMBEN)//'.DAT',FORM='FORMATTED',
     1  STATUS='UNKNOWN')
C
C    >WRITE TITLE ON (NOMBEN).DAT FOR BENCH.,I1
C
       TIT1="     q"
       TIT2="   EXPKeff"
       TIT3="  EXPerror"
       FORMAT1="(A6,"//NN(NLIB)//"3A10)"
       WRITE(4,FORMAT1)TIT1,(NOMLIB(LN),LN=1,NLIB),TIT2,TIT3
C
C    >LOOP OVER NOUT WIMS-OUTPUTS OF BENCH I1
C
       DO J1=1,NOUT
C
C    >READ WIMS-OUTP NAME AND NUMB.OF CASES FOR BENH I1, OUT J1 FROM QVALUE.INP
C
        READ(1,5)NOMOUT
        READ(1,2)NCAS
C
C    >OPEN WIMS-OUTPUT NOMOUT FILE FOR BENCH I1, OUT J1
C
        OPEN(UNIT=3,FILE=NOMOUT,FORM='FORMATTED',STATUS='OLD')
C
C    >LOOP OVER NCAS CASES OF BENCH I1, OUT J1
C
        DO K1=1,NCAS
C
C    >READ Keff VALUES FOR BENCH I1,OUT J1,CASE K1 FOR ALL LIBS FROM SMRLIB.LST
C
  70     read(2,11)LINE
         DO WHILE(LINE(1:10).NE.NOMLIB(1))
          read(2,11,END=80)LINE
         END DO
         BACKSPACE(2)
         BACKSPACE(2)
         READ(2,3)NOMCAS
         IF(NOMCAS.EQ."   Average".or.NOMCAS.EQ." Average  ")
     &       read(2,11)LINE
         IF(NOMCAS.EQ."   Average".or.NOMCAS.EQ." Average  ")GOTO 70
         BACKSPACE(2)
         READ(2,6)NOMCAS,AKEXP,DKPEXP
         DKEXP=DKPEXP/100.0
         DO L=1,NLIB
          read(2,12)AK(L)
         ENDDO
         GOTO 81
C
  80     CLOSE(1)
         CLOSE(2)
         CLOSE(3)
         CLOSE(4)
         STOP "PROBLEM WITH SMRLIB.LST FILE"
C
C    >READ SCATTERING MATRIX FOR BENCH I1, OUT J1, CASE K1
C
  81     read(3,11)LINE
         DO WHILE(LINE(2:38).NE.'CELL AVERAGE SCATTERING CROSS SECTION')
          read(3,11,END=90)LINE
         END DO
         GOTO 91
C
  90     CLOSE(1)
         CLOSE(2)
         CLOSE(3)
         CLOSE(4)
         PRINT *,'PROBLEM WITH SCAT.XS MATRIX ON OUTPUT FILE ',NOMOUT
         STOP "PROBLEM WITH SCAT.XS MATRIX ON OUTPUT FILE"
C
  91     L1=1
         L10=10
         NJ=NG/10+1
         DO J=1,NJ
          DO I=1,4
           read(3,11)LINE
          ENDDO
          read(3,11)LINE
          IF(J.LT.NJ)THEN
           DO IG=1,NG
            read(3,21)(XSGGP(IG,IJ),IJ=L1,L10)
           ENDDO
          ELSE
           L11=10*NJ-NG
           DO IG=1,NG
            read(3,21)(XSGGP(IG,IJ),IJ=L1,L10-L11)
           ENDDO
          ENDIF
          L1=L10+1
          L10=L1+9
         ENDDO
C
C    >READ nu*XSf AND FLUXeff FOR BENCH I1, OUT J1, CASE K1
C
         read(3,11)LINE
         DO WHILE(LINE(2:33).NE.'GROUP     DIFFUSION    DIFFUSION')
          read(3,11)LINE
         END DO
         DO IG=1,NG
          read(3,22)ANUXSF(IG),FLUX(IG)
         ENDDO
C
C    >CALCUL Q-VALUE FOR BENCH I1, OUT J1, CASE K1
C
C     NUMERATOR
C
         Q1=0.0
         DO IG=1,NGEP
          Q2=0.0
          DO IJ=NGEP+1,NG
           Q2=Q2+XSGGP(IG,IJ)
          ENDDO
          Q1=Q1+Q2*FLUX(IG)
         ENDDO
C
C     DENOMINATOR
C
         Q3=0.0
         DO IG=1,NG
          Q3=Q3+FLUX(IG)*ANUXSF(IG)
         ENDDO
C
C     Q-VALUE
C
         QVALUE=Q1/Q3
C
C    >WRITE RESULTS FOR BENCH I1, OUT J1, CASE K1
C
         FORMAT2="(F6.3,"//NN(NLIB)//"F10.5,2F10.5,2X,A10)"
         WRITE(4,FORMAT2)QVALUE,(AK(NL),NL=1,NLIB),AKEXP,DKEXP,NOMCAS
C
        ENDDO
       ENDDO
       CLOSE(4)
      ENDDO
      CLOSE(1)
      CLOSE(2)
      CLOSE(3)
 
C
C***********************************************************************
  1   FORMAT(2I5)
  2   FORMAT(I5)
  3   FORMAT(A10)
  4   FORMAT(A7)
  5   FORMAT(A12)
  6   FORMAT(A10,F8.5,2X,F3.2)
C
 11   FORMAT(A80)
 12   FORMAT(10X,F8.5)
C
 21   FORMAT(3X,10(1X,E11.4))
 22   FORMAT(64X,E13.6,1X,E13.6)
C
      STOP 'Qvalue_w Completed'
      END
*deck RPINKE 
      PROGRAM RPINKE
C-Title  : Program RPINKE
C-Purpose: Average contributions to Rowlands pin-cell benchmark
C-Version: Creation date 9-Oct-97
C-M
C-M  Manual for Program RPINKE
C-M  =========================
C-M  Results from various laboratories contributing to the
C-M  establisment of the reference solution are averaged in a
C-M  consistent way. The results consist of four pairs of K-inf
C-M  and K-eff values for a simple pin-cell configuration. The
C-M  four cases differ in the temperature of the fuel, can and
C-M  moderator. An entry set of K-inf and K-eff values from a
C-M  particular code may have a systematic error, but such errors
C-M  in the relative changes of K due to leakage or changes in
C-M  temperature are believed to be smaller. These changes in K
C-M  were therefore considered independent entries. A system of
C-M  equations was derived to obtain a consistent solution for
C-M  K-inf and K-eff, and therefore also for the changes in K.
C-M
C-M  Instructions:
C-M  The filename of the data file containing the K-inf and/or
C-M  K-eff values and their respective weights is requested from
C-M  input.
C-M    The results are written to "RPINKE.LOG". No additional
C-M  input is expected.
C-Author: A.Trkov, International Atomic Energy Agency, (1997)
C-
      PARAMETER   (MC=20, MP=21)
C*
      IMPLICIT     REAL*8 (A-H,O-Z)
      CHARACTER*80 REC
      CHARACTER*40 BLNK,FLNM,FLNI,FLNO
      CHARACTER*16 BL16,CODE(MC)
      CHARACTER*8  TYPE(21)
C*
      DIMENSION  AA(8,8), FF(8), QK(MP)
      DIMENSION  AK(MC,MP),WT(MC,MP), SUM(MP), WGT(MP), SIG(MP)
C*
      DATA TYPE/'     Ki1','     Ki2','     Ki3','     Ki4'
     1         ,'     Ke5','     Ke6','     Ke7','     Ke8'
     2         ,' Ki1-Ki2',' Ki2-Ki4',' Ki4-Ki3',' Ki2-Ki3'
     2         ,' Ki1-Ki3',' Ki1-Ke5',' Ki2-Ke6',' Ki3-Ke7'
     3         ,' Ki4-Ki8',' Ke5-Ke6',' Ke6-Ke8',' Ke8-Ke7'
     3         ,' Ke6-Ke7'/
      DATA SUM /MP*0.D0/
     1     WGT /MP*0.D0/
     1     SIG /MP*0.D0/
C*
      DATA LIN,LOU,LKB,LTT / 1, 2, 5, 6 /
      DATA BLNK/'                                        '/
     1     FLNI/'RPINU.DAT'/
     2     FLNO/'RPINKE.LOG'/
C* Define the K-filename
      WRITE(LTT,801) ' RPINKE - Rowlands Pin-cell Reference   '
      WRITE(LTT,801) ' ====================================   '
      WRITE(LTT,801)
   12 WRITE(LTT,801) ' Default file with data to be averaged: ',FLNI
      WRITE(LTT,801) '$          Enter new name to redefine : '
      READ (LKB,801) FLNM
      IF(FLNM.NE.BLNK) FLNI=FLNM
C* Open the data file containing contributing results to the
C* reference solution of the Rowlands pin-cell benchmark
      OPEN (UNIT=LIN,FILE=FLNI,STATUS='OLD',ERR=12)
      OPEN (UNIT=LOU,FILE=FLNO,STATUS='UNKNOWN')
C* Read the data
      NC= 1
   20 READ (LIN,800,END=30) REC
      IF(REC(1:8).EQ.'        ') GO TO 20
      READ (REC,802) CODE(NC),(AK(NC,J),J=1,8)
      READ (LIN,803)          (WT(NC,J),J=1,MP)
      AK(NC, 9)=AK(NC,1)-AK(NC,2)
      AK(NC,10)=AK(NC,2)-AK(NC,4)
      AK(NC,11)=AK(NC,4)-AK(NC,3)
      AK(NC,12)=AK(NC,2)-AK(NC,3)
      AK(NC,13)=AK(NC,1)-AK(NC,3)
      AK(NC,14)=AK(NC,1)-AK(NC,5)
      AK(NC,15)=AK(NC,2)-AK(NC,6)
      AK(NC,16)=AK(NC,3)-AK(NC,7)
      AK(NC,17)=AK(NC,4)-AK(NC,8)
      AK(NC,18)=AK(NC,5)-AK(NC,6)
      AK(NC,19)=AK(NC,6)-AK(NC,8)
      AK(NC,20)=AK(NC,8)-AK(NC,7)
      AK(NC,21)=AK(NC,6)-AK(NC,7)
      NC= NC+1
      IF(NC.GE.MC) STOP 'RPIKE ERROR - MC limit exceeded'
      GO TO 20
C* All data entries read
   30 CODE(NC)='                '
      NC= NC-1
      WRITE(LOU,860)
      WRITE(LOU,860) ' RPINKE - Rowlands Pin-cell Reference   '
      WRITE(LOU,860) ' ====================================   '
      WRITE(LOU,860)
      WRITE(LOU,860) ' Total number of input data sets read : ',NC
      WRITE(LOU,860)
C*
C* Begin constructing the weighted sums
      WRITE(LOU,861) '    Type','Minimum         ','Maximum         '
     1              ,'Sets','   Average'
      DO 38 IK=1,MP
C* Identify the largest and the smallest element - set weight to zero
      MX =-1
      MN =-1
      JC =0
      DO 32 IC=1,NC
      IF(WT(IC,IK).LE. 0 ) GO TO 32
      IF(MN.LT. 0) MN=IC
      IF(MX.LT. 0) MX=IC
      JC =JC+1
      IF(AK(IC,IK).LE.AK(MN,IK)) MN=IC
      IF(AK(IC,IK).GE.AK(MX,IK)) MX=IC
   32 CONTINUE
      IF(JC.GT.3) THEN
        WT(MX,IK)=0.
        WT(MN,IK)=0.
      ELSE
        MX=NC+1
        MN=NC+1
      END IF
C* Calculate the weighted sums
      DO 34 IC=1,NC
      SUM(IK)=SUM(IK)+WT(IC,IK)*AK(IC,IK)
      WGT(IK)=WGT(IK)+WT(IC,IK)
   34 CONTINUE
      AV=0.
      IF(WGT(IK).GT.0) AV=SUM(IK)/WGT(IK)
      WRITE(LOU,862) TYPE(IK),CODE(MN),CODE(MX), JC,AV
   38 CONTINUE
C*
C* Assemble the matrix of correlation coefficients
      AA(1,1)= WGT( 1)+WGT( 9)+WGT(13)+WGT(14)
      AA(1,2)=-WGT( 9)
      AA(1,3)=-WGT(13)
      AA(1,4)= 0
      AA(1,5)=-WGT(14)
      AA(1,6)= 0
      AA(1,7)= 0
      AA(1,8)= 0
      FF( 1 )= SUM( 1)+SUM( 9)+SUM(13)+SUM(14)
      AA(2,1)=-WGT(9)
      AA(2,2)= WGT( 2)+WGT( 9)+WGT(10)+WGT(12)+WGT(15)
      AA(2,3)=-WGT(12)
      AA(2,4)=-WGT(10)
      AA(2,5)= 0
      AA(2,6)=-WGT(15)
      AA(2,7)= 0
      AA(2,8)= 0
      FF( 2 )= SUM( 2)-SUM( 9)+SUM(10)+SUM(12)+SUM(15)
      AA(3,1)=-WGT(13)
      AA(3,2)=-WGT(12)
      AA(3,3)= WGT( 3)+WGT(11)+WGT(12)+WGT(13)+WGT(16)
      AA(3,4)=-WGT(11)
      AA(3,5)= 0
      AA(3,6)= 0
      AA(3,7)=-WGT(16)
      AA(3,8)= 0
      FF( 3 )= SUM( 3)-SUM(11)-SUM(12)-SUM(13)+SUM(16)
      AA(4,1)= 0
      AA(4,2)=-WGT(10)
      AA(4,3)=-WGT(11)
      AA(4,4)= WGT( 4)+WGT(10)+WGT(11)+WGT(17)
      AA(4,5)= 0
      AA(4,6)= 0
      AA(4,7)= 0
      AA(4,8)=-WGT(17)
      FF( 4 )= SUM( 4)-SUM(10)+SUM(11)+SUM(17)
      AA(5,1)=-WGT(14)
      AA(5,2)= 0
      AA(5,3)= 0
      AA(5,4)= 0
      AA(5,5)= WGT( 5)+WGT(14)+WGT(18)
      AA(5,6)=-WGT(18)
      AA(5,7)= 0
      AA(5,8)= 0
      FF( 5 )= SUM( 5)-SUM(14)+SUM(18)
      AA(6,1)= 0
      AA(6,2)=-WGT(15)
      AA(6,3)= 0
      AA(6,4)= 0
      AA(6,5)=-WGT(18)
      AA(6,6)= WGT( 6)+WGT(15)+WGT(18)+WGT(19)+WGT(21)
      AA(6,7)=-WGT(21)
      AA(6,8)=-WGT(19)
      FF( 6 )= SUM( 6)-SUM(15)-SUM(18)+SUM(19)+SUM(21)
      AA(7,1)= 0
      AA(7,2)= 0
      AA(7,3)=-WGT(16)
      AA(7,4)= 0
      AA(7,5)= 0
      AA(7,6)=-WGT(21)
      AA(7,7)= WGT( 7)+WGT(16)+WGT(20)+WGT(21)
      AA(7,8)=-WGT(20)
      FF( 7 )= SUM( 7)-SUM(16)-SUM(20)-SUM(21)
      AA(8,1)= 0
      AA(8,2)= 0
      AA(8,3)= 0
      AA(8,4)=-WGT(17)
      AA(8,5)= 0
      AA(8,6)=-WGT(19)
      AA(8,7)=-WGT(20)
      AA(8,8)= WGT( 8)+WGT(17)+WGT(19)+WGT(20)
      FF( 8 )= SUM( 8)-SUM(17)-SUM(19)+SUM(20)
C* Solve for the system of equations
      CALL MTXGUP(AA,FF,QK, 8,LD,DET)
      IF(DET.EQ.0) STOP 'RPINKE ERROR - Zero determinant'
      QK( 9)=QK(1)-QK(2)
      QK(10)=QK(2)-QK(4)
      QK(11)=QK(4)-QK(3)
      QK(12)=QK(2)-QK(3)
      QK(13)=QK(1)-QK(3)
      QK(14)=QK(1)-QK(5)
      QK(15)=QK(2)-QK(6)
      QK(16)=QK(3)-QK(7)
      QK(17)=QK(4)-QK(8)
      QK(18)=QK(5)-QK(6)
      QK(19)=QK(6)-QK(8)
      QK(20)=QK(8)-QK(7)
      QK(21)=QK(6)-QK(7)
C*
C* Calculate standard deviation
      DO 40 I=1,NC
      SIG( 1)=SIG( 1) + WT(I, 1)*(QK( 1)- AK(I, 1))**2
      SIG( 2)=SIG( 2) + WT(I, 2)*(QK( 2)- AK(I, 2))**2
      SIG( 3)=SIG( 3) + WT(I, 3)*(QK( 3)- AK(I, 3))**2
      SIG( 4)=SIG( 4) + WT(I, 4)*(QK( 4)- AK(I, 4))**2
      SIG( 5)=SIG( 5) + WT(I, 5)*(QK( 5)- AK(I, 5))**2
      SIG( 6)=SIG( 6) + WT(I, 6)*(QK( 6)- AK(I, 6))**2
      SIG( 7)=SIG( 7) + WT(I, 7)*(QK( 7)- AK(I, 7))**2
      SIG( 8)=SIG( 8) + WT(I, 8)*(QK( 8)- AK(I, 8))**2
      SIG( 9)=SIG( 9) + WT(I, 9)*(QK( 9)-(AK(I,1)-AK(I,2)))**2
      SIG(10)=SIG(10) + WT(I,10)*(QK(10)-(AK(I,2)-AK(I,4)))**2
      SIG(11)=SIG(11) + WT(I,11)*(QK(11)-(AK(I,4)-AK(I,3)))**2
      SIG(12)=SIG(12) + WT(I,12)*(QK(12)-(AK(I,2)-AK(I,3)))**2
      SIG(13)=SIG(13) + WT(I,13)*(QK(13)-(AK(I,1)-AK(I,3)))**2
      SIG(14)=SIG(14) + WT(I,14)*(QK(14)-(AK(I,1)-AK(I,5)))**2
      SIG(15)=SIG(15) + WT(I,15)*(QK(15)-(AK(I,2)-AK(I,6)))**2
      SIG(16)=SIG(16) + WT(I,16)*(QK(16)-(AK(I,3)-AK(I,7)))**2
      SIG(17)=SIG(17) + WT(I,17)*(QK(17)-(AK(I,4)-AK(I,8)))**2
      SIG(18)=SIG(18) + WT(I,18)*(QK(18)-(AK(I,5)-AK(I,6)))**2
      SIG(19)=SIG(19) + WT(I,19)*(QK(19)-(AK(I,6)-AK(I,8)))**2
      SIG(20)=SIG(20) + WT(I,20)*(QK(20)-(AK(I,8)-AK(I,7)))**2
      SIG(21)=SIG(21) + WT(I,21)*(QK(21)-(AK(I,6)-AK(I,7)))**2
   40 CONTINUE
      IF(WGT( 1).GT.0) SIG( 1)=SQRT(SIG( 1) / WGT( 1))
      IF(WGT( 2).GT.0) SIG( 2)=SQRT(SIG( 2) / WGT( 2))
      IF(WGT( 3).GT.0) SIG( 3)=SQRT(SIG( 3) / WGT( 3))
      IF(WGT( 4).GT.0) SIG( 4)=SQRT(SIG( 4) / WGT( 4))
      IF(WGT( 5).GT.0) SIG( 5)=SQRT(SIG( 5) / WGT( 5))
      IF(WGT( 6).GT.0) SIG( 6)=SQRT(SIG( 6) / WGT( 6))
      IF(WGT( 7).GT.0) SIG( 7)=SQRT(SIG( 7) / WGT( 7))
      IF(WGT( 8).GT.0) SIG( 8)=SQRT(SIG( 8) / WGT( 9))
      IF(WGT( 9).GT.0) SIG( 9)=SQRT(SIG( 9) / WGT( 9))
      IF(WGT(10).GT.0) SIG(10)=SQRT(SIG(10) / WGT(10))
      IF(WGT(11).GT.0) SIG(11)=SQRT(SIG(11) / WGT(11))
      IF(WGT(12).GT.0) SIG(12)=SQRT(SIG(12) / WGT(12))
      IF(WGT(13).GT.0) SIG(13)=SQRT(SIG(13) / WGT(13))
      IF(WGT(14).GT.0) SIG(14)=SQRT(SIG(14) / WGT(14))
      IF(WGT(15).GT.0) SIG(15)=SQRT(SIG(15) / WGT(15))
      IF(WGT(16).GT.0) SIG(16)=SQRT(SIG(16) / WGT(16))
      IF(WGT(17).GT.0) SIG(17)=SQRT(SIG(17) / WGT(17))
      IF(WGT(18).GT.0) SIG(18)=SQRT(SIG(18) / WGT(18))
      IF(WGT(19).GT.0) SIG(19)=SQRT(SIG(19) / WGT(19))
      IF(WGT(20).GT.0) SIG(20)=SQRT(SIG(20) / WGT(20))
      IF(WGT(21).GT.0) SIG(21)=SQRT(SIG(21) / WGT(21))
C* Print to log file
      WRITE(LOU,860)
      WRITE(LOU,860) ' Multiplication factors K-inf           '
      WRITE(LOU,864) '        ',(TYPE(J),J=1,4)
      WRITE(LOU,868) '  K-inf ',(  QK(J),J=1,4)
      WRITE(LOU,868) '  Sigma ',( SIG(J),J=1,4)
      WRITE(LOU,860)
      WRITE(LOU,860) ' Multiplication factors K-eff           '
      WRITE(LOU,864) '        ',(TYPE(J),J=5,8)
      WRITE(LOU,868) '  K-eff ',(  QK(J),J=5,8)
      WRITE(LOU,868) '  Sigma ',( SIG(J),J=5,8)
      WRITE(LOU,860)
      WRITE(LOU,860) ' Changes in K-inf due to temperature    '
      WRITE(LOU,864) '        ',(TYPE(J),J=9,13)
      WRITE(LOU,869) '  Dki(T)',(NINT(1.E5* QK(J)),J=9,13)
      WRITE(LOU,869) '  Sigma ',(NINT(1.E5*SIG(J)),J=9,13)
      WRITE(LOU,860)
      WRITE(LOU,860) ' Changes in K-inf due to leakage        '
      WRITE(LOU,864) '        ',(TYPE(J),J=14,17)
      WRITE(LOU,869) '  Dki(L)',(NINT(1.E5* QK(J)),J=14,17)
      WRITE(LOU,869) '  Sigma ',(NINT(1.E5*SIG(J)),J=14,17)
      WRITE(LOU,860)
      WRITE(LOU,860) ' Changes in K-eff due to temperature    '
      WRITE(LOU,864) '        ',(TYPE(J),J=18,21)
      WRITE(LOU,869) '  Dke(T)',(NINT(1.E5* QK(J)),J=18,21)
      WRITE(LOU,869) '  Sigma ',(NINT(1.E5*SIG(J)),J=18,21)
C*
      STOP 'RPINKE Completed'
C*
  800 FORMAT(A80)
  801 FORMAT(2A40)
  802 FORMAT(A16,8F8.0)
  803 FORMAT(16X,8F8.0)
  860 FORMAT(A40,I10)
  861 FORMAT(4X,A8,4X,2A16,A4,A10)
  862 FORMAT(4X,A8,4X,2A16,I4,F10.5)
  864 FORMAT(10A8)
  868 FORMAT(A8,8F8.5)
  869 FORMAT(A8,8I8)
      END
      SUBROUTINE MTXGUP(A,F,X,N,LDIG,DET)
C-Title  : MTXGUP subroutine
C-Purpose: Matrix solver, Gauss elimination, part.pivoting
C-Description:
C-D Decompose matrix A, calculate determinant and/or solve a set of
C-D linear simultaneous equations  A x = F  (order n) using Gauss
C-D elimination technique with partial pivoting by rows.
C-Author : A.Trkov , Institute J.Stefan, Ljubljana, Slovenia
C-Version: 1984 Original coding
C-V 93/03 - improved zero-determinant trapping
C-V 00/11 - further refinement of zero-determinant trapping (A.Trkov)
C-
      IMPLICIT     REAL*8 (A-H,O-Z)
      DIMENSION A(N,N),F(N),X(*)
      DET=1.
      ER =1.
      DO 40 I=2,N
      I1=I-1
C* Find the pivot
      A1=0.
      DO 10 K=I1,N
      IF(ABS(A(K,I1)).LT.A1) GO TO 10
      A1=ABS(A(K,I1))
      K1=K
   10 CONTINUE
      IF(I1.LT.2) GO TO 12
      IF(ABS(A1/A0) .GT.1.E-5) GO TO 12
      DET=0.
      RETURN
   12 A0 =A1
      DET=DET*A1
      IF(K1.LT.I) GO TO 20
      A1=A(K1,I1)
      A(K1,I1)=A(I1,I1)
      A(I1,I1)=A1
      A1=F(K1)
      F(K1)=F(I1)
      F(I1)=A1
   20 DO 30 J=I,N
      X(J)=A(J,I1)/A(I1,I1)
      A(J,I1)=0.
   30 F(J)=F(J)-F(I1)*X(J)
      DO 40 J=I,N
      IF(K1.LT.I) GO TO 35
      A1=A(K1,J)
      A(K1,J)=A(I1,J)
      A(I1,J)=A1
   35 DO 40 K=I,N
      A1=A(K,J)
      A2=A1-A(I1,J)*X(K)
      IF(ABS(A1).GT.0.) ER=MIN(ER,ABS(A2/A1))
      A(K,J)=A2
   40 CONTINUE
C* Estimate number of digits lost due to subtraction
      LDIG=-LOG10(ER+1.E-33)+1.
C* Solve by backward substitution
   45 DO 60 I=2,N
      I1=N-I+2
      X(I1)=F(I1)/A(I1,I1)
      J1=N+1-I
      DO 60 J=1,J1
      F(J)=F(J)-X(I1)*A(J,I1)
   60 CONTINUE
      X(1)=F(1)/A(1,1)
      RETURN
      END
*deck RTCBEN 
       PROGRAM RTCBEN
C-Title  : RTCBEN Program
C-Purpose: Summarize WLUP RTC Supplementary Benchmarks
C-Version: Original code.
C-Author : A.Trkov, Institute Jozef Stefan, Ljubljana, Slovenia (2002)
C-A        Corrected by D. L. Aldama IAEA/NDS Consultant, 2005.
C-M
C-M  Manual for Program RTCBEN
C-M  =========================
C-M  A summary of results for the WLUP RTC
C-M  benchmarks is compiled from pintcr.exe output RTC.O
C-M
C-M  The list files are those produced by analysing the WIMS-D
C-M  outputs with post-processing code developed within the scope
C-M  of the WIMS-D Library Update Project (IAEA-CRP 1999-2000) by
C-M  Lhoussine Erradi.
C-M
C-
      DIMENSION EXPER(10),CALCUL(10),DCALC(10)
      DIMENSION DEXPE(10)
      CHARACTER*120 REC
      CHARACTER*40  BLNK,FLNM,FLNI(8),FLNO
      CHARACTER*10  NAME(16)
C* Filenames and logical file units
      DATA LIN,LOU,LKB,LTT / 1, 2, 5, 6 /
      DATA BLNK/'                                        '/
     1    ,FLNI/'RTC.O      '
     2    ,     '           '
     3    ,     '           '
     4    ,     '           '
     1    ,     '           '
     1    ,     '           '
     1    ,     '           '
     1    ,     '           '/
     1    ,FLNO/'RTCBEN.LST'/
C*
      DATA NAME/'NORA-1.66 '
     1         ,'NORA-3.03 '
     2         ,'   KRITZ1 '
     2         ,'  KRITZ21 '
     3         ,' KRITZ213 '
     4         ,' KRITZ219 '
     4         ,'    VVER1 '
     4         ,'    VVER2 '
     4         ,'    VVER3 '
     1         ,'    VVER4 '
     1         ,'          '
     1         ,'          '
     1         ,'          '
     1         ,'          '
     1         ,'          '
     4         ,'          '/
C*
C* Define input parameters - Write banner to terminal
      WRITE(LTT,693)' RTC comparison - REACTIVITY TEMPERATURE COEFFIC. '
      WRITE(LTT,693)' ================================================='
      WRITE(LTT,692)
C*
C* Define the output file
      WRITE(LTT,691) ' Default output filename              : ',FLNO
      WRITE(LTT,692) '$          Enter new name to redefine : '
      READ (LKB,692) FLNM
      IF(FLNM.NE.BLNK) FLNO=FLNM
C*
C* Define the output file
      IC=1
   11 WRITE(LTT,691) ' Default RTCBENCH Benchmark file  :    ',FLNI(IC)
      WRITE(LTT,692) '$          Enter new name to redefine : '
      READ (LKB,692) FLNM
      IF(FLNM.NE.BLNK) FLNI(IC)=FLNM
      IF(FLNM(1:1).NE.'-') THEN
        OPEN (UNIT=LIN,FILE=FLNI(IC),STATUS='OLD',ERR=11)
        CLOSE(UNIT=LIN)
      END IF
C*
      OPEN (UNIT=LOU,FILE=FLNO,STATUS='UNKNOWN')
      WRITE(LOU,693)' RTC-DIFFS.BETWEEN CALCULATION AND MEASUREMENTS   '
      WRITE(LOU,693)' ================================================='
      WRITE(LOU,692)
      WRITE(LOU,691) ' Processed Benchmark analysis reports : '
      IF(FLNI(1).NE.'-')
     1WRITE(LOU,691) '                              1 case  : ',FLNI(1)
      WRITE(LOU,691)
C*
      WRITE(LOU,694)'     Case   D-ALPHA(pcm/C)                        '
      WRITE(LOU,694)' ================================================='
C
C* Begin processing DOPPLER Benchmarks
      IC=1
      OPEN (UNIT=LIN,FILE=FLNI(IC),STATUS='OLD')
   20 READ (LIN,692) REC
      IF(REC(1:8).NE.'  Vm/Vf ') GO TO 20
      DO ILIN=1,3
       READ (LIN,692) REC
      ENDDO
c           NORA 1.66
      READ (LIN,800)DCALC(1)
      DO ILIN=1,4
       READ (LIN,692) REC
      ENDDO
c           NORA 3.03
      READ (LIN,800)DCALC(2)
      DO ILIN=1,19
       READ (LIN,692) REC
      ENDDO
c           KRITZ1
      READ (LIN,801)DCALC(3)
      DO ILIN=1,18
       READ (LIN,692) REC
      ENDDO
c           KRITZ21
      READ (LIN,801)DCALC(4)
      DO ILIN=1,18
       READ (LIN,692) REC
      ENDDO
c           KRITZ213
      READ (LIN,801)DCALC(5)
      DO ILIN=1,17
       READ (LIN,692) REC
      ENDDO
c           KRITZ219
      READ (LIN,801)DCALC(6)
c
c           R1-100H skipped (38 lines)
c
      DO ILIN=1,38
       READ (LIN,692) REC
      ENDDO
c           VVER1
      READ (LIN,802)DCALC(7)
      DO ICAS=8,10
       DO ILIN=1,17
        READ (LIN,692) REC
       ENDDO
c           VVER2 to VVER4
       READ (LIN,802)DCALC(ICAS)
      ENDDO
C* Print the resutls for this benchmark
      DO ICAS=1,10
       DEXPE(ICAS)= 0.0
      ENDDO
      DO ICASO=1,10
       WRITE(LOU,701) NAME(ICASO)
       WRITE(LOU,702) DCALC(ICASO)
       WRITE(LOU,692)
      ENDDO
      CLOSE(UNIT=LIN)
C*
      WRITE(LOU,694)' ================================================='
      SRDC=0.0
      SDDC=0.0
      ADDC=0.0
      DO ICAS=1,10
       SRDC=SRDC+2*DEXPE(ICAS)
       SDDC=SDDC+DCALC(ICAS)*DCALC(ICAS)
       ADDC=ADDC+DCALC(ICAS)
      ENDDO
      SRDC=SRDC/10.0
      SDDC=SQRT(SDDC/10.0)
      ADDC=ADDC/10.0
      WRITE(LOU,703) ' Average  ',SRDC
      WRITE(LOU,704) ' Dif/St.Dv',ADDC,SDDC
C
      CLOSE(UNIT=LOU)
C* End of file processing
  80  STOP 'RTCBEN Completed'
C*
 691  FORMAT(2A40)
 692  FORMAT(A50)
 693  FORMAT(A50)
 694  FORMAT(A50)
 701  FORMAT(A10)
 702  FORMAT(19X,'(',F9.6,')')
 703  FORMAT(A10,9X,'(',F9.6,')')
 704  FORMAT(A10,F9.6,'(',F9.6,')')
 800  FORMAT(65X,F11.8)
 801  FORMAT(45X,F10.7)
 802  FORMAT(54X,F11.8)
C
      END
*deck smrdi2 
      PROGRAM SMRDI2
C-Title  : SMRDI2 Program
C-Purpose: Tabulate and compare benchmark summary results
C-         for BNL-Th benchmarks
C-         =SMRDIF with modified output title
C-Author : A.Trkov, Institute Jozef Stefan, Ljubljana, Slovenia.
C-Version: 1998
C-V 01/05  F.Leszczynski, A.Trkov:
C-V      - Allow for more benchmarks.
C-V      - Add instructions in the comments.
C-M
C-M  Manual for Program SMRDIF
C-M  =========================
C-M  The program reads the K-eff and four spectral indices from a
C-M  reference file and from the WEDOG3 output, which summarizes the
C-M  results of a WIMS-D calculation for BNL-Th benchmarks
C-M
C-M  The file containing reference results may contain up to MXBN
C-M  records, each corresponding to one benchmark lattice. The value
C-M  of MXBN is set in the PARAMETER statement in the code.
C-M  The format of the file containing reference results is:
C-M  Column  Description:
C-M    1-10  Lattice identification string.
C-M   11-18  Reference multiplication factor.
C-M   19-23  Uncertainty in the multiplication factor [pcm].
C-M   24-29  Rho28
C-M   30-35  Uncertainty in Rho28
C-M   36-43  Del25
C-M   44-50  Uncertainty in Del25
C-M   51-58  Del28
C-M   59-65  Uncertainty in Del28
C-M   66-72  C*
C-M   73-78  Uncertainty in C*
C-M
C-M  The number of records and the sequence in the WEDOG2 output
C-M  file must correspond to the sequence in the reference file. No
C-M  checking for consistency is done in the code.
C-M
C-M  Instructions:
C-M  The filenames are entered in response to the prompts
C-M  -  Reference results filename.
C-M  -  WEDOG2 output analysing WIMS-D results.
C-M  -  Output summary file.
C-M  -  String to flag printout differences in percent. If blank
C-M     is specified, the absolute differences are printed.
C-
      PARAMETER     (MXBN=100)
      CHARACTER*40   FLNM,FLNR,FLNC
      CHARACTER*10   BLN,LBL
      CHARACTER*6    HRJ,HR(5),HC(5)
      DIMENSION      PR(5),PC(5),ER(5),EC(5,MXBN)
     1              ,ND(5),RV(5),AV(5),AE(5)
      DATA ND,RV,AV /5*0, 5*0., 5*0./
      DATA BLN/'          '/
C* Define the filenames
      WRITE(6,91)
      WRITE(6,91) ' SMRDI2 - Compare lattice spectr.indices'
      WRITE(6,91) ' ====================================   '
      WRITE(6,91)
      WRITE(6,91) '$Enter the reference filename         : '
      READ (5,91) FLNM
      FLNR=FLNM
      OPEN (UNIT=1,FILE=FLNM,STATUS='OLD')
      WRITE(6,91) '$Enter the compared  filename         : '
      READ (5,91) FLNM
      FLNC=FLNM
      OPEN (UNIT=2,FILE=FLNM,STATUS='OLD')
      WRITE(6,91) '$Enter the output filename            : '
      READ (5,91) FLNM
      OPEN (UNIT=8,FILE=FLNM,STATUS='UNKNOWN',CARRIAGECONTROL='LIST')
      WRITE(6,91) '$Enter non-blank to print % diff.     : '
      READ (5,91) FLNM
C* Write the header to output
      WRITE(8,91)
      WRITE(8,91) ' SMRDIF - Compare lattice spectr.indices'
      WRITE(8,91) ' ====================================   '
      WRITE(8,91)
      WRITE(8,91) ' Reference file                       : ',FLNR
      WRITE(8,91) ' Compared  file                       : ',FLNC
      WRITE(8,91)
      WRITE(8,91) '   LATTICE      K-eff       Rho28       '
     1           ,'  Del25          Del28         ConvR    '
      WRITE(8,91) '  ======================================'
     1           ,'================================        '
      NE=0
C* Read a line from reference and compared data base
   20 READ (1,92,END=80) LBL,PR(1),IKR,(PR(J),ER(J),J=2,5)
      READ (2,94,END=80)     PC(1),    (PC(J)      ,J=2,5)
      NE=NE+1
C* Calculate differences in K-eff and 4 spectral indices
      ER(1   )=IKR
      EC(1,NE)=0.
      IF(PR(1).NE.0) EC(1,NE)=1.E5*ALOG(PC(1)/PR(1))
      IKC=EC(1,NE)
      ND(1) =ND(1)+1
      DO 22 J=2,5
      EC(J,NE)=0.
      IF(PR(J).EQ.0) GO TO 22
      EC(J,NE)=PC(J)-PR(J)
      IF(EC(J,NE).EQ.0) EC(J,NE)=1.E-30
      ND(J) =ND(J)+1
   22 CONTINUE
C* Case: Print absolute differences
      IF(FLNM.NE.'                                        ') GO TO 30
      WRITE(8,92) LBL,PR(1),IKR,(PR(J),ER(J   ),J=2,5)
      WRITE(8,92) BLN,PC(1),IKC,(PC(J),EC(J,NE),J=2,5)
      WRITE(8,92)
      GO TO 20
C* Case: Print relative differences
   30 ERJ=0.
C*        multiplication factor
      IF(PR(1).NE.0) ERJ=100.*IKR*1E-5/PR(1)
      RV(1)=RV(1)+ERJ*ERJ
      ERJ=ABS(ERJ)
      IF(ERJ  .GE. 9.950) WRITE(HRJ,95) IFIX(ERJ+0.5)
      IF(ERJ  .LT. 9.950) WRITE(HRJ,96) ERJ
      IF(ERJ  .LT. 0.995) WRITE(HRJ,97) ERJ
      HRJ(2:2)='~'
      HR(1)   =HRJ
      ERJ=100.*IKC*1E-5/PC(1)
      EC(1,NE)=ERJ
      AV(1)=AV(1)+ERJ
      IF     (ERJ     .GT. 9999  ) THEN
        WRITE(HRJ,95) 9999
        GO TO 31
      ELSE IF(ERJ     .GT. 9.950 ) THEN
        WRITE(HRJ,95) IFIX(ERJ+0.5)
        GO TO 31
      ELSE IF(ERJ     .GT. 0     ) THEN
        WRITE(HRJ,97) ERJ
        GO TO 31
      ELSE IF(ERJ     .EQ. 0     ) THEN
        HRJ     ='      '
        GO TO 31
      ELSE IF(ERJ     .GT. -.995 ) THEN
        WRITE(HRJ,97) ABS(ERJ)
        HRJ(2:2)='-'
        GO TO 31
      ELSE IF(ERJ     .GT. -9.95 ) THEN
        WRITE(HRJ,96) ERJ
        GO TO 31
      ELSE IF(ERJ     .GT. -999.5) THEN
        WRITE(HRJ,95) IFIX(ERJ-0.5)
        GO TO 31
      ELSE
        WRITE(HRJ,95) -999
      END IF
   31 HC(1)   =HRJ
C*        spectral indices
      DO 34 J=2,5
      ERJ=0.
      IF(PR(J).NE.0) ERJ=ABS(100.*ER(J)/PR(J))
      RV(J)=RV(J)+ERJ*ERJ
      IF(ERJ  .GE. 9.950) WRITE(HRJ,95) IFIX(ERJ+0.5)
      IF(ERJ  .LT. 9.950) WRITE(HRJ,96) ERJ
      IF(ERJ  .LT. 0.995) WRITE(HRJ,97) ERJ
      HRJ(2:2)='~'
      IF(ER(J).EQ. 0    ) HRJ     ='      '
      HR(J)=HRJ
      ERJ=0.
      IF(PR(J).NE.0) ERJ=100.*EC(J,NE)/PR(J)
      EC(J,NE)=ERJ
      AV(J)=AV(J)+ERJ
      IF     (ERJ     .GT. 9999  ) THEN
        WRITE(HRJ,95) 9999
        GO TO 33
      ELSE IF(ERJ     .GT. 9.950 ) THEN
        WRITE(HRJ,95) IFIX(ERJ+0.5)
        GO TO 33
      ELSE IF(ERJ     .GT. 0     ) THEN
        WRITE(HRJ,97) ERJ
        GO TO 33
      ELSE IF(ERJ     .EQ. 0     ) THEN
        HRJ     ='      '
        GO TO 33
      ELSE IF(ERJ     .GT. -.995 ) THEN
        WRITE(HRJ,97) ABS(ERJ)
        HRJ(2:2)='-'
        GO TO 33
      ELSE IF(ERJ     .GT. -9.95 ) THEN
        WRITE(HRJ,96) ERJ
        GO TO 33
      ELSE IF(ERJ     .GT. -999.5) THEN
        WRITE(HRJ,95) IFIX(ERJ-0.5)
        GO TO 33
      ELSE
        WRITE(HRJ,95) -999
      END IF
   33 HC(J)=HRJ
   34 CONTINUE
C* Write the relative differences for the current lattice
      WRITE(8,93) LBL,(PR(J),HR(J),J=1,5)
      WRITE(8,93) BLN,(PC(J),HC(J),J=1,5)
      WRITE(8,93)
      GO TO 20
C* Input exhausted - print average if rel.differences requested
   80 IF(FLNM.EQ.'                                        ') GO TO 90
      DO 86 J=1,5
      IF(ND(J).GT.0) RV(J)=SQRT(RV(J)/ND(J))
      IF(ND(J).GT.0) AV(J)=     AV(J)/ND(J)
      AE(J)=0.
      IF(ND(J).EQ.0) GO TO 86
      DO 82 I=1,NE
      IF(EC(J,I).NE.0) AE(J)=AE(J)+(EC(J,I)-AV(J))**2
   82 CONTINUE
      IF(ND(J).GT.0) AE(J)=SQRT(AE(J)/ND(J))
   86 CONTINUE
      WRITE(8,98) '   Average',(RV(J)      ,J=1,5),(AV(J),AE(J),J=1,5)
   90 STOP 'SMRDI2 Completed'
   91 FORMAT(2A40)
   92 FORMAT(A10,F8.5,I5,1X,2F6.3,1X,2F7.4,1X,2F7.4,1X,2F6.3)
   93 FORMAT(A10,F8.5,A6,F7.3,A6,F8.4,A6,F8.4,A6,F7.3,A6)
   94 FORMAT(5F10.0)
   95 FORMAT('(',I4  ,')')
   96 FORMAT('(',F4.1,')')
   97 FORMAT('(',F4.2,')')
   98 FORMAT(2X,78('-')/  A10,F13.2,F13.2,F14.2,F14.2,F13.2 /
     1 11X,2( F6.2,'(~',F4.2,')'),2( F7.2,'(~',F4.2,')')
     1      , F6.2,'(~',F4.2,')' )
      END
*deck smrdif 
      PROGRAM SMRDIF
C-Title  : SMRDIF Program
C-Purpose: Tabulate and compare benchmark summary results
C-Author : A.Trkov, Institute Jozef Stefan, Ljubljana, Slovenia.
C-Version: 1998
C-V 01/05  F.Leszczynski, A.Trkov:
C-V      - Allow for more benchmarks.
C-V      - Add instructions in the comments.
C-V 01/09- Print banner, assign variables to logical units (A.Trkov)
C-M
C-M  Manual for Program SMRDIF
C-M  =========================
C-M  The program reads the K-eff and four spectral indices from a
C-M  reference file and from the WEDOG2 output, which summarizes the
C-M  results of a WIMS-D calculation.
C-M
C-M  The file containing reference results may contain up to MXBN
C-M  records, each corresponding to one benchmark lattice. The value
C-M  of MXBN is set in the PARAMETER statement in the code.
C-M  The format of the file containing reference results is:
C-M  Column  Description:
C-M    1-10  Lattice identification string.
C-M   11-18  Reference multiplication factor.
C-M   19-23  Uncertainty in the multiplication factor [pcm].
C-M   24-29  Rho28
C-M   30-35  Uncertainty in Rho28
C-M   36-43  Del25
C-M   44-50  Uncertainty in Del25
C-M   51-58  Del28
C-M   59-65  Uncertainty in Del28
C-M   66-72  C*
C-M   73-78  Uncertainty in C*
C-M
C-M  The number of records and the sequence in the WEDOG2 output
C-M  file must correspond to the sequence in the reference file. No
C-M  checking for consistency is done in the code.
C-M
C-M  Instructions:
C-M  The filenames are entered in response to the prompts
C-M  -  Reference results filename.
C-M  -  WEDOG2 output analysing WIMS-D results.
C-M  -  Output summary file.
C-M  -  String to flag printout differences in percent. If blank
C-M     is specified, the absolute differences are printed.
C-
      PARAMETER     (MXBN=100)
      CHARACTER*40   FLNM,FLNR,FLNC
      CHARACTER*10   BLN,LBL
      CHARACTER*6    HRJ,HR(5),HC(5)
      DIMENSION      PR(5),PC(5),ER(5),EC(5,MXBN)
     1              ,ND(5),RV(5),AV(5),AE(5)
      DATA ND,RV,AV /5*0, 5*0., 5*0./
      DATA BLN/'          '/
      DATA LRE,LIN,LOU,LKB,LTT/ 1, 2, 8, 5, 6 /
C*
      WRITE(LTT,91)
      WRITE(LTT,91) ' SMRDIF - Compare lattice spectr.indices'
      WRITE(LTT,91) ' ======================================='
      WRITE(LTT,91)
C* Define the filenames
      WRITE(LTT,91) '$Enter the reference filename         : '
      READ (LKB,91) FLNM
      FLNR=FLNM
      OPEN (UNIT=LRE,FILE=FLNM,STATUS='OLD')
      WRITE(LTT,91) '$Enter the compared  filename         : '
      READ (LKB,91) FLNM
      FLNC=FLNM
      OPEN (UNIT=2,FILE=FLNM,STATUS='OLD')
      WRITE(LTT,91) '$Enter the output filename            : '
      READ (LKB,91) FLNM
      OPEN (UNIT=8,FILE=FLNM,STATUS='UNKNOWN',CARRIAGECONTROL='LIST')
      WRITE(LTT,91) '$Enter non-blank to print % diff.     : '
      READ (LKB,91) FLNM
C* Write the header to output
      WRITE(LOU,91)
      WRITE(LOU,91) ' SMRDIF - Compare lattice spectr.indices'
      WRITE(LOU,91) ' ======================================='
      WRITE(LOU,91)
      WRITE(LOU,91) ' Reference file                       : ',FLNR
      WRITE(LOU,91) ' Compared  file                       : ',FLNC
      WRITE(LOU,91)
      WRITE(LOU,91) '   LATTICE      K-eff       Rho28       '
     1           ,'  Del25          Del28         ConvR    '
      WRITE(LOU,91) '  ======================================'
     1           ,'================================        '
      NE=0
C* Read a line from reference and compared data base
   20 READ (LRE,92,END=80,ERR=80) LBL,PR(1),IKR,(PR(J),ER(J),J=2,5)
      READ (LIN,94,END=80,ERR=80)     PC(1),    (PC(J)      ,J=2,5)
      NE=NE+1
C* Calculate differences in K-eff and 4 spectral indices
      ER(1   )=IKR
      EC(1,NE)=0.
      IF(PR(1).NE.0) EC(1,NE)=1.E5*ALOG(PC(1)/PR(1))
      IKC=EC(1,NE)
      ND(1) =ND(1)+1
      DO 22 J=2,5
      EC(J,NE)=0.
      IF(PR(J).EQ.0) GO TO 22
      EC(J,NE)=PC(J)-PR(J)
      IF(EC(J,NE).EQ.0) EC(J,NE)=1.E-30
      ND(J) =ND(J)+1
   22 CONTINUE
C* Case: Print absolute differences
      IF(FLNM.NE.'                                        ') GO TO 30
      WRITE(LOU,92) LBL,PR(1),IKR,(PR(J),ER(J   ),J=2,5)
      WRITE(LOU,92) BLN,PC(1),IKC,(PC(J),EC(J,NE),J=2,5)
      WRITE(LOU,92)
      GO TO 20
C* Case: Print relative differences
   30 ERJ=0.
C*        multiplication factor
      IF(PR(1).NE.0) ERJ=100.*IKR*1E-5/PR(1)
      RV(1)=RV(1)+ERJ*ERJ
      ERJ=ABS(ERJ)
      IF(ERJ  .GE. 9.950) WRITE(HRJ,95) IFIX(ERJ+0.5)
      IF(ERJ  .LT. 9.950) WRITE(HRJ,96) ERJ
      IF(ERJ  .LT. 0.995) WRITE(HRJ,97) ERJ
      HRJ(2:2)='~'
      HR(1)   =HRJ
      ERJ=100.*IKC*1E-5/PC(1)
      EC(1,NE)=ERJ
      AV(1)=AV(1)+ERJ
      IF     (ERJ     .GT. 9999  ) THEN
        WRITE(HRJ,95) 9999
        GO TO 31
      ELSE IF(ERJ     .GT. 9.950 ) THEN
        WRITE(HRJ,95) IFIX(ERJ+0.5)
        GO TO 31
      ELSE IF(ERJ     .GT. 0     ) THEN
        WRITE(HRJ,97) ERJ
        GO TO 31
      ELSE IF(ERJ     .EQ. 0     ) THEN
        HRJ     ='      '
        GO TO 31
      ELSE IF(ERJ     .GT. -.995 ) THEN
        WRITE(HRJ,97) ABS(ERJ)
        HRJ(2:2)='-'
        GO TO 31
      ELSE IF(ERJ     .GT. -9.95 ) THEN
        WRITE(HRJ,96) ERJ
        GO TO 31
      ELSE IF(ERJ     .GT. -999.5) THEN
        WRITE(HRJ,95) IFIX(ERJ-0.5)
        GO TO 31
      ELSE
        WRITE(HRJ,95) -999
      END IF
   31 HC(1)   =HRJ
C*        spectral indices
      DO 34 J=2,5
      ERJ=0.
      IF(PR(J).NE.0) ERJ=ABS(100.*ER(J)/PR(J))
      RV(J)=RV(J)+ERJ*ERJ
      IF(ERJ  .GE. 9.950) WRITE(HRJ,95) IFIX(ERJ+0.5)
      IF(ERJ  .LT. 9.950) WRITE(HRJ,96) ERJ
      IF(ERJ  .LT. 0.995) WRITE(HRJ,97) ERJ
      HRJ(2:2)='~'
      IF(ER(J).EQ. 0    ) HRJ     ='      '
      HR(J)=HRJ
      ERJ=0.
      IF(PR(J).NE.0) ERJ=100.*EC(J,NE)/PR(J)
      EC(J,NE)=ERJ
      AV(J)=AV(J)+ERJ
      IF     (ERJ     .GT. 9999  ) THEN
        WRITE(HRJ,95) 9999
        GO TO 33
      ELSE IF(ERJ     .GT. 9.950 ) THEN
        WRITE(HRJ,95) IFIX(ERJ+0.5)
        GO TO 33
      ELSE IF(ERJ     .GT. 0     ) THEN
        WRITE(HRJ,97) ERJ
        GO TO 33
      ELSE IF(ERJ     .EQ. 0     ) THEN
        HRJ     ='      '
        GO TO 33
      ELSE IF(ERJ     .GT. -.995 ) THEN
        WRITE(HRJ,97) ABS(ERJ)
        HRJ(2:2)='-'
        GO TO 33
      ELSE IF(ERJ     .GT. -9.95 ) THEN
        WRITE(HRJ,96) ERJ
        GO TO 33
      ELSE IF(ERJ     .GT. -999.5) THEN
        WRITE(HRJ,95) IFIX(ERJ-0.5)
        GO TO 33
      ELSE
        WRITE(HRJ,95) -999
      END IF
   33 HC(J)=HRJ
   34 CONTINUE
C* Write the relative differences for the current lattice
      WRITE(LOU,93) LBL,(PR(J),HR(J),J=1,5)
      WRITE(LOU,93) BLN,(PC(J),HC(J),J=1,5)
      WRITE(LOU,93)
      GO TO 20
C* Input exhausted - print average if rel.differences requested
   80 IF(FLNM.EQ.'                                        ') GO TO 90
      DO 86 J=1,5
      IF(ND(J).GT.0) RV(J)=SQRT(RV(J)/ND(J))
      IF(ND(J).GT.0) AV(J)=     AV(J)/ND(J)
      AE(J)=0.
      IF(ND(J).EQ.0) GO TO 86
      DO 82 I=1,NE
      IF(EC(J,I).NE.0) AE(J)=AE(J)+(EC(J,I)-AV(J))**2
   82 CONTINUE
      IF(ND(J).GT.0) AE(J)=SQRT(AE(J)/ND(J))
   86 CONTINUE
      WRITE(LOU,98) '   Average',(RV(J)      ,J=1,5),(AV(J),AE(J),J=1,5)
   90 STOP 'SMRDIF Completed'
   91 FORMAT(2A40)
   92 FORMAT(A10,F8.5,I5,1X,2F6.3,1X,2F7.4,1X,2F7.4,1X,2F6.3)
   93 FORMAT(A10,F8.5,A6,F7.3,A6,F8.4,A6,F8.4,A6,F7.3,A6)
   94 FORMAT(5F10.0)
   95 FORMAT('(',I4  ,')')
   96 FORMAT('(',F4.1,')')
   97 FORMAT('(',F4.2,')')
   98 FORMAT(2X,78('-')/  A10,F13.2,F13.2,F14.2,F14.2,F13.2 /
     1 11X,2( F6.2,'(~',F4.2,')'),2( F7.2,'(~',F4.2,')')
     1      , F6.2,'(~',F4.2,')' )
      END
 
*deck smrlib 
      PROGRAM SMRLIB
C-Title  : SMRLIB Program
C-Purpose: Compare SMRDIF summary results for different libraries
C-Author : A.Trkov, IAEA-NDS, Vienna
C-Version: Nov-2000 Original code.
C-M
C-M  Manual for Program SMRLIB
C-M  -------------------------
C-M
C-M  The program compares SMRDIF outputs from the analysis of the
C-M  WLUP series of benchmarks. More than one SMRDIF output may
C-M  appear on the same file. The program also recognises and is
C-M  able to process D2OSMR and WEDB1B outputs on the same file,
C-M  but at least one SMRDIF output must appear at the beginning.
C-M  The source library names are extracted from it.
C-M
C-M  Comparison consists of copying the heading information and
C-M  the reference result, followed by the corresponding record
C-M  from each of the SMRDIF output files. In the first 10 columns
C-M  the library identification string is added, extracted from
C-M  the first SMRLIB output set on each file.
C-M
C-M  Instructions:
C-M  The following input parameters are entered interactively:
C-M  - Output list filename (default SMRLIB.LST).
C-M  - SMRLIB files to be compared. Up to MXFL files can be
C-M    specified. The list is terminated by blank or "-".
C-
      PARAMETER     (MXFL=15,MXIS=400)
      CHARACTER*100   REC,RC2
      CHARACTER*61   LINE
      CHARACTER*40   BLNK,FLNM,FLIN(MXFL),FLOU
      CHARACTER*20   SRCH(14)
      CHARACTER*10   CH10,BLBL(MXFL)
      CHARACTER*8    ISOT(MXIS),JSOT
      CHARACTER*1    C1
      DIMENSION      NLBL(MXFL)
      DIMENSION      ERX(MXFL,MXIS),ELM(MXIS),REF(MXIS)
C*
      DATA NLBL/MXFL*0/
      DATA LIN,LOU,LKB,LTT/ 20, 2, 5, 6 /
      DATA BLNK/'                                        '/
     1     FLOU/'Smrlib.lst'/
C* Search strings
      DATA SRCH/' SMRDIF - Compare la'
     &         ,' D2OSMR - Summarize '
     &         ,' WEDB1B - Isotopic c'
     &         ,' D2OE3B comparison A'
     &         ,' DOPPLER comparison '
     &         ,' RTC-DIFFS.BETWEEN C'
     &         ,' MTR-OWR comparison '
     &         ,' Thermal Neutron Flu'
     &         ,' Therm.Flux Distr.H2'
     &         ,' Therm.Flux Distr.AI'
     &         ,' Therm.Flux Distr.12'
     &         ,' Therm.Flux Distr.-A'
     &         ,' PWR THORIUM PIN CEL'
     &         ,' SMRDIF Integral par'/
C*
C* Write the banner
      WRITE(LTT,901) ' SMRLIB - Comparison of SMRDIF outputs  '
      WRITE(LTT,901) ' =====================================  '
      WRITE(LTT,901)
C*
C* Define the filenames
      WRITE(LTT,901) '$Enter the output summary filename    : '
      READ (LKB,901) FLNM
      IF(FLNM.NE.BLNK) FLOU=FLNM
      OPEN (UNIT=LOU,FILE=FLOU,STATUS='UNKNOWN')
      NSMR=0
      GO TO 14
C* Trap illegal or non-existent files
   12 WRITE(LTT,901) ' ERROR - Invalid summary file      : ',FLNM
   14 KIN=LIN+NSMR+1
      WRITE(LTT,901) '$Enter the input summary filename     : '
      READ (LKB,901,END=40) FLNM
      IF(FLNM.EQ.BLNK .OR. FLNM(1:1).EQ.'-') GO TO 40
      OPEN (UNIT=KIN,FILE=FLNM,STATUS='OLD',ERR=12)
C*
C* Find the appropriate search string
   20 READ (KIN,902,END=22) REC
      IF(NSMR.EQ.0 .AND. REC(2:2).EQ.'#') WRITE(LOU,902) REC
      IF(REC(1:20).NE.SRCH(1).AND.REC(1:20).NE.SRCH(4).AND.REC(1:20).NE.
     1SRCH(5).AND.REC(1:20).NE.SRCH(6).AND.REC(1:20).NE.SRCH(7).AND.
     2REC(1:20).NE.SRCH(8).AND.REC(1:20).NE.SRCH(9).AND.REC(1:20).NE.
     3SRCH(10).AND.REC(1:20).NE.SRCH(11).AND.REC(1:20).NE.SRCH(12).AND.
     4REC(1:20).NE.SRCH(13).AND.REC(1:20).NE.SRCH(14))GO TO 20
      GO TO 30
C*
C* Trap unrecognised/invalid file
   22 WRITE(LTT,901) ' WARNING - Not SMRDIF output file  : ',FLNM
      CLOSE(UNIT=KIN)
      GO TO 12
C*
C* SMRDIF output located in this file - try next file
   30 NSMR=NSMR+1
      FLIN(NSMR)=FLNM
      IF(NSMR.LT.MXFL) GO TO 14
C*
C* All files opened - begin comparison
   40 IF(NSMR.LT.2) THEN
        WRITE(LTT,901) ' WARNING - Nothing to compare - 1 file  '
        GO TO 900
      END IF
      WRITE(LTT,901)
      WRITE(LTT,901) ' Following files summarised in          ',FLOU
      DO 41 I=1,NSMR
      WRITE(LTT,901) BLNK,FLIN(I)
   41 CONTINUE
C*
C* Start assembling the output file
C* Write heading information from SMRDIF output
      WRITE(LOU,902) REC
      DO 44 K=1,3
      IDIF=0
      DO 42 I=1,NSMR
        KIN=LIN+I
        READ (KIN,902) RC2
        IF(I.EQ.1) THEN
          REC=RC2
          WRITE(LOU,902) REC
        END IF
C* Check if same reference IDIF=flag indicating differences
        IF(RC2.NE.REC) THEN
          IF(IDIF.EQ.0)
     1    WRITE(LTT,901) ' WARNING - '//FLIN(1)(1:29),REC(41:70)
          WRITE(LTT,901) '           '//FLIN(I)(1:29),RC2(41:70)
          IDIF=IDIF+1
        END IF
   42 CONTINUE
   44 CONTINUE
C* Identify the source library into BLBL 10-character string
      DO 48 I=1,NSMR
        KIN=LIN+I
        READ (KIN,902) RC2
        WRITE(LOU,902) RC2
        N2=81
   45   N2=N2-1
        IF(N2.LT.1) THEN
          WRITE(LTT,901) ' SMRLIB ERROR reading file            : '
     &                  ,FLIN(I)
          STOP 'SMRLIB ERROR - Reading file'
        END IF
        IF(RC2(N2:N2).EQ.' ') GO TO 45
        N1=N2
   46   N1=N1-1
        IF(RC2(N1:N1).EQ.'.') THEN
          N2=N1-1
          GO TO 46
        END IF
        IF(N2-N1.LT.0) THEN
          WRITE(LTT,901) ' SMRLIB ERROR reading file            : '
     &                  ,FLIN(I)
          WRITE(LTT,901) '              Invalid library name      '
          STOP 'SMRLIB ERROR - Reading file'
        END IF
        IF(RC2(N1:N1).NE.' ') GO TO 46
        NN=MIN(10,N2-N1)
        CH10='          '
        CH10(11-NN:10)=RC2(N1+1:N1+NN)
        BLBL(I)=CH10
   48 CONTINUE
C* Copy the header
      DO 52 I=1,3
      DO 51 J=1,NSMR
      READ (LIN+J,902) REC
      IF(J.EQ.1) WRITE(LOU,902) REC
   51 CONTINUE
   52 CONTINUE
C*
C* Compare benchmark results from different files (SMRDIF & D2OSMR)
C* IBN flag to suppress blank line printout between sets
C* IEN flag to mark end of data on reference file
      IBN=0
   60 READ (LIN+1,902) REC
      IF(REC(1:20).EQ.'                    ') GO TO 60
      IF(REC(1:20).EQ.'  ------------------' .OR.
     1   REC(1:20).EQ.' -------------------' .OR.
     2   REC(1:20).EQ.' ===================') THEN
        WRITE(LOU,902) REC
        IBN=0
        NLBL(1)=1
        GO TO 60
      END IF
      IF(IBN.NE.0) WRITE(LOU,902)
      IBN=IBN+1
      WRITE(LOU,902) REC
      READ (LIN+1,902) RC2
      RC2(1:10)=BLBL(1)
      WRITE(LOU,902) RC2
      DO 64 J=2,NSMR
      IF(NLBL(J).NE.0) THEN
        IF(NLBL(1).NE.0) THEN
          GO TO 62
        ELSE
          GO TO 64
        END IF
      END IF
   61 READ (LIN+J,902) RC2
      IF(RC2(1:10).EQ.REC(1:10)) GO TO 62
      IF(RC2(1:10).EQ.'   Average'.OR.RC2(1:10).EQ.' Average  ')THEN
        NLBL(J)=1
        GO TO 64
      END IF
      IF(RC2(1:10).NE.REC(1:10)) GO TO 61
   62 READ (LIN+J,902) RC2
      RC2(1:10)=BLBL(J)
      WRITE(LOU,902) RC2
   64 CONTINUE
      IF(NLBL(1).EQ.0) GO TO 60
      DO 66 J=1,NSMR
      NLBL(J)=0
   66 CONTINUE
C*
C* Check for any additional data sets on the same file
   70 KIN=LIN+1
   71 READ (KIN,902,END=900) REC
      IF(REC(2:2).EQ.'#') WRITE(LOU,902) REC
      IF(REC(1:20).EQ.SRCH(1)) GO TO 72
      IF(REC(1:20).EQ.SRCH(2)) GO TO 72
      IF(REC(1:20).EQ.SRCH(3)) GO TO 80
      IF(REC(1:20).EQ.SRCH(4)) GO TO 72
      IF(REC(1:20).EQ.SRCH(5)) GO TO 72
      IF(REC(1:20).EQ.SRCH(6)) GO TO 72
      IF(REC(1:20).EQ.SRCH(7)) GO TO 72
      IF(REC(1:20).EQ.SRCH(8)) GO TO 72
      IF(REC(1:20).EQ.SRCH(9)) GO TO 72
      IF(REC(1:20).EQ.SRCH(10)) GO TO 72
      IF(REC(1:20).EQ.SRCH(11)) GO TO 72
      IF(REC(1:20).EQ.SRCH(12)) GO TO 72
      IF(REC(1:20).EQ.SRCH(13)) GO TO 72
      IF(REC(1:20).EQ.SRCH(14)) GO TO 72
      GO TO 71
C* Next SMRDIF or D2OSMR output identified
   72 WRITE(LOU,902)
      WRITE(LOU,902)
      WRITE(LOU,902) REC
      READ (KIN,902) RC2
      WRITE(LOU,902) RC2
   73 READ (KIN,902,END=900) RC2
      IF(RC2(1:10).NE.'   LATTICE'.AND.RC2(1:10).NE.'       BUP'.AND.
     1RC2(1:10).NE.'     E(wt%'.AND.RC2(1:10).NE.'     Case '.AND.
     2RC2(1:10).NE.'       CYC'.AND.RC2(1:10).NE.'NAME      '.AND.
     3RC2(1:10).NE.' Case  COO'.AND.RC2(1:10).NE.' R(cm)    '.AND.
     4RC2(1:10).NE.' Case     '.AND.RC2(1:10).NE.' B(MWd/kgH'.AND.
     5RC2(1:10).NE.'    ISOTOP') GO TO 73
      WRITE(LOU,902)
      WRITE(LOU,902) RC2
      READ (KIN,902) RC2
      WRITE(LOU,902) RC2
      DO 78 J=2,NSMR
      KIN=LIN+J
   76 READ (KIN,902,END=900) RC2
      IF(RC2(1:20).NE.REC(1:20)) GO TO 76
   77 READ (KIN,902) RC2
      IF(RC2(1:10).NE.'   LATTICE'.AND.RC2(1:10).NE.'       BUP'.AND.
     1RC2(1:10).NE.'     E(wt%'.AND.RC2(1:10).NE.'     Case '.AND.
     2RC2(1:10).NE.'       CYC'.AND.RC2(1:10).NE.'NAME      '.AND.
     3RC2(1:10).NE.' Case  COO'.AND.RC2(1:10).NE.' R(cm)    '.AND.
     4RC2(1:10).NE.' Case     '.AND.RC2(1:10).NE.' B(MWd/kgH'.AND.
     5RC2(1:10).NE.'    ISOTOP') GO TO 77
      READ (KIN,902) RC2
   78 CONTINUE
      IBN=0
      GO TO 60
C*
C* WEDB1B output identified
   80 WRITE(LOU,902)
      WRITE(LOU,902)
      WRITE(LOU,902) REC
C* Copy comments
   82 READ (KIN,902,END=900) REC
      IF(REC(1:10).EQ.' Calculate') GO TO 82
      IF(REC(1:10).EQ.' Isotope  ') GO TO 84
      WRITE(LOU,902) REC
      GO TO 82
C* Read the isotope, rel.diff. and uncertainty from the first file
   84 NIS=0
      READ (KIN,902,END=900)
      READ (KIN,902,END=900)
   86 NIS=NIS+1
   87 READ (KIN,982,ERR=88,END=88) ISOT(NIS),CAL,ERX(1,NIS)
     1                            ,REF(NIS),ELM(NIS)
      IF(CAL.EQ.0 .AND. REF(NIS).EQ.0) GO TO 87
      IF(ISOT(NIS).EQ.'        ') GO TO 88
      GO TO 86
   88 NIS=NIS-1
C* Process the remaining files
      DO 120 J=2,NSMR
      KIN=LIN+J
   92 READ (KIN,902,END=900) REC
      IF(REC(1:20).NE.SRCH(3)) GO TO 92
   94 READ (KIN,902,END=900) REC
      IF(REC(1:10).NE.' Isotope  ') GO TO 94
      READ (KIN,902,END=900)
      READ (KIN,902,END=900)
      JIS=0
   96 READ (KIN,982,ERR=98,END=98) JSOT,DMY,ERJ
      IF(JSOT.EQ.ISOT(JIS+1)) THEN
        JIS=JIS+1
        ERX(J,JIS)=ERJ
      END IF
      IF(JIS.LT.NIS) GO TO 96
   98 IF(JIS.LT.NIS)
     &WRITE(LTT,901) ' WARNING - Unmatching isotopes on file  ',FLIN(J)
  120 CONTINUE
C* Print the differences
      WRITE(LOU,901) ' Legend: --- Uncertainty                '
      WRITE(LOU,901) '         *   Multiple points            '
      DO 122 J=1,NSMR
      WRITE(LOU,901) '        '//CHAR(48+J)//'  '//BLBL(J)
     1             //'                  '
  122 CONTINUE
      WRITE(LOU,901)
      WRITE(LOU,903)'  Isot. ','Ref.[mg/g]'
     1,'V_-20% _______________________V________________________+20%_V'
      NCHW=61
      EMN=-20.
      EMX= 20.
      DO 130 I=1,NIS
      CALL LNPLT1(LINE,NCHW,NSMR,ERX(1,I),ELM(I),EMN,EMX)
      WRITE(LOU,904) ISOT(I),REF(I),LINE
  130 CONTINUE
      GO TO 70
C*
C* File processing completed
  900 STOP 'SMRLIB Completed'
C*
  901 FORMAT(2A40)
  902 FORMAT(A100)
  903 FORMAT(A8,   A10  ,A61)
  904 FORMAT(A8,1P,E10.3,A61)
  982 FORMAT(A8,F12.0,F7.0,F12.0,F6.0)
      END
      SUBROUTINE LNPLT1(LINE,NCHW,NER,ERX,ELM,EMN,EMX)
C-Title  : Subroutine LNPLOT
C-Purpose: Set plot line-bar character string
C-Description:
C-D  The routine generates a character line LINE of length NCHW
C-D  to display NER sets of errors contained in ER and the
C-D  reference uncertainty. The routine is designed for the
C-D  purpose of comparing errors in the predicted isotopic
C-D  concentrations after burnup using various data libraries
C-D  in comparison with the uncertainty in the measured
C-D  concentrations.
C-D  - The line string represents error range from EMN (usually
C-D    negative) to EMX (usually positive).
C-D  - The measured uncertainty ELM (if given) is represented by
C-D    a sequence of strings "---" from minus to plus the
C-D    uncertainty.
C-D  - Errors of individual data sets are superimposed by
C-D    placing the numeral "n" into the appropriate place in the
C-D    string where "n" is the consecutive number of the data set.
C-
      CHARACTER*120 LINE
      CHARACTER*1   C1,H1
      DIMENSION     ERX(1)
C* Clear the output string
      DO 10 I=1,NCHW
      LINE(I:I)=' '
   10 CONTINUE
C* Define limits
      LINE(  1 :  1 )='|'
      LINE(NCHW:NCHW)='|'
C* Set the measured uncertainty range
      F0=FLOAT(NCHW-1)*(-ELM-EMN)/(EMX-EMN)
      L0=1+NINT(F0)
        IF(L0.LT.  1 ) L0=1
        IF(L0.GT.NCHW) L0=NCHW
      F1=FLOAT(NCHW-1)*( ELM-EMN)/(EMX-EMN)
      L1=1+NINT(F1)
        IF(L1.LT.  1 ) L1=1
        IF(L1.GT.NCHW) L1=NCHW
      LA=MIN(L0,L1)
      LB=MAX(L0,L1)
      DO 20 I=LA,LB
        LINE(I:I)='-'
   20 CONTINUE
C* Set centreline
      F0=FLOAT(NCHW-1)*(    -EMN)/(EMX-EMN)
      L0=1+NINT(F0)
      LINE(L0:L0)='|'
C* Set the errors for the data sets
      DO 60 I=1,NER
      ER=ERX(I)
      IF     (ER.LT.EMN) THEN
C* Mark error out of lower bound
        LINE(  1 :  1 )='<'
      ELSE IF(ER.GT.EMX) THEN
C* Mark error out of upper bound
        LINE(NCHW:NCHW)='>'
      ELSE
        FL=FLOAT(NCHW-1)*( ER-EMN)/(EMX-EMN)
        LL=1+NINT(FL)
        C1=CHAR(48+I)
        H1=LINE(LL:LL)
C* Mark multiple points with a star
        IF(H1.GE.CHAR(48+1) .AND.
     &     H1.LT.C1) THEN
           LINE(LL:LL)='*'
        ELSE
           IF(H1.NE.'*') LINE(LL:LL)=C1
        END IF
      END IF
   60 CONTINUE
      RETURN
      END
 
*deck THBURN 
C
C  PROGRAM THBURN
C
C  AUTHOR: FRANCISCO LESZCZYNSKI-INGENIERIA NUCLEAR- 2002
C                                CENTRO ATOMICO BARILOCHE
C                                ARGENTINA
C
C  PROCESS WIMS OUTPUT FOR BENCHMARK PWR THORIUM PIN CELL BURNUP
C
C  1) READ REFERENCE VALUES OF PARAMETERS FROM THBURN.REF
C
C  2) READ WIMS-D RESULTS FROM THBURN.OUT
C
C  3) CALCUL RELATIONS AND WRITE RESULTS
C
C***********************************************************************
      DIMENSION BURNUP(20),AKAIN(20),AKACAL(20),ATDENS(20),RELAT(10)
      DIMENSION IDAYS(20),MATER(20),IMATC(3)
      DIMENSION DENATC(3),DENCAL(20,20),DIFK(20),DIFDEN(20,20)
      DIMENSION REL(10),DIFR(10)
C
      CHARACTER*6 SIMBOL(20)
      CHARACTER*11 TITREL(10),SIMB
      CHARACTER*80,TIT,TIT1,TIT2,TIT3
      CHARACTER*120 LINE
C
C***********************************************************************
C
C  1) READ EXPERIMENTAL VALUES OF PARAMETERS
C
      OPEN(1,FILE='THBURN.REF')
      read(1,1)TIT
      read(1,1)REF
C
      read(1,1)TIT1
      DO I=1,11
       read(1,2)BURNUP(I),IDAYS(I),AKAIN(I)
      ENDDO
C
      read(1,1)TIT2
      DO I=1,16
       read(1,3)SIMBOL(I),MATER(I),ATDENS(I)
      ENDDO
C
      read(1,1)TIT3
      DO I=1,4
       read(1,4)TITREL(I),RELAT(I)
      ENDDO
C
      DO I=1,16
       DENCAL(I,1)=0.0
      END DO
      read(1,1)TIT3
      read(1,4)SIMB,DENCAL(1,1)
      read(1,4)SIMB,DENCAL(6,1)
      read(1,4)SIMB,DENCAL(7,1)
      read(1,4)SIMB,DENCAL(9,1)
C
      CLOSE(1)
C
C***********************************************************************
C  2) READ WIMS-D RESULTS
C
      OPEN(1,FILE='THBURN.OUT')
C
C       CHECK IF LIBRARY WIMS86
C
        read(1,'(A120)')LINE
        IW86=0
        DO WHILE(LINE(16:34).NE.'entry into chain  2')
         read(1,'(A120)')LINE
         IF(LINE(1:43).EQ.'    129    69    25    14    13    17    55')
     1    IW86=1
        END DO
        CLOSE(1)
C
      OPEN(1,FILE='THBURN.OUT')
C
  50  READ(1,5,END=300)LINE
      IF(LINE(26:35).NE.'k-infinity')GOTO 50
      BACKSPACE(1)
      READ(1,6)AKACAL(1)
C
      DO N=1,12
       DO I=1,16
        DENCAL(I,N)=0.0
       ENDDO
      ENDDO
C
  60  N=1
  70  IF(N.EQ.12)GOTO 300
  80  READ(1,5,END=300)LINE
      IF(LINE(2:4).NE.'t= ')GOTO 80
      BACKSPACE(1)
      READ(1,7)IDAYSC
      IF(IDAYSC.LT.IDAYS(N+1))GOTO 80
      N=N+1
  90  READ(1,5,END=300)LINE
      IF(LINE(1:9).NE.' material')GOTO 90
      M=0
  95  READ(1,8)(IMATC(J),DENATC(J),J=1,3)
      DO J=1,3
       DO I=1,16
        IF(IMATC(J).EQ.MATER(I))THEN
         DENCAL(I,N)=DENATC(J)
         M=M+1
        ENDIF
       ENDDO
      ENDDO
      IF(IW86.EQ.0.AND.M.LT.16)GOTO 95
      IF(IW86.EQ.1.AND.M.LT.14)GOTO 95
 100  READ(1,5,END=300)LINE
      IF(LINE(26:35).NE.'k-infinity')GOTO 100
      BACKSPACE(1)
      READ(1,6)AKACAL(N)
      GOTO 70
 300  continue
      CLOSE(1)
C
C***********************************************************************
C  3) CALCUL RATIOS AND WRITE RESULTS
C
C     K-INF
      DO I=1,11
       DIFK(I)=(AKACAL(I)-AKAIN(I))*100.0/AKAIN(I)
      ENDDO
C
C    ISOTOPE CONCENTRATIONS
      DO J=2,11
       DO I=1,16
        DIFDEN(I,J)=(DENCAL(I,J)-ATDENS(I))*100.0/ATDENS(I)
       ENDDO
      ENDDO
C
      REL(1)=DENCAL(2,10)+DENCAL(3,10)+DENCAL(5,10)+DENCAL(7,10)+
     1 DENCAL(10,10)+DENCAL(11,10)+DENCAL(13,10)+DENCAL(15,10)
      DIFR(1)=(REL(1)-RELAT(1))*100.0/RELAT(1)
C
      ACT0=0.0
      ACT10=0.0
      DO I=1,16
       ACT0=ACT0+DENCAL(I,1)
       ACT10=ACT10+DENCAL(I,10)
      ENDDO
      REL(2)=(ACT0-ACT10)/ACT0
      DIFR(2)=(REL(2)-RELAT(2))*100.0/RELAT(2)
C
      FERT1=DENCAL(1,1)+DENCAL(9,1)
      FERT10=DENCAL(1,10)+DENCAL(9,10)
      REL(3)=(FERT1-FERT10)/FERT1
      DIFR(3)=(REL(3)-RELAT(3))*100.0/RELAT(3)
C
      THDEP=(DENCAL(1,10)-DENCAL(1,1))/DENCAL(1,1)
      U8DEP=(DENCAL(9,10)-DENCAL(9,1))/DENCAL(9,1)
      REL(4)=THDEP/U8DEP
      DIFR(4)=(REL(4)-RELAT(4))*100.0/RELAT(4)
C ---------------------------------------------
      OPEN(3,FILE="THBURN.LST")
C
C*
       WRITE(3,1)TIT
       WRITE(3,693)' ================================================='
       WRITE(3,1)
       WRITE(3,16)' Processed Benchmark analysis reports :           '
       WRITE(3,16)'                              1 case  : thburn.lst'
       WRITE(3,1)
       WRITE(3,14)
       WRITE(3,693)' ================================================='
C
       DO I=1,11
        WRITE(3,9)BURNUP(I),AKAIN(I)
        WRITE(3,10)AKACAL(I),DIFK(I)
        WRITE(3,13)
       ENDDO
       WRITE(3,693)' ================================================='
       WRITE(3,719)' Average  '
       WRITE(3,719)' Dif/St.Dv'
       WRITE(3,718)' # '
C
       WRITE(3,1)TIT
       WRITE(3,693)' ================================================='
       WRITE(3,1)
       WRITE(3,16)' Processed Benchmark analysis reports :           '
       WRITE(3,16)'                              1 case  : thburn.lst'
       WRITE(3,1)
       WRITE(3,15)
       WRITE(3,693)' ================================================='
       DO I=1,16
        WRITE(3,11)SIMBOL(I),ATDENS(I)
        WRITE(3,10)DENCAL(I,10),DIFDEN(I,10)
        WRITE(3,13)
       ENDDO
       WRITE(3,693)' ================================================='
       WRITE(3,719)' Average  '
       WRITE(3,719)' Dif/St.Dv'
C
C      DO I=1,4
C       WRITE(3,12)TITREL(I),RELAT(I)
C       WRITE(3,10)REL(I),DIFR(I)
C       WRITE(3,13)
C      ENDDO
C
      CLOSE(3)
C
  1   FORMAT(A80)
  2   FORMAT(F11.3,I7,F11.5)
  3   FORMAT(A6,I5,E12.5)
  4   FORMAT(A11,E12.5)
  5   FORMAT(A120)
  6   FORMAT(36X,E13.6)
  7   FORMAT(4X,I5)
  8   FORMAT(3(I6,3X,E14.7))
  9   FORMAT(F11.3,1X,1PE12.5,' (   0.0 )')
 10   FORMAT(12X,1PE12.5,' (',0PF7.2,')')
 11   FORMAT(5X,A6,1X,1PE12.5,' (   0.0 )')
 12   FORMAT(1X,A11,1PE12.5,' (   0.0 )')
 13   FORMAT(' ')
 14   FORMAT(' B(MWd/kgHM) Kinfinity   diff(%)')
 15   FORMAT('    ISOTOPE  AtomDens.   diff(%)')
 16   FORMAT(A50)
 693  FORMAT(A50)
 718  FORMAT(A4)
 719  FORMAT(A10)
C
      STOP 'Completed'
      END
*deck updbrn 
      program updbrn
c
c     updbrn: Update energy released per fission and decay data
c             d.l.aldama, iaea/nds consultant
c             December 2006
c
c     Input files: (enter interactively from the default input unit)
c            enfiss.lst: output from enfiss.for
c                        (energy released per fission data)
c            endfdy.dat: evaluated nuclear decay data file
c            endfnt.dat: evaluated nuclear neutron data file
c            njoyin.nji: NJOY input option file
c
c     Output file:
c            updated.nji: updated NJOY input file
c
c     Description
c            The program asks for the input file names.
c            Extract energy released per fission and decay data
c            from the evaluated nuclear data files. Finally,
c            update and write the new NJOY input option file.
c
      character*20  tok(20)
      character*80  fn,line,lline
      dimension matef(100),ef(100)
      dimension ddza(5000),hldd(5000)
      dimension matn(500),zan(500)
c
c     Read fission energy released per fission
c     Output of enfiss.for code
c      
      write(*,*)' Program updbrn: Update E-fission and Decay Data'
      write(*,*)' ==============================================='
      write(*,*) 
      write(*,*)' Enter enfiss output data file: '
      read(*,*)fn
      write(*,*)' Energy released per fission read from: ', fn
      open(1,file=fn)
      ifind=0
      do while (ifind.eq.0)
        read(1,'(a80)',end=100)line
        if (line(54:61).eq.'[J/mole]') ifind=1
      enddo
 100  if (ifind.ne.0) then
        i=0
        do while (.true.)
          read(1,'(a80)', end=200)line
          i=i+1
          read(line,'(i6,45x,e11.0)')matef(i),ef(i)
          write(*,'(i6,1pe12.5)')matef(i),ef(i)
        enddo  
      endif
 200  nmatef=i            
      close(1)
      write(*,*)
c
c    Read evaluated decay data file
c
      write(*,*)' Enter evaluated decay data file: '
      read(*,*)fn
      write(*,*)' Decay data read from: ',fn
      open(1, file=fn)
      read(1,'(a66,i4,i2,i3,i5)')line,matdd,mf,mt,is
      matdd=10000
      j=0
      do while(matdd.ge.0)
        read(1,'(a66,i4,i2,i3,i5)')line,matdd,mf,mt,is
        if (mf.eq.8) then
          j=j+1
          read(line,'(2e11.0,4i11)')ddza(j),dummy,lisdd,lis0dd
          ddza(j)=ddza(j)+0.1*lis0dd
          read(1,'(2e11.0)')hldd(j),dummy         
          write(*,'(f11.1,1pe13.5)')ddza(j),hldd(j)
          do while (mf.eq.8)
            read(1,'(a66,i4,i2,i3,i5)')line,matdd,mf,mt,is
          enddo
        endif
      enddo
      ndd=j      
      close(1)
      write(*,*)
c
c     Evaluated nuclear data file for XS
c      
      write(*,*)' Enter evaluated nuclear data file for XS: '
      read(*,*)fn
      write(*,*)' Evaluated nuclear data read from: ',fn
      open(1,file=fn)
        read(1,'(a66,i4,i2,i3,i5)')line,mat,mf,mt,is
        mat=10000
        j=0
        do while(mat.ge.0)
          read(1,'(a66,i4,i2,i3,i5)')line,mat,mf,mt,is
          if (mf.eq.1 .and. mt.eq.451) then
            j=j+1
            matn(j)=mat
            read(line,'(e11.0)')zan(j)
            read(1,'(22x,4i11)')lisn,lis0n
            zan(j)=zan(j)+0.1*lis0n
            write(*,'(i6,f10.1)')matn(j),zan(j)
            do while (mt.eq.451)
              read(1,'(a66,i4,i2,i3,i5)')line,mat,mf,mt,is
            enddo
          endif  
        enddo
      close(1)
      nmatn=j
      write(*,*)
c
c     Updating energy released per fission and decay data
c     
      write(*,*)' Enter NJOY input data file: '
      read(*,*)fn
      write(*,*)' Njoy input options read from: ',fn
      open(1,file=fn)
      open(2,file='updated.nji')
      do while (.true.)
        read(1,'(a80)',END=300)lline
        call gettok(lline,20,ntok,tok)
        if (tok(1)(1:2).eq.'--'.and.lline(4:9).ne.'      ') then
          write (*,'(a17,a6)')'  Updating deck: ',tok(2)(1:6)
          call writelt(2,lline)           
        else if (tok(1)(1:5).eq.'wimsr') then
          call writelt(2,lline)
          read(1,'(a80)')lline
          call writelt(2,lline)
          read(1,'(a80)')lline
          call writelt(2,lline)
          call gettok(lline,20,ntok,tok)
          igroup=0                     
          if (ntok.ge.3) igroup=itok(tok(3))
          if (igroup.ne.0) then
            read(1,'(a80)')lline
            call writelt(2,lline)
          endif  
          read(1,'(a80)')lline
          call writelt(2,lline)
          call gettok(lline,20,ntok,tok)
          if (ntok.ge.1)imat=itok(tok(1))
          zanji=-1000
          ifind=0
          j=1
          do while (j.le.nmatn.and.ifind.eq.0)
            if (imat.eq.matn(j)) then
              ifind=1
              zanji=zan(j)
            else
              j=j+1  
            endif
          enddo
          iburn=4
          if (ntok.ge.4) iburn=itok(tok(4))
          if (iburn.gt.0) then
            read(1,'(a80)')lline
            call writelt(2,lline)
            call gettok(lline,20,ntok,tok)
            ifprod=0
            if (ntok.ge.11) ifprod=itok(tok(11))
            read(1,'(a80)')lline
            if (ifprod.eq.0) then
              call gettok(lline,20,ntok,tok)
              nn1=2
              if (ntok.ge.1) nn1=itok(tok(1))
              eff=0.0
              if (ntok.ge.2) eff=ftok(tok(2))
              ifind=0
              j=1
              do while (j.le.nmatef.and.ifind.eq.0)
                if (imat.eq.matef(j)) then
                  eff=ef(j)
                  ifind=1
                else
                   j=j+1  
                endif
              enddo
              if (nn1.eq.2) then
                write(line,'(i6,1pe11.4)')nn1,eff
                lline=adjustl(line)
                call writelt(2,lline)
              else
                write(2,'(i6,1pe11.4)')nn1,eff  
              endif  
            else
              call writelt(2,lline)
            endif
            read(1,'(a80)')lline
            call writelt(2,lline)
            read(1,'(a80)')lline
            call gettok(lline,20,ntok,tok)
            nn=itok(tok(1))
            decay=0.0
            if (ntok.ge.2)decay=ftok(tok(2))
            if (.not.(decay .eq. 0.0 .and. nn.eq.0)) then
              if (zanji.ge.0.0) then
                kfind=0
                j=1
                do while (j.le.ndd.and.kfind.eq.0)
                  if (abs(zanji-ddza(j)).lt.0.01) then
                    kfind=1
                    decay=0.6931472/hldd(j)
                  else
                    j=j+1  
                  endif
                enddo                
              endif
              if (ifprod.ne.0 .or. nn1.eq.2) then
                 write(line,'(i6,1pe11.4)')nn,decay
                 lline=adjustl(line)
                 call writelt(2,lline)
              else
                write(2,'(i6,1pe11.4)')nn,decay
              endif  
            else
              call writelt(2,lline)                                         
            endif            
          endif              
        else
          call writelt(2,lline)
        endif
      enddo     
 300  close(1)
      close(2)           
      stop
      end
c
c       gettok, ftok, itok
c
      subroutine gettok(line,marg,narg,arg)
c
c     version : 1.00
c
c     compiler: lahey fortran 77. version 4.00
c
c     written by : d. l. aldama
c                  la habana, cuba
c                  setp./94
c
c     input parameters:
c       marg : maximum number of tokens,
c              equal to the array arg dimension.
c
c     output parameters:
c       narg : actual number of tokens,
c              (narg.le.marg).
c       arg  : character array of tokens.
c
c
      character*(*) line
      character*(*) arg(marg)
      kmax=len(line)
      k=len(arg(1))
c      write(*,*)kmax,line,k
      do i=1,marg
        do j=1,k
          arg(i)(j:j)=' '
        end do
      end do
      narg=0
      i=1
      do while (i.le.kmax.and.line(i:i).ne.'/')
        if (line(i:i).eq.' ') then
          i=i+1
        else
          narg=narg+1
          if (narg.gt.marg) then
            narg=marg
c            write(*,*)narg,arg
c            return
          endif
          k=1
          do while (line(i:i).ne.' '.and.line(i:i).ne.'/')
            arg(narg)(k:k)=line(i:i)
            k=k+1
            i=i+1
          end do
        endif
      end do
c      write(*,*)narg,arg
      return
      end
      real*4 function ftok(string)
      character*(*) string
      k=len(string)
      read(string(1:k),*)ftok
      return
      end
      integer*4 function itok(string)
      character*(*) string
      k=len(string)
      read(string(1:k),*)itok
      return
      end
      subroutine writelt(nunit,lstr)
        character*(*) lstr
        ltrim=len_trim(lstr)
        write(nunit,'(a)')lstr(1:ltrim)
        return
      end
*deck WEDB1A 
      PROGRAM WEDB1A
C-Title  : WEDB1A Program
C-Purpose: Analysis of the Burnup Credit Criticality Benchmark PART-1A
C-Author : D.L.Aldama, A.Trkov (1998)
C-M
C-M  Manual for Program WEDB1A
C-M  =========================
C-M
C-M    The program analyses the results of the NEA/CRP Burnup Credit
C-M  benchmark Part-1A (criticality prediction) from the WIMS-D code.
C-M    The differences in Kinf and deltaK are calculated with
C-M  reference to the solution described in the report
C-M  JAERI-M 94-003, 1994. Reactions rates also extracted
C-M  and normalized to 1 in each energy group. Results are
C-M  saved on a separate output file.
C-M
C-M  The program was originally written for the Cuban version of the
C-M  WIMS-D/4 output. It was modified for compatibility with WIMSD5.
C-M  Also, the command line input was changed to read the filenames
C-M  from the keyboard explicitly.
C-
      PARAMETER (NFF=12, N0=28, NK=13, NG1=3)
      CHARACTER*120 LINE
      CHARACTER*40  BLNK,FLNM,FLWO,FLOU,FLRR
      CHARACTER*7  CDW(N0)
      DIMENSION IDW(N0),RRA(N0,NG1,NK),RRF(N0,NG1,NK),RRN(N0,NG1,NK)
      DIMENSION XKREF(NK),SXKREF(NK),DKREF(NK),SDKREF(NK)
      DIMENSION SUMA(NG1,NK),SUMN(NG1,NK),SUMF(NG1,NK),XNU(NFF,NG1,NK)
      DIMENSION XKINF(NK)
C* WIMS-D "1986" material identifiers
      DATA CDW/'U -234 ','U -235 ','U -236 ','U -238 ','Pu-238 ',
     6         'Pu-239 ','Pu-240 ','Pu-241 ','Pu-242 ','Am-241 ',
     6         'Am-243 ','Np-237 ',
     6         'Mo- 95 ','Tc- 99 ','Ru-101 ','Rh-103 ','Ag-109 ',
     6         'Cs-133 ','Nd-143 ','Nd-145 ','Sm-147 ','Sm-149 ',
     6         'Sm-150 ','Sm-151 ','Sm-152 ','Eu-153 ','Gd-155 ',
     6         'O - 16 '/
c    1         'U -234 ','U -235 ','U -236 ','U -238 ','Pu-238 ',
c    1         'Pu-239 ','Pu-240 ','Pu-241 ','Pu-242 ','Am-241 ',
c    1         'Am-243 ','Np-237 ',
c    1         'Mo- 95 ','Tc- 99 ','Ru-101 ','Rh-103 ','Ag-109 ',
c    1         'Cs-133 ','Nd-143 ','Nd-145 ','Sm-147 ','Sm-149 ',
c    1         'Sm-150 ','Sm-151 ','Sm-152 ','Eu-153 ','Gd-155 ',
c    1         'O - 16 '/
      DATA IDW/    234  ,   2235  ,    236  ,   8238  ,    948  ,
     6            6239  ,   1240  ,   1241  ,   1242  ,    951  ,
     6             953  ,    937  ,
     6            4095  ,   4099  ,   4101  ,   4103  ,   4109  ,
     6            4133  ,   4143  ,   4145  ,   6147  ,   4149  ,
     6            4150  ,   4151  ,   4152  ,   4153  ,   2155  ,
     6            6016  /
c    1             234  ,    235  ,    236  ,   2238  ,     -1  ,
c    1            3239  ,   1240  ,    241  ,    242  ,     -1  ,
c    1              -1  ,     -1  ,
c    1              95  ,     99  ,    101  ,    103  ,    109  ,
c    1             133  ,    143  ,    145  ,   2147  ,    149  ,
c    1             150  ,    151  ,    152  ,    153  ,   1155  ,
c    1              16  /
      DATA XKREF/1.4378,1.1402,1.0638,1.2456,1.1885,1.1123,1.0240,
     &           1.2284,1.1657,1.2635,1.2566,1.1080,1.0758/
      DATA SXKREF/0.0175,0.0169,0.0170,0.0107,0.0110,0.0164,0.0156,
     &           0.0109,0.0099,0.0108,0.0109,0.0194,0.0185/
      DATA DKREF/0.0000,-0.2976,-0.3740,-0.1922,-0.2493,-0.3255,
     &           -0.4138,-0.2094,-0.2721,-0.1743,-0.1812,-0.3290,
     &           -0.3612/
      DATA SDKREF/0.0000,0.0134,0.0154,0.0097,0.0107,0.0149,
     &            0.0147,0.0099,0.0114,0.0100,0.0097,0.0205,
     &            0.0248/
C*
      DATA LIN,LOU,LRR,LKB,LTT / 1, 2, 3, 5, 6 /
      DATA BLNK/'                                        '/
     1     FLWO/'WIMSDOUT'/
     2     FLOU/'WEDB1A.LST'/
     3     FLRR/'WEDB1A.RRT'/
C*
      WRITE(LTT,91)
      WRITE(LTT,91) ' WEDB1A - NEA Burnup Credit Benchmark   '
      WRITE(LTT,91) ' ====================================   '
      WRITE(LTT,91)
      WRITE(LTT,91) ' Part-1A  Criticality Prediction        '
      WRITE(LTT,91)
C* Define the filenames
   12 WRITE(LTT,91) ' Enter the WIMS output filename       : '
      READ (LKB,91) FLWO
      OPEN (UNIT=LIN,FILE=FLWO,STATUS='OLD',ERR=12)
C*
   14 WRITE(LTT,91) ' Default output report filename       : ',FLOU
      WRITE(LTT,91) '           Enter new name to redefine : '
      READ (LKB,91) FLNM
      IF(FLNM.NE.BLNK) FLOU=FLNM
      OPEN(UNIT=LOU,FILE=FLOU,STATUS='UNKNOWN')
      WRITE(LOU,91)
      WRITE(LOU,91) ' WEDB1A - NEA Burnup Credit Benchmark   '
      WRITE(LOU,91) ' ====================================   '
      WRITE(LOU,91)
      WRITE(LOU,91) ' Part-1A  Criticality Prediction        '
      WRITE(LOU,91)
      WRITE(LOU,91) ' Calculated results filename:         : ',FLWO
      WRITE(LOU,91)
      WRITE(LOU,91) ' Delta K = K(Case n) - K(Case 1)        '
      WRITE(LOU,91) ' Second row gives:                      '
      WRITE(LOU,91) '     Uncertainty (2 sigma) for reference'
      WRITE(LOU,91) '     Difference from reference for cal. '
      WRITE(LOU,91) ' Third row gives the same in %          '
      WRITE(LOU,91)
      N=2
C*
      WRITE(LTT,91) '$Enter Reaction rates report filename : '
      READ (LKB,91) FLRR
      IF(FLRR.NE.BLNK) THEN
        N=3
        OPEN (LRR,FILE=FLRR)
      END IF
C*
c  16 WRITE(LTT,91) ' Enter reference results filename     : '
c     READ (LKB,91) FLNM
c     IF(FLNM.NE.BLNK) THEN
c       FLRF=FLNM
c       OPEN(UNIT=LRF,FILE=FLRF,STATUS='OLD',ERR=16)
c       N=3
c     END IF
C*
      IK=0
      READ(LIN,'(A120)',END=400)LINE
      DO WHILE (LINE(1:15).NE.' END OF FILE ON')
        IF (LINE(27:34).EQ.'chain 14') THEN
          IK=IK+1
          CALL GETK(LIN,XKINF(IK),1)
        ELSE IF (LINE(27:34).EQ.'chain 15') THEN
          CALL GETRR(LIN,N0,NG1,IK,IDW,RRA,RRF,RRN)
        ENDIF
        READ(LIN,'(A120)',END=400)LINE
      END DO
  400 WRITE(LOU,1)'CASE','K - REF. ','K - CAL. ',
     &                    'DELTA K-REF.','DELTA K-CAL.'
      IF(N.EQ.3) WRITE(LRR,1)'CASE','K - REF. ','K - CAL. ',
     &                    'DELTA K-REF.','DELTA K-CAL.'
      DO I=1,IK
        DRHO=(XKINF(I)-XKINF(1))*100000.
        DK=DKREF(I)*100000.
        SXK=SXKREF(I)*100000.
        SDK=SDKREF(I)*100000.
        WRITE(LOU,2)I,XKREF(I),XKINF(I),INT(DK),INT(DRHO)
        IF(N.EQ.3) WRITE(LRR,20)I,XKREF(I),XKINF(I),INT(DK),INT(DRHO)
        DEVAK=(XKINF(I)-XKREF(I))*100000.
        DEVAR=(DRHO-DK)
        WRITE(LOU,3)INT(SXK),INT(DEVAK),INT(SDK),INT(DEVAR)
        IF(N.EQ.3)WRITE(LRR,30)INT(SXK),INT(DEVAK),INT(SDK),INT(DEVAR)
        IF (XKREF(I).NE.0.0) THEN
          DEVRK=(XKINF(I)/XKREF(I)-1.0)*100.0
        ELSE
          DEVRK=0.0
        ENDIF
        IF (INT(SDK).NE.0) THEN
          DEVRR=(DRHO/DK-1.0)*100.0
        ELSE
          DEVRR=0.0
        ENDIF
        WRITE(LOU,4)DEVRK,DEVRR
        WRITE(LOU,*)
        IF (N.EQ.3) THEN
          WRITE(LRR,40)DEVRK,DEVRR
          WRITE(LRR,*)
        ENDIF
      END DO
      DO I=1,IK
        DO J=1,NG1
          SUMA(J,I)=0.0
          SUMN(J,I)=0.0
          SUMF(J,I)=0.0
          DO K=1,N0
            SUMA(J,I)=SUMA(J,I)+RRA(K,J,I)
            SUMN(J,I)=SUMN(J,I)+RRN(K,J,I)
            SUMF(J,I)=SUMF(J,I)+RRF(K,J,I)
          END DO
        END DO
      END DO
C*
      DO I=1,IK
        DO J=1,NG1
          IF(SUMA(J,I).LE.0) SUMA(J,I)=1
          IF(SUMN(J,I).LE.0) SUMN(J,I)=1
          IF(SUMF(J,I).LE.0) SUMF(J,I)=1
        END DO
      END DO
C*
      DO IG=1,NG1
c       WRITE(LOU,*)' ABSORPTION RATES [%]  ENERGY GROUP: ',IG
c       WRITE(LOU,6)'  ISOT.',(J,J=1,IK)
        IF (N.EQ.3) THEN
          WRITE(LRR,*)' ABSORPTION RATES [%]  ENERGY GROUP: ',IG
          WRITE(LRR,60)'  ISOT.',(J,J=1,IK)
        ENDIF
        DO I=1,N0
c         WRITE(LOU,5)CDW(I),(RRA(I,IG,J)/SUMA(IG,J)*100.,J=1,IK)
          IF(N.EQ.3) THEN
            WRITE(LRR,50)CDW(I),(RRA(I,IG,J)/SUMA(IG,J)*100.,J=1,IK)
          ENDIF
        END DO
c       WRITE(LOU,*)
        IF(N.EQ.3) WRITE(LRR,*)
      END DO
      DO IG=1,NG1
c       WRITE(LOU,*)' NEUTRON PRODUCTION RATES [%]  ENERGY GROUP: ',IG
c       WRITE(LOU,6)'  ISOT.',(J,J=1,IK)
        IF (N.EQ.3) THEN
          WRITE(LRR,*)
     &              ' NEUTRON PRODUCTION RATES [%]  ENERGY GROUP: ',IG
          WRITE(LRR,60)'  ISOT.',(J,J=1,IK)
        ENDIF
        DO I=1,NFF
c         WRITE(LOU,5)CDW(I),(RRN(I,IG,J)/SUMN(IG,J)*100,J=1,IK)
          IF(N.EQ.3) THEN
            WRITE(LRR,50)CDW(I),(RRN(I,IG,J)/SUMN(IG,J)*100,J=1,IK)
          ENDIF
        END DO
        WRITE(LOU,*)
        IF(N.EQ.3) WRITE(LRR,*)
      END DO
      DO IG=1,NG1
c       WRITE(LOU,*)' FISSION RATES [%]  ENERGY GROUP: ',IG
c       WRITE(LOU,6)'  ISOT.',(J,J=1,IK)
        IF (N.EQ.3) THEN
          WRITE(LRR,*)' FISSION RATES [%]  ENERGY GROUP: ',IG
          WRITE(LRR,60)'  ISOT.',(J,J=1,IK)
        ENDIF
        DO I=1,NFF
c         WRITE(LOU,5)CDW(I),(RRF(I,IG,J)/SUMF(IG,J)*100,J=1,IK)
          IF(N.EQ.3) THEN
            WRITE(LRR,50)CDW(I),(RRF(I,IG,J)/SUMF(IG,J)*100,J=1,IK)
          ENDIF
        END DO
c       WRITE(LOU,*)
        IF(N.EQ.3) WRITE(LRR,*)
      END DO
      DO IG=1,NG1
c       WRITE(LOU,*)' NEUTRONS PER FISSION   ENERGY GROUP: ',IG
c       WRITE(LOU,6)'  ISOT.',(J,J=1,IK)
        IF (N.EQ.3) THEN
          WRITE(LRR,*)' NEUTRONS PER FISSION   ENERGY GROUP: ',IG
          WRITE(LRR,60)'  ISOT.',(J,J=1,IK)
        ENDIF
        DO I=1,NFF
          DO J=1,IK
            IF (RRF(I,IG,J).NE.0.0) THEN
              XNU(I,IG,J)=RRN(I,IG,J)/RRF(I,IG,J)
            ELSE
              XNU(I,IG,J)=0.0
            ENDIF
          END DO
c         WRITE(LOU,5)CDW(I),(XNU(I,IG,J),J=1,IK)
          IF (N.EQ.3) THEN
            WRITE(LRR,50)CDW(I),(XNU(I,IG,J),J=1,IK)
          ENDIF
        END DO
c       WRITE(LOU,*)
        IF(N.EQ.3) WRITE(LRR,*)
      END DO
      CLOSE(LIN)
      CLOSE(LOU)
      IF(N.EQ.3) CLOSE(LRR)
      STOP 'WEDB1A Completed'
    1 FORMAT(1X,A4,2X,A9,2X,A9,2X,A12,2X,A12)
    2 FORMAT(1X,I3,3X,F8.5,3X,F8.5,3X,I10,3X,I10)
    3 FORMAT(7X,I8,3X,I8,3X,I10,3X,I10)
    4 FORMAT(18X,F8.2,16X,F10.2)
    5 FORMAT(1X,A7,13F6.2)
    6 FORMAT(1X,A7,13I6)
   20 FORMAT(1X,I3,' ',F8.5,' ',F8.5,' ',I10,' ',I10)
   30 FORMAT(1X,3X,' ',I8,' ',I8,' ',I10,' ',I10)
   40 FORMAT(1X,3X,' ',8X,' ',F8.2,' ',10X,' ',F10.2)
   50 FORMAT(1X,A7,' ',10(F6.2,' '),F6.2)
   60 FORMAT(1X,A7,' ',10(I6,' '),I6)
   91 FORMAT(2A40)
      END
      SUBROUTINE GETK(LIN,XK,IKK)
      CHARACTER*120 LINE
      I=0
      READ(LIN,'(A120)')LINE
      DO WHILE(LINE(16:31).NE.'entry into chain')
        IF (LINE(26:35).EQ.'k-infinity') THEN
          I=I+1
          IF (I.EQ.IKK) THEN
            READ(LINE,'(36X,E13.0)')XK
          END IF
          READ(LIN,'(A120)')LINE
        END IF
        READ(LIN,'(A120)')LINE
      END DO
      BACKSPACE(LIN)
      RETURN
      END
      SUBROUTINE GETRR(LIN,N0,NG1,IK,IDW,RRA,RRF,RRN)
      DIMENSION IDW(N0),RRA(N0,NG1,*),RRF(N0,NG1,*),RRN(N0,NG1,*)
      CHARACTER*120 LINE
      READ(LIN,'(A120)')LINE
      DO WHILE (LINE(2:11).NE.'k-inf edit')
        READ(LIN,'(A120)')LINE
      END DO
      DO J=1,N0
        DO WHILE (LINE(2:8).NE.'element')
          READ(LIN,'(A120)')LINE
        END DO
        IF (LINE(16:24).EQ.'reactions') THEN
          READ(LINE,'(8X,I6)')IEL
          IPT=0
          I=1
          DO WHILE (I.LE.N0.AND.IPT.EQ.0)
            IF (IDW(I).EQ.IEL) IPT=I
            I=I+1
          END DO
          IF (IPT.EQ.0) THEN
            WRITE(*,*)' ELEMENT ',IEL,' NOT FOUND'
            STOP
          ENDIF
          READ(LIN,'(A120)')LINE
          READ(LIN,'(A120)')LINE
          DO IG=1,NG1
            READ(LIN,'(13X,E12.0)')RRA(IPT,IG,IK)
          END DO
          READ(LIN,'(A120)')LINE
          IF (LINE(2:8).EQ.'fission') THEN
            READ(LIN,'(A120)')LINE
            DO IG=1,NG1
              READ(LIN,'(13X,E12.0)')RRF(IPT,IG,IK)
            END DO
            READ(LIN,'(A120)')LINE
            READ(LIN,'(A120)')LINE
            DO IG=1,NG1
              READ(LIN,'(13X,E12.0)')RRN(IPT,IG,IK)
            END DO
          ELSE
            BACKSPACE(LIN)
          ENDIF
        ENDIF
      END DO
      BACKSPACE(LIN)
      DO WHILE(LINE(16:31).NE.'entry into chain')
        READ(LIN,'(A120)')LINE
      END DO
      BACKSPACE(LIN)
      RETURN
      END
*deck wedb1b 
      PROGRAM WEDB1B
C-Title  : WEDB1B Program
C-Purpose: Analysis of the Burnup Credit Criticality Benchmark PART-1B
C-Author : D.L.Aldama, A.Trkov (1998)
C-Version:
C-V 1999/03 - Extension to process Plutonium Recycling benchmark
C-V 2006/09 - Minor additions to comments and manual.
C-V         - Add convention that burnup with -ve sign in the reference
C-V           solution file includes cooling time.
C-M
C-M  Manual for Porgram WEDB1B
C-M  =========================
C-M
C-M    The program analyses the WIMS-D results of the NEA/CRP Burnup
C-M  Credit Benchmark Part-1B and the Physics of Plutonium Recycling
C-M  Benchmark Case A.
C-M    By default, the isotopic composition and the k-inf. for each
C-M  burnup step are printed to the output list file. If the reference
C-M  results filename is specified, the LAST calculated isotopic
C-M  composition is compared to the reference one at the appropriate
C-M  burnup step. A bar-graph diagram showing differences from the
C-M  reference is printed to WEDB1B.PLT file (fixed filename).
C-M    The reference results are read from a file apecified on
C-M  input. The program assumes that at least the leading 5 records
C-M  are comments and copies them to output. The burnup is
C-M  identified from the record beginning with " BURNUP = ".
C-M  The next record is skipped. The records that follow are
C-M  expected to contain the information on the isotopic
C-M  composition as follows:
C-M    Columns     1  Blank
C-M             2- 8  Chemical symbol
C-M             9-20  Concentration [mg/gUO2]
C-M            21-26  Uncertainty (2 sigma) [%]
C-M            27-32  Ratio: Actual/Model
C-M  The concentration ratio allows the correction for the
C-M  difference between the actual fuel pellet environment and
C-M  the idealised benchmark mode. It is applicable to the
C-M  comparison with the measured values. By default it is
C-M  equal to 1.
C-M    There are more than one data sets on the reference file.
C-M  The data following the burnup are chosen where the burnup
C-M  differs by less than 1 MWd/tU from the last burnup step on
C-M  the WIMS output.
C-M
C-M  The program was originally written for the Cuban version of the
C-M  WIMS-D/4 output. It was modified for compatibility with WIMSD5.
C-M  Also, the command line input was changed to read the filenames
C-M  from the keyboard explicitly.
C-
      PARAMETER (NN=3, N0=45, NK=100, NW=120)
      CHARACTER*120 LINE
      CHARACTER*50  BLNK,FLNM,FLWO,FLOU,FLRF,FLPL
      CHARACTER*7   CDW(N0)
      DIMENSION IDW(N0,4),AW(N0), XMAS(N0),INDX(N0)
     1         ,XREF(N0),SREF(N0),WREF(N0),DN(N0)
     1         ,BURNUP(NK),XKINF(NK),DAYS(NK)
C* Default materials list
      DATA CDW/'U -234 ','U -235 ','U -236 ','U -238 ','Np-237 ',
     1         'Pu-238 ','Pu-239 ','Pu-240 ','Pu-241 ','Pu-242 ',
     2         'Am-241 ','Am-242m','Am-243 ','Cm-242 ','Cm-243 ',
     2         'Cm-244 ','Cm-245 ','Mo- 95 ','Tc- 99 ','Ru-101 ',
     3         'Rh-103 ','Pd-105 ','Pd-107 ','Pd-108 ','Ag-109 ',
     3         'Xe-131 ','Xe-135 ','Cs-133 ','Cs-135 ','Nd-143 ',
     4         'Nd-145 ','Pm-147 ','Sm-147 ','Pm-148m','Sm-149 ',
     4         'Sm-150 ','Sm-151 ','Sm-152 ','Eu-153 ','Eu-154 ',
     5         'Eu-155 ','Gd-155 ','Gd-157 ','Gd-157 ','O - 16 '/
C* Atomic weights of the selected materials
      DATA AW /234.040527,235.044144,236.045761,238.050980,237.048157,
     &         238.049469,239.052582,240.054199,241.048737,242.058411,
     &         241.056793,242.059   ,243.061035,242.058   ,243.061   ,
     &         244.063   ,245.064   , 94.905891, 99.000465,100.905838,
     &         102.905014,104.905   ,106.905   ,107.904   ,108.904549,
     &         130.906   ,134.907   ,132.905731,134.905914,142.909683,
     &         144.912872,146.915   ,146.915085,147.918   ,148.917282,
     &         149.916870,150.919479,151.920074,152.921677,153.922   ,
     &         154.923   ,154.922867,156.924072,156.924072, 15.999400/
C* WIMS ident numbers with aliases(allow for "1981" & "1986" libraries)
      DATA IDW/    234  ,   2235  ,    236  ,   8238  ,    937  ,
     &             948  ,   6239  ,   1240  ,   1241  ,   1242  ,
     &             951  ,    952  ,    953  ,    962  ,    963  ,
     &             964  ,    965  ,   4095  ,   4099  ,   4101  ,
     &            4103  ,   5105  ,   4107  ,   4108  ,   4109  ,
     &            4131  ,   4135  ,   4133  ,   5135  ,   4143  ,
     &            4145  ,   4147  ,   6147  ,   4148  ,   4149  ,
     &            4150  ,   4151  ,   4152  ,   4153  ,   4154  ,
     &            4155  ,   2155  ,   2157  ,   4157  ,   6016  ,
     &               0  ,      0  ,      0  ,      0  ,      0  ,
     &               0  ,      0  ,      0  ,      0  ,      0  ,
     &               0  ,      0  ,      0  ,      0  ,      0  ,
     &               0  ,      0  ,      0  ,      0  ,      0  ,
     &               0  ,      0  ,      0  ,      0  ,      0  ,
     &               0  ,      0  ,      0  ,      0  ,      0  ,
     &               0  ,   5147  ,      0  ,      0  ,      0  ,
     &               0  ,      0  ,      0  ,      0  ,      0  ,
     &               0  ,      0  ,      0  ,      0  ,      0  ,
     &               0  ,    235  ,      0  ,   2238  ,      0  ,
     &               0  ,   3239  ,      0  ,    241  ,    242  ,
     &               0  ,      0  ,      0  ,      0  ,      0  ,
     &               0  ,      0  ,     95  ,     99  ,    101  ,
     &             103  ,   1105  ,    107  ,    108  ,    109  ,
     &             131  ,    135  ,    133  ,   1135  ,    143  ,
     &             145  ,    147  ,   2147  ,    148  ,    149  ,
     &             150  ,    151  ,    152  ,    153  ,    154  ,
     &               0  ,      0  ,   4157  ,    157  ,     16  ,
     &               0  ,      0  ,      0  ,      0  ,      0  ,
     &               0  ,      0  ,      0  ,      0  ,      0  ,
     &               0  ,      0  ,      0  ,      0  ,      0  ,
     &               0  ,      0  ,      0  ,      0  ,      0  ,
     &               0  ,      0  ,      0  ,      0  ,      0  ,
     &               0  ,      0  ,      0  ,      0  ,      0  ,
     &               0  ,   1147  ,      0  ,      0  ,      0  ,
     &               0  ,      0  ,      0  ,      0  ,      0  ,
     &               0  ,      0  ,      0  ,      0  ,      0  /
C*
      DATA BLNK/'                                        '/
     1     FLWO/'BUCR1B.OUT'/
     2     FLOU/'WEDB1B.LST'/
     3     FLRF/'BUCR1B.REF'/
     4     FLPL/'WEDB1B.PLT'/
C*
      DATA LIN,LOU,LRF,LPL,LKB,LTT/ 1, 2, 3, 4, 5, 6 /
C*
      DATA FMAS/ 0. /
C*
      WRITE(LTT,'(2A40)')' WEDB1B - Isotopic composition compariso'
      WRITE(LTT,'(2A40)')' ======================================='
      WRITE(LTT,'(2A40)')
C* Define the filenames
   12 WRITE(LTT,'(2A40)')' Enter the WIMS output filename       : '
      READ (LKB,'(2A40)')FLWO
      OPEN (UNIT=LIN,FILE=FLWO,STATUS='OLD',ERR=12)
C*
   14 WRITE(LTT,'(2A40)')' Default output report filename       : ',FLOU
      WRITE(LTT,'(2A40)')'           Enter new name to redefine : '
      READ (LKB,'(2A40)')FLNM
      IF(FLNM.NE.BLNK) FLOU=FLNM
      OPEN(UNIT=LOU,FILE=FLOU,STATUS='UNKNOWN')
      WRITE(LOU,'(2A40)')' WEDB1B - Isotopic composition compariso'
     &                  ,'n                                       '
      N=2
C*
   16 WRITE(LTT,'(2A40)')' Enter reference results filename     : '
      READ (LKB,'(2A40)')FLNM
      IF(FLNM.NE.BLNK) THEN
        FLRF=FLNM
        OPEN(UNIT=LRF,FILE=FLRF,STATUS='OLD',ERR=16)
        OPEN(UNIT=LPL,FILE=FLPL,STATUS='UNKNOWN')
        N=3
      END IF
C*
        IK=0
        BURNUP(1)=0
        DAYS(1)=0
C* Process the WIMS-D output until End-of-file
        READ(LIN,'(A120)')LINE
        DO WHILE (LINE(1:15).NE.' END OF FILE ON')
C*        -- Beginning of a burnup sequence identified
          IF (LINE(27:34).EQ.'chain 14') THEN
            IK=IK+1
            IF(IK.GT.NK) STOP 'WEDB1B ERROR - NK limit exceeded'
            IF (IK.EQ.1 .AND. N.EQ.2) THEN
              WRITE(LOU,'(A32)')'********************************'
              WRITE(LOU,'(A32)')' INITIAL COMPOSITION            '
            ENDIF
C*          -- First K-eff in leakage edit from previous burnup step
            CALL GETK(LIN,XKINF(IK),1)
C* Print the data for the burnup step
            IF(N.EQ.2) THEN
              WRITE(LOU,'(A32)')'********************************'
              WRITE(LOU,*)
              WRITE(LOU,'(A12,I6)')' Burnup step',IK-1
              WRITE(LOU,'('' Burnup   '',F8.2,'' GWd/tU'')') BURNUP(IK)
              WRITE(LOU,'(A10,F8.5)')' k-inf    ',XKINF(IK)
              IF(NT.GT.0) THEN
                WRITE(LOU,*)
                WRITE(LOU,'(A8,A12,A6,A16)')' ISOTOPE',' M[mg/gFuel]'
     &                                     ,'   ID ','  N[1/(barn.cm)]'
                DO I=1,NT
                  K=INDX(I)
                  WRITE(LOU,'(A8,1P,E12.3,I6,E15.7)')
     &                           CDW(K),XMAS(K),IDW(K,1),DN(K)
                END DO
                NT=0
              END IF
            END IF
          ELSE IF (LINE(15:26).EQ.'days, Irrad=') THEN
C*          -- Extract burnup of the next step
            READ(LINE( 4:13),'(F10.0)') DY
            READ(LINE(27:36),'(F10.0)') BU
            BURNUP(IK+1)=BU/1000.
            DAYS(IK+1)  =DY
          ELSE IF (LINE( 2:23).EQ.'punched material cards') THEN
            DO I=1,N0
              XMAS(I)=0.
            END DO
            CALL RWMAT(LIN,N0,IDW,AW,FMAS,BURNUP(IK),XMAS,INDX,DN,NT)
          END IF
C* Read the next record from input
          READ(LIN,'(A120)',END=60)LINE
        END DO
   60 CLOSE(LIN)
      IF(N.LT.3) GO TO 80
C* Process the reference results
      BUEOC=BURNUP(IK)
      IF(IK.GT.1) THEN
        IF(ABS(BURNUP(IK)-BURNUP(IK-1)).LT.1 .AND.
     &     ABS(DAYS(IK)-DAYS(IK-1)).GE.1) THEN
C*          Flag burnup negative if cooling time is included
          BUEOC=-BUEOC
        END IF
      END IF
      CALL RWREF(LRF,N0,CDW,BUEOC,XREF,SREF,WREF,INDX,N1)
      REWIND LRF
      DO I=1,5
        READ (LRF,'(A120)')LINE
        LINE(1:1)=' '
        WRITE(LOU,'(A120)')LINE
        WRITE(LPL,'(A120)')LINE
      END DO
      WRITE(LOU,'('' Burnup = '',F8.2,'' GWd/tU'')') BUEOC
      WRITE(LOU,'('' k-inf  = '',F8.5)')             XKINF (IK)
      WRITE(LOU,'('' ************************'')')
      WRITE(LOU,*)
      WRITE(LOU,'(2A40)')
     1 ' Calculated results                   : ',FLWO
     1,' Reference  results                   : ',FLRF
      WRITE(LOU,*)
      WRITE(LOU,'('' Isotope  Calculated Diff.   Reference Sigma'')')
      WRITE(LOU,'(''          [mg/gFuel]   [%]  [mg/gFuel]   [%]'')')
      WRITE(LOU,'('' -------------------------------------------'')')
C*
      WRITE(LPL,'('' Burnup = '',F8.2,'' GWd/tU'')') BUEOC
      WRITE(LPL,'('' ************************'')')
      WRITE(LPL,*)
      WRITE(LPL,'(2A40)')
     1 ' Calculated results                   : ',FLWO
     1,' Reference  results                   : ',FLRF
      WRITE(LPL,*)
      WRITE(LPL,'('' Legend: --- Error bar'')')
      WRITE(LPL,'(''         X   Uncertainty'')')
      WRITE(LPL,'(''         0   Zero or no data'')')
      WRITE(LPL,*)
      WRITE(LPL,'(1X,A6,1X,A61)') ' Isot.'
     1,'V_-20% _______________________V________________________+20%_V'
      NCHW=61
      EMN=-20.
      EMX= 20.
C*
      DO J=1,N1
        I=INDX(J)
        IF(XREF(I).NE.0) THEN
          XMS=XMAS(I)*WREF(I)
          ER=100.*(XMS-XREF(I))/XREF(I)
        ELSE
          XMS=XMAS(I)
          ER=0.
        END IF
        IF(XMS.GT.0) THEN
          WRITE(LOU,'(1X,A7,2(1P,E12.3,0P,F6.1))') CDW(I),XMS,ER
     1                                            ,XREF(I),SREF(I)
          CALL LNPLOT(LINE,NCHW,ER,SREF(I),EMN,EMX)
          WRITE(LPL,'(1X,A7,A61)') CDW(I),LINE(1:NCHW)
        END IF
      END DO
C* Procesing completed
   80 CLOSE(LOU)
      STOP 'WEDB1B Completed'
      END
      SUBROUTINE RWMAT(LIN,N0,IDW,AW,FMAS,BURNUP,XMAS,INDX,DN,NT)
C-Title  : Subroutine RWMAT
C-Purpose: Process Punched Materials in WIMS-D output
      CHARACTER*120 LINE
      DIMENSION AW(N0),IDW(N0,1),XMAS(N0),INDX(N0),DN(1)
     1         ,R(3),X(3)
C*
      NT=0
      FM=0.
      DO L=1,N0
        XMAS(L) =0
        DN(L)   =0
      END DO
C*
C* Read the first set of material data
      READ(LIN,'(A120)')LINE
      READ(LIN,'(A120)')LINE
      READ(LIN,'(A120)')LINE
C* Read a record from the WIMS-D output
      DO WHILE (LINE(16:31).NE.'entry into chain' .AND.
     &          LINE(1:10) .NE. ' material ')
        READ(LINE,'(3(F8.0,E15.0))',ERR=20) (R(K),X(K),K=1,3)
C* Three pairs of ID/No.Density per record are assumed
        DO K=1,3
          ID=R(K)+0.00001
          IF (ID.GT.0.AND.X(K).GT.0.0) THEN
C* Identify the nuclide and convert to g/cm3
            DO L=1,N0
            DO M=1,4
            IF(ID.EQ.IDW(L,M)) THEN
              NT      =NT + 1
              INDX(NT)=L
              GCM3    =X(K)*AW(L)
              XMAS(L) =XMAS(L)+GCM3
              DN(L)   =DN(L)  +X(K)
              FM      =FM + GCM3
            END IF
            END DO
            END DO
          ENDIF
        END DO
        READ(LIN,'(A120)',END=20)LINE
      END DO
C* Normalise the nuclide mass to mg/g-fuel
   20 IF(FMAS.EQ.0) FMAS=FM
      DO I=1,N0
        XMAS(I)=1000.0*XMAS(I)/FMAS
      END DO
      RETURN
      END
      SUBROUTINE GETK(LIN,XK,IKK)
      CHARACTER*120 LINE
      I=0
      DO WHILE(I.NE.IKK)
        READ(LIN,'(A120)')LINE
        IF (LINE(26:35).EQ.'k-infinity') THEN
          I=I+1
          IF (I.EQ.IKK) THEN
            READ(LINE,'(36X,E13.0)')XK
            RETURN
C         ELSE
C           READ(LINE,'(A120)')LINE
          END IF
        END IF
      END DO
      RETURN
      END
      SUBROUTINE RWREF(LIN,N0,CDW,BURNUP,XREF,SREF,WREF,INDX,N1)
C-Title  : RWREF Subroutine
C-Purpose: Read Reference Results file
      CHARACTER*7   CDW(N0),SYMB
      CHARACTER*120 LINE
      DIMENSION     XREF(1),SREF(1),WREF(1),INDX(1)
C* Find the appropriate burnup set
   20 READ(LIN,'(A120)')LINE
      IF (LINE(1:8).NE.' BURNUP ') GO TO 20
      READ(LINE,'(10X,F7.0)') BRREF
      IF(ABS(BURNUP-BRREF).GT.1) GO TO 20
      READ(LIN,'(A120)')LINE
C* Read the reference weight and uncertainty
      N1=0
   40 READ(LIN,'(A120)',END=60) LINE
      IF(LINE(1:10).EQ.'          ') GO TO 60
      READ(LINE,'(1X,A7,F12.0,2F6.0)') SYMB,XR,SR,WT
      IF(WT.EQ.0) WT=1.
      DO L=1,N0
        IF(SYMB.EQ.CDW(L)) THEN
          XREF(L)=XR
          SREF(L)=SR
          WREF(L)=WT
          N1=N1+1
          INDX(N1)=L
        END IF
      END DO
      GO TO 40
   60 RETURN
      END
      SUBROUTINE LNPLOT(LINE,NCHW,ER,ELM,EMN,EMX)
C-Title  : Subroutine LNPLOT
C-Purpose: Set plot line-bar character string
      CHARACTER*120 LINE
      DO 10 I=1,NCHW
      LINE(I:I)=' '
   10 CONTINUE
      LINE(  1 :  1 )='|'
      LINE(NCHW:NCHW)='|'
      F0=FLOAT(NCHW-1)*(  -EMN)/(EMX-EMN)
      L0=1+NINT(F0)
        IF(L0.LT.  1 ) L0=1
        IF(L0.GT.NCHW) L0=NCHW
      F1=FLOAT(NCHW-1)*(ER-EMN)/(EMX-EMN)
      L1=1+NINT(F1)
        IF(L1.LT.  1 ) L1=1
        IF(L1.GT.NCHW) L1=NCHW
      LA=MIN(L0,L1)
      LB=MAX(L0,L1)
      DO 20 I=LA,LB
        LINE(I:I)='-'
   20 CONTINUE
C* Mark error limits
      IF(ER.GT.0) THEN
        FL=FLOAT(NCHW-1)*( ELM-EMN)/(EMX-EMN)
      ELSE
        FL=FLOAT(NCHW-1)*(-ELM-EMN)/(EMX-EMN)
      END IF
      LL=1+NINT(FL)
      IF(LL.GT.1 .AND. LL.LT.NCHW) LINE(LL:LL)='X'
C* Mark error out of bounds
      IF(ER.GT.EMX) LINE(NCHW:NCHW)='>'
      IF(ER.LT.EMN) LINE(  1 :  1 )='<'
C* Mark centreline
      LINE(L0:L0)='+'
      IF(ABS(ER/(EMX-EMN)).LT.(0.5/NCHW)) LINE(L0:L0)='I'
C* Mark "no data"
      IF(ER.EQ. 0 ) LINE(L0:L0)='0'
      RETURN
      END
*deck wedkin 
      PROGRAM WEDKIN
C-Title  : WEDKIN Program
C-Purpose: Extract k-inf from WIMS output as a function of burnup
C-Author : A.Trkov, Institute Jozef Stefan, Ljubljana, Slovenia
C-Version: 2003 Original code
C-M
C-M  Manual for Program WEDKIN
C-M  =========================
C-M  A WIMS output with burnu is processed. The k-inf values as a
C-M  function of burnup are tabulated in PLOTTAB curves format.
C-M    The k-eff values are read from leakage edit of Chain 14
C-M  and the burnup is estimated from the burnup step Chain2 output
C-M  that follows.
C-M
C-M  Files used:
C-M    3  WIMS output file to be processed (requested from input),
C-M    4  Tabulated k-eff output file in plottab format,
C-M    5  Keyboard input,
C-M    6  Diagnostics output.
C-
      CHARACTER*120 REC
      CHARACTER*40  BLNK,FLNM,FLWI,FLCU
      DATA BLNK/'                                        '/
     3     FLWI/'WIMSD.OUT'/
     4     FLCU/'WEDKIN.CUR'/
      DATA LWI,LCU,LKB,LTT/ 3, 4, 5, 6 /
C*
      WRITE(LTT,940)
      WRITE(LTT,940) ' WEDKIN - Tabulate k-eff from WIMS    '
      WRITE(LTT,940) ' =================================    '
      WRITE(LTT,940)
C*
C* Select the output option
      WRITE(LTT,940) ' Select the output option:            '
      WRITE(LTT,940) '   0  Unnormalised k-inf '
      WRITE(LTT,940) '   1  Unnormalised k-eff '
      WRITE(LTT,940) '  10  k-inf normalised to first point '
      WRITE(LTT,940) '$ 11  k-eff normalised to first point '
      READ (LKB,940) FLNM
      IF(FLNM.NE.BLNK) READ(FLNM,*) IOP
      IOK=IOP-10*(IOP/10)
C* Specify the output curve filename
C...  WRITE(LTT,940) '$Enter output curve filename        : '
C...  READ (LKB,940) FLNM
C...  IF(FLNM.NE.BLNK) FLCU=FLNM
      OPEN (UNIT=LCU,FILE=FLCU,STATUS='UNKNOWN')
C* Specify the WIMS library name
      GO TO 12
   11 WRITE(LTT,940) ' ERROR - non existent file requested  ',FLWI
   12 WRITE(LTT,940) '$Enter WIMS file to be processed    : '
      READ (LKB,940,END=90) FLNM
      IF(FLNM.EQ.BLNK) GO TO 90
      FLWI=FLNM
      OPEN (UNIT=LWI,FILE=FLWI,STATUS='OLD',ERR=11)
C*
      IKI=0
      NBU=0
C*
C* Begin processing the WIMS output
C* Find k-inf in the leakage edit
C"172 GROUPS.....  k-infinity  1.309005E+00   k-effective  1.004001E+00"
   20 DO WHILE (REC(13:23).NE.'GROUPS.....')
        READ (LWI,980,END=80) REC
      END DO
C* Choose k-inf or k-eff
      IF(IOK.EQ.0) THEN
        READ (REC(36:49), * ) AKE
      ELSE
        READ (REC(64:77), * ) AKE
      END IF
      READ (LWI,980) REC
      IKI=1
C* Find burnup in the Chain 15 output
      DO WHILE(REC(1:4).NE.'0t= ')
        READ (LWI,980,END=80) REC
      END DO
C* Check that k-eff was read
      IF(IKI.NE.1) GO TO 20
C"0t=     0.000 days, Irrad=     0.000 MWd/te"
      READ (REC(27:36), * ) BRN
      NBU=NBU+1
      IF(NBU.EQ.1) THEN
        WRITE(LCU,940) FLWI
        AK0=AKE
      END IF
      IF(IOP.GE.10)  AKE=AKE/AK0
      WRITE(LCU,911) BRN,AKE
      IKI=0
      GO TO 20
C*
   80 IF(NBU.GT.0) THEN
        WRITE(LCU,940)
      ELSE
        WRITE(LTT,940) ' WARNING - No burnup steps found on     ',FLWI
      END IF
      CLOSE(UNIT=LWI)
      GO TO 12
C*
   90 CLOSE(UNIT=LCU)
      STOP 'WEDKIN - Completed'
C*
  911 FORMAT(F11.1,F11.5)
  940 FORMAT(2A40)
  980 FORMAT(A120)
      END
*deck wedog2 
      PROGRAM WEDOG2
C-Title  : Program WEDOG2
C-Purpose: Calculate 2-group reaction rates from WIMS output
C-Author : A.Trkov, Institute J.Stefan, Ljubljana, Slovenia (1993)
C-Version: 1993 Original code
C-V  00/06 Allow Gr.1 flux from CELL edit for homog.cases (A.Trkov)
C-V  00/12 Allow for the absence of reaction rates (k-eff only)
C-V  01/01 Minor fix (D.L.Aldama).
C-V  01/02 Identify materials in "Reactions edit" by Mat.ID (A.Trkov).
C-V  01/05 Define spectral indices for Th232-U233 system (A.Trkov).
C-M
C-M  Manual for the program WEDOG2
C-M  =============================
C-M
C-M  WIMS output is processed. It is assumed that 2-group reaction
C-M  rates have been requested, namely for the principal fuel
C-M  constituents (U-235 and U-238 or U-233 and Th-232).
C-M  Reaction rates are identified from the last three digits of
C-M  the material ident number (i.e. 235 for U-235 and 238 for
C-M  U-238 or 233 for U-233 and 232 for Th-232, respectively).
C-M  This is necessary if more reactions are specified
C-M  on input or when the nuclides are ordered differently in
C-M  the library (for example, the WIMS-ANL library). A correction
C-M  for the (n,2n) reaction is made, making use of the calculated
C-M  flux in the fuel. Since the (n,2n) cross section is not
C-M  available from the WIMS library and to simplify the code, the
C-M  group-1 (n,2n) cross sections for U-235, U-238, U-233, Th-232
C-M  are defined with the DATA statement in the Z2N variable. The
C-M  cross sections were derived from the ENDF/B libraries. The
C-M  sensitivity of the integral parameters to the precise values
C-M  of the (n,2n) cross section should not be very large, but the
C-M  user should check for any significant differences of the cross
C-M  sections for the library currently being processed.
C-M  NOTE: Cross sections for the (n,2n) reactions must be consistent
C-M        with the transport group structure. For example, if calcul-
C-M        ations are done in full 69 groups it is sufficient to enter
C-M        gr.1 cross section of the 69 group set. If the first
C-M        transport group spans over several groups, an appropriate
C-M        correction to the (n,2n) cross sections must be made.
C-M
C-M    Two output files are produced: the extended output WEDOUT
C-M  contains the uncorrected and (n,2n) corrected reaction rates for
C-M  the K-inf and the K-eff edit and also the spectral indices. The
C-M  summary output WEDSMR contains only k-eff and the spectral indices
C-M  from the K-eff edit in 10-column format.
C-M
C-M  Files used: (Unit / Default filename / Description)
C-M    1  WIMOUT  WIMS output file to be processed
C-M    2  WEDSMR  WEDOG2 summary output file
C-M    3  WEDOUT  WEDOG2 descriptive output filename
C-M
C-M  Input instructions:
C-M  The WIMS output filename is specified from keyboard interactively.
C-M  The output files are defined outomatically by changing the last
C-M  three non-blank characters to "WED" and "SMR" respectively.
C-M    Alternately, (if blank filename or EOF is specified) the default
C-M  filenames are used. This option may also be used to define files
C-M  with the ASSIGN statement.
C-M  Example:
C-M    ASSIGN/USER "wimsoutput" WIMOUT
C-M    ASSIGN/USER "wedoutput"  WEDOUT
C-M    ASSIGN/USER "wedsummary" WEDSMR
C-M  where "wimsoutput" is the WIMS output filename and "wedoutput"
C-M  and "wedsummary" are WEDOG2 output filenames
C-M
C-
      PARAMETER   (MXMT=200)
      CHARACTER*2  C28,C25
      CHARACTER*16 COM(2)
      CHARACTER*40 REC,ORD,STAR,BLNK,FLNM,FLWI,FLSM,FLWE
      DIMENSION    CPF(10),CPT(10),FSF(10),FST(10)
     1            ,MATI(MXMT),DNS(MXMT),Z2N(10)
C*
C* Cross section (n,2n) for correcting reaction rates
C*
C* Two data statement are included in the code.
C* One for ENDF-B/VI and another one for ENDF-B/IV library.
C* They exclude each other !!!.
C*
C* The first  number is the U-235 (n,2n) XS in WIMS library group 1.
C* The second number is the U-238 (n,2n) XS in WIMS library group 1.
C*
C* Next data statement should be used for ENDF-B/VI library
C*        sig_U_235(n,2n) = 0.4051
C*        sig_U_238(n,2n) = 0.5422
C*        sig_U_233(n,2n) = 0.2033
C*        sig_Th232(n,2n) = 0.5487
C*
       DATA Z2N/ 0.4051, 0.5422, 0.2033, 0.5487, 6*0./
C*
C* Next data statement should be used for ENDF-B/IV library.
C*        sig_U235(n,2n) = 0.2740
C*        sig_U238(n,2n) = 0.6268
C*
C     DATA Z2N/ 0.2740, 0.6268, 8*0./
C*
C* Default filenames
      DATA BLNK/'                                        '/
     1    ,FLWI/'WIMOUT'/
     2    ,FLSM/'WEDSMR'/
     3    ,FLWE/'WEDOUT'/
C* Initialize
      DATA COM/'DIRECT          ','CORRECTED (n,2n)'/
      DATA STAR/' ***************************************'/
C* Default flux values
      DATA FX1,F1I,F1E / 0., 1., 1. /
      KE=0
      KI=0
      IE=0
      IB=0
      RHO28=0
      DEL25=0
      DEL28=0
      CONVR=0
C* Write banner
      WRITE(6,91)
      WRITE(6,91) ' WEDOG2 - Post-process WIMS output      '
      WRITE(6,91) ' =================================      '
      WRITE(6,91)
C* Define the filenames
      GO TO 12
   11 IE=1
      WRITE(6,91) ' ERROR in filename - redo from start    ',FLNM
   12 WRITE(6,91) '$Enter the WIMS output filename       : '
      READ (5,91,END=82) FLNM
      IF(FLNM.EQ.BLNK) GO TO 19
C* From the filename root, generate output filenames
      DO 14 I=1,38
      IP=41-I
      IF(FLNM(IP:IP).NE.' ') GO TO 18
   14 CONTINUE
   18 FLWI=FLNM
      FLSM=FLNM
      FLWE=FLNM
      FLSM(IP-2:IP)='SMR'
      FLWE(IP-2:IP)='WED'
   19 OPEN (UNIT=1,FILE=FLWI,STATUS='OLD',ERR=11)
      OPEN (UNIT=2,FILE=FLSM,STATUS='UNKNOWN',CARRIAGECONTROL='LIST')
      OPEN (UNIT=3,FILE=FLWE,STATUS='UNKNOWN',CARRIAGECONTROL='LIST')
C*
C* Search the output file and pick miscellaneous quantities
   20 READ (1,91,END=80) REC,ORD
      IF(REC( 1: 2).NE.' *' .AND.
     1   REC( 1: 7).NE.'      *') GO TO 21
C* Copy comments from WIMS output
      IF(REC(3:3).EQ.' ' .OR. REC(3:3).EQ.'*' .OR.
     1   REC(7:7).EQ.'*') WRITE(3,91) REC,ORD
      GO TO 20
C* Check for boundary conditions (set IB=1 if FREE)
   21 IF(REC( 1: 5).NE.' FREE' .AND.
     1   REC( 1:10).NE.'      FREE' .AND.
     1   REC( 1:10).NE.'      free') GO TO 22
      IB=1
      GO TO 20
C* Reset KI flag if new case is encountered
   22 IF(REC(16:34).NE.'ENTRY INTO CHAIN  1' .AND.
     1   REC(16:34).NE.'entry into chain  1') GO TO 23
      IF(KI.NE.0) WRITE(2,106) AKE
      KI=0
      KE=0
      IE=0
      IB=0
      DU3=0
      DU5=0
      DU8=0
      DTH=0
      RHO28=0
      DEL25=0
      DEL28=0
      CONVR=0
      GO TO 20
C* Retrieve the MAT numbers and number densities of the first material
   23 IF(REC( 1:10).NE.'0ISOTOPE N' .AND.
     1   REC( 1:10).NE.'0isotope n') GO TO 26
      IRE=0
      READ (1,91)
      READ (1,91)
      READ (1,91)
      NMAT=0
   24 READ (1,96,ERR=20) MATI(NMAT+1),DNS(NMAT+1)
      NMAT=NMAT+1
      IF(NMAT.GE.MXMT) STOP 'WEDOG2 ERROR - MXMT Limit exceeded'
      GO TO 24
C* Retrieve K-eff from DSN transport calculation
   26 IF(ORD(6:17).NE.'  EIGENVALUE') GO TO 28
      READ (ORD(20:33),102) AKE
      IF(AKE.NE.0) AKE=1./AKE
      GO TO 20
C* Retrieve K from the Leakage edit
   28 IF((REC(21:30).NE.'...  K-INF' .AND.
     1    REC(21:30).NE.'...  k-inf') .OR. KI.NE.0) GO TO 30
C* Write k-inf and k-eff to WED output
      KI=1
      IF(IB.EQ.0) READ (ORD(24:37),102) AKE
      WRITE(ORD(24:37),104) AKE
      WRITE(3,91)
      WRITE(3,91) REC,ORD
      READ (1,91)
      READ (1,91)
      READ (1,91)
      READ (1,91)
      READ (1,91)
      IF(FX1.NE.0) READ (1,93) F1E,F1I
C* Read K-inf
      ORD(24:28)=REC(36:40)
      ORD(29:37)=ORD( 1: 9)
      READ (ORD(24:37),102) AKI
      GO TO 20
C* Retrieve group-1 flux in the fuel for the (n,2n) correction
   30 IF(REC( 1:10).NE.'0REGION  1' .AND.
     1   REC( 1:10).NE.' CELL     ') GO TO 40
C*     Skip CELL edit if REGION edit was present
      IF(IRE.EQ.1) GO TO 20
      READ (1,91)
      READ (1,91)
      READ (1,95) FX1
      IRE=0
      IF(REC( 1:10).EQ.'0REGION  1') IRE=1
      GO TO 20
C* Search the file for Reactions and K-Inf. edit
   40 IF(REC(16:25).EQ.'REACTIONS ' .OR.
     1   REC(16:25).EQ.'reactions ') GO TO 42
      IF(REC(1:10).NE.'1K-INF EDI' .AND.
     1   REC(1:10).NE.'1k-inf edi' .AND.
     2   REC(1:10).NE.'1K-EFF EDI' .AND.
     2   REC(1:10).NE.'1k-eff edi') GO TO 20
      IF(REC(1:10).EQ.'1K-EFF EDI' .OR.
     1   REC(1:10).EQ.'1k-eff edi') KE=1
      NMT=0
      REC(1:1)=' '
      WRITE(3,91)
      WRITE(3,91) STAR,STAR
      WRITE(3,91) REC,ORD
      GO TO 20
C* Process reactions edit
   42 REC(1:1)=' '
      IF(KE.NE.1) WRITE(3,91)
      WRITE(3,91) REC
      READ (REC,101) MAT
      JMAT=MAT-1000*(MAT/1000)
      IF     (JMAT.EQ.235) THEN
        MT=1
      ELSE IF(JMAT.EQ.238) THEN
        MT=2
      ELSE IF(JMAT.EQ.233) THEN
        MT=3
      ELSE IF(JMAT.EQ.232) THEN
        MT=4
      ELSE
        GO TO 20
      END IF
      NMT=MAX(NMT,MT)
      READ (1,91)
      READ (1,91)
      READ (1,94) AB1
      READ (1,94) AB2
      READ (1,91)
      READ (1,91)
      READ (1,91)
      READ (1,94) FS1
      READ (1,94) FS2
C*
      CP1=AB1-FS1
      CP2=AB2-FS2
C*
      IC=0
      DNMT=0
      IF(NMAT.LE.0) GO TO 44
C* Define nuclide number density for (n,2n) correction
      DO 43 I=1,NMAT
      IF(MAT.NE.MATI(I)) GO TO 43
      DNMT=DNS(I)
      IF(MT.EQ.1) DU5=DNMT
      IF(MT.EQ.2) DU8=DNMT
      IF(MT.EQ.3) DU3=DNMT
      IF(MT.EQ.4) DTH=DNMT
      GO TO 44
   43 CONTINUE
C* Calculate the reactions
   44 IC=IC+1
      CPF(MT)=CP1
      CPT(MT)=CP2
      FSF(MT)=FS1
      FST(MT)=FS2
      WRITE(3,97) COM(IC)
      WRITE(3,98) 'Capt.',CPF(MT),CPT(MT)
      WRITE(3,98) 'Fiss.',FSF(MT),FST(MT)
      IF(IC.EQ.2) GO TO 50
      FF=FX1
      IF(KE.EQ.1) FF=FF*F1E/F1I
      CP1=CP1+FF*DNMT*Z2N(MT)
      IF(Z2N(MT).NE.0) GO TO 44
   50 IF(MT .EQ.2 .AND. DU5.LE.0) GO TO 20
      IF(MT .EQ.4 .AND. DU3.LE.0) GO TO 20
      IF(NMT.EQ.4 .AND. DTH.LT.DU8) NMT=2
      IF     (NMT.EQ.2) THEN
        RHO28=CPF(2)/CPT(2)
        DEL25=FSF(1)/FST(1)
        DEL28=(FSF(2)+FST(2)) / (FSF(1)+FST(1))
        CONVR=(CPF(2)+CPT(2)) / (FSF(1)+FST(1))
        C28='28'
        C25='25'
      ELSE IF(NMT.EQ.4) THEN
        RHO28=CPF(4)/CPT(4)
        DEL25=FSF(3)/FST(3)
        DEL28=(FSF(4)+FST(4)) / (FSF(3)+FST(3))
        CONVR=(CPF(4)+CPT(4)) / (FSF(3)+FST(3))
        C28='02'
        C25='23'
      ELSE
        GO TO 20
      END IF
      IF(RHO28.GT.99.999 )   RHO28=99.999
      IF(DEL25.GT. 9.99999)  DEL25= 9.99999
      IF(KE.EQ.0) WRITE(3, 99) AKI,C28,RHO28,C25,DEL25,C28,DEL28,CONVR
      IF(KE.EQ.1) WRITE(3, 99) AKE,C28,RHO28,C25,DEL25,C28,DEL28,CONVR
      IF(KE.EQ.1) WRITE(2,106) AKE,RHO28,DEL25,DEL28,CONVR
      DU3=0
      DU5=0
      DU5=0
      DU8=0
      DTH=0
      KI=0
      GO TO 20
C* Normal termination
   80 IF(KI.NE.0) WRITE(2,106) AKE
      CLOSE(UNIT=2)
      CLOSE(UNIT=3)
      STOP 'WEDOG2 Completed'
C* Error trap when WIMS output file can not be opened
   82 IF(IE.EQ.0) GO TO 19
      STOP 'WEDOG2 - ERROR in filename'
C*
   91 FORMAT(2A40)
   93 FORMAT(77X,2F14.0)
   94 FORMAT(13X,F12.0)
   95 FORMAT(52X,F12.0)
   96 FORMAT(I6,F11.0)
   97 FORMAT(/1X,A16/' Group','        Fast','     Thermal')
   98 FORMAT(1X,A5,2F12.6,4F12.5)
   99 FORMAT(/' K=',F8.5,'  Rho',A2,'=',F6.3,'    Del',A2,'=',F8.5
     1      ,'    Del',A2,'=',F8.5,'    C*=',F7.4)
  101 FORMAT(8X,I6)
  102 FORMAT(F14.0)
  104 FORMAT(F10.5,4X)
  106 FORMAT(F10.5,F10.4,2F10.5,F10.4)
      END
*deck WEDRPU 
      PROGRAM WEDRPU
C-Title  : Rrogram WEDRPU
C-Purpose: Process WIMS-D results for Rowlands Pu pin cell benchmark
C-M
C-M  Manual for Program WEDRPU
C-M  =========================
C-M
C-M  The WIMS-D results for the Rowlands Plutonium pin-cell
C-M  benchmarks are processed.
C-M
C-M  It is assumed that the records containing the results
C-M  of the K-inf and K-eff leakage edit of WIMS-D are extracted
C-M  on the file "RPINPU.K". Double leakage edit (transport
C-M  corrected and B1) is allowed. It is identified by the
C-M  K-inf value, which must be the same to within 1 pcm.
C-M  The K-inf, K-eff and differences in K are calculated and
C-M  printed to output. If double leakage edit is present, the
C-M  K values and differences in K due to leakage are taken
C-M  from the B1 leakage edit. Differences due to temperature
C-M  changes are taken from the transport corrected leakage
C-M  edit, since the B1 edit may be incorrect due to a single
C-M  P1 scattering matrix in the library.
C-M
C-M  The reference results are read from the "RPINKE.LOG" file
C-M  which is normally produced by the RPINKE code which
C-M  analyses and averages the results of a number of different
C-M  independent calculations.
C-M
C-M  A summary of results is written to "WEDRPU.LOG"
C-M
C-Author : A.Trkov, Institute Jozef Stefan, Slovenia (1999)
C-
      CHARACTER*120 RECI
      CHARACTER*40  FLNM,FLNI,FLRE,FLNO
C*
      DIMENSION     AKIN(4),AKEB(4),AKET(4)
     1            , AK(21) ,RK(21) ,SG(21) ,ER(21)
C*
      DATA  LIN,LRE,LOU / 1, 2 , 4 /
      DATA  FLNI/'RPINPU.K'/
     1      FLRE/'RPINKE.LOG'/
     1      FLNO/'WEDRPU.LOG'/
C*
      OPEN (UNIT=LIN,FILE=FLNI,STATUS='OLD')
      OPEN (UNIT=LRE,FILE=FLRE,STATUS='OLD')
      OPEN (UNIT=LOU,FILE=FLNO,STATUS='UNKNOWN')
C*
C* Initialize
      NK=0
C*
C* Process WIMS results - read the K-inf and K-eff from the file
   20 READ (LIN,800,END=21) RECI
      CALL UPCASE(40,RECI)
      IF(RECI(21:30).NE.'...  K-INF') GO TO 20
      READ(RECI(38:49),802) XKI
      READ(RECI(66:77),802) XKE
C* Distinguish between transport-corrected and B1 leakage edit
      IF(ABS(XKI-AKIN(NK)).LT.1.E-5) THEN
        AKEB(NK)=XKE
      ELSE
        IF(NK.LT.4) NK=NK+1
        AKIN(NK)=XKI
        AKET(NK)=XKE
        AKEB(NK)=XKE
      END IF
      GO TO 20
   21 IF(NK.NE.4) GO TO 92
C* Sort out the results
      AK (1)=AKIN(1)
      AK (2)=AKIN(2)
      AK (4)=AKIN(3)
      AK (3)=AKIN(4)
      AK (5)=1
      AK (6)=1
      AK (7)=1
      AK (8)=1
      AK( 9)=AKIN(1)-AKIN(2)
      AK(10)=0
      AK(11)=AKIN(3)-AKIN(4)
      AK(12)=0
      AK(13)=0
      AK(14)=0
      AK(15)=0
      AK(16)=0
      AK(17)=0
      AK(18)=0
      AK(19)=0
      AK(20)=0
      AK(21)=0
C*
C* Process the reference results file
   40 READ (LRE,800) RECI
      IF(RECI(1:8).NE.'  K-inf ') GO TO 40
      READ(RECI,804) (RK(J),J= 1, 4)
      READ(LRE ,804) (SG(J),J= 1, 4)
   41 READ (LRE,800) RECI
      IF(RECI(1:8).NE.'  K-eff ') GO TO 41
      READ(RECI,804) (RK(J),J= 5, 8)
      READ(LRE ,804) (SG(J),J= 5, 8)
   42 READ (LRE,800) RECI
      IF(RECI(1:8).NE.'  Dki(T)') GO TO 42
      READ(RECI,804) (RK(J),J= 9,13)
      READ(LRE ,804) (SG(J),J= 9,13)
   44 READ (LRE,800) RECI
      IF(RECI(1:8).NE.'  Dki(L)') GO TO 44
      READ(RECI,804) (RK(J),J=14,17)
      READ(LRE ,804) (SG(J),J=14,17)
   46 READ (LRE,800) RECI
      IF(RECI(1:8).NE.'  Dke(T)') GO TO 46
      READ(RECI,804) (RK(J),J=18,21)
      READ(LRE ,804) (SG(J),J=18,21)
C*
C* Calculate the error w.r.t reference
      DO 50 I=1,21
      IF( I.GT.8) AK( I)=1.E5*AK(I)
      ER( I)=(AK( I)-RK( I))
      IF( I.LE.8) ER( I)=1.E5*ER(I)
      IF( I.LE.8) SG( I)=1.E5*SG(I)
   50 CONTINUE
C*
C* Print to log file
      WRITE(LOU,840) ' Rowlands Plutonium Pin-cell Benchmark  '
      WRITE(LOU,840) ' =====================================  '
      WRITE(LOU,840)
      WRITE(LOU,840) ' Case summary                           '
      WRITE(LOU,840) ' ------------                           '
      WRITE(LOU,840) ' Case  Material Tfuel  Tcan  Tmod       '
      WRITE(LOU,840) '                  (K)   (K)   (K)       '
      WRITE(LOU,840) '   1     MOX-1    300   300   300       '
      WRITE(LOU,840) '   2     MOX-1    560   300   300       '
      WRITE(LOU,840) '   3     MOX-2    560   300   300       '
      WRITE(LOU,840) '   4     MOX-2    300   300   300       '
      WRITE(LOU,840)
      WRITE(LOU,840) ' NOTE:                                  '
      WRITE(LOU,840) ' - Reference results contain            '
      WRITE(LOU,840) '   the uncertainty in braces [pcm]      '
      WRITE(LOU,840) ' - WIMS results contain the difference  '
      WRITE(LOU,840) '   from reference in braces [pcm]       '
      WRITE(LOU,840)
      WRITE(LOU,840) ' Multiplication factors K-inf           '
      WRITE(LOU,840) ' ----------------------------           '
      WRITE(LOU,821) (J,J=1,4)
      WRITE(LOU,823) ' Ref. ',(RK(J),NINT(SG(J)),J= 1, 4)
      WRITE(LOU,823) ' WIMS ',(AK(J),NINT(ER(J)),J= 1, 4)
      WRITE(LOU,840)
      WRITE(LOU,840) ' Change in K-inf due to temperature[pcm]'
      WRITE(LOU,840) ' ---------------------------------------'
      WRITE(LOU,822) 1,'-',2, 4,'-',3
      WRITE(LOU,824) ' Ref. ',NINT(RK( 9)),NINT(SG( 9))
     1                       ,NINT(RK(11)),NINT(SG(11))
      WRITE(LOU,824) ' WIMS ',NINT(AK( 9)),NINT(ER( 9))
     1                       ,NINT(AK(11)),NINT(ER(11))
   90 STOP 'WEDRPU Completed'
C*
   92 PRINT *,NK
      STOP 'WEDRPU ERROR - EOF before all data read'
C*
  800 FORMAT(A120)
  802 FORMAT(BN,F12.0)
  804 FORMAT(8X,8F8.0)
  840 FORMAT(A40)
  821 FORMAT(' Case ',5(10X,I1,3X))
  822 FORMAT(' Case ',5(7X,I1,A1,I1,2X))
  823 FORMAT(A6,5(F8.5,'(',I4,')') )
  824 FORMAT(A6,5(I6  ,'(',I4,')') )
      END
      SUBROUTINE UPCASE(NL,STR)
C-Title  : Subroutine UPCASE
C-Purpose: Force character string string Uppercase
      CHARACTER*1 STR(NL)
      DO 20 I=1,NL
      IC =ICHAR(STR(I))
      IF(IC.GT.96) STR(I)=CHAR(IC-32)
   20 CONTINUE
      RETURN
      END
*deck WEDRU 
      PROGRAM WEDRU
C-Title  : Rrogram WEDRU
C-Purpose: Process WIMS-D outputs for Rowlands U pin cell benchmark
C-M
C-M  Manual for Program WEDRU
C-M  =========================
C-M
C-M  The WIMS-D results for the Rowlands Uranium pin-cell
C-M  benchmarks are processed.
C-M
C-M  It is assumed that the records containing the results
C-M  of the K-inf and K-eff leakage edit of WIMS-D are extracted
C-M  on the file "RPINU.K". Double leakage edit (transport
C-M  corrected and B1) is allowed. It is identified by the
C-M  K-inf value, which must be the same to within 1 pcm.
C-M  The K-inf, K-eff and differences in K are calculated and
C-M  printed to output. If double leakage edit is present, the
C-M  K values and differences in K due to leakage are taken
C-M  from the B1 leakage edit. Differences due to temperature
C-M  changes are taken from the transport corrected leakage
C-M  edit, since the B1 edit may be incorrect due to a single
C-M  P1 scattering matrix in the library.
C-M
C-M  The reference results are read from the "RPINKE.LOG" file
C-M  which is normally produced by the RPINKE code which
C-M  analyses and averages the results of a number of different
C-M  independent calculations.
C-M
C-M  A summary of results is written to "WEDRU.LOG"
C-M
C-M  Note: The original version of the file was named RPINDK.
C-M        For the sake of consistency in nomenclature the
C-M        program was renamed.
C-Author : A.Trkov, International Atomic Energy Agency (1997)
C-
      CHARACTER*120 RECI
      CHARACTER*40  FLNM,FLNI,FLRE,FLNO
C*
      DIMENSION     AKIN(4),AKEB(4),AKET(4)
     1            , AK(21) ,RK(21) ,SG(21) ,ER(21)
C*
      DATA  LIN,LRE,LOU / 1, 2 , 4 /
      DATA  FLNI/'RPINU.K'/
     1      FLRE/'RPINKE.LOG'/
     1      FLNO/'WEDRU.LOG'/
C*
      OPEN (UNIT=LIN,FILE=FLNI,STATUS='OLD')
      OPEN (UNIT=LRE,FILE=FLRE,STATUS='OLD')
      OPEN (UNIT=LOU,FILE=FLNO,STATUS='UNKNOWN')
C*
C* Initialize
      NK=0
C*
C* Process WIMS results - read the K-inf and K-eff from the file
   20 READ (LIN,800,END=21) RECI
      CALL UPCASE(40,RECI)
      IF(RECI(21:30).NE.'...  K-INF') GO TO 20
      READ(RECI(38:49),802) XKI
      READ(RECI(66:77),802) XKE
C* Distinguish between transport-corrected and B1 leakage edit
      IF(ABS(XKI-AKIN(NK)).LT.1.E-5) THEN
        AKEB(NK)=XKE
      ELSE
        IF(NK.LT.4) NK=NK+1
        AKIN(NK)=XKI
        AKET(NK)=XKE
        AKEB(NK)=XKE
      END IF
      GO TO 20
   21 IF(NK.NE.4) GO TO 92
C* Sort out the results
      AK (1)=AKIN(1)
      AK (2)=AKIN(2)
      AK (3)=AKIN(3)
      AK (4)=AKIN(4)
      AK (5)=AKEB(1)
      AK (6)=AKEB(2)
      AK (7)=AKEB(3)
      AK (8)=AKEB(4)
      AK( 9)=AKIN(1)-AKIN(2)
      AK(10)=AKIN(2)-AKIN(4)
      AK(11)=AKIN(4)-AKIN(3)
      AK(12)=AKIN(2)-AKIN(3)
      AK(13)=AKIN(1)-AKIN(3)
      AK(14)=AKIN(1)-AKEB(1)
      AK(15)=AKIN(2)-AKEB(2)
      AK(16)=AKIN(3)-AKEB(3)
      AK(17)=AKIN(4)-AKEB(4)
      AK(18)=AKEB(1)-AKEB(2)
      AK(19)=AKET(2)-AKET(4)
      AK(20)=AKET(4)-AKET(3)
      AK(21)=AKET(2)-AKET(3)
C*
C* Process the reference results file
   40 READ (LRE,800) RECI
      IF(RECI(1:8).NE.'  K-inf ') GO TO 40
      READ(RECI,804) (RK(J),J= 1, 4)
      READ(LRE ,804) (SG(J),J= 1, 4)
   41 READ (LRE,800) RECI
      IF(RECI(1:8).NE.'  K-eff ') GO TO 41
      READ(RECI,804) (RK(J),J= 5, 8)
      READ(LRE ,804) (SG(J),J= 5, 8)
   42 READ (LRE,800) RECI
      IF(RECI(1:8).NE.'  Dki(T)') GO TO 42
      READ(RECI,804) (RK(J),J= 9,13)
      READ(LRE ,804) (SG(J),J= 9,13)
   44 READ (LRE,800) RECI
      IF(RECI(1:8).NE.'  Dki(L)') GO TO 44
      READ(RECI,804) (RK(J),J=14,17)
      READ(LRE ,804) (SG(J),J=14,17)
   46 READ (LRE,800) RECI
      IF(RECI(1:8).NE.'  Dke(T)') GO TO 46
      READ(RECI,804) (RK(J),J=18,21)
      READ(LRE ,804) (SG(J),J=18,21)
C*
C* Calculate the error w.r.t reference
      DO 50 I=1,21
      IF( I.GT.8) AK( I)=1.E5*AK(I)
      ER( I)=(AK( I)-RK( I))
      IF( I.LE.8) ER( I)=1.E5*ER(I)
      IF( I.LE.8) SG( I)=1.E5*SG(I)
   50 CONTINUE
C*
C* Print to log file
      WRITE(LOU,840) ' Rowlands Pin-cell Uranium Benchmark    '
      WRITE(LOU,840) ' ===================================    '
      WRITE(LOU,840)
      WRITE(LOU,840) ' Case summary                           '
      WRITE(LOU,840) ' ------------                           '
      WRITE(LOU,840) ' Case  Tfuel  Tcan  Tmod.  RhoW    B**2 '
      WRITE(LOU,840) '         (K)   (K)   (K) (g/cm3) (1/cm2)'
      WRITE(LOU,840) ' 1,5     290   293   293    1.0    0.01 '
      WRITE(LOU,840) ' 2,6     293   293   293    0.7    0.01 '
      WRITE(LOU,840) ' 3,7     900   600   550    0.7    0.01 '
      WRITE(LOU,840) ' 4,8     550   550   550    0.7    0.01 '
      WRITE(LOU,840)
      WRITE(LOU,840) ' NOTE:                                  '
      WRITE(LOU,840) ' - Reference results contain            '
      WRITE(LOU,840) '   the uncertainty in braces [pcm]      '
      WRITE(LOU,840) ' - WIMS results contain the difference  '
      WRITE(LOU,840) '   from reference in braces [pcm]       '
      WRITE(LOU,840)
      WRITE(LOU,840) ' Multiplication factors K-inf           '
      WRITE(LOU,840) ' ----------------------------           '
      WRITE(LOU,821) (J,J=1,4)
      WRITE(LOU,823) ' Ref. ',(RK(J),NINT(SG(J)),J= 1, 4)
      WRITE(LOU,823) ' WIMS ',(AK(J),NINT(ER(J)),J= 1, 4)
      WRITE(LOU,840)
      WRITE(LOU,840) ' Multiplication factors K-eff           '
      WRITE(LOU,840) ' ----------------------------           '
      WRITE(LOU,821) (J+4,J=1,4)
      WRITE(LOU,823) ' Ref. ',(RK(J),NINT(SG(J)),J= 5, 8)
      WRITE(LOU,823) ' WIMS ',(AK(J),NINT(ER(J)),J= 5, 8)
      WRITE(LOU,840)
      WRITE(LOU,840) ' Change in K-inf due to temperature[pcm]'
      WRITE(LOU,840) ' ---------------------------------------'
      WRITE(LOU,822) 1,'-',2, 2,'-',4, 4,'-',3, 2,'-',3, 1,'-',3
      WRITE(LOU,824) ' Ref. ',(NINT(RK(J)),NINT(SG(J)),J= 9,13)
      WRITE(LOU,824) ' WIMS ',(NINT(AK(J)),NINT(ER(J)),J= 9,13)
      WRITE(LOU,840)
      WRITE(LOU,840) ' Change in K-inf due to leakage [pcm]   '
      WRITE(LOU,840) ' ------------------------------------   '
      WRITE(LOU,822) (J,'-',J+4,J=1,4)
      WRITE(LOU,824) ' Ref. ',(NINT(RK(J)),NINT(SG(J)),J=14,17)
      WRITE(LOU,824) ' WIMS ',(NINT(AK(J)),NINT(ER(J)),J=14,17)
      WRITE(LOU,840)
      WRITE(LOU,840) ' Change in K-eff due to temperature[pcm]'
      WRITE(LOU,840) ' ---------------------------------------'
      WRITE(LOU,822) 5,'-',6, 6,'-',8, 8,'-',7, 6,'-',7
      WRITE(LOU,824) ' Ref. ',(NINT(RK(J)),NINT(SG(J)),J=18,21)
      WRITE(LOU,824) ' WIMS ',(NINT(AK(J)),NINT(ER(J)),J=18,21)
   90 STOP 'WEDRU Completed'
C*
   92 PRINT *,NK
      STOP 'WEDRU ERROR - EOF before all data read'
C*
  800 FORMAT(A120)
  802 FORMAT(BN,F12.0)
  804 FORMAT(8X,8F8.0)
  840 FORMAT(A40)
  821 FORMAT(' Case ',5(10X,I1,3X))
  822 FORMAT(' Case ',5(7X,I1,A1,I1,2X))
  823 FORMAT(A6,5(F8.5,'(',I4,')') )
  824 FORMAT(A6,5(I6  ,'(',I4,')') )
      END
      SUBROUTINE UPCASE(NL,STR)
C-Title  : Subroutine UPCASE
C-Purpose: Force character string string Uppercase
      CHARACTER*1 STR(NL)
      DO 20 I=1,NL
      IC =ICHAR(STR(I))
      IF(IC.GT.96) STR(I)=CHAR(IC-32)
   20 CONTINUE
      RETURN
      END
*deck wedspe 
C-Title  : WEDSPE Program
C-Purpose: Extract spectra from WIMS output
C-Author : A.Trkov, Institute Jozef Stefan, Ljubljana, Slovenia
C-Version: 1992 Original code
C-V  02/03 A.Trkov
C-V        - Printout control from input.
C-V        - 172-group capability.
C-M
C-M  Manual for Program WEDSPE
C-M  -------------------------
C-M
C-M  The WIMS output is processed and the calculated spectra are
C-M  extracted and pronted in PLOTTAB Format
C-M
C-M  NOTES:
C-M   - Group energy boundaries are required to calculate the spectra.
C-M     At present, the 69-group WIMS-D and the 172-group X-mas scheme
C-M     energy boundaries are built into the code. WEDSPE will not work
C-M     (or not work correctly) with any other group scheme.
C-M   - Transport group schemes are defined with the FEWGROUP command
C-M     in WIMS-D input. The present version of WEDSPE has not been
C-M     coded to read this data. The only options allowed are:
C-M      * full group scheme (any library),
C-M      * 32-group transport scheme (69-group library only). WEDSPE
C-M        will not work (or not work correctly) with any other
C-M        transport group scheme.
C-
      PARAMETER   (MXGR=200)
      CHARACTER*8  HDR ,SR1A,SR1B
      CHARACTER*30 SR0A,SR0B,SRC1,SRC2,RECI
      CHARACTER*40 COMM,BLNK,FLNM,FLIN,FLOU
      DIMENSION    NGB(MXGR),MGB(MXGR),US(MXGR),SPE(MXGR),SPI(MXGR)
      DIMENSION    NG1(32)  ,US2(69) ,US3(172)
C* File units
      DATA LIN,LOU,LKB,LTT/ 1, 2, 5, 6 /
C* Default filenames
      DATA BLNK/'                                        '/
     1     FLIN/'WIMSDOUT'/
     2     FLOU/'WEDSPE.CUR'/
C* Search strings for Spectrox, Cell and Leakage spectra
      DATA SR1A,SR1B /' DUMMY  ',' DUMMY  '/
     1    ,SR0A /'1FLUX.                        '/
     1    ,SR0B /'1flux.                        '/
     1    ,SRC1 /'1FEW-GROUP REGIONAL AND CELL E'/
     2    ,SRC2 /' GROUP     DIFFUSION    DIFFUS'/
C* Assumed WIMS transport FEWGROUP structure
      DATA NG1 /
     1   2, 4, 6,11,14,21,23,25,26,27,28,29,30,32,33,35,38,40,41,43,45
     2 ,47,49,52,54,55,56,57,60,63,66,69/
C* WIMS group energy boundaries (69 and 172)
      DATA US2/
     1  10.0000E6,   6.0655E6,   3.6790E6,   2.2310E6,   1.3530E6,
     1   0.8210E6,   0.5000E6,   0.3025E6,   0.1830E6,   0.1110E6,
     2  67.3400E3,  40.8500E3,  24.7800E3,  15.0300E3,   9.1180E3,
     2   5.5300E3,   3.5191E3,   2.23945E3,  1.4251E3, 906.898   ,
     3 367.262   , 148.728   ,  75.5014   , 48.05    ,  27.7     ,
     3  15.968   ,   9.877   ,   4.0      ,  3.3     ,   2.6     ,
     4   2.1     ,   1.5     ,   1.3      ,  1.15    ,   1.123   ,
     4   1.097   ,   1.071   ,   1.045    ,  1.02    ,   0.996   ,
     5   0.972   ,   0.950   ,   0.91     ,  0.85    ,   0.78    ,
     5   0.625   ,   0.5     ,   0.4      ,  0.35    ,   0.32    ,
     6   0.3     ,   0.28    ,   0.25     ,  0.22    ,   0.18    ,
     6   0.14    ,   0.1     ,   0.08     ,  0.067   ,   0.058   ,
     7   0.05    ,   0.042   ,   0.035    ,  0.03    ,   0.025   ,
     7   0.02    ,   0.015   ,   0.01     ,  0.005 /
      DATA US3/
     & 1.96403E+7, 1.73325E+7, 1.49182E+7, 1.38403E+7, 1.16183E+7,
     & 1.00000E+7, 8.18731E+6, 6.70320E+6, 6.06531E+6, 5.48812E+6,
     & 4.49329E+6, 3.67879E+6, 3.01194E+6, 2.46597E+6, 2.23130E+6,
     & 2.01897E+6, 1.65299E+6, 1.35335E+6, 1.22456E+6, 1.10803E+6,
     & 1.00259E+6, 9.07180E+5, 8.20850E+5, 6.08101E+5, 5.50232E+5,
     & 4.97871E+5, 4.50492E+5, 4.07622E+5, 3.01974E+5, 2.73237E+5,
     & 2.47235E+5, 1.83156E+5, 1.22773E+5, 1.11090E+5, 8.22975E+4,
     & 6.73795E+4, 5.51656E+4, 4.08677E+4, 3.69786E+4, 2.92830E+4,
     & 2.73944E+4, 2.47875E+4, 1.66156E+4, 1.50344E+4, 1.11378E+4,
     & 9.11882E+3, 7.46586E+3, 5.53084E+3, 5.00451E+3, 3.52662E+3,
     & 3.35463E+3, 2.24867E+3, 2.03468E+3, 1.50733E+3, 1.43382E+3,
     & 1.23410E+3, 1.01039E+3, 9.14242E+2, 7.48518E+2, 6.77287E+2,
     & 4.53999E+2, 3.71703E+2, 3.04325E+2, 2.03995E+2, 1.48625E+2,
     & 1.36742E+2, 9.16609E+1, 7.56736E+1, 6.79041E+1, 5.55951E+1,
     & 5.15780E+1, 4.82516E+1, 4.55174E+1, 4.01690E+1, 3.72665E+1,
     & 3.37201E+1, 3.05113E+1, 2.76077E+1, 2.49805E+1, 2.26033E+1,
     & 1.94548E+1, 1.59283E+1, 1.37096E+1, 1.12245E+1, 9.90555E+0,
     & 9.18981E+0, 8.31529E+0, 7.52398E+0, 6.16012E+0, 5.34643E+0,
     & 5.04348E+0, 4.12925E+0, 4.00000E+0, 3.38075E+0, 3.30000E+0,
     & 2.76792E+0, 2.72000E+0, 2.60000E+0, 2.55000E+0, 2.36000E+0,
     & 2.13000E+0, 2.10000E+0, 2.02000E+0, 1.93000E+0, 1.84000E+0,
     & 1.75500E+0, 1.67000E+0, 1.59000E+0, 1.50000E+0, 1.47500E+0,
     & 1.44498E+0, 1.37000E+0, 1.33750E+0, 1.30000E+0, 1.23500E+0,
     & 1.17000E+0, 1.15000E+0, 1.12535E+0, 1.11000E+0, 1.09700E+0,
     & 1.07100E+0, 1.04500E+0, 1.03500E+0, 1.02000E+0, 9.96000E-1,
     & 9.86000E-1, 9.72000E-1, 9.50000E-1, 9.30000E-1, 9.10000E-1,
     & 8.60000E-1, 8.50000E-1, 7.90000E-1, 7.80000E-1, 7.05000E-1,
     & 6.25000E-1, 5.40000E-1, 5.00000E-1, 4.85000E-1, 4.33000E-1,
     & 4.00000E-1, 3.91000E-1, 3.50000E-1, 3.20000E-1, 3.14500E-1,
     & 3.00000E-1, 2.80000E-1, 2.48000E-1, 2.20000E-1, 1.89000E-1,
     & 1.80000E-1, 1.60000E-1, 1.40000E-1, 1.34000E-1, 1.15000E-1,
     & 1.00001E-1, 9.50000E-2, 8.00000E-2, 7.70000E-2, 6.70000E-2,
     & 5.80000E-2, 5.00000E-2, 4.20000E-2, 3.50000E-2, 3.00000E-2,
     & 2.50000E-2, 2.00000E-2, 1.50000E-2, 1.00000E-2, 6.90000E-3,
     & 5.00000E-3, 3.00000E-3/
C* Default number of transport and library groups
      NG =69
      NGL=69
      ILTH=0
      IHST=0
      DO 8 I=1,MXGR
      MGB(I)=I
    8 CONTINUE
C*
C* Print banner
      WRITE(LTT,96)
      WRITE(LTT,96) ' WEDSPE - Process spectra from WIMS-D   '
      WRITE(LTT,96) ' ====================================   '
      WRITE(LTT,96)
C* Define and open WIMS output file to be processed
      WRITE(LTT,96) '$Enter WIMS output filename           : '
      READ (LKB,96) FLNM
      IF(FLNM.NE.BLNK) FLIN=FLNM
      OPEN (UNIT=LIN,FILE=FLIN,STATUS='OLD')
C* Find the number of library groups
   11 READ (LIN,91,END=82) RECI
      IF(RECI(16:30).NE.'entry into main' .AND.
     &   RECI(16:30).NE.'ENTRY INTO MAIN') GO TO 11
      READ (LIN, * ) NMT,NGL
      WRITE(LTT, 97) ' Number of library materials          : ',NMT
      WRITE(LTT, 97) ' Number of library energy groups      : ',NGL
      IF     (NGL.EQ. 69) THEN
        DO 12 I=1,NGL
        US(I)=US2(I)
   12   CONTINUE
        US(NGL+1)=1.E-4
      ELSE IF(NGL.EQ.172) THEN
        DO 13 I=1,NGL
        US(I)=US3(I)
   13   CONTINUE
        US(NGL+1)=1.E-5
      ELSE
        STOP 'WEDSPE ERROR - Only 69 and 172 group library supported'
      END IF
C* Find the number of transport groups
   14 READ (LIN,91,END=84) RECI
      I1=0
   15 I1=I1+1
      IF(I1.GT.7) GO TO 14
      IF(RECI(I1:I1).EQ.' ') GO TO 15
      IF(RECI(I1:I1+3).NE.'NGRO' .AND. RECI(I1:I1+3).NE.'ngro') GO TO 14
   16 I1=I1+1
      IF(RECI(I1:I1).NE.' ') GO TO 16
      READ (RECI(I1:30), * ) NG
      WRITE(LTT, 97) ' Number of transport groups           : ',NG
      IF     (NG.EQ. 32) THEN
        IF(NGL.EQ.69) THEN
          DO 17 I=1,NG
          NGB(I)=NG1(I)
   17     CONTINUE
        ELSE
          STOP 'WEDSPE ERROR - 32g transport with 69g lib.only'
        END IF
      ELSE
        DO 18 I=1,NG
        NGB(I)=I
   18   CONTINUE
      END IF
C* Select spectra types to be processed:
      IP11=0
      IP11=0
      IP21=0
      IP22=0
      IP23=0
      IP31=0
      WRITE(LTT,96) '$    Process fuel Spectrox (No=blank) : '
      READ (LKB,96) FLNM
      IF(FLNM.NE.BLNK) IP11=1
      WRITE(LTT,96) '$ Process coolant Spectrox (No=blank) : '
      READ (LKB,96) FLNM
      IF(FLNM.NE.BLNK) IP12=1
C*
C...  WRITE(LTT,96) '$Process transport spectra (No=blank) : '
C...  READ (LKB,96) FLNM
C...  IF(FLNM.EQ.BLNK) GO TO 19
C...  IP21=1
      WRITE(LTT,96) '$   Process region spectra (No=blank) : '
      READ (LKB,96) FLNM
      IF(FLNM.NE.BLNK) IP22=1
      WRITE(LTT,96) '$Process cell aver.spectra (No=blank) : '
      READ (LKB,96) FLNM
      IF(FLNM.NE.BLNK) IP23=1
      IF(IP22.GT.0 .OR. IP23.GT.0) IP21=1
C*
   19 WRITE(LTT,96) '$  Process leakage spectra (No=blank) : '
      READ (LKB,96) FLNM
      IF(FLNM.NE.BLNK) IP31=1
C*
      WRITE(LTT,96)
      WRITE(LTT,96) ' Output spectra representation          '
      WRITE(LTT,96) '$  Output Lethargy spectra?(No=blank) : '
      READ (LKB,96) FLNM
      IF(FLNM.NE.BLNK) ILTH=1
      WRITE(LTT,96) '$  Histogram? (Smooth linear=blank)   : '
      READ (LKB,96) FLNM
      IF(FLNM.NE.BLNK) IHST=1
C*
C* Spectra output file in PLOTTAB format
      OPEN (UNIT=LOU,FILE=FLOU,STATUS='UNKNOWN'
     1     ,CARRIAGECONTROL='LIST')
C* Find the output sections containing spectra
   20 READ (LIN,91,END=90) RECI
C* Fuel and coolant spectra from spectrox calculation
      IF((IP11.EQ.1 .OR. IP12.EQ.1) .AND.
     1   (RECI     .EQ.SR0A .OR. RECI.EQ.SR0B) ) GO TO 21
C* Spectra from the transport solution
      IF( IP21.EQ.1 .AND. RECI     .EQ.SRC1) GO TO 30
C*      Region-wise spectrum printout
      IF( IP22.EQ.1 .AND. RECI(1:8).EQ.SR1A) GO TO 31
C*      Cell average spectrum
      IF( IP23.EQ.1 .AND. RECI(1:8).EQ.SR1B) GO TO 31
C* Spectrum from the leakage edit
      IF( IP31.EQ.1 .AND. RECI     .EQ.SRC2) GO TO 40
      GO TO 20
C*
C* Process the spectrum from the SPECTROX calculation
   21 WRITE(LTT,96) ' SPECTROX spectrum to be processed      '
      READ (LIN,91,END=90) RECI
      READ (LIN,91)        RECI
C* Loop for the fuel and the coolant spectrum
      DO 26 ISP=1,2
      READ (LIN,91)        RECI
      READ (LIN,91)        RECI
      READ (LIN,93,ERR=20) HDR,(SPI(I),I=1,NGL)
      COMM=BLNK
      COMM(1:8)=HDR
      IF     (HDR.EQ.'  fuel  ') THEN
        IF(IP11.NE.1) GO TO 26
      ELSE IF(HDR.EQ.'  coolnt') THEN
        IF(IP12.NE.1) GO TO 26
      ELSE
        GO TO 20
      END IF
      CALL PRNTSP(LOU,ILTH,IHST,COMM,NG,MGB,US,SPI)
   26 CONTINUE
      GO TO 20
C*
C* Process the Region and Cell spectra output
   30 WRITE(LTT,96) ' Region and Cell spectrum processed     '
      SR1A='0REGION '
      SR1B=' CELL   '
      GO TO 20
   31 RECI(1:1)=' '
      COMM=RECI
      READ (LIN,91)
      READ (LIN,91)
      DO 32 I=1,NG
      READ (LIN,92) IDM,RDM,RDM,RDM, RDM,SPE(I)
   32 CONTINUE
      CALL PRNTSP(LOU,ILTH,IHST,COMM,NG,NGB,US,SPE)
      GO TO 20
C*
C* Process the Leakage edit spectra output
   40 WRITE(LTT,96) ' LEAKAGE Spectrum to be processed       '
      DO 42 I=1,NG
      READ (LIN,94) IDM,RDM,RDM,RDM,RDM,RDM,SPE(I),SPI(I)
   42 CONTINUE
      COMM=' LEAKAGE EFF.SP.                        '
      CALL PRNTSP(LOU,ILTH,IHST,COMM,NG,NGB,US,SPE)
      COMM=' LEAKAGE INF.SP.                        '
      CALL PRNTSP(LOU,ILTH,IHST,COMM,NG,NGB,US,SPI)
      GO TO 20
C* Error traps
   82 STOP 'WEDSPE ERROR - Library groups not found'
   84 STOP 'WEDSPE ERROR - Transport groups not found'
C* File processing completed
   90 STOP 'WEDSPE Completed'
   91 FORMAT(A30)
   92 FORMAT(I5,2X,3E13.5,5X,2E13.5)
   93 FORMAT(A8,9F12.0/(8X,9F12.0))
   94 FORMAT(I4,3X,7E14.5)
   96 FORMAT(2A40)
   97 FORMAT(A40,I6)
   98 FORMAT(1P,2E11.4)
      END
      SUBROUTINE PRNTSP(LOU,ILTH,IHST,COMM,NG,NGB,EGB,SPE)
C-Title  : Subroutine PRINTSP
C-Purpose: Print the spectrum in PLOTTAB curves format
C-Description:
C-D  LOU  Logical output unit
C-D  ILTH Spectrum type flag:
C-D        0  Spectrum per unit energy
C-D        1  Spectrum per unit lethargy
C-D  IHST Spectrum interpolation flag:
C-D        0  Linear between centroid of energy boundaries
C-D        1  Histogram
C-D  COMM Header comment for curve identification
C-D  NG   Number of points
C-D  NGB  Index array to the energy boundaries.
C-D  EGB  Energy boundaries (in descending order)
C-D  SPE  Spectrum values (integrated over energy group).
C-
      CHARACTER*40 COMM
      DIMENSION    NGB(1),EGB(1),SPE(1)
C*
C* Print the header
      WRITE(LOU,93) COMM
C*
C* Spectrum normalisation constant
      SSP= 0
      DO 32 I=1,NG
      SSP= SSP+SPE(I)
   32 CONTINUE
C*
C* Print the spectrum in ascending energy order
      N2 = NGB(NG)
      E2 = EGB(N2+1)
      DO 34 J=1,NG
      I  = NG+1-J
      N2 = NGB(I)
      E1 = E2
      E2 = EGB(N2)
      IF(ILTH.EQ.1) THEN
C* Case:  Print the LETHARGY spectrum
        FF = SSP*ALOG(E2/E1)
        IF(IHST.EQ.1) THEN
C*        Histogram representation
          WRITE(LOU,98) E1,SPE(I)/FF
          WRITE(LOU,98) E2,SPE(I)/FF
        ELSE
C*        Linear representation
          IF(E1.GT.0) THEN
            EE=SQRT(E1*E2)
          ELSE
            EE=E2/2
          END IF
          WRITE(LOU,98) EE,SPE(I)/FF
        END IF
      ELSE
C* Case: Print ENERGY spectrum (scaled by 1.E12)
        FF = SSP*    (E2-E1) * 1.e-12
        IF(IHST.EQ.1) THEN
C*        Histogram representation
          WRITE(LOU,98) E1,SPE(I)/FF
          WRITE(LOU,98) E2,SPE(I)/FF
        ELSE
C*        Linear representation with intermediate points
          IF(J.EQ. 1) THEN
            WRITE(LOU,98) 1.E-5,0.
            C2=SQRT(E1*E2)
            F2=SPE(I)/FF
            WRITE(LOU,98) C2,F2
          ELSE IF(J.EQ.NG) THEN
            F1=F2
            F2=SPE(I)/FF
            C1=C2
            C2=SQRT(E1*E2)
            FB=EXP( LOG(F1)+LOG(F2/F1)*LOG(E1/C1)/LOG(C2/C1) )
            FU=EXP( LOG(F1)+LOG(F2/F1)*LOG(E2/C1)/LOG(C2/C1) )
            WRITE(LOU,98) E1,FB
            WRITE(LOU,98) C2,F2
            WRITE(LOU,98) E2,FU
            WRITE(LOU,98) 2.E+7,0.
          ELSE
            F1=F2
            F2=SPE(I)/FF
            C1=C2
            C2=SQRT(E1*E2)
            FB=EXP( LOG(F1)+LOG(F2/F1)*LOG(E1/C1)/LOG(C2/C1) )
            WRITE(LOU,98) E1,FB
            WRITE(LOU,98) C2,F2
          END IF
        END IF
      END IF
   34 CONTINUE
      WRITE(LOU,93)
      RETURN
C*
   93 FORMAT(A40)
   98 FORMAT(1P,2E11.4)
      END
*deck willie 
      PROGRAM WILLIE
C-Title  : WILLIE Program
C-Purpose: Operations on WIMS cross section library
C-Author : A.Trkov, Inst."Jozef Stefan", Ljubljana, Slovenia,
C-A        A.Holubar, Nucl.Research Inst., Rez, Czech Republic.
C-Version: WILLIE original code derived from WILIT (workname: WILIT2).
C-V  93/05 log-lin interpolation over last RI interval in INTERI.
C-V  94/08 - input interpolation flag in PTAB option,
C-V        - new RINTER routine for Res.Integral interpolation.
C-V  94/10 Fix filemark search in Res.Int. tables in COMPMT.
C-V  94/11 Allow data insertion BEFORE a specified MAT in INCLMT.
C-V  96/07 Interpret different file marks in the binary files.
C-V  96/10/03  Define FormFeed with CHAR function.
C-V  96/10/07  Define CHCK as Hollerith for compatibility.
C-V            Define " EXPORT" version as default.
C-V  97/10/07  Open new files in "EXPORT" version with 'UNKNOWN' status.
C-V  98/11/10  Implement option DELM to delete materials
C-V            Implement option CHCK to check the library integrity.
C-V  98/12/22  Interpret blank keywords as comment lines.
C-V  99/01/06  Allow fissile materials redefined as fission products.
C-V  99/10/20  Fix undefined LER in COMPMT (found by O.Cabellos).
C-V  00/03/20  Add NEWL option.
C-V  01/05/22  MIXM group structure specification and description.
C-M
C-M  Manual for Program WILLIE
C-M  =========================
C-M
C-M  1. INTRODUCTION
C-M  ---------------
C-M  WILLIE  is a service program for various operations on the WIMS-D
C-M  cross sections data library. It is a direct descendant of the
C-M  WILIT code by A.Holubar. Major modifications and extensions were
C-M  introduced by A.Trkov to the input formats to make them more
C-M  user-friendly when running in the interactive mode. Some
C-M  modifications were also introduced in the cross sections input
C-M  file formats for better compatibility with external data
C-M  processing codes (such as NJOY). Fairly extensive changes were
C-M  also introduced for clearer, commented coding. In the present
C-M  version of WILLIE some of the old WILIT options are not supported,
C-M  while some others are added, such as the capability for producing
C-M  cross section data files suitable as input to graphics plotting
C-M  programs (for example, PLOTTAB).
C-M
C-M  2. PURPOSE AND CHARACTERISTICS OF THE CODE
C-M  ------------------------------------------
C-M  Program WILLIE was designed to offer the possibility of making
C-M  various changes in a WIMS-D library. In particular, it enables
C-M  to include new data file generated by a processing code such
C-M  as NJOY into an existing WIMS library. It is also provides
C-M  for extracting data for a requested material onto a new file
C-M  and re-inserting the data (after editing the file or otherwise)
C-M  back into the library with another material identification
C-M  number. Comparison of two data sets extracted from a WIMS
C-M  library by WILLIE can be made. WILLIE mostly deals with the
C-M  card-image form of the library but it is also used to perform
C-M  the transformations between the binary and the coded form of
C-M  the library.
C-M
C-M  A detailed description of the binary and formatted forms of the
C-M  WIMS library are given in the Appendix, since this information
C-M  is considered useful for a better understanding of the WILLIE
C-M  code application and its further improvements.
C-M
C-M  WILLIE is designed to be used from a terminal. Brief instructions
C-M  for defining and formatting the input parameters are given on
C-M  the screen. At present, WILLIE provides sixteen functions by
C-M  selecting the appropriate four-letter keywords (some of which
C-M  are incative).
C-M
C-M  3. INPUT DESCRIPTION
C-M  --------------------
C-M  Every service request from WILLIE begins by entering the
C-M  appropriate keyword on the input line. Only the first four
C-M  characters are interpreted and they must be uppercase. All
C-M  required data files are opened explicitly by requesting the
C-M  appropriate filenames from input. Up to 40 characters are
C-M  interpreted to define filenames. Up to 20 characters are read
C-M  when entering numeric values. Blanks are interpreted as null,
C-M  so the input entries need not be right-justified. A decimal
C-M  point for floating point values is not mandatory. Currently
C-M  available services identified by keywords and additional
C-M  input parameters (if any) are listed below.
C-M      When running WILLIE in batch mode (i.e. feeding the
C-M  input directives from a file) it is useful to know that
C-M  input statements with a "blank" keyword are simply copied
C-M  to the default output unit. This feature can be used to
C-M  enter comments into the input file before activating a
C-M  particular servece request from WILLIE.
C-M
C-M  KWRD. Description
C-M  """""""""""""""""
C-M  FOBI  Formatted (card-image) library is transformed into binary
C-M        library. Additional input parameters are:
C-M         - source formatted library filename,
C-M         - target binary library filename.
C-M  BIFO  A binary library is transformed into a formatted library.
C-M        Additional input parameters are:
C-M         - source binary library filename,
C-M         - target formatted library filename.
C-M  COPY  Data for a selected material are extracted from the
C-M        formatted WIMS library and stored on an output file.
C-M        The original library remains unchanged. Additional
C-M        parameters are
C-M         - source formatted library filename,
C-M         - target cross section filename.
C-M         - AMT1 identifier of the nuclide (including the decimal
C-M           resonance integral identifier), the data of which is
C-M           to be extracted.
C-M  COP1  Data for a selected P1 scattering matrix are extracted
C-M        from the formatted WIMS library and stored on the output
C-M        file. The original library remains unchanged. Additional
C-M        parameters are
C-M         - source formatted library filename,
C-M         - consecutive number NP1 of the P1 matrix to be extracted.
C-M           Zero or blank is not a valid entry. It causes a list of
C-M           materials in the library to be displayed. Entering a
C-M           negative number aborts the service request.
C-M         - target P1 matrix filename.
C-M        NOTE: At present only the standard format of the source
C-M              WIMS library with four P1 scattering matrices in
C-M              expanded format is accepted. In future this will be
C-M              extended to include any number of condensed or
C-M              uncondensed P1 scattering matrices to be processed,
C-M              and optionally to convert between the expanded and
C-M              condensed format of the matrices. In addition, it
C-M              will be possible to append the P1 matrix to a material
C-M              cross section file, rather than unconditionally open
C-M              a new file.
C-M  NEWL  A starter file for a new library is generated. Additional
C-M        input parameters are:
C-M         - Filename for the new library.
C-M         - Total number of groups.
C-M         - Number of fast neutron energy groups.
C-M         - Number of resonance energy groups.
C-M        NOTE: Make sure that the energy boundaries and the spectrum
C-M              are entered with the INCL command before the library
C-M              is used.
C-M  INCL  Data for a material extracted from a WIMS library either by
C-M        the WILLIE option COPY or otherwise are read and added to the
C-M        WIMS formatted library. If present, the burnup data, nuclide
C-M        cross section data, resonance integrals tables and P1 matrix
C-M        are processed. Additional input parameters are:
C-M         - source formatted library filename,
C-M         - source cross section filename,
C-M         - target formatted library filename,
C-M         - identification number MAT of the material to be inserted
C-M           where the decimal point labels the resonance tables.
C-M           SPECIAL CASES:
C-M            * If a zero (or blank) is entered, the default material
C-M              number on the cross section file is assumed.
C-M            * If the selected MAT number is already in the
C-M              library, an additional request for the MAT number is
C-M              issued. The following options are available:
C-M               . blank to replace the data in the WIMS library,
C-M               . new MAT number to insert the new data BEFORE the
C-M                 data for the previously defined MAT number.
C-M            * In case of an input error, the user may wish to abort
C-M              the current service by entering a negative MAT number.
C-M  SMTR  A cross section data file, such as produced by the COPY
C-M        service option is processed. A correction to the self-
C-M        scattering terms of the scattering matrices is applied such
C-M        that the absorption cross section and the sum of the
C-M        scattering matrix element for a particular group add up to
C-M        the transport cross section. Resonance integrals are
C-M        copied, but P1-matrices (if any) are skipped. Additional
C-M        input parameters are:
C-M         - source cross section filename,
C-M         - output cross section filename.
C-M  CHCK  Check the library format and consistency. The following
C-M        tests are made:
C-M        * NEL,NG,NG0,NG1,NG2,NG3 (number of materials, number of
C-M          energy groups, fission spectrum groups, number of fast,
C-M          resonance and thermal groups, respectively) are checked
C-M          implicitly. In case of inconsistency an abnormal program
C-M          termination occurs due to library format errors. This
C-M          type of inconsistency can not be corrected.
C-M        * NNFD number of fissile nuclei implies all nuclides
C-M          with the burnup data vector greater than eight.
C-M          If in error, the value in the library is corrected.
C-M        * NNFPD number of fission product nuclei implies all
C-M          nuclides with the burnup data vector length of eight.
C-M          If in error, the value in the library is corrected.
C-M        * Nuclide identification numbers. A check for duplicate
C-M          entries is made.
C-M
C-M          In addition, the burnup and fission yield vectors of
C-M          all materials are checked to make sure that the
C-M          addressed nuclides are burnable. A warning is printed,
C-M          but no corrective action can be taken.
C-M        Additional input parameters are:
C-M         - source library filename,
C-M         - corrected library filename.
C-M  COMP  Two data files, such as produced by the COPY service option
C-M        or otherwise can be compared in tabular form. Cross sections,
C-M        P0 scattering matrices and resonance integrals can be
C-M        processed. Consistency between the scattering matrix and the
C-M        transport cross section is checked. A separate tolerance
C-M        criterion is entered for cross sections, transport
C-M        consistency and resonance integrals. Only the groups in
C-M        which the difference exceeds the tolerance limit are printed.
C-M        If zero is entered, all cross sections are printed. Entering
C-M        a negative value suppresses the groups printout, so that only
C-M        the maximum and the minimum difference are printed. Up to 60
C-M        lines are printed per page. If a reaction type would not fit
C-M        onto the same page, a form feed is printed. The full output
C-M        is written on a file defined from input. A brief summary of
C-M        differences exceeding the specified threshold are written
C-M        on the COMPMT.LOG file. Additional input parameters are:
C-M         - reference cross section filename,
C-M         - compared cross section filename,
C-M         - output report filename,
C-M         - cross section printout tolerance [%],
C-M         - transport consistency tolerance [%],
C-M         - resonance integral tolerance [%].
C-M        NOTE: Resonance integrals are tabulated and compared on a
C-M              grid of the Bondarenko Sig0 values. A conversion is
C-M              made from the WIMS background cross section SigB to
C-M              the Bondarenko Sig0 by subtracting Lambda*SigP from
C-M              SigB. On the Sig0 scale the resonance integrals are
C-M              comparable better since the dependence of the absorber
C-M              potential cross section is removed from the definition
C-M              to a large extent.
C-M                From the Sig0 grid of the reference and the compared
C-M              data, WILLIE first constructs a union grid. It then
C-M              eliminates the endpoints to avoid extrapolation for
C-M              either of the data sets. Since no more than 9 values
C-M              can be printed per line, it reduces the union grid by
C-M              eliminating the points which lie close together, so
C-M              that the final grid is as uniform as possible.
C-M              Resonance integrals are interpolated to the union Sig0
C-M              grid using Segev interpolation, except for very low
C-M              Sig0 values where Root(Sig0) interpolation is applied.
C-M  PTAB  Cross sections from a WILLIE file produced by the COPY option
C-M        or otherwise are tabulated in two-column format that can be
C-M        read by a graphics program such as PLOTTAB. Several input
C-M        files can be specified so that the data sets can be sorted
C-M        by reaction (i.e.: same cross section from different files)
C-M        or by material (i.e.: different cross sections from one or
C-M        more files). Resonance integrals are tabulated as a function
C-M        of the internally defined mesh of the WIMS background cross
C-M        section SigB for a user-specified group or all groups.
C-M        Additional input parameters are:
C-M         - reference cross section filename (up to 10 files can be
C-M           specified, terminated by blank),
C-M         - data descriptor for each data set, which appears as the
C-M           first record on the output data file for a data set
C-M           (default descriptor is the filename),
C-M         - reaction ident form the following list:
C-M                       1 - potential cross section
C-M                       2 - slowing down power
C-M                       3 - transport cross section
C-M                       4 - absorption cross section
C-M                       5 - neutron fission yield
C-M                       6 - fission cross section
C-M                       7 - outscattering cross section
C-M                       8 - total scattering cross section
C-M                       9 - group scattering matrix
C-M                      10 - absorption resonance integrals
C-M                      11 - fission resonance integrals
C-M                      -1 - to finish
C-M         - output filename; entering blank implies adding data to the
C-M           default filename (PTABMT.CUR defined initially). By
C-M           entering a new filename the old output file (if open) is
C-M           closed and the new file opened as the default output file,
C-M         - required temperature [K],
C-M           NOTE: only when more than one temperature is present in
C-M                 the thermal cross section or the resonance integrals
C-M                 tables.
C-M         - required group
C-M           NOTE: only for the resonance integrals. If zero is entered
C-M                 the resonance integrals for all resonance groups are
C-M                 tabulated.
C-M         - interpolation flag
C-M           NOTE: only for the resonance integrals. An integer entry
C-M                 greater than zero forces Root(SigB) interpolation
C-M                 (except in the last interval where 1/SigB rule is
C-M                 specified). This is equivalent to the original
C-M                 WIMS-D/4 resonance integral interpolation rule.
C-M        The request for the reaction type and subsequent data entries
C-M        is repeated until a negative entry is encountered.
C-M  MIXM  Data for two or more material extracted from a WIMS library
C-M        either by the WILLIE option COPY or otherwise are summed
C-M        with a weighting factor entered from input in per-cent.
C-M        Normally the weighting factor is the natural abundance,
C-M        when reconstructing elemental data from the isotopic. Note
C-M        that the entered abundances are not normalised to 100%.
C-M        Additional input parameters are:
C-M        a. Output (mixed) cross section filename (default MIXMAT.XSW)
C-M        b. WIMS ID number for the new material.
C-M        c. Source cross section filename.
C-M        d. Weighting factor for this set [%].
C-M        e.   Number of fast groups - requested only when the source
C-M             cross section set does not contain the data delimiter
C-M             record with appropriate specifications (default 14).
C-M        f.   Number of resonance groups - same condition as above.
C-M             (default 13).
C-M        g.   Number of thermal groups - same condition as above.
C-M             (default 42).
C-M        n. Input item pair c./d. can be repeated any number of
C-M           times. The list is terminated by specifying zero
C-M           weighting factor.
C-M
C-D  Options of the old WILIT which are NOT implemented in WILLIE:
C-D  incb  data for material compiled by libcom-wimlib (using fedgroup-r
C-D        results) - file wimmat - are read from file number n3 and
C-D        included into another WIMS formatted library read from the
C-D        file number n1, the resulting formatted library is written on
C-D        file number n2. burnup data for material being included are
C-D        copied from indicated material from the original library.
C-D  inp1  superseeded by INCL.
C-D  test  consistency of transport cross sections, p0 and p1 scattering
C-D        matrices is tested for a material from formatted library on
C-D        file number n1. p1 matrix copied from WIMS library in a
C-D        previous run is supposed on file number n3. results of the
C-D        test are printed on file nout1=7.
C-D  redu  contents of WIMS library is reduced - only the specified
C-D        materials are copied into the new formatted library on file
C-D        number n2
C-D  fisp  superseeded by INCL.
C-D  comw  superseeded by COMP.
C-D  coms  superseeded by COMP.
C-D  comg  superseeded by COMP.
C-D  rtab  superseeded by PTAB.
C-D  reca  tables of resonance integrals for one material are
C-D        recalculated for a new mesh of sigmap values specified in
C-D        input using the Segev's scheme for interpolation. new tables
C-D        replace the old ones in the new WIMS library written on
C-D        file number n2. value of the new mesh points will be read
C-D        from input.
C-M
C-M  4. Brief description of the main modules in WILLIE
C-M  --------------------------------------------------
C-M  Program WILLIE is composed of a number of modules (subroutines)
C-M  which perform various functions which the code offers. Some
C-M  additional auxilliary routines are called from the modules which
C-M  are described separately within the modules.
C-M
C-M  Main modules are the following:
C-M
C-M  BINFOR - module for the WILLIE service option BIFO.
C-M  FORBIN - module for the WILLIE service option FOBI.
C-M  COPYMT - module for the WILLIE service option COPY.
C-M  COP1MT - module for the WILLIE service option COP1.
C-M  INCLMT - module for the WILLIE service option INCL.
C-M  SMTXTR - module for the WILLIE service option SMTR.
C-M  COMPMT - module for the WILLIE service option COMP.
C-M  PTABMT - module for the WILLIE service option PTAB.
C-M
C-M  5. APPENDIX - WIMS library format
C-M  ---------------------------------
C-M  Information is gathered from various manuals on WIMS and from the
C-M  description of WILMA code. Note that in addition to the standard
C-M  WIMS/D-4 format there exists a CRNL (Canada) modification and also
C-M  the WIMS-E format. These are not supported by WILLIE at present.
C-M
C-M  The binary form of WIMS library is composed of a number of records,
C-M  each being created by one Fortran WRITE statement. In the card-
C-M  image form of library the data from one record are stored on an
C-M  appropriate number of cards. These can be written by more than one
C-M  fortran WRITE starement. The records can be grouped into:
C-M       a. general and burnup data,
C-M       b. cross-section data (nuclide files),
C-M       c. resonance tables,
C-M       d. P1-scattering matrices.
C-M  A brief description and format (applicable to the formatted
C-M  library) is given below.
C-M
C-M  a. General and burnup data
C-M  --------------------------
C-M  The first four records define the general parameters of the library
C-M  and are common for all nuclides. Note that this includes the
C-M  fission spectrum, which can not be entered for individual fissile
C-M  species separately. Then follow the burnup data for each nuclide.
C-M  Rec. Format                Data:
C-M    1  (5I15)                NEL,NG,NG0,NG1,NG2,NG3,NNFD,NNFPD
C-M    2  (5I15)                (ID(i),i=1,NEL)
C-M    3  (1P,5E15.8)           (EG(i),i=1,NG+1)
C-M    4  (1P,5E15.8)           (CHI(i),i=1,NG0)
C-M  4+i  (1P,I15/(3(E15.8,I6)) NDAT1,(MTF(j),YLD(j),j=1,NDAT1/2)
C-M                             for i = 1 to NEL
C-M 5+NEL (I15)                 filemark
C-M
C-M  Parameter description:
C-M    NEL      - total number of nuclides in the library,
C-M    NG       - total number of groups,
C-M    NG0      - number of groups in which fission neutrons appear,
C-M    NG1      - number of groups in the fast energy range,
C-M    NG2      - number of groups in the resonance range,
C-M    NG3      - number of groups in the thermal range,
C-M    NNFD     - number of fissile nuclei in the library (NDAT1>8),
C-M    NNFPD    - number of fission products in the library (NDAT1=8),
C-M    ID(i)    - material identification number (integer),
C-M    EG(i)    - energy group boundaries [eV] in descending order,
C-M    CHI(i)   - fraction of fission neutrons born in group (i),
C-M    NDAT1    - burnup data length for nuclide (i)
C-M                 = 2 for non-burnable and structural materials,
C-M                 = 8 for burnable materials and fission products,
C-M                 > 8 for fissile materials with fission product
C-M                     yields.
C-M    MTF(1)   - ident of nuclide (i), equal to ID(i),
C-M    MTF(2)   - ident of nuclide (j) formed by capture,
C-M    MTF(3)   - ident of nuclide (j) formed by decay,
C-M    MTF(4)   - a flag that can have one of the following values :
C-M                 -2  fission product with resonance tables
C-M                 -1  fission product without resonance tables
C-M                  0  not fissile, no resonance tables
C-M                  1  not fissile with resonance tables
C-M                  2  fissile with resonance absorption tables
C-M                  3  fissile with resonance absorption, fission
C-M                     tables
C-M                  4  fissile without resonance tables
C-M    MTF(k+4) - ident of the fission product nuclide (k=1,(NDAT1-8)/2)
C-M    YLD(1)   - dummy (normally zero)
C-M    YLD(2)   - fraction of captures producing nuclide MTF(2)
C-M    YLD(3)   - decay constant of nuclide ID(i) [1/s]
C-M    YLD(4)   - energy released per fission [J/mole*1E-24]
C-M    YLD(5)   - fraction of nuclide MTF(2) formed by decay,
C-M    YLD(k+5) - fraction of nuclide MTF(k+4) produced per fission.
C-M
C-M
C-M  b. Cross-section data of the nuclide files
C-M  ------------------------------------------
C-M  The cross sections are given first for the epithermal range and
C-M  are assumed temperature independent. Temperature and resonance
C-M  self-shielding are accounted for separately in the resonance
C-M  integr tables for the nuclides for which these effects are
C-M  important. Data in the thermal range can be tabulated for one
C-M  or more temperatures. It is assumed that the energy mesh in the
C-M  thermal groups is fine enough to account for the self-shielding
C-M  effects in the low-lying resonances explicitly.
C-M
C-M  Rec. Format                Data:
C-M    1  (1P,I6,E15.8,6I6)     ID,AW,IZ,NF,NT,NR
C-M    2  (1P,5E15.8)          (XP(NG1+i),i=1,NG2),(XX(NG1+i),i=1,NG2),
C-M                            (XT(i),i=1,NG1+NG2),(XA(i),i=1,NG1+NG2),
C-M                            (XQ(NG1+i),i=1,NG2),(GL(NG1+i),i=1,NG2)
C-M    3  (1P,I6,E15.8,6I6)    (XF(i),i=1,NG1+NG2),(VF(i),i=1,NG1+NG2)
C-M                             (only if NF > 1)
C-M    4  (1P,I15/(5E15.8))     NDAT2,(XSCF(i),i=1,NDAT2)
C-M    5  (1P,5E15.8)          (TMP(i),i=1,NT)
C-M    6  (1P,5E15.8)          (XT(NG12+i),i=1,NG3),(XA(NG12+i),i=1,NG3)
C-M    7  (1P,5E15.8)          (XF(NG12+i),i=1,NG3),(VF(NG12+i),i=1,NG3)
C-M                             (only if NF > 1)
C-M    8  (1P,I15/(5E15.8))     NDAT3,(XSCF(i),i=1,NDAT3)
C-M                             NOTE: Records 6,7,8 are repeated for
C-M                                   NT-times for each temperature.
C-M 6+3NT (I15)                 filemark
C-M
C-M  Parameter description:
C-M    ID       - material identification number (integer),
C-M    AW       - atomic weight of the nuclide [amu],
C-M    IZ       - atomic number of the nuclide,
C-M    NF       - flag
C-M    NT       - number of thermal range temperature tabulatins,
C-M    NR       - number of resonance integral data sets,
C-M    NG12     = NG1+NG2
C-M    XP(i)    - potential scattering cross section in group (i),
C-M    XX(i)    - slowing down power per lethargy width in group (i),
C-M    XT(i)    - transport cross section in group (i),
C-M    XA(i)    - absorption cross section in group (i),
C-M    XQ(i)    - dummy (obsolete) entry,
C-M    GL(i)    - Goldstein-Cohen parameters for group (i),
C-M    XF(i)    - fission cross section in group (i),
C-M    VF(i)    - neutron fission yield (nu*Sig.Fiss.) in group (i),
C-M    NDAT2    - length of the epithermal scattering matrix vector,
C-M    XSCF(i)  - epithermal scattering matrix in condensed format,
C-M    TMP(i)   - temperature list for the thermal data [K]
C-M    NDAT3    - length of the thermal scattering matrix vector,
C-M    XSCT(i)  - thermal scattering matrix in condensed format.
C-M
C-M  c. Resonance tables
C-M  -------------------
C-M  There are up to two sets of tables for each of the NR2 resonance
C-M  group (depending on the NF flag). Resonance absorption integrals
C-M  appear in record-1 for materials with NF=1,2. Resonance neutron
C-D  fission yield integrals appear in record-2 if NF=3 only.
C-M
C-M  Rec. Format                Data:
C-M    1  (I15/1PE15.8,2I6/     M1*M2, RID,M1,M2
C-M            (1P5E15.8))      (Tres(i,i=1,M1),(SigB(j,j=1,M2)
C-M                             ((RIa(j,i),j=1,M2),i=1,M1)
C-M    2  (I15/1PE15.8,2I6/     M1*M2, RID,M1,M2
C-M            (1P5E15.8))      (Tres(i),i=1,M1),(SigB(j),j=1,M2)
C-M                             ((RIa(j,i),j=1,M2),i=1,M1)
C-M
C-M  NOTE: In the binary library the parameter M1*M2 is not written.
C-M
C-M  Resonance integral tables for a group are terminated by an entry
C-M  with (M1=1,M2=1,RID=0. and RIa=0.), followed by a filemark.
C-M
C-M  Parameter description:
C-M    M1       - Number of temperatures for the resonance integrals,
C-M    M2       - Number of SigB values for the resonance integrals,
C-M    Tres(i)  - Temperature at which the resonance integrals are
C-M               tabulated [K],
C-M    SigB(j)  - Background cross section at which the resonance
C-M               integrals are tabulated [barns],
C-M    RIa(j,i) - Absorption resonance integral per unit lethargy at
C-M               temperature Tres(i) and SigB(j) [barns].
C-M    RIf(j,i) - Neutron fission yield resonance integral per unit
C-M               lethargy at temperature Tres(i) and SigB(j) [barns].
C-M
C-M
C-M  d. P1 scattering matrices
C-M  -------------------------
C-M  There are four P1 scattering matrices given at the end of the WIMS
C-M  library. Usually they are assigned to hydrogen bound in water,
C-M  deuterium in heavy water, oxygen and carbon. They are given in
C-M  the full (expanded) form as NGxNG matrix.
C-M    A special feature of WILLIE is that it can read the P1 scattering
C-M  matrices in condensed format when the INCLMT option is used to
C-M  update the WIMS library. The matrix is expanded and written into
C-M  the library in the usual way.
C-M
C-M  Rec. Format                Data:
C-M    i  (1P,5E15.8)           (SCP1(j,i),j=1,NG)
C-M
C-M  The matrix elements are given for all groups (i). Four P1 matrices
C-M  are given one after the other, without filemarks in between. The
C-M  file is terminated with the filemark.
C-M
C-M  Parameter description:
C-M    SCP1(j,i)- P1-scattering cross section for transfer from group
C-M               (i) into group (j)
C-M       nres      total number of resonance tables  (0.le.nres.le.25)
C-M                 it is the same for each resonance group and is equal
C-M                 to the sum (over the all resonance isotopes) of
C-M                 of the products nver(i)*ntab(i), where
C-M                 nver(i) is the number of different versions of
C-M                 resonance tables for i-th isotope (for example
C-M                 the isotope with id=235 has three versions of
C-M                 resonance tables, identified with the rid values
C-M                 235.2, 235.3 and 235.4)
C-M                 and ntab(i) is the number of reactions for which
C-M                 resonance tables for i-th isotope are given
C-M                 (ntab=1 if only absorption, ntab=2 for absorption
C-M                 and fission)
C-M
C-
C* Reserve space for the real and integer work field
      PARAMETER   (MXRW=80 000, MXIW=5 000)
C* To change No.of keywords, alter parameter NKW and DATA KWRD,DSCR
      PARAMETER      (NKW =16)
      CHARACTER*4     KWRD(16) ,KEY, ALDO1,ALDO2
      CHARACTER*40    DSCR(16) ,DMMY(2)
      DIMENSION       RWO(MXRW),IWO(MXIW)
      COMMON /DATFIL/ RDAT
      COMMON /TERWOR/ ITERM,ALDO(2)
C* Logical filemark
      DATA JTERM/999999999/,ALDO1/'ALDO'/,ALDO2/'aldo'/
C* Keywords for selecting service options
      DATA  KWRD / 'BIFO', 'FOBI', 'COPY', 'COP1', 'INCL'
     1           , 'NEWL', 'DELM', 'SMTR', 'CHCK', 'INCB'
     2           , 'COMP', 'PTAB', 'MIXM', 'RTAB', 'RECA'
     3           , 'END '/
C* Service options description for output
       DATA DSCR
     1  / ' - Binary to formatted conversion       '
     2  , ' - Formatted to binary conversion       '
     3  , ' - Extract nuclide data from library    '
     4  , ' - Extract P1 matrix from library       '
     5  , ' - Insert new data into library         '
     6  , ' - Make a starter file for a new library'
     7  , ' - Delete a material from the library   '
     8  , ' - Transport-correct scattering matrix  '
     9  , ' - Check library integrity              '
     *  , ' -      inactive INCB'
     1  , ' - Compare two x-sect data sets         '
     2  , ' - Tabulate data for plotting           '
     3  , ' - Mix x-sect to make a new material    '
     4  , ' -      inactive RTAB'
     5  , ' -      inactive RECA'
     *  , ' - Finish all processing.               '/
C* File units
      DATA  LKB,LTT / 5, 6 /
      ITERM=JTERM
      READ(ALDO1,501) ALDO(1)
      READ(ALDO2,501) ALDO(2)
C* Select the WILLIE service option
   10 WRITE(LTT,603) (KWRD(I),DSCR(I), I=1,NKW)
   11 WRITE(LTT,691)
      WRITE(LTT,691) '$Enter the selected option            : '
   12 READ (LKB,691) DMMY
      KEY=DMMY(1)(1:4)
      IF(KEY.EQ.'    ') THEN
C* Copy input records with blank keyword to output as comments
        WRITE(LTT,691) DMMY
        GO TO 12
      END IF
C* Identify the selected option
      IK=NKW+1
      DO 14 I=1,NKW
      IF(KEY.EQ.KWRD(I)) IK=I
   14 CONTINUE
      IF(IK.GE.1 .AND. IK.LE.NKW) THEN
        WRITE(LTT,691)
        WRITE(LTT,604) KEY,DSCR(IK)
        WRITE(LTT,691)
        GO TO ( 18, 20, 30, 40, 50, 60, 70, 80, 90,100
     1        ,110,120,130,140,150                ,200), IK
      END IF
C* Print warning on Illegal entry - keyword not defined
      WRITE(LTT,609) KEY
      GO TO 10
C* Binary to formatted conversion
   18 CALL BINFOR(LKB,LTT,RWO,IWO,MXRW,MXIW)
      GO TO 11
C* Formatted to binary conversion
   20 CALL FORBIN(LKB,LTT,RWO,IWO,MXRW,MXIW)
      GO TO 11
C* Extract nuclide data from library
   30 CALL COPYMT(LKB,LTT,RWO,IWO,MXRW,MXIW)
      GO TO 11
C* Extract a P1 scattering matrix from library
   40 CALL COP1MT(LKB,LTT,RWO,IWO,MXRW,MXIW)
      GO TO 11
C* Add or replace nuclide data in the library
   50 CALL INCLMT(LKB,LTT,RWO,IWO,MXRW,MXIW)
      GO TO 11
C* Make a starter file for a new library
   60 CALL NEWLIB(LKB,LTT,RWO,IWO,MXRW,MXIW)
      GO TO 11
C* Delete a material from the library
   70 CALL DELEMT(LKB,LTT,RWO,IWO,MXRW,MXIW)
      GO TO 11
C* Transport-correct self-scattering term of the scattering matrix
   80 CALL SMTXTR(LKB,LTT,RWO,IWO,MXRW,MXIW)
      GO TO 11
C* Check the library integrity
   90 CALL CHKLIB(LKB,LTT,RWO,IWO,MXRW,MXIW)
      GO TO 11
  100 CONTINUE
C     CALL INCLMB
      GO TO 150
C* Make comparison tables for x-sect and RI for two WILIT files
  110 CALL COMPMT(LKB,LTT,RWO,IWO,MXRW,MXIW)
      GO TO 11
C* Tabulate nuclide data for plotting purposes
  120 CALL PTABMT(LKB,LTT,RWO,IWO,MXRW,MXIW)
      GO TO 11
C* Mix cross sections to make a new material
  130 CALL MIXMAT(LKB,LTT,RWO,IWO,MXRW,MXIW)
      GO TO 11
  140 CONTINUE
  150 CONTINUE
C* All processing completed
  200 STOP 'WILLIE Completed'
  501 FORMAT(A4)
  603 FORMAT(/' WILLIE - WIMS Library Utility'/
     !        ' ============================='/
     1        ' The following service options are available:'/
     1       (3X,A4,A40))
  604 FORMAT(' Run ',A4,A40)
  609 FORMAT(' WILLIE Error: unknown keyword "',A4,'"')
  691 FORMAT(2A40)
      END
      SUBROUTINE ERRWAR(LTT,IER)
C-Title  : ERRWAR Subroutine
C-Purpose: Print error warning on incorrect library reading
      WRITE(LTT,2001) IER
      STOP
 2001 FORMAT(6X,'ERROR DURING READING LIBRARY IN PLACE NUMBER  ',I2)
      END
      SUBROUTINE XSMSUM(NG,ISS,XSM,XSO)
C-Title  :
C-Purpose: Sum elements of the scattering matrix
C-Description:
C-D  Scattering matrix elements packed in XSM in condensed WIMS
C-D  format are summed by rows and stored in XSO. If ISS is
C-D  greater than zero, the self-scattering component is excluded
C-D  from the sum.
C-D
      DIMENSION XSM(*),XSO(*)
      L =1
      DO 40 I=1,NG
      S =0.
      NS=XSM(L  )+0.1
      NE=XSM(L+1)+0.1
      DO 20 J=1,NE
      IF(J.NE.NS .OR. ISS.EQ.0) S =S + XSM(L+1+J)
   20 CONTINUE
      XSO(I)=S
      L =L+2+NE
   40 CONTINUE
      RETURN
      END
      SUBROUTINE PROCXS(RWO,IWO,LF1,LF2,NG1,NG2,NG3,NF,NT)
C-Title  : PROCXS Subroutine
C-Purpose: Copy(LF2>0) or skip(LF2=0) the WIMS cross section data
      DIMENSION       RWO(*),IWO(*)
      COMMON /TERWOR/ ITERM,ALDO(2)
      NG12=NG1+NG2
      KLN =2*NG12+4*NG2
C* Epithermal cross sections
      READ(LF1,702)               (RWO(I),I=1,KLN)
      IF(LF2.GT.0) WRITE(LF2,702) (RWO(I),I=1,KLN)
      IF(ABS(NF).LE.1) GO TO 40
C* Fission yield and fission cross section
      KLN=2*NG12
      READ(LF1,702)               (RWO(I),I=1,KLN)
      IF(LF2.GT.0 .AND.
     1   NF .GT.1) WRITE(LF2,702) (RWO(I),I=1,KLN)
C* Epithermal scattering matrix
   40 READ(LF1,705)               NDAT2,(RWO(I),I=1,NDAT2)
      IF(LF2.GT.0) WRITE(LF2,705) NDAT2,(RWO(I),I=1,NDAT2)
C* Temperature list for thermal cross sections
      READ(LF1,702)               (RWO(I),I=1,NT)
      IF(LF2.GT.0) WRITE(LF2,702) (RWO(I),I=1,NT)
      DO 60 K=1,NT
      KLN=2*NG3
      READ(LF1,702)               (RWO(I),I=1,KLN)
      IF(LF2.GT.0) WRITE(LF2,702) (RWO(I),I=1,KLN)
      IF(ABS(NF).LE.1) GO TO 50
      READ(LF1,702)               (RWO(I),I=1,KLN)
      IF(LF2.GT.0 .AND.
     1   NF .GT.1) WRITE(LF2,702) (RWO(I),I=1,KLN)
   50 READ(LF1,705)               NDAT3,(RWO(I),I=1,NDAT3)
      IF(LF2.GT.0) WRITE(LF2,705) NDAT3,(RWO(I),I=1,NDAT3)
   60 CONTINUE
      RETURN
  701 FORMAT(5I15)
  702 FORMAT(1P5E15.8)
  705 FORMAT(1P,I15/(5E15.8))
      END
      SUBROUTINE BINFOR(LKB,LTT,RWO,IWO,MXRW,MXIW)
C-Title  : BINFOR Subroutine
C-Purpose: Convert binary form of WIMS library to formatted
C-
      CHARACTER*40    FLWI,FLWO
      DIMENSION       RWO(*),IWO(*)
      COMMON /TERWOR/ ITERM,ALDO(2)
C* Logical file units for the binary (source) and formatted (target) lib
      DATA LF1,LF2 / 1, 2 /
C* Preset dummy file delimiter
      DATA CHDM/.777777/
C* Define the filenames
   12 WRITE(LTT,691) '$Enter source binary library filename : '
      READ (LKB,691) FLWI
C***** VAX *****
C     OPEN (UNIT=LF1,FILE=FLWI,STATUS='OLD',ERR=12
C    1     ,FORM='UNFORMATTED',READONLY)
C***** VAX *****
C***** EXPORT *****
      OPEN (UNIT=LF1,FILE=FLWI,STATUS='OLD',ERR=12,FORM='UNFORMATTED')
C***** EXPORT *****
   14 WRITE(LTT,691) '$Enter formatted library filename     : '
      READ (LKB,691) FLWO
C***** VAX *****
C     OPEN (UNIT=LF2,FILE=FLWO,STATUS='NEW',ERR=14
C    1     ,CARRIAGECONTROL='LIST')
C***** VAX *****
C***** EXPORT *****
      IF(FLWI.EQ.FLWO) GO TO 14
      OPEN (UNIT=LF2,FILE=FLWO,STATUS='UNKNOWN',ERR=14)
C***** EXPORT *****
C* Verification printout
      WRITE(LTT,691)
      WRITE(LTT,691) ' Processing:                            '
      WRITE(LTT,691) '        Source WIMS-D binary    library : ',FLWI
      WRITE(LTT,691) '        Output WIMS-D formatted library : ',FLWO
      WRITE(LTT,691)
C*
C* Begin processing the files - write the header indices
      READ (LF1)     NEL,NG,NG0,NG1,NG2,NG3,NNFD,NFPD
      WRITE(LF2,701) NEL,NG,NG0,NG1,NG2,NG3,NNFD,NFPD
C* List of nuclides
      READ (LF1)     (IWO(I),I=1,NEL)
      WRITE(LF2,701) (IWO(I),I=1,NEL)
C* Group boundaries
      KLN=NG+1
      READ (LF1)     (RWO(I),I=1,KLN)
      WRITE(LF2,702) (RWO(I),I=1,KLN)
C* Fission spectrum
      READ (LF1)     (RWO(I),I=1,NG0)
      WRITE(LF2,702) (RWO(I),I=1,NG0)
C* Burnup data for each nuclide
      DO 20 J=1,NEL
      READ (LF1)     NDAT1,IWO(1),(RWO(I),IWO(I),I=2,NDAT1/2)
      RWO(1)=0.
      WRITE(LF2,701) NDAT1
   20 WRITE(LF2,703) (RWO(I/2),IWO(I/2),I=2,NDAT1,2)
C* Begin processing the nuclide files - check for logical file mark
      IER=1
      CHCK=CHDM
      READ (LF1,ERR=21) CHCK
   21 IF(CHCK.NE.ALDO(1).AND.CHCK.NE.ALDO(2)) GO TO 190
      WRITE(LF2,701) ITERM
C* Loop over all nuclides
      DO 60 J=1,NEL
C* Identifier
      READ (LF1)     ID,AW,IZ,NF,NT,NR
      WRITE(LF2,704) ID,AW,IZ,NF,NT,NR
      KLN=4*NG2+2*(NG1+NG2)
C* Absorption, transport slow.dwn.pwr, Lambda, Ksi, sg.pot
      READ (LF1) (RWO(I),I=1,KLN)
      WRITE(LF2,702) (RWO(I),I=1,KLN)
      IF(NF.LE.1) GO TO 42
C* If nuclide is fissile, process fission yield & fission cross sect
      KLN=2*(NG1+NG2)
      READ (LF1)     (RWO(I),I=1,KLN)
      WRITE(LF2,702) (RWO(I),I=1,KLN)
C* Epithermal scattering matrix
   42 READ (LF1)     NDAT2,(RWO(I),I=1,NDAT2)
      WRITE(LF2,705) NDAT2,(RWO(I),I=1,NDAT2)
C* Thermal range temperatures
      READ (LF1)     (RWO(I),I=1,NT)
      WRITE(LF2,702) (RWO(I),I=1,NT)
C* Loop over all temperatures in the thermal range
      DO 50 K=1,NT
      KLN=2*(NG-NG1-NG2)
C* Thermal absorption and transport
      READ (LF1)     (RWO(I),I=1,KLN)
      WRITE(LF2,702) (RWO(I),I=1,KLN)
      IF(NF.LE.1) GO TO 44
C* If nuclide is fissile, process fission yield & fission cross sect
      READ (LF1) (RWO(I),I=1,KLN)
      WRITE(LF2,702) (RWO(I),I=1,KLN)
C* Thermal scattering matrix
   44 READ (LF1)     NDAT3,(RWO(I),I=1,NDAT3)
   50 WRITE(LF2,705) NDAT3,(RWO(I),I=1,NDAT3)
      IER=2
      CHCK=CHDM
      READ (LF1,ERR=51) CHCK
   51 IF(CHCK.NE.ALDO(1).AND.CHCK.NE.ALDO(2)) GO TO 190
      WRITE(LF2,701) ITERM
   60 CONTINUE
C* Begin processing the resonance files - loop over all res. groups
      DO 90 J=1,NG2
C* Implied loop over all res.tables in a group
   70 READ (LF1)     RID,M1,M2,(RWO(I),I=1,M1),
     *              (RWO(I+1000),I=1,M2),
     *             ((RWO(M1*(II-1)+I+2000),I=1,M1),II=1,M2)
      M12=M1*M2
      WRITE(LF2,706) M12,RID,M1,M2,(RWO(I),I=1,M1),
     *              (RWO(I+1000),I=1,M2),
     *              (RWO(I+2000),I=1,M12)
      IF(RID.EQ.0.) GO TO 80
      GO TO 70
C* Grout resonance tables processed - check for file mark
   80 IER=3
      CHCK=CHDM
      READ (LF1,ERR=81) CHCK
   81 IF(CHCK.NE.ALDO(1).AND.CHCK.NE.ALDO(2)) GO TO 190
      WRITE(LF2,701) ITERM
   90 CONTINUE
C* Begin processing the P1 scattering matrices
      DO 100 J=1,4
      DO 100 K=1,NG
      READ (LF1)     (RWO(I),I=1,NG)
  100 WRITE(LF2,702) (RWO(I),I=1,NG)
      IER=4
      CHCK=CHDM
      READ (LF1,ERR=101) CHCK
  101 IF(CHCK.NE.ALDO(1).AND.CHCK.NE.ALDO(2)) GO TO 190
      WRITE(LF2,701) ITERM
C* Processing terminated successfully
      CLOSE(UNIT=LF1)
      CLOSE(UNIT=LF2)
      RETURN
C* Library read error
  190 CALL ERRWAR(LTT,IER)
      RETURN
  601 FORMAT(' Formatted WIMS library written on    : ',A40)
  691 FORMAT(2A40)
  701 FORMAT(5I15)
  702 FORMAT(1P,5E15.8)
  703 FORMAT(3(1P,E15.8,I6))
  704 FORMAT(I6,1P,E15.8,4I6)
  705 FORMAT(I15/(1P,5E15.8))
  706 FORMAT(I15/1P,E15.8,2I6/(1P,5E15.8))
      END
      SUBROUTINE FORBIN(LKB,LTT,RWO,IWO,MXRW,MXIW)
C-Title  : FORBIN Subroutine
C-Purpose: Convert formatted form of wims library to binary
C-
      CHARACTER*80    REC
      CHARACTER*40    FLWI,FLWO
      DIMENSION       RWO(*),IWO(*),NP1(4)
      COMMON /TERWOR/ ITERM,ALDO(2)
C* Logical file units for the binary (source) and formatted (target) lib
      DATA LF1,LF2 / 1, 2 /
C* Define the filenames
   12 WRITE(LTT,691) '$Enter source formatted library filenm: '
      READ (LKB,691) FLWI
C***** VAX *****
C     OPEN (UNIT=LF1,FILE=FLWI,STATUS='OLD',ERR=12,READONLY)
C***** VAX *****
C***** EXPORT *****
      OPEN (UNIT=LF1,FILE=FLWI,STATUS='OLD',ERR=12)
C***** EXPORT *****
   14 WRITE(LTT,691) '$Enter binary library filename        : '
      READ (LKB,691) FLWO
C***** VAX *****
C     OPEN (UNIT=LF2,FILE=FLWO,STATUS='NEW',ERR=14,FORM='UNFORMATTED')
C***** VAX *****
C***** EXPORT *****
      IF(FLWI.EQ.FLWO) GO TO 14
      OPEN (UNIT=LF2,FILE=FLWO,STATUS='UNKNOWN',ERR=14
     1     ,FORM='UNFORMATTED')
C***** EXPORT *****
C* Define P1 scattering matrix selection
      ISRT=0
      JP1 =1
      WRITE(LTT,691) '    First P1 matrix (default first 4) : '
      READ (LKB,892,END=16) NP1(1)
      IF(NP1(1).GT.0) GO TO 17
   16 NP1(1)=1
      NP1(2)=2
      NP1(3)=3
      NP1(4)=4
      GO TO 19
C* Explicitly defined positions
   17 JP1=JP1+1
   18 WRITE(LTT,691) '                       Next P1 matrix : '
      READ (LKB,892,ERR=18) NP1(JP1)
      IF(NP1(JP1).EQ.0 .OR. NP1(JP1).EQ.NP1(JP1-1))  THEN
        WRITE(LTT,691) ' Illegal entry - redo from start        '
        GO TO 18
      END IF
      IF(NP1(JP1).LT.NP1(JP1-1)) ISRT=1
      IF(JP1.LT.4) GO TO 17
   19 CONTINUE
C* Verification printout
      WRITE(LTT,691)
      WRITE(LTT,691) ' Processing:                            '
      WRITE(LTT,691) '        Source WIMS-D formatted library : ',FLWI
      WRITE(LTT,691) '        Output WIMS-D binary    library : ',FLWO
      WRITE(LTT,691)
C*
C* Begin processing the files - write the header indices
      READ (LF1,701) NEL,NG,NG0,NG1,NG2,NG3,NNFD,NFPD
      WRITE(LF2)     NEL,NG,NG0,NG1,NG2,NG3,NNFD,NFPD
C* List of nuclides
      READ (LF1,701) (IWO(I),I=1,NEL)
      WRITE(LF2)     (IWO(I),I=1,NEL)
C* Group boundaries
      KLN=NG+1
      READ (LF1,702) (RWO(I),I=1,KLN)
      WRITE(LF2)     (RWO(I),I=1,KLN)
C* Fission spectrum
      READ (LF1,702) (RWO(I),I=1,NG0)
      WRITE(LF2)     (RWO(I),I=1,NG0)
C* Burnup data for each nuclide
      DO 20 J=1,NEL
      READ (LF1,701) NDAT1
      READ (LF1,703) (RWO(I),IWO(I),I=1,NDAT1/2)
   20 WRITE(LF2)     NDAT1,IWO(1),(RWO(I),IWO(I),I=2,NDAT1/2)
C* Begin processing the nuclide files - check for logical file mark
      IER=1
      READ(LF1,701,ERR=190) ICHK
      IF(ICHK.NE.ITERM) GO TO 190
      WRITE(LF2) ALDO(1)
C* Loop over all nuclides
      DO 60 J=1,NEL
C* Identifier
      READ (LF1,704) ID,AW,IZ,NF,NT,NR
      WRITE(LF2)     ID,AW,IZ,NF,NT,NR
      KLN=4*NG2+2*(NG1+NG2)
C* Absorption, transport slow.dwn.pwr, Lambda, Ksi, sg.pot
      READ (LF1,702) (RWO(I),I=1,KLN)
      WRITE(LF2)     (RWO(I),I=1,KLN)
      IF(NF.LE.1) GO TO 42
C* If nuclide is fissile, process fission yield & fission cross sect
      KLN=2*(NG1+NG2)
      READ (LF1,702) (RWO(I),I=1,KLN)
      WRITE(LF2)     (RWO(I),I=1,KLN)
C* Epithermal scattering matrix
   42 READ (LF1,705) NDAT2,(RWO(I),I=1,NDAT2)
      WRITE(LF2)     NDAT2,(RWO(I),I=1,NDAT2)
C* Thermal range temperatures
      READ (LF1,702) (RWO(I),I=1,NT)
      WRITE(LF2)     (RWO(I),I=1,NT)
C* Loop over all temperatures in the thermal range
      DO 50 K=1,NT
      KLN=2*(NG-NG1-NG2)
C* Thermal absorption and transport
      READ (LF1,702) (RWO(I),I=1,KLN)
      WRITE(LF2)     (RWO(I),I=1,KLN)
      IF(NF.LE.1) GO TO 44
C* If nuclide is fissile, process fission yield & fission cross sect
      READ (LF1,702) (RWO(I),I=1,KLN)
      WRITE(LF2)     (RWO(I),I=1,KLN)
C* Thermal scattering matrix
   44 READ (LF1,705) NDAT3,(RWO(I),I=1,NDAT3)
      WRITE(LF2)     NDAT3,(RWO(I),I=1,NDAT3)
   50 CONTINUE
      IER=2
      READ (LF1,701,ERR=190) ICHK
      IF(ICHK.NE.ITERM) GO TO 190
      WRITE(LF2) ALDO(1)
   60 CONTINUE
C* Begin processing the resonance files - loop over all res. groups
      DO 90 J=1,NG2
C* Implied loop over all res.tables in a group
   70 READ (LF1,706) M12,RID,M1,M2,(RWO(I),I=1,M1),
     *              (RWO(I+1000),I=1,M2),
     *              (RWO(I+2000),I=1,M12)
      WRITE(LF2)     RID,M1,M2,(RWO(I),I=1,M1),
     *              (RWO(I+1000),I=1,M2),
     *             ((RWO(M1*(II-1)+I+2000),I=1,M1),II=1,M2)
      IF(RID.EQ.0.) GO TO 80
      GO TO 70
C* Group resonance tables processed - check for file mark
   80 IER=3
      READ (LF1,701,ERR=190) ICHK
      IF(ICHK.NE.ITERM) GO TO 190
      WRITE(LF2) ALDO(1)
   90 CONTINUE
C*
C* Begin processing the P1 scattering matrices
      IF(ISRT.NE.0) THEN
        ISRT=LF2
        LF2 =31
        OPEN (UNIT=LF2,FILE='FOBI.TMP',STATUS='UNKNOWN'
     1       ,FORM='UNFORMATTED')
      END IF
      IP1=0
      JP1=1
  100 IP1=IP1+1
C* Identify the format on the original library (full or condensed)
C* Next card may be the last filemark, matrix length or data
      IER=56
  101 READ (LF1,692,END=190) REC
      READ (REC,701,ERR=150) KL1
C* Filemark found - read next data set
      IF(KL1.EQ.ITERM) GO TO 101
C* Case: Matrix length on record - read condensed P1 matrix
      L1 =NG*NG+1
      DO 141 J=1,L1
      RWO(J)=0
  141 CONTINUE
      READ (LF1,702) (RWO(L1-1+J),J=1,KL1)
C*       Expand the matrix
      JG=0
  145 JG=JG+1
      NU =RWO(L1  )+0.1
      NS =RWO(L1+1)+0.1
      DO 148 J=1,NS
      RWO((JG-1)*NG + JG-NU-1+J)=RWO(L1+1+J)
  148 CONTINUE
      L1=L1+2+NS
      IF(JG.LT.NG) GO TO 145
      GO TO 160
C* Case: read expanded P1 matriX
  150 READ (REC,702) (RWO(J),J=1,5)
      READ (LF1,702) (RWO(J),J=6,NG)
      DO 152 K=2,NG
      READ (LF1,702) (RWO((K-1)*NG+J),J=1,NG)
  152 CONTINUE
C* Write the P1 scattering matrix, if selected
  160 DO 163 J=1,4
      IF(NP1(J).EQ.IP1) THEN
        DO 162 K=1,NG
        WRITE(LF2)     (RWO((K-1)*NG+I),I=1,NG)
  162   CONTINUE
        IF(ISRT.EQ.0)
     1  WRITE(LTT,693) '        Written P1-matrix from position ',IP1
        JP1=JP1+1
      END IF
  163 CONTINUE
      IF(JP1.LE.4) GO TO 100
C* Sort the P1 matrices if necessary
      IF(ISRT.NE.0) THEN
        LSC=LF2
        LF2=ISRT
        DO 168 JP1=1,4
          REWIND LSC
C* Find the next P1 matrix to write
          IP1=1000
          DO 164 J=1,4
          IF(NP1(J).LT.IP1) IP1=J
  164     CONTINUE
C* Skip preceeding P1 matrices and copy IP1-th one
          DO 166 J=1,IP1
            DO 165 K=1,NG
            READ (LSC)              (RWO((K-1)*NG+I),I=1,NG)
            IF(J.EQ.IP1) WRITE(LF2) (RWO((K-1)*NG+I),I=1,NG)
  165       CONTINUE
  166     CONTINUE
          WRITE(LTT,693) '        Written P1-matrix from position '
     1                  ,NP1(IP1)
          NP1(IP1)=NP1(IP1)+1000
  168   CONTINUE
      END IF
C* Check the last filemark
C...  IER=4
C...  READ (LF1,701,ERR=190) ICHK
C...  IF(ICHK.NE.ITERM) GO TO 190
      WRITE(LF2) ALDO(1)
C* Processing terminated successfully
      CLOSE(UNIT=LF1)
      CLOSE(UNIT=LF2)
      RETURN
C* Library read error
  190 CALL ERRWAR(LTT,IER)
      RETURN
  691 FORMAT(2A40)
  692 FORMAT(A80)
  693 FORMAT(A40,I4)
  701 FORMAT(5I15)
  702 FORMAT(1P,5E15.8)
  703 FORMAT(1P,3(E15.8,I6))
  704 FORMAT(1P,I6,E15.8,4I6)
  705 FORMAT(1P,I15/(5E15.8))
  706 FORMAT(1P,I15/E15.8,2I6/(5E15.8))
  892 FORMAT(BN,I10)
      END
      SUBROUTINE COPYMT(LKB,LTT,RWO,IWO,MXRW,MXIW)
C-Title  : COPYMT Subroutine
C-Purpose: Extract data for selected material from wims library
C-
      CHARACTER*40    FLNM
      DIMENSION       RWO(*),IWO(*)
      COMMON /TERWOR/ ITERM,ALDO(2)
C* Logical file units for source library and output file
      DATA LF1,LF2 / 1, 2 /
C* Define the filenames
   12 WRITE(LTT,691) '$Enter source formatted library filenm: '
      READ (LKB,691) FLNM
C***** VAX *****
C     OPEN (UNIT=LF1,FILE=FLNM,STATUS='OLD',ERR=12,READONLY)
C***** VAX *****
C***** EXPORT *****
      OPEN (UNIT=LF1,FILE=FLNM,STATUS='OLD',ERR=12)
C***** EXPORT *****
   14 WRITE(LTT,691) '$Enter nuclide data output filename   : '
      READ (LKB,691) FLNM
C***** VAX *****
C     OPEN (UNIT=LF2,FILE=FLNM,STATUS='NEW',ERR=14
C    1     ,CARRIAGECONTROL='LIST')
C***** VAX *****
C***** EXPORT *****
      OPEN (UNIT=LF2,FILE=FLNM,STATUS='UNKNOWN',ERR=14)
C***** EXPORT *****
C* Read the header indices
      READ (LF1,701) NEL,NG,NG0,NG1,NG2,NG3,NNFD,NFPD
C* Read the list of nuclides
      READ (LF1,701) (IWO(I),I=1,NEL)
C* Define the data set to be extracted
   15 WRITE(LTT,691) '$  Enter the selected material ident. : '
      READ (LKB,501,ERR=17) RMT
      IF(RMT.EQ.0) GO TO 100
C* Check if material is on the list
      MAT=RMT+0.001
      DO 16 I=1,NEL
      IF(IWO(I).EQ.MAT) GO TO 18
   16 CONTINUE
      WRITE(LTT,601) MAT
   17 WRITE(LTT,602) (IWO(J),J=1,NEL)
      GO TO 15
   18 CONTINUE
C* Skip group boundaries
      KLN=NG+1
      READ (LF1,702) (RWO(I),I=1,KLN)
C* Skip fission spectrum
      READ (LF1,702) (RWO(I),I=1,NG0)
C* Extract burnup data for selected nuclide
      WRITE(LF2,701) ITERM, 3
      DO 20 J=1,NEL
      RWO(1)=0.
      READ (LF1,701) NDAT1
      READ (LF1,703) (RWO(I),IWO(I),I=1,NDAT1,2)
      IF(IWO(1).NE.MAT) GO TO 20
      WRITE(LF2,701) NDAT1
      WRITE(LF2,703) (RWO(I),IWO(I),I=1,NDAT1,2)
   20 CONTINUE
C* Beginning of the nuclide files - check for logical file mark
      IER=1
      READ (LF1,701,ERR=190) JTERM
      IF(JTERM.NE.ITERM) GO TO 190
C* Loop over all nuclides
      DO 60 J=1,NEL
      LFF=0
C* Read the nuclide header card
      READ (LF1,704) ID,AW,IZ,NF,NT,NR
C* Only one set of resonance parameters is copied
      IF(NR.GT.1) NR =1
C* If selected nuclide then write to output, else skip to next file mark
      IF(ID.NE.MAT) GO TO 42
      LFF=LF2
      WRITE(LF2,701) ITERM, 4,NG1,NG2,NG3
      WRITE(LF2,704) ID,AW,IZ,NF,NT,NR
   42 CALL PROCXS(RWO,IWO,LF1,LFF,NG1,NG2,NG3,NF,NT)
   45 IER=110
      READ (LF1,701) JTERM
      IF(JTERM.NE.ITERM) GO TO 190
   60 CONTINUE
C* Begin processing the resonance files - loop over all res. groups
      DO 90 J=1,NG2
      NRM=0
C* Implied loop over all res.tables in a group
   70 READ (LF1,706) M12,RID,M1,M2,(RWO(I     ),I=1,M1),
     *                             (RWO(I+1000),I=1,M2),
     *                             (RWO(I+2000),I=1,M12)
      IF(    RID     .EQ.0.  ) GO TO 80
      IF(ABS(RID-RMT).GT.0.01) GO TO 70
      NRM=NRM+1
      IF(NRM.EQ.1) WRITE(LF2,701) ITERM, 5,NG1+J,NG1,NG2
      WRITE(LF2,706) M12,RID,M1,M2,(RWO(I     ),I=1,M1),
     *                             (RWO(I+1000),I=1,M2),
     *                             (RWO(I+2000),I=1,M12)
      GO TO 70
C* Group resonance tables processed - check the file mark
   80 READ (LF1,701) JTERM
      IF(JTERM.NE.ITERM) GO TO 190
   90 CONTINUE
C* P1-scattering matrices are ignored
      WRITE(LF2,701) ITERM
      REWIND LF1
      GO TO 15
C* All material processed
  100 CLOSE(UNIT=LF1)
      CLOSE(UNIT=LF2)
      RETURN
C* Library read error
  190 CALL ERRWAR(LTT,IER)
      RETURN
  501 FORMAT(BN,F20.0)
  601 FORMAT(' WILLIE ERROR - Material',I6,' not found')
  602 FORMAT('   Select from the list below:'/ (6X,10I6) )
  603 FORMAT(' Processing material',F8.1,' completed'/)
  691 FORMAT(2A40)
  701 FORMAT(5I15)
  702 FORMAT(1P,5E15.8)
  703 FORMAT(1P,3(E15.8,I6))
  704 FORMAT(1P,I6,E15.8,4I6)
  705 FORMAT(1P,I15/(5E15.8))
  706 FORMAT(1P,I15/E15.8,2I6/(5E15.8))
      END
      SUBROUTINE COP1MT(LKB,LTT,RWO,IWO,MXRW,MXIW)
C-Title  : COP1MT Subroutine
C-Purpose: Extract P1 matrix for a selected material from WIMS library
C-
      CHARACTER*40    FLNM
      DIMENSION       RWO(*),IWO(*)
      COMMON /TERWOR/ ITERM,ALDO(2)
C* Logical file units for source library and output file
      DATA LF1,LF2 / 1, 2 /
C* Define the filenames
   12 WRITE(LTT,691) '$Enter source formatted library filenm: '
      READ (LKB,691) FLNM
C***** VAX *****
C     OPEN (UNIT=LF1,FILE=FLNM,STATUS='OLD',ERR=12,READONLY)
C***** VAX *****
C***** EXPORT *****
      OPEN (UNIT=LF1,FILE=FLNM,STATUS='OLD',ERR=12)
C***** EXPORT *****
C* Read the header indices
      READ (LF1,701) NEL,NG,NG0,NG1,NG2,NG3,NNFD,NFPD
C* Read the list of nuclides
      READ (LF1,701) (IWO(I),I=1,NEL)
C* Define the data set to be extracted
   15 WRITE(LTT,691) '$  Enter consecutive P1-matrix number : '
      READ (LKB,501,ERR=17) NP1
      IF(NP1.LT.0) GO TO 100
      IF(NP1.GT.0) GO TO  20
C* Invalid entry - display materials and inquire again
   17 WRITE(LTT,602) (IWO(J),J=1,NEL)
      WRITE(LTT,691) '   Invalid entry - input -1 to quit, or '
      GO TO 15
   20 WRITE(LTT,691) '$Enter the data output filename       : '
      READ (LKB,691) FLNM
C***** VAX *****
C     OPEN (UNIT=LF2,FILE=FLNM,STATUS='NEW',ERR=20
C    1     ,CARRIAGECONTROL='LIST')
C***** VAX *****
C***** EXPORT *****
      OPEN (UNIT=LF2,FILE=FLNM,STATUS='UNKNOWN',ERR=20)
C***** EXPORT *****
C* Skip the nuclide files boundaries
      CALL SKIPWF(LF1,ITERM,JTERM,N1,N2,N3,N4)
      DO 22 I=1,NEL
      CALL SKIPWF(LF1,ITERM,JTERM,N1,N2,N3,N4)
   22 CONTINUE
C* Skip the resonance files
      DO 24 I=1,NG2
      CALL SKIPWF(LF1,ITERM,JTERM,N1,N2,N3,N4)
   24 CONTINUE
C* Copy the selected P1 matrix to output file
      JP1=0
C* At present it works only for standard (expanded) library format
   30 JP1=JP1+1
      DO 32 IG=1,NG
      READ (LF1,702,ERR=190) (RWO(J),J=1,NG)
      IF(JP1.EQ.NP1) WRITE(LF2,702) (RWO(J),J=1,NG)
   32 CONTINUE
      IF(JP1.LT.4) GO TO 30
C* All material processed
  100 WRITE(LF2,701) ITERM
      CLOSE(UNIT=LF1)
      CLOSE(UNIT=LF2)
  120 RETURN
C* Library read error
  190 WRITE(LTT,691) ' ERROR - only standard format supported '
      RETURN
  501 FORMAT(BN,I20)
  602 FORMAT(' The library contains the following materials:'/(6X,10I6))
  691 FORMAT(2A40)
  701 FORMAT(5I15)
  702 FORMAT(1P,5E15.8)
      END
      SUBROUTINE COMPMT(LKB,LTT,RWO,IWO,MXRW,MXIW)
C-Title  : COMPMT Subroutine
C-Purpose: Compare two WIMS library cross section data sets
C-Description:
C-D  A cross section file such as produced by WILLIE option COPY
C-D  is processed. It generously allows labelled, unlabelled
C-D  as well as no-filemark formats. Cross sections are compared
C-D  group-by-group, their values together with relative and
C-D  absolute differences are printed. Maximum and minimum
C-D  relative differences are recorded explicitly.
C-D    Comparison of temperature dependent data is limited in the
C-D  sense that:
C-D   - no interpolation in temperature is provided,
C-D   - data are compared if temperatures differ by < 10 deg.C,
C-D   - no provision is made for the case when the reference
C-D     data set is given on a fine temperature mesh.
C-D
      CHARACTER*1  FF
      CHARACTER*10 RITY(3)
      CHARACTER*40 FLN1,FLN2,FLNO,FLNL,FLNM, COMM
      DIMENSION RWO(*),IWO(*)
      COMMON /TERWOR/ ITERM,ALDO(2)
C* Default group structure (fast/resonance/thermal)
      DATA NG1,NG2,NG3/ 14, 13, 42 /
C* Alternative group structure
      DATA MG1,MG2,MG3/ 45, 47, 80 /
C* Default output filename
      DATA FLNO /'COMPMT.OUT'/
     1     FLNL /'COMPMT.LOG'/
C* Local file units
      DATA LF1,LF2,LOU,LER / 1, 2, 3, 7 /
C* Resonance integral types
      DATA RITY /'ABSORPTION','FISSION   ','??????????'/
C* Define output page size (lines) and current page position
      DATA NP,IP /62,0/
C* Form feed character
      FF =CHAR(12)
C* Define the reference cross section filename
      LFF=LF1
      WRITE(LTT,691) ' REFERENCE CROSS SECTION DATA:          '
      GO TO 12
   11 WRITE(LTT,691) '                   ERROR reading file : ',FLN2
   12 WRITE(LTT,691) '$Enter the cross section data filename: '
      READ (LKB,691) FLN2
C***** VAX *****
C     OPEN(UNIT=LFF,FILE=FLN2,STATUS='OLD',ERR=11,READONLY)
C***** VAX *****
C***** EXPORT *****
      OPEN(UNIT=LFF,FILE=FLN2,STATUS='OLD',ERR=11)
C***** EXPORT *****
C* Try to interpret the filemark record
      READ (LFF,701,ERR=26) JTERM, NTYP,JG1,JG2,JG3
      IF(NTYP.EQ.0) GO TO 32
   20 IF(NTYP - 4 ) 30,32,38
C* No labelled filemark present
   26 REWIND LFF
      GO TO 40
C* Inappropriate labelled filemark found
   30 READ (LFF,701,ERR=30) JTERM, NTYP,JG1,JG2,JG3
      GO TO 20
C* Labelled filemark for cross section data found
   32 IF(LFF.NE.LF2) GO TO 36
C* - Reference data file
      IF(JG1.GT.0) NG1=JG1
      IF(JG2.GT.0) NG2=JG2
      IF(JG3.GT.0) NG3=JG3
      GO TO 40
C* - Compared data file
   36 IF(JG1.GT.0 .AND. JG1.NE.NG1) GO TO 37
      IF(JG2.GT.0 .AND. JG2.NE.NG2) GO TO 37
      IF(JG3.GT.0 .AND. JG3.NE.NG3) GO TO 37
      GO TO 40
C* Error condition on group structure
   37 WRITE(LTT,691) ' Incompatible group structure on file : ',FLN2
      GO TO 12
C* No cross section data found
   38 WRITE(LTT,691) '        No cross section data on file : ',FLN2
      GO TO 12
C* Define the compared cross section filename
   40 IF(LFF.EQ.LF2) GO TO 42
C* Check the group structure
      IF(JG1.EQ.0) THEN
        NGR=NG1+NG2+NG3
        WRITE(LTT,693) ' Assumed number of groups               ',NGR
        WRITE(LTT,693) '$  Enter number of groups to redefine : '
        READ (LKB,695) JGR
        IF     (JGR.EQ.0 .OR. JGR.EQ. 69) THEN
C*        69-groups default
        ELSE IF(JGR.EQ.172) THEN
C*        172-grous alternative group structure
          NG1=MG1
          NG2=MG2
          NG3=MG3
          NGR=JGR
        ELSE
C*        Arbitrary group structure
          WRITE(LTT,693) '$         Enter number of fast groups : '
          READ (LKB,695) NG1
          WRITE(LTT,693) '$    Enter number of resonance groups : '
          READ (LKB,695) NG2
          NGR=JGR
          NG3=NGR-NG1-NG2
        END IF
      END IF
      FLN1=FLN2
      LFF =LF2
      WRITE(LTT,691) ' COMPARED  CROSS SECTION DATA:          '
      GO TO 12
C* Both data files have been initialized, open the output
   42 WRITE(LTT,691) '0Default output report filename       : ',FLNO
      WRITE(LTT,691) '$      Enter new filename to redefine : '
      READ (LKB,691) FLNM
      IF(FLNM.NE.'                                        ') FLNO=FLNM
C***** VAX *****
C     OPEN (UNIT=LOU,FILE=FLNO,STATUS='NEW',CARRIAGECONTROL='LIST')
C     OPEN (UNIT=LER,FILE=FLNL,STATUS='NEW',CARRIAGECONTROL='LIST')
C***** VAX *****
C***** EXPORT *****
      OPEN (UNIT=LOU,FILE=FLNO,STATUS='UNKNOWN')
      OPEN (UNIT=LER,FILE=FLNL,STATUS='UNKNOWN')
C***** EXPORT *****
C* Enter the threshold for comparison output
      WRITE(LTT,691) '$Enter threshold diff.for x-sect.  [%]: '
      READ (LKB,694) EPS
      WRITE(LTT,691) '$Enter threshold diff.for trans.   [%]: '
      READ (LKB,694) EPZ
      WRITE(LTT,691) '$Enter threshold diff.for R.I.     [%]: '
      READ (LKB,694) EPR
      NG12=NG1 +NG2
      NG = NG12+NG3
C* Begin processing the cross sections
  400 READ(LF1,704) MT1,AW1,IZ1,NF1,NT1,NR1
      READ(LF2,704) MT2,AW2,IZ2,NF2,NT2,NR2
C* Label the output file
      WRITE(LOU,607)
      WRITE(LOU,608) ' Reference',MT1,AW1,IZ1,NF1,NT1,NR1,FLN1
      WRITE(LOU,608) ' Compared ',MT2,AW2,IZ2,NF2,NT2,NR2,FLN2
      WRITE(LER,607)
      WRITE(LER,608) ' Reference',MT1,AW1,IZ1,NF1,NT1,NR1,FLN1
      WRITE(LER,608) ' Compared ',MT2,AW2,IZ2,NF2,NT2,NR2,FLN2
      IP =8
      IF(EPS.LE.0) GO TO 402
      IF(EPS.LE.999.9) WRITE(LOU,606) EPS
      IF(EPS.LE.999.9) WRITE(LER,606) EPS
      WRITE(LER,691)
      IP =IP+2
C*
C* Epithermal cross sections processing
C*
  402 KLN=4*NG2+2*NG12
      KLF=2*NG12
      LS =1
C* Read the reference epithermal data
      L1 =LS
      READ(LF1,702) (RWO(LS-1+I),I=1,KLN)
      LS =LS+KLN
      IF(NF1.GE.2) READ(LF1,702) (RWO(LS-1+I),I=1,KLF)
      LS =LS+KLF
      READ(LF1,705) KL1,(RWO(LS-1+I),I=1,KL1)
      LS =LS+KL1+NG12
C* Read the compared epithermal data
      L2=LS
      READ(LF2,702) (RWO(LS-1+I),I=1,KLN)
      LS =LS+KLN
      IF(NF2.GE.2) READ(LF2,702) (RWO(LS-1+I),I=1,KLF)
      LS =LS+KLF
      READ(LF2,705) KL2,(RWO(LS-1+I),I=1,KL2)
      LS =LS+KL2+NG12
C* Perform comparison for epithermal cross sections
      LX1=L1
      LX2=L2
      COMM = ' POTENTIAL SCATTERING CROSS SECTION     '
      CALL XSDIFF(LOU,LER
     1           ,NG1,NG2,COMM,RWO(LX1),RWO(LX2),RWO(LS),EPS,NP,IP)
      LX1=LX1+NG2
      LX2=LX2+NG2
      COMM = ' SLOWING DOWN POWER                     '
      CALL XSDIFF(LOU,LER
     1           ,NG1,NG2,COMM,RWO(LX1),RWO(LX2),RWO(LS),EPS,NP,IP)
      LX1=LX1+NG2
      LX2=LX2+NG2
      COMM = ' TRANSPORT CROSS SECTION                '
      CALL XSDIFF(LOU,LER
     1           , 0,NG12,COMM,RWO(LX1),RWO(LX2),RWO(LS),EPS,NP,IP)
      LX1=LX1+NG12
      LX2=LX2+NG12
      COMM = ' ABSORPTION CROSS SECTION               '
      CALL XSDIFF(LOU,LER
     1           , 0,NG12,COMM,RWO(LX1),RWO(LX2),RWO(LS),EPS,NP,IP)
      LX1=LX1+NG12 + 2*NG2
      LX2=LX2+NG12 + 2*NG2
C* Epithermal fission yield and fission cross section
      IF(NF1.LT.2 .OR. NF2.LT.2) GO TO 412
      COMM = ' NEUTRON FISSION YIELD                  '
      CALL XSDIFF(LOU,LER
     1           , 0,NG12,COMM,RWO(LX1),RWO(LX2),RWO(LS),EPS,NP,IP)
  412 LX1=LX1+NG12
      LX2=LX2+NG12
      IF(NF1.LT.2 .OR. NF2.LT.2) GO TO 414
      COMM = ' FISSION CROSS SECTION                  '
      CALL XSDIFF(LOU,LER
     1           , 0,NG12,COMM,RWO(LX1),RWO(LX2),RWO(LS),EPS,NP,IP)
  414 LX1=LX1+NG12
      LX2=LX2+NG12
C* Epithermal scattering matrix (compare outscatter only)
      LO1=LX1+KL1
      LO2=LX2+KL2
      CALL XSMSUM(NG12,1,RWO(LX1),RWO(LO1))
      CALL XSMSUM(NG12,1,RWO(LX2),RWO(LO2))
      COMM = ' OUTSCATTERING CROSS SECTION            '
      CALL XSDIFF(LOU,LER
     1           , 0,NG12,COMM,RWO(LO1),RWO(LO2),RWO(LS),EPS,NP,IP)
      CALL XSMSUM(NG12,0,RWO(LX1),RWO(LO1))
      CALL XSMSUM(NG12,0,RWO(LX2),RWO(LO2))
      COMM = ' TOTAL SCATTERING CROSS SECTION         '
      CALL XSDIFF(LOU,LER
     1           , 0,NG12,COMM,RWO(LO1),RWO(LO2),RWO(LS),EPS,NP,IP)
C* Epithermal transport consistency check
      LZ1= L1+2*NG2
      LZ2= L2+2*NG2
      DO 418 I=1,NG12
      RWO(LO1-1+I)=RWO(LO1-1+I)+RWO(LZ1-1+NG12+I)
      RWO(LO2-1+I)=RWO(LO2-1+I)+RWO(LZ2-1+NG12+I)
  418 CONTINUE
      COMM = ' REF : TRANSP. VS. SCATT.MTX CONSISTENCY'
      CALL XSDIFF(LOU,LER
     1           , 0,NG12,COMM,RWO(LZ1),RWO(LO1),RWO(LS),EPZ,NP,IP)
      COMM = ' COMP: TRANSP. VS. SCATT.MTX CONSISTENCY'
      CALL XSDIFF(LOU,LER
     1           , 0,NG12,COMM,RWO(LZ2),RWO(LO2),RWO(LS),EPZ,NP,IP)
C* Save Lambda*SigP for RI intercomparison
      LG1=L1
      LG2=LG1+NG2
      DO 420 I=1,NG2
      RWO(LG1-1+I)=RWO(L1-1+I)*RWO(L1-1+NG2*3+NG12*2+I)
      RWO(LG2-1+I)=RWO(L2-1+I)*RWO(L2-1+NG2*3+NG12*2+I)
  420 CONTINUE
      LS =LG2+NG2
      LS0=LS
C*
C* Thermal cross sections processing
C*
  430 KLN=2*NG3
      KLF=2*NG3
      LS =LS0
C* Read temperature list for thermal cross section tables
      READ(LF1,702) (RWO(LS-1+I),I=1,NT1)
      LT1=LS
      LS =LS+NT1
      READ(LF2,702) (RWO(LS-1+I),I=1,NT2)
      LT2=LS
      LS =LT2+NT2
      L1 =LS
C* Read the reference thermal data for one temperature
      IT2=0
      IT1=0
  440 IF(IT1.GE.NT1) GO TO 450
      IT1=IT1+1
      LS =L1
      READ(LF1,702) (RWO(LS-1+I),I=1,KLN)
      LS =LS+KLN
      IF(NF1.GE.2) READ(LF1,702) (RWO(LS-1+I),I=1,KLF)
      LS =LS+KLF
      READ(LF1,705) KL1,(RWO(LS-1+I),I=1,KL1)
      LS =LS+KL1+NG3
      L2 =LS
C* Read the compared thermal data for one temperature
  450 IF(IT2.LT.NT2) GO TO 452
      IF(IT1.LT.NT1) GO TO 440
      GO TO 500
  452 IT2=IT2+1
      LS =L2
      READ(LF2,702) (RWO(LS-1+I),I=1,KLN)
      LS =LS+KLN
      IF(NF2.GE.2) READ(LF2,702) (RWO(LS-1+I),I=1,KLF)
      LS =LS+KLF
      READ(LF2,705) KL2,(RWO(LS-1+I),I=1,KL2)
      LS =LS+KL2+NG3
C* Compare data only if temp. differ by less than 10 degrees
  460 IF(ABS( RWO(LT1-1+IT1) -  RWO(LT2-1+IT2) ) .LT. 10.) GO TO 470
      IF(     RWO(LT1-1+IT1).GT.RWO(LT2-1+IT2) )           GO TO 450
C* - No provision is made for fine temperature mesh reference data
      GO TO 440
C* Begin comparison of thermal cross sections
  470 IF(EPS.LT.0) GO TO 440
      WRITE(LOU,699) FF
      WRITE(LOU,609) RWO(LT1-1+IT1)
      IP =4
      LX1=L1
      LX2=L2
      COMM = ' TRANSPORT CROSS SECTION                '
      CALL XSDIFF(LOU,LER
     1           ,NG12,NG3,COMM,RWO(LX1),RWO(LX2),RWO(LS),EPS,NP,IP)
      LX1=LX1+NG3
      LX2=LX2+NG3
      COMM = ' ABSORPTION CROSS SECTION               '
      CALL XSDIFF(LOU,LER
     1           ,NG12,NG3,COMM,RWO(LX1),RWO(LX2),RWO(LS),EPS,NP,IP)
      LX1=LX1+NG3
      LX2=LX2+NG3
C* Neutron fission yield and fission cross section
      IF(NF1.LT.2 .OR. NF2.LT.2) GO TO 472
      COMM = ' NEUTRON FISSION YIELD                  '
      CALL XSDIFF(LOU,LER
     1           ,NG12,NG3,COMM,RWO(LX1),RWO(LX2),RWO(LS),EPS,NP,IP)
  472 LX1=LX1+NG3
      LX2=LX2+NG3
      IF(NF1.LT.2 .OR. NF2.LT.2) GO TO 474
      COMM = ' FISSION CROSS SECTION                  '
      CALL XSDIFF(LOU,LER
     1           ,NG12,NG3,COMM,RWO(LX1),RWO(LX2),RWO(LS),EPS,NP,IP)
  474 LX1=LX1+NG3
      LX2=LX2+NG3
C* Thermal scattering matrix (compare outscatter & check transport)
      LO1=LX1+KL1
      LO2=LX2+KL2
      CALL XSMSUM(NG3,1,RWO(LX1),RWO(LO1))
      CALL XSMSUM(NG3,1,RWO(LX2),RWO(LO2))
      COMM = ' OUTSCATTERING CROSS SECTION            '
      CALL XSDIFF(LOU,LER
     1           ,NG12,NG3,COMM,RWO(LO1),RWO(LO2),RWO(LS),EPS,NP,IP)
      CALL XSMSUM(NG3,0,RWO(LX1),RWO(LO1))
      CALL XSMSUM(NG3,0,RWO(LX2),RWO(LO2))
      COMM = ' TOTAL SCATTERING CROSS SECTION         '
      CALL XSDIFF(LOU,LER
     1           ,NG12,NG3,COMM,RWO(LO1),RWO(LO2),RWO(LS),EPS,NP,IP)
C* Thermal transport consistency check
      DO 478 I=1,NG3
      RWO(LO1-1+I)=RWO(LO1-1+I)+RWO(L1 -1+NG3+I)
      RWO(LO2-1+I)=RWO(LO2-1+I)+RWO(L2 -1+NG3+I)
  478 CONTINUE
      COMM = ' REF : TRANSP. VS. SCATT.MTX CONSISTENCY'
      CALL XSDIFF(LOU,LER
     1           ,NG12,NG3,COMM,RWO(L1 ),RWO(LO1),RWO(LS),EPZ,NP,IP)
      COMM = ' COMP: TRANSP. VS. SCATT.MTX CONSISTENCY'
      CALL XSDIFF(LOU,LER
     1           ,NG12,NG3,COMM,RWO(L2 ),RWO(LO2),RWO(LS),EPZ,NP,IP)
      GO TO 440
C* Rrocess resonance integral data if any
  500 IF(NF1.LT.1 .OR. NF2.LT.1) GO TO 600
      IF(NF1.NE.NF2)             GO TO 596
C* Print the header to output
      IF(EPR.LT.0) GO TO 502
      WRITE(LOU,614) FF
      IP =4
  502 JRG=NG1
      NR =0
  510 LFF=LF1
      LS =LS0
C* Read the filemark and check for labels
  512 READ (LFF,701,ERR=512,END=592) JTERM,N1,N2,N3,N4
      IF(JTERM.NE.ITERM) GO TO 514
      IF(LFF.EQ.LF1) JRG=JRG+1
      IF(N1.NE.0 .AND. N1.NE.5) GO TO 594
      IF(N2.NE.0) JRG=N2
      IF(N3.NE.0) NG1=N3
      IF(N4.NE.0) NG2=N4
      READ (LFF,701,ERR=591,END=592) NST
      IR =0
C* Read the data
  514 READ (LFF,706) AM2,NT2,NS2
      LL =NT2+NS2+NT2*NS2
      READ (LFF,702) (RWO(LS-1+J),J=1,LL)
      L2 =LS
      LS =LS +LL
      IF(LFF.EQ.LF2) GO TO 520
C* Prepare to read the second data set
      LFF=LF2
      AM1=AM2
      NT1=NT2
      NS1=NS2
      L1 =L2
      GO TO 512
  520 CONTINUE
C* For a group both data sets read - do the comparison
      IR =MIN(IR+1,3)
      NR =MAX(IR,NR)
      LRG=JRG-NG1
      WRITE(COMM,612) RITY(IR),AM1,AM2
      CALL RIDIFF(LOU,LER,COMM,JRG
     1    ,NS1,NT1,RWO(L1),RWO(L1+NT1),RWO(L1+NT1+NS1),RWO(LG1-1+LRG)
     2    ,NS2,NT2,RWO(L2),RWO(L2+NT2),RWO(L2+NT2+NS2),RWO(LG2-1+LRG)
     3    ,RWO(LS),EPR,NP,IP)
C* Check if more groups to be processed, else finish
      IF(JRG.LT.NG1+NG2 .OR. IR.LT.NR) GO TO 510
      GO TO 600
C* Error traps
  591 WRITE(LTT,611) ' COMPMT Error reading res. data on unit ',LFF
      GO TO 600
  592 WRITE(LTT,611) ' COMPMT E-O-F reading res. data on unit ',LFF
      GO TO 600
  594 WRITE(LTT,611) ' COMPMT incorrect file mark label found ',N1
      GO TO 600
  596 WRITE(LTT,611) ' COMPMT incompatible NF for RI compar.  ',NF1,NF2
C* All data compared
  600 CLOSE (UNIT=LF1)
      CLOSE (UNIT=LF2)
      CLOSE (UNIT=LOU)
      RETURN
  606 FORMAT(/' Only differences in excess of',F6.1,' % are displayed')
  607 FORMAT(//    ' WILLIE - DATA COMPARISON UTILITY'/
     1             ' ================================'//
     1         10X,' Mat.ID   At.Wt.   Z Nf Nt Nr Filename')
  608 FORMAT(  A10,':',  I6,    F9.4, I4,I3,I3,I3,1X,A40)
  609 FORMAT(' TEMPERATURE',F8.1,' K'/' =====================')
  611 FORMAT(A40,2I2)
  612 FORMAT(1X,A10,' RI MAT.',F8.1,' AND',F8.1)
  614 FORMAT(1X,A1//' RESONANCE INTEGRALS TABLES'/
     1             ,' ==========================')
  691 FORMAT(2A40)
  693 FORMAT(A40,I6)
  694 FORMAT(BN,F20.0)
  695 FORMAT(BN,I10)
  699 FORMAT(1X,A1//)
  701 FORMAT(5I15)
  702 FORMAT(1P,5E15.8)
  703 FORMAT(1P,3(E15.8,I6))
  704 FORMAT(1P,I6,E15.8,4I6)
  705 FORMAT(1P,I15/(5E15.8))
  706 FORMAT(1P,E15.8,2I6)
      END
      SUBROUTINE XSDIFF(LOU,LER,NG0,NGR,COM,XS1,XS2,RWO,EPS,NP,IP)
C-Title  : XSDIFF Subroutine
C-Purpose: Compare cross sections
      CHARACTER*1  FF
      CHARACTER*40 COM
      DIMENSION    XS1(*),XS2(*),RWO(*)
C* Rel.diff.threshold below which data are considered identical
      DATA ERMX/1.E-5/
C* Form feed character
      FF =CHAR(12)
C* Check if printout is requested
      IF(EPS.LT.0) RETURN
C* Initialize
      ERM1=0.
      EAM1=0.
      ERM2=0.
      EAM2=0.
      JP  =0
C* Calculate differences
      DO 60 I=1,NGR
      IG=NG0+I
      EA=XS2(I)-XS1(I)
      ER=0.
      IF(XS1(I).GT.0) ER= 100.*EA/XS1(I)
      IF(ER.GT. 999.) ER= 999.
      IF(ER.LT.-999.) ER=-999.
      IF(ER.LE.ERM1) GO TO 51
        IRM1=IG
        ERM1=ER
   51 IF(EA.LE.EAM1) GO TO 52
        IAM1=IG
        EAM1=EA
   52 IF(ER.GE.ERM2) GO TO 53
        IRM2=IG
        ERM2=ER
   53 IF(EA.GE.EAM2) GO TO 54
        IAM2=IG
        EAM2=EA
   54 RWO(I    )=ER
      RWO(I+NGR)=EA
      IF(ABS(ER).GE.EPS) JP =JP+1
   60 CONTINUE
C* Check for space on output page
      KP =4
      IF(ERM1.GT.ERMX .OR. -EAM2.GT.ERMX) KP=KP+3
      IF(JP.GT.0) KP=KP+2+JP
      IF(IP+KP.LT.NP) GO TO 62
      WRITE(LOU,99) FF
      IP =0
   62 IP =IP+KP
C* Write header
      WRITE(LOU,90) COM,NG0+1,NG0+NGR
C* Check if there ara differences to be printed
      IF(JP.LT.1) GO TO 82
      WRITE(LOU,91)
      DO 80 I=1,NGR
      IG=NG0+I
      ER=RWO(I)
      EA=RWO(I+NGR)
      X1=XS1(I)
      X2=XS2(I)
      IF(X1.LT.1E-9) X1=0.
      IF(X2.LT.1E-9) X2=0.
      IF(ABS(ER).GE.EPS) WRITE(LOU,92) IG,X1,X2,ER,EA
   80 CONTINUE
C* Print the extreme defferences
   82 IF(ERM1.GT.ERMX .OR. -ERM2.GT.ERMX) GO TO 84
      WRITE(LOU,96)
C     WRITE(LER,98)
      RETURN
   84 WRITE(LOU,93)
      WRITE(LOU,94) ' Max.',IRM1,ERM1,IAM1,EAM1
      WRITE(LOU,94) ' Min.',IRM2,ERM2,IAM2,EAM2
      IRM=IRM1
      IF(-ERM2.GT.ERM1) IRM=IRM2
      ERM=ERM1
      IF(-ERM2.GT.ERM1) ERM=-ERM2
C     WRITE(LER,97) COM,IRM,ERM
      IF(ABS(ERM).GT.EPS) WRITE(LER,97) COM,IRM,ERM
      RETURN
   90 FORMAT(/A40,' Group',I4,' to',I4/
     1 ,' ========================================================')
   91 FORMAT('  Gr.   Ref.[b]  Comp.[b]  Erel.[%]  Eabs.[b]'/
     4      ,' --------------------------------------------')
   92 FORMAT(1P,I5,2E10.3E1,0P,2F10.3)
   93 FORMAT(' Extrema:   Gr.  Erel.[%]   Gr.  Eabs.[b]'/
     3      ,'       ----------------------------------')
   94 FORMAT(6X,A5,I4,F10.3,I6,F10.4)
   96 FORMAT(' Data sets identical')
   97 FORMAT(A40,' Gr',I3,'   Emx',F10.3,' %')
   98 FORMAT(A40,' Data identical')
   99 FORMAT(1X,A1//)
      END
      SUBROUTINE RIDIFF(LOU,LER,COM,JRG
     1                 ,NS1,NT1,TM1,SG1,RI1,PL1
     2                 ,NS2,NT2,TM2,SG2,RI2,PL2 ,RWO,EPR,NP,IP)
C-Title  : RIDIFF Subroutine
C-Purpose: Compare Resonance Integral data sets
      CHARACTER*40 COM
      CHARACTER*8  DASH,  CH8,   REC(10,6)
      CHARACTER*1  FF
      DIMENSION    TM1(*),SG1(*),RI1(NS1,NT1)
     1            ,TM2(*),SG2(*),RI2(NS2,NT2) ,RWO(*)
      DATA DASH     /'--------'/
     1    ,REC(1,1) /' Sig0   '/
     1    ,REC(1,2) /' -------'/
     1    ,REC(1,3) /' Ref.   '/
     1    ,REC(1,4) /' Comp.  '/
     1    ,REC(1,5) /' Er [%] '/
     1    ,REC(1,6) /' Ea [b] '/
C* Rel.diff.threshold below which data are considered identical
      DATA ERMX/1.E-5/
C* Form feed character
      FF =CHAR(12)
C* Check if printout is requested
      IF(EPR.LT.0) GO TO 600
      EPS=0.01
C* Convert WIMS background x-sect to Bondarenko Sig0
      DO 110 I=1,NS1
      SG1(I)=SG1(I)-PL1
  110 CONTINUE
      DO 120 I=1,NS2
      SG2(I)=SG2(I)-PL2
  120 CONTINUE
C* Loop over temperatures - select temperature indices
      JT1=0
  130 JT1=JT1+1
      IF(JT1.GT.NT1) GO TO 600
      JT2=0
  131 JT2=JT2+1
      JTI=MIN(NT2,JT2+1)
      IF(TM2(JTI).LT.TM1(JT1) .AND. JTI.LT.NT2) GO TO 131
C* Check for matching data at this temperature
      IF(ABS(TM1(JT1)-TM2(JT2)).GT.10. .AND. JT2.EQ.JTI) GO TO 130
C* Define Sig0 mesh
      LSG=1
      KSG=NS1+NS2
      LR1=LSG+KSG
      LR2=LR1+KSG
      LRI=LR2+KSG
      LBL=LRI+KSG
C* Sig0 mesh as the union of both data sets (if possible)
  140 JNT=1
      SGB=0.
      NSG=0
C* Skip the smallest Sig0 to avoid extrapolation
      I1 =0
  142 I1 =I1+1
      IF(SG1(I1) .LT. SG2(1)) GO TO 142
      I2 =0
  144 I2 =I2+1
      IF(SG2(I2) .LT. SG1(1)) GO TO 144
C* Identify the data set from which the next entry is taken
  160 IF(SG1(I1) .GT. SG2(I2)) GO TO 166
C* Case: Next Sig0 mesh point from reference set
  162 IF(I1.GT.NS1) GO TO 166
      IF(ABS(SG1(I1)-SGB).LT.EPS*SGB) GO TO 164
      NSG=NSG+1
      SGB=SG1(I1)
      RWO(LSG-1+NSG)=SGB
  164 I1 = I1+1
      IF(I1.LE.NS1) GO TO 160
C* Case: Next Sig0 mesh point from compared set
  166 IF(I2.GT.NS2) GO TO 168
      IF(ABS(SG2(I2)-SGB).LT.EPS*SGB) GO TO 167
      NSG=NSG+1
      SGB=SG2(I2)
      RWO(LSG-1+NSG)=SGB
  167 I2 = I2+1
      IF(I2.LE.NS2) GO TO 160
      GO TO 162
C* Last entry is 1.E10 - eliminate higher entries
  168 IF(RWO(LSG-1+NSG).LE.1.E10) GO TO 170
      RWO(LSG-1+NSG)=1.E10
      IF(RWO(LSG-2+NSG).LT.RWO(LSG-1+NSG)) GO TO 170
      NSG=NSG-1
      GO TO 168
C* Check if Sig0 mesh needs to be reduced
  170 JM =NSG
      RM =1.E30
C* Locate the densest Sig0 mesh spacing
      DO 172 I=2,NSG
      RR =ALOG(RWO(LSG+I-1)/RWO(LSG+I-2))
      IF(RR.GT.RM) GO TO 172
      RM =RR
      JM =I
  172 CONTINUE
      IF(NSG.LE.9 .AND. (RR-1.).GT.EPS) GO TO 200
C* Reduce the Sig0 mesh by eliminating smallest Sig0 intervals
      J1 =MAX(  1,JM-2)
      J2 =MIN(NSG,JM+1)
      R1 =ALOG(RWO(LSG-1+JM)/RWO(LSG-1+J1  ))
      R2 =ALOG(RWO(LSG-1+J2)/RWO(LSG-1+JM-1))
C* Case: Eliminate lower point of the narrow Sig0 interval
      IF(R1.LT.R2 .AND. JM.NE.  2) JD=JM
C* Case: Eliminate upper point of the narrow Sig0 interval
      IF(R1.GE.R2 .AND. JM.NE.NSG) JD=JM+1
C* Shift the Sig0 values
      DO 178 I=JD,NSG
      RWO(LSG+I-2)=RWO(LSG+I-1)
  178 CONTINUE
      NSG=NSG-1
      GO TO 170
C* Interpolate resonance integrals to a common grid
  200 IF(JNT.LE.0) GO TO 300
C* Interpolate in the SigB domain (rather than Sig0)
      LS1=LBL
      DO 220 I=1,NSG
      RWO(LS1-1+I)=RWO(LSG-1+I)+PL1
  220 CONTINUE
      CALL INTERI(NS1,NSG,SG1,RWO(LS1),RI1(1,JT1),RWO(LR1),INT)
      DO 240 I=1,NSG
      RWO(LS1-1+I)=RWO(LSG-1+I)+PL2
  240 CONTINUE
      CALL INTERI(NS2,NSG,SG2,RWO(LS1),RI2(1,JT2),RWO(LR2),INT)
      CALL INTERI(NS2,NSG,SG2,RWO(LS1),RI2(1,JTI),RWO(LRI),INT)
  300 IF(ABS(TM1(JT1)-TM2(JT2)).LT.10.) GO TO 400
C* Interpolate second data set for temperature
  334 GG= (SQRT(TM1(JT1))-SQRT(TM2(JT2)))
     1  / (SQRT(TM2(JTI))-SQRT(TM2(JT2)))
      DO 336 I=1,NSG
      RWO(LR2-1+I)=RWO(LR2-1+I) + GG*(RWO(LRI-1+I)-RWO(LR2-1+I))
  336 CONTINUE
      TM2(JT2)=TM1(JT1)
C* Calculate the differences
  400 CONTINUE
      IRM1=1
      IAM1=1
      IRM2=1
      IAM2=1
      ERM1=0.
      EAM1=0.
      ERM2=0.
      EAM2=0.
      DO 460 I=1,NSG
      EA = RWO(LR2-1+I)-RWO(LR1-1+I)
      ER = 0.
      IF(RWO(LR1-1+I).GT.0) ER = 100.*EA/RWO(LR1-1+I)
      IF(ER.GT. 999.) ER= 999.
      IF(ER.LT.-999.) ER=-999.
      IF(ER.LE.ERM1) GO TO 451
        IRM1=I
        ERM1=ER
  451 IF(EA.LE.EAM1) GO TO 452
        IAM1=I
        EAM1=EA
  452 IF(ER.GE.ERM2) GO TO 453
        IRM2=I
        ERM2=ER
  453 IF(EA.GE.EAM2) GO TO 454
        IAM2=I
        EAM2=EA
  454 CALL CH8PCK(REC(I+1,1),RWO(LSG-1+I))
      REC(I+1,2) = DASH
      CALL CH8PCK(REC(I+1,3),RWO(LR1-1+I))
      CALL CH8PCK(REC(I+1,4),RWO(LR2-1+I))
      WRITE(REC(I+1,5),692) ER
      WRITE(REC(I+1,6),694) EA
  460 CONTINUE
C* Print the results
      JP=3 + 4
      IF(ERM1.GT.EPR .OR. -ERM2.GT.EPR) JP=JP+7
      IF(IP+JP.LT.NP) GO TO 461
      WRITE(LOU,609) FF
      IP=0
  461 IP=IP+JP
      WRITE(LOU,601) COM,TM1(JT1),JRG
      IF(ERM1.GT.ERMX .OR. -ERM2.GT.ERMX) GO TO 464
      WRITE(LOU,696)
C     WRITE(LER,698)
      GO TO 130
  464 IF(ERM1.LE.EPR .AND. -ERM2.LE.EPR) GO TO 470
      NSG1=NSG+1
      DO 466 I=1,6
      WRITE(LOU,690) (REC(J,I),J=1,NSG1)
  466 CONTINUE
      WRITE(LOU,690)
  470 WRITE(LOU,603)
      WRITE(LOU,604) ' Max.',REC(IRM1+1,1),ERM1,REC(IAM1+1,1),EAM1
      WRITE(LOU,604) ' Min.',REC(IRM2+1,1),ERM2,REC(IAM2+1,1),EAM2
      CH8=REC(IRM1+1,1)
      IF(-ERM2.GT.ERM1) CH8=REC(IRM2+1,1)
      ERM=ERM1
      IF(-ERM2.GT.ERM1) ERM=-ERM2
C     WRITE(LER,697) COM,TM1(JT1),JRG,CH8,ERM
      IF(ABS(ERM).GT.EPR) WRITE(LER,697) COM,TM1(JT1),JRG,CH8,ERM
      GO TO 130
  600 RETURN
  601 FORMAT(/A40,'  TEMP.',F6.1,' K  GROUP',I3/
     1  ' ================================',
     1  '================================')
  603 FORMAT(' Extrema:      Sig0  Erel.[%]      Sig0  Eabs.[b]'/
     3      ,'       ------------------------------------------')
  604 FORMAT(6X,A5,A8,F10.3,2X,A8,F10.4)
  609 FORMAT(1X,A1//)
  690 FORMAT(10A8)
  692 FORMAT(F8.2)
  694 FORMAT(F8.4)
  696 FORMAT(' Data sets identical')
  697 FORMAT(A14,' Temp',F6.1,' K  Gr',I3,' Sg0',A8,'   Emx',F10.3,' %')
  698 FORMAT(A14,' Temp',F6.1,' K  Gr',I3,' Data identical')
      END
      SUBROUTINE INTERI(NA,NB,SA,SB,RA,RB,INT)
C-Title  : INTERI Subroutine
C-Purpose: Interpolate a table of resonance integrals
C-Description:
C-D  A set of NA input resonance integrals RA on Sig0 mesh SA
C-D  in ascending order is given. The last point is assumed at
C-D  infinite dilution. Resonance integrals are interpolated to
C-D  NB values RB at meshpoints SB. Flag INT>0 forces Root(Sig0)
C-D  interpolation, which is equivalent to the original WIMS-D/4
C-D  method.
C-D
      DIMENSION SA(*),SB(*),RA(*),RB(*)
C* Define the RI at infinite dilution
      RI=RA(NA)
C* Implied loop over output mesh
      IB=0
   10 IB=IB+1
      IF(IB.GT.NB) RETURN
C* Locate the correct interval on the input mesh
      J2=1
   20 J1=J2
      J2=J1+1
      IF(SA(J2).LT.SB(IB) .AND. J2.LT.NA-1) GO TO 20
C* Perform interpolation
   30 CALL RINTER(SA(J1),SA(J2),SB(IB),RI,RA(J1),RA(J2),RB(IB),INT)
      GO TO 10
      END
      SUBROUTINE RINTER(S1,S2,SS,RI,R1,R2,RR,INT)
C-Title  : RINTER Subroutine
C-Purpose: Interpolate resonance integrals using Segev's formula
C-Description:
C-D  Given the resonance integral at infinite dilition RI and
C-D  two resonance integrals R1,R2 at the corresponding Sig0
C-D  values S1,S2, calculate the interpolated resonance integral
C-D  RR at Sig0 value SS.
C-D    If INT>0 then the Root(Sig0) interpolation is used,
C-D  except in the last interval extending to infinity where
C-D  the 1/Sig0 interpolation scheme is applied. This is
C-D  equivalent to the original WIMS-D/4 interpolation. This
C-D  interpolation rule is also forced automatically if the
C-D  resonance integrals are not monotonic ascending or when
C-D  the upper interval boundary S2 liev above SG0. Otherwise
C-D  the Segeev interpolation is used, which requires the
C-D  root WW of a transcendental equation in an interval W1,W2
C-D  which encloses the root. Compared to the original Segev's
C-D  work, the differences in the present algorithm are a better
C-D  protection against numerical failure and a new root-finding
C-D  algorithm which is a combination of the bisection method
C-D  (HH=1) and the method of false position (HH=0), controlled
C-D  according to the success of the root estimate in the
C-D  previous iteration.
C-D  NOTE: S2 must be smaller than the assumed Sig0 at inf.dil.
C-D        (R2<RI) otherwise the (1/Sig0) interpolation is
C-D        used which may be inappropriate.
C-Author : A.Trkov, Institute J.Stefan, Ljubljana, Slovenia (1994)
C-A        Reprogrammed after the original version by A.Holubar.
C-Version:
C-V  94/12 - Tighten iter.converg. criterion DFF from 1E-2 to 1E-4.
C-V        - Apply 1/Sig0 interpolation in the last interval.
C-V        - Use Root(Sig0) interpolation below threshold SG0.
C-Refern.: M.Segev, Nucl.Sci.Eng. 79, p.113 (1981).
C-
C* Tolerance limits:
C*   DFR on R1,R2,RI to switch to Root(Sig0)-interpolation (rel.),
C*   DFW on W1,W2 to finish iterations on small root interval (rel.),
C*   DFF on FF to finish iterations on small function value (abs.),
C*   DIL assumed Sig0 at infinite dilution [barns].
C*   SG0 threshold below which Root(Sig0) interpolation is used
      DATA DFR,DFW,DFF,DIL,SG0/1.0E-4, 1.0E-6, 1.0E-4,  1.0E+10, 100./
C* Transfer boundary values to local variables
      IF(S1.GT.S2) GO TO 12
      SA=S1
      RA=R1
      SB=S2
      RB=R2
      GO TO 14
C* Swap entries if S1,S2 not in ascending order
   12 SA=S2
      RA=R2
      SB=S1
      RB=R1
C* Test if RI are monotonic to avoid numerical problems
   14 IF( INT      .GT. 0 ) GO TO 80
      IF(  SB      .LT.SG0) GO TO 80
      IF((RB-RA)/RI.LT.DFR) GO TO 80
      IF((RI-RB)/RI.LT.DFR) GO TO 80
C* Solve transcendental equation - initialize variables
      G1=RI/RA
      G2=RI/RB
      RW=SA/SB
      A1=ALOG(G1)
      A2=ALOG(G2)
      DD=A2-A1
C* Define root lower bound W1 and function value F1
      W1=ALOG(RW*A1/A2) / DD
      F1=G2**W1-1.-RW*(G1**W1-1.)
C* Define root upper bound W2 and function value F2
      W2=ALOG(RW      ) / DD
      F2=G2**W2-1.-RW*(G1**W2-1.)
      HH=0.
C* Iteration loop - determine new guess for the root WW
   20 HH=MAX(0.0,HH)
      HH=MIN(1.0,HH)
      WW=W1 + (W2-W1)*( 0.5*HH + (1.-HH)*F1/(F1-F2) )
C* Check for convergence on small root interval value
      IF(ABS((W2-W1)/WW).LE.DFW) GO TO 60
C* Determine the function value
      GW=G1**WW-1.
      FF=G2**WW-1.-RW*GW
C* Check for convergence on small function value
      IF(ABS(FF).LE.DFF) GO TO 60
C* Reduce the interval and re-iterate
      IF(FF.GT.0.) GO TO 30
      HH=FF/F2
      W2=WW
      F2=FF
      GO TO 20
   30 HH=FF/F1
      W1=WW
      F1=FF
      GO TO 20
C* Iterations complete - evaluate the resonance integral
   60 ET=GW*SA
      PP=1./WW
      RR=RI*(SS/(SS+ET))**PP
      RETURN
C* Interpolation if non-monotonic res.int. tables are given or INT>0
   80 IF(SS.LE.SB) GO TO 82
C* Special treatment for 1/Sig0 interpolation towards infinite dilution
      RA=RB
      RB=RI
      SA=SB
      SB=DIL
      IF(SB/SA.LT.100.) SB=SA*100.
      QA=1/SA
      QB=1/SB
      QQ=1/SS
      GO TO 84
C* Root(Sig0) interpolation
   82 QA=SQRT(SA)
      QB=SQRT(SB)
      QQ=SQRT(SS)
   84 RR=RA + (RB-RA)*(QQ-QA)/(QB-QA)
      RETURN
      END
      SUBROUTINE RESPOL(S1,S2,S,RI,R1,R2,R)
C-Title  : RESPOL Subroutine
C-Purpose: Interpolate resonance integrals using Segev's formula
C-Description:
C-D  Given the resonance integral at infinite dilition RI and
C-D  two resonance integrals R1,R2 at the corresponding Sig0
C-D  values S1,S2, interpolate the resonance integral R to a
C-D  Sig0 value S
C-D
C-Author : Ales Holubar, Nucl.Res.Inst., Rez, Czechoslovakia (1990)
C-Refern.: Segev, Nucl.Sci.Eng. 79, 113 (1981).
C-Version: 93/2  A.Trkov, use Log interpolation if R1.ge.R2
C-V        94/8  A.Trkov, guard against small WH/WL interval.
C-V        SUPERSEEDED BY RINTER
C-
      DATA EPS/1.0E-4/
      IF(S1.LT.S2) GO TO 1
C* Swap entries if not in ascending order
      S0=S2
      R0=R2
      S2=S1
      R2=R1
      S1=S0
      R1=R0
C* Test if RI are monotonic to avoid numerical problems
    1 IF((R2-R1)/RI.LT.EPS) GO TO 6
      IF((RI-R2)/RI.LT.EPS) GO TO 6
C* Initialize bounds for the root W
      G1=RI/R1
      G2=RI/R2
      RW=S1/S2
      A1=ALOG(G1)
      A2=ALOG(G2)
      T =ALOG(G1)/ALOG(G2)
      D =ALOG(G2/G1)
      WL=ALOG(RW*T)/D
      WH=ALOG(RW)/D
C* Iterate for the loop (stop on small diff. or function value
    2 W =(WL+WH)*0.5
      IF(ABS((WH-WL)/W).LT.1.0E-6) GO TO 4
      G = G2**W-1.-RW*(G1**W-1.)
      IF(ABS(G)    .LT.  0.01) GO TO 4
C* Reduce the bounds by bisection and re-iterate
      IF(G.LT.0.) GO TO 3
      WL=W
      GO TO 2
    3 WH=W
      GO TO 2
C* Iterations complete - evaluate the resonance integral
    4 GW=(G1**W-1.)
      ET= GW*S1
      P = 1./W
      R = RI*(S/(S+ET))**P
      RETURN
C* Log interpolation if non-monotonic res.int. tables are given
    6 R =R1+(R2-R1)*ALOG(S/S1)/ALOG(S2/S1)
      RETURN
      END
      SUBROUTINE CH8PCK(CH,R)
C-Title  : CH8PCK subroutine
C-Purpose: Write a real number R into CH string, 8 characters long
C-Author : A.Trkov, Institute Jozef Stefan, Ljubljana, Slovenia (1990)
      CHARACTER*8 CH
      IF( R .NE. 0) GO TO 10
      CH ='       0'
      RETURN
   10 AR =ABS(R)
      IF( AR .GE. 1.E-4 .AND. AR .LT. 1.E6) GO TO 20
      WRITE(CH,11) R
      RETURN
   20 IF( AR .GT. 9.99999) GO TO 30
      WRITE(CH,21) R
      IF( CH(8:8) .NE. '0' ) RETURN
   30 IF( AR .GT. 99.9999) GO TO 40
      WRITE(CH,31) R
      IF( CH(8:8) .NE. '0' ) RETURN
   40 IF( AR .GT. 999.999) GO TO 50
      WRITE(CH,41) R
      IF( CH(8:8) .NE. '0' ) RETURN
   50 IF( AR .GT. 9999.99) GO TO 60
      WRITE(CH,51) R
      IF( CH(8:8) .NE. '0' ) RETURN
   60 IF( AR .GT. 99999.9) GO TO 70
      WRITE(CH,61) R
      IF( CH(8:8) .NE. '0' ) RETURN
   70 IR=R+0.5
      WRITE(CH,71) IR
      RETURN
   11 FORMAT(1PE8.1)
   21 FORMAT(F8.5)
   31 FORMAT(F8.4)
   41 FORMAT(F8.3)
   51 FORMAT(F8.2)
   61 FORMAT(F8.1)
   71 FORMAT(I8)
      END
      SUBROUTINE PTABMT(LKB,LTT,RWO,IWO,MXRW,MXIW)
C-Title  : PTABMT Subroutine
C-Purpose: Tabulate nuclide data for plotting purposes
C-Description:
C-D  To use high quality plotting software such as PLOTTAB, the
C-D  cross sections and resonance integrals must be tabulated on
C-D  separate files.
C-D    First the filename containing the group energy boundaries
C-D  is requested. It may be a WIMS library, a WILLIE file with
C-D  labelled filemarks or another list file where 70 (default)
C-D  group boundaries are read, 5 per line, 15 colums each (as
C-D  in the original WIMS library).
C-D    Next the list of files to be processed is entered, terminated
C-D  by a blank entry. The files may be WILLIE files produced by
C-D  the COPY option or otherwise (for example, from the WIMSR
C-D  module of the NJOY code).
C-D    The possibility is offered to define special labels which
C-D  appear at the beginning of each output set. The labes is
C-D  specific file containing the data set and may be up to 40
C-D  characters long. The reaction type label is appended
C-D  automatically after column 40.
C-D    Reaction cross section to be plotted is selected by entering
C-D  the appropriate key number. A negative entry implies end of
C-D  processing. The data for the selected reaction will be written
C-D  on the output file from all input files. The procedure may be
C-D  repeated for as many reactions as desired.
C-D    The default output filename is displayed. It may be redefined
C-D  by entering a new filename, otherwise the data continue to be
C-D  written on the same file.
C-D
C-
      PARAMETER       (MXFL=10)
      CHARACTER*10    IDNT(12)
      CHARACTER*40    BLNK,FLNM,FLNO,FLNI(MXFL)
      CHARACTER*80    COMM(MXFL)
      DIMENSION       RWO(*),IWO(*), RMT(MXFL)
      COMMON /TERWOR/ ITERM,ALDO(2)
      SAVE            FLNO
      DATA BLNK /'                                        '/
     1    ,FLNO /'PTABMT.CUR'/
C* Number and selectable reaction types
      DATA MSEL,IDNT / 12
     1,'POTENTIAL ','SLOW.DN.PW','TRANSPORT ','ABSORPTION','FISS.YIELD'
     1,'FISSION   ','OUTSCATT. ','SCATTERING','DIFF.SCAT.','ABSORPT.RI'
     2,'FISSION RI','FISS.SPECT'/
      DATA RMT/ MXFL*0.0 /
C* Default group system (No.of fast,resonance,thermal groups)
      DATA NG1,NG2,NG3/ 14, 13, 43 /
C* Logical file units for source library and output file
      DATA LF1,LF2 / 1, -2 /
C* Default temperatures [K] for cross sect. and res.int.
      TMX=300.
      TMR=300.
      LBL=1
      DO 11 I=1,MXFL
      RMT(I)=0
   11 CONTINUE
C* Define the filenames
      GO TO 14
   12 WRITE(LTT,691) ' WIMS library of WILLIE file with labell'
     1              ,'ed filemarks must be entered.           '
   14 WRITE(LTT,691) '$Enter group boundaries filename      : '
      READ (LKB,691) FLNM
C***** VAX *****
C     OPEN (UNIT=LF1,FILE=FLNM,STATUS='OLD',ERR=12,READONLY)
C***** VAX *****
C***** EXPORT *****
      OPEN (UNIT=LF1,FILE=FLNM,STATUS='OLD',ERR=12)
C***** EXPORT *****
C* Interpret the header
      READ (LF1,701,ERR=16) JTERM,N1,N2,N3,N4
      IF(JTERM.NE.ITERM) GO TO 18
      IF(N1.NE.0 .AND. N1.NE.1) GO TO 12
C* Case: WILLIE file with labelled filemarks
      NG1=N2
      NG2=N3
      NG3=N4
      GO TO 20
C* Case: file without headers
   16 REWIND LF1
      GO TO 20
C* Case: WIMS library
   18 NEL=JTERM
      NG =N1
      NG0=N2
      NG1=N3
      NG2=N4
      READ (LF1,701,ERR=12) NG3,NNFD,NFPD
      READ (LF1,701,ERR=12) (IWO(I),I=1,NEL)
C* Read the group boundaries (in descending energy)
   20 NG =NG1+NG2+NG3
      NGB=NG+1
      READ (LF1,702,ERR=12) (RWO(LBL-1+J),J=1,NGB)
      LGB=LBL
      LGC=LGB+NGB
      LBL=LBL+NGB+NG2
      CLOSE(UNIT=LF1)
C* Define the data filenames
   30 WRITE(LTT,691) ' Define the cross section data files  : '
      NFL=0
   32 WRITE(LTT,691) '$                                     : '
      READ (LKB,691) FLNM
      IF(FLNM.EQ.BLNK) GO TO 34
      NFL=NFL+1
      FLNI(NFL)=FLNM
      GO TO 32
C* Enter the labels for each data set
   34 FLNM=          ' LABEL                                  '
      DO 36 JFL=1,NFL
C* One blank entry implies default setting for the remaining files
      IF(FLNM.EQ.BLNK) GO TO 35
      WRITE(LTT,691) '                                 File : '
     1,FLNI(JFL)
      WRITE(LTT,691) '$Enter the label (default="filename") : '
      READ (LKB,691)  FLNM
      COMM(JFL)(1:40)=FLNM
      IF(FLNM.NE.BLNK) GO TO 36
   35 COMM(JFL)(1:40)=FLNI(JFL)
   36 CONTINUE
C* Define the parameter to be tabulated
   40 WRITE(LTT,691) ' Select from the following reactions  : '
      WRITE(LTT,691) '   1 - potential cross section          '
      WRITE(LTT,691) '   2 - slowing down power               '
      WRITE(LTT,691) '   3 - transport cross section          '
      WRITE(LTT,691) '   4 - absorption cross section         '
      WRITE(LTT,691) '   5 - neutron fission yield            '
      WRITE(LTT,691) '   6 - fission cross section            '
      WRITE(LTT,691) '   7 - outscattering cross section      '
      WRITE(LTT,691) '   8 - total scattering cross section   '
      WRITE(LTT,691) '   9 - group scattering matrix          '
      WRITE(LTT,691) '  10 - absorption resonance integrals   '
      WRITE(LTT,691) '  11 - fission resonance integrals      '
      WRITE(LTT,691) '  12 - fission spectrum                 '
      WRITE(LTT,691) '$ -1 - to finish                      : '
      READ (LKB,501) ISEL
      IF(ISEL.LT.0) GO TO 500
      IF(ISEL.LT.1 .OR. ISEL.GT.MSEL) GO TO 40
C* Define the output filename
      WRITE(LTT,691) ' Default output table filename        : ',FLNO
      WRITE(LTT,691) '$   Enter new name to redefine        : '
      READ (LKB,691) FLNM
      IF(FLNM.EQ.BLNK) FLNM=FLNO
      IF(FLNM.EQ.FLNO .AND. LF2.GT.0) GO TO 48
      FLNO=FLNM
      IF(LF2.GT.0) CLOSE(UNIT=LF2)
      LF2=IABS(LF2)
C***** VAX *****
C     OPEN (UNIT=LF2,FILE=FLNM,STATUS='NEW',CARRIAGECONTROL='LIST')
C***** VAX *****
C***** EXPORT *****
      OPEN (UNIT=LF2,FILE=FLNM,STATUS='UNKNOWN')
C***** EXPORT *****
C*
C* Begin processing the data files
   48 JFL=1
      GO TO 100
C* Error condition reading a file
   90 WRITE(LTT,691) ' Error reading file                     '
     1              ,  FLNI(JFL)
      WRITE(LTT,691) '$Enter new filename or blank to skip  : '
      READ (LKB,691) FLNI(JFL)
C* Loop over all the files
  100 JEL=0
      NEL=1
      MAT=RMT(JFL)+0.01
      IF(FLNI(JFL) .EQ. BLNK) GO TO 400
C***** VAX *****
C     OPEN (UNIT=LF1,FILE=FLNI(JFL),STATUS='OLD',ERR=90,READONLY)
C***** VAX *****
C***** EXPORT *****
      OPEN (UNIT=LF1,FILE=FLNI(JFL),STATUS='OLD',ERR=90)
C***** EXPORT *****
C* Identify the file format
      READ (LF1,701,ERR=160) JTERM,N1,N2,N3,N4
      IF(JTERM.NE.ITERM) GO TO 180
  110 IF(N1.EQ.0) GO TO 112
      IF(N1.EQ.4) GO TO 150
      IF(N1.EQ.2) GO TO 120
  112 CALL SKIPWF(LF1,ITERM,JTERM,N1,N2,N3,N4)
      IF(JTERM.LT.0) GO TO 90
      GO TO 110
C* Case: WILLIE fission spectrum file with labelled filemarks
  120 IF(ISEL.NE.12) GO TO 112
      IF(N2.GT.0) NG0=N2
  122 IF(NFL.GT.1) THEN
        COMM(JFL)=IDNT(ISEL)//'                              '
      ELSE
        COMM(JFL)( 1:10)=IDNT(ISEL)
      END IF
      CALL PTABSP(RWO(LBL),COMM(JFL),RWO(LGB),LF1,LF2,NG0)
      GO TO 400
C* Case: WILLIE cross section file with labelled filemarks
  150 IF(N2.GT.0 .AND. N2.NE.NG1) GO TO 90
      IF(N3.GT.0 .AND. N3.NE.NG2) GO TO 90
      IF(N4.GT.0 .AND. N4.NE.NG3) GO TO 90
      GO TO 200
C* Case: file without headers
  160 REWIND LF1
      GO TO 200
C* Case: WIMS library
  180 NEL=JTERM
      IF(N1.NE.NG )GO TO 90
      IF(N3.NE.NG1)GO TO 90
      IF(N4.NE.NG2)GO TO 90
      READ (LF1,701,ERR=90) NG3,NNFD,NFPD
      READ (LF1,701,ERR=90) (IWO(I),I=1,NEL)
C*       Blank-read the group boundaries
      READ (LF1,702) (RWO(LBL-1+I),I=1,NG)
C*       Check if fission spectrum is to be processed
      IF(ISEL.EQ.12) GO TO 122
C* Select the material to be processed
  185 IF(RMT(JFL).GT.0) GO TO 188
      WRITE(LTT,691) '$  Enter the selected material ident. : '
      READ (LKB,502,ERR=187) RMT(JFL)
      IF(RMT(JFL).EQ.0) GO TO 400
C* Check if material is on the list
      MAT=RMT(JFL)+0.001
      DO 186 I=1,NEL
      IF(IWO(I).EQ.MAT) GO TO 188
  186 CONTINUE
      WRITE(LTT,601) MAT
  187 WRITE(LTT,602) (IWO(J),J=1,NEL)
      GO TO 185
  188 CONTINUE
C* Skip to the beginning of the nuclide files
      CALL SKIPWF(LF1,ITERM,JTERM,N1,N2,N3,N4)
C*
C* Read the nuclide header card
  200 READ (LF1,704) ID,AW,IZ,NF,NT,NR
      IF(MAT.EQ.0 .OR. MAT.EQ.ID) GO TO 220
C* Skip to the next file
      CALL SKIPWF(LF1,ITERM,JTERM,N1,N2,N3,N4)
      IER=109
      IF(JTERM.LT.0) GO TO 590
      GO TO 240
C* Select the temperature for thermal cross section data
  220 IF(ISEL.GE.10) GO TO 230
  221 WRITE(LTT,691) '$  Enter temperature for cross sect.  : '
      READ (LKB,502,ERR=221) TMX
C* Tabulate the cross sections
  230 IF(NFL.GT.1) THEN
        COMM(JFL)(41:80)=IDNT(ISEL)//'                              '
      ELSE
        COMM(JFL)(41:80)=COMM(JFL)( 1:40)
        COMM(JFL)( 1:40)=IDNT(ISEL)//'                              '
      END IF
      WRITE(COMM(JFL)(61:68),605) ID
      CALL PTABXS(RWO(LBL),IWO,COMM(JFL),RWO(LGB),RWO(LGC)
     1           ,LF1,LF2,NG1,NG2,NG3,NF,NT,TMX,ISEL)
C* Check the filemark
      IER=110
      READ (LF1,701,ERR=590) JTERM
      IF(JTERM.NE.ITERM) GO TO 590
  240 JEL=JEL+1
      IF(JEL.LT.NEL) GO TO 200
C*
C* Begin processing the resonance files
  300 IF(ISEL.LT.10) GO TO 400
      IF(JFL .GT.1) GO TO 320
  302 WRITE(LTT,691) '$  Enter temperature for R.I.         : '
      READ (LKB,502,ERR=302) TM
      IF(TM.NE.0) TMR=TM
      WRITE(LTT,691) '$  Enter R.I. interp.( >0=SQRT(Sig0) ): '
      READ (LKB,502,ERR=302) TRP
      INT=0
      IF(TRP.GT.0) INT=1
      WRITE(LTT,691) '$  Enter group (default=all groups)   : '
      READ (LKB,502,ERR=302) GR
      JGR=GR+0.1
C* Tabulate the resonance integrals
  320 IF(NFL.GT.1) THEN
        COMM(JFL)(41:50)=IDNT(ISEL)
      ELSE
        COMM(JFL)( 1:10)=IDNT(ISEL)
      END IF
      CALL PTABRI(RWO(LBL),IWO,COMM(JFL),LF1,LF2
     1           ,NG1,NG2,NG3,JGR,RWO(LGC),RMT(JFL),TMR,ISEL,INT)
  400 CLOSE(UNIT=LF1)
      JFL=JFL+1
      IF(JFL.LE.NFL) GO TO 100
      GO TO 40
C* Processing completed (leave output unit open to allow append)
  500 CLOSE(UNIT=LF1)
      RETURN
C* Library read error
  590 CALL ERRWAR(LTT,IER)
      CLOSE(UNIT=LF1)
      CLOSE(UNIT=LF2)
      RETURN
  501 FORMAT(BN,I20)
  502 FORMAT(BN,F20.0)
  601 FORMAT(' WILLIE ERROR - Material',I6,' not found')
  602 FORMAT('   Select from the list below:'/ (6X,10I6) )
  603 FORMAT(' Processing material',F8.1,' completed'/)
  605 FORMAT('MAT',I5)
  691 FORMAT(2A40)
  701 FORMAT(5I15)
  702 FORMAT(1P,5E15.8)
  703 FORMAT(1P,3(E15.8,I6))
  704 FORMAT(1P,I6,E15.8,4I6)
  705 FORMAT(1P,I15/(5E15.8))
  706 FORMAT(1P,I15/E15.8,2I6/(5E15.8))
      END
      SUBROUTINE SKIPWF(LUN,ITERM,JTERM,N1,N2,N3,N4)
C-Title  : SKIPWF Subroutine
C-Purpose: Skip WIMS or WILLIE file till the next filemark
   10 READ (LUN,92,ERR=10,END=90) JTERM,N1,N2,N3,N4
      IF(JTERM.NE.ITERM) GO TO 10
      RETURN
C* EOF encountered before filemark
   90 JTERM=-1
      RETURN
   92 FORMAT(5I15)
      END
      SUBROUTINE PTABSP(RWO,COM,GEB,LF1,LF2,NG0)
C-Title  : PTABSP Subroutine
C-Purpose: Tabulate fission spectrum in PLOTTAB histogram format
      CHARACTER*80    COM
      DIMENSION       RWO(*),GEB(*)
      COMMON /TERWOR/ ITERM,ALDO(2)
C* Read the spectrum
      READ (LF1,702) (RWO(I),I=1,NG0)
C* Write the complete data set to output in ascending energy
   80 WRITE(LF2,800) COM
      EHI=GEB(NG0+1)
      DO 82 I=1,NG0
      ELO=EHI
      EHI=GEB(NG0+1-I)
      SP =RWO(NG0+1-I)/(EHI-ELO)
      WRITE(LF2,801) ELO,SP
      WRITE(LF2,801) EHI,SP
   82 CONTINUE
      WRITE(LF2,800)
      RETURN
  702 FORMAT(1P5E15.8)
  800 FORMAT(A80)
  801 FORMAT(1P,2E11.4)
      END
      SUBROUTINE PTABXS(RWO,IWO,COM,GEB,PLG,LF1,LF2
     1                 ,NG1,NG2,NG3,NF,NT,TMP,ISEL)
C-Title  : PTABXS Subroutine
C-Purpose: Tabulate cross sections in PLOTTAB histogram format
      CHARACTER*80    COM
      DIMENSION       RWO(*),IWO(*),GEB(*),PLG(*)
      COMMON /TERWOR/ ITERM,ALDO(2)
      NG12=NG1+NG2
      KLN =2*NG12+4*NG2
      LBL =1
      L1  =LBL
C* Read Epithermal cross sections
      READ (LF1,702)               (RWO(LBL-1+I),I=1,KLN)
C* Save SigP*Lambda
      DO 20 I=1,NG2
      PLG(I)=RWO(LBL-1+I)*RWO(LBL+2*NG12+3*NG2-1+I)
   20 CONTINUE
      LBL =LBL+KLN
C* Read fission yield and fission cross section
      KLN =2*NG12
      IF(NF.GT.1) READ (LF1,702)   (RWO(LBL-1+I),I=1,KLN)
      LBL =LBL+KLN
C* Read epithermal scattering matrix
   40 READ (LF1,705)               NDAT2,(RWO(LBL-1+I),I=1,NDAT2)
      LBL =LBL+NDAT2
C* Read temperature list for thermal cross sections
      READ (LF1,702)               (RWO(LBL-1+I),I=1,NT)
      LT  =LBL
      LBL =LBL+NT
      L2  =LBL
C* Read thermal cross sections for all temperatures
      DO 60 K=1,NT
      IF(RWO(LT-1+K).LE.TMP) L2=LBL
      KLN =2*NG3
      READ (LF1,702)               (RWO(LBL-1+I),I=1,KLN)
      LBL =LBL+KLN
      IF(NF.GT.1) READ (LF1,702)   (RWO(LBL-1+I),I=1,KLN)
      LBL =LBL+KLN
   50 READ (LF1,705)               NDAT3,(RWO(LBL-1+I),I=1,NDAT3)
      LBL =LBL+NDAT3
   60 CONTINUE
      IF(ISEL.GT.9) RETURN
C* Shift the selected epithermal data to beginning of work field
      NX =NG12
      LB =NG1+NG2+NG3+1
      IF(ISEL.LT.3) NX=NG2
      IF(ISEL.LT.3) LB=NG12+1
      IF(ISEL.EQ.1) LX=L1
      IF(ISEL.EQ.2) LX=L1+NG2
      IF(ISEL.EQ.3) LX=L1+NG2*2
      IF(ISEL.EQ.4) LX=L1+NG2*2+NG12
      IF(ISEL.EQ.5) LX=L1+NG2*4+NG12*2
      IF(ISEL.EQ.6) LX=L1+NG2*4+NG12*3
      IF(ISEL.GT.6) GO TO 72
C* Case: process epithermal cross sections
      DO 70 I=1,NX
      RWO(I)=RWO(LX-1+I)
   70 CONTINUE
      GO TO 75
C* Case: process epithermal scattering matrix
   72 LX  =L1+NG2*4+NG12*4
      ISS =8-ISEL
      IF(ISS.LT.0) STOP ' PTABMT MATRIX PRINTOUT OPTION NOT AVAILABLE'
      CALL XSMSUM(NG12,ISS,RWO(LX),RWO)
C* Shift the selected thermal data to beginning of work field
   75 IF(ISEL.LT.3) GO TO 80
      IF(ISEL.EQ.3) LX=L2
      IF(ISEL.EQ.4) LX=L2+NG3
      IF(ISEL.EQ.5) LX=L2+NG3*2
      IF(ISEL.EQ.6) LX=L2+NG3*3
      IF(ISEL.GT.6) GO TO 77
C* Case: process thermal cross sections
      DO 76 I=1,NG3
      RWO(I+NX)=RWO(LX-1+I)
   76 CONTINUE
      GO TO 78
C* Case: process thermal scattering matrix
   77 LX=L2+NG3*4
      CALL XSMSUM(NG3,ISS,RWO(LX),RWO(NX+1))
   78 NX  =NX+NG3
C* Write the complete data set to output in ascending energy
   80 WRITE(LF2,800) COM
      IF(NF.LT.2 .AND. (ISEL.EQ.5 .OR. ISEL.EQ.6)) GO TO 84
      IF(NF.NE.3 .AND.  ISEL.EQ.11               ) GO TO 84
      DO 82 I=1,NX
      WRITE(LF2,801) GEB(LB+1-I),RWO(NX+1-I)
      WRITE(LF2,801) GEB(LB  -I),RWO(NX+1-I)
   82 CONTINUE
   84 WRITE(LF2,800)
      RETURN
  701 FORMAT(5I15)
  702 FORMAT(1P5E15.8)
  705 FORMAT(1P,I15/(5E15.8))
  800 FORMAT(A80)
  801 FORMAT(1P,2E11.4)
      END
      SUBROUTINE PTABRI(RWO,IWO,COM,LF1,LF2,NG1,NG2,NG3,JG
     1                 ,PLG,RMT,TMP,ISEL,INT)
C-Title  : PTABRI Subroutine
C-Purpose: Tabulate Resonance Integrals in PLOTTAB format
      CHARACTER*80    COM
      DIMENSION       RWO(*),IWO(*),PLG(*)
      COMMON /TERWOR/ ITERM,ALDO(2)
C* Define the number of Sig0 points to be generated
      DATA NSG /181/
      LTM=1
      LS0=1000+1
      LR0=2000+1
C* Loop over resonance groups
      DO 90 KG=1,NG2
      IG =NG1+KG
      NRT=0
C* Implied loop over all res.tables in a group
   70 READ (LF1,701) M12
      IF(M12.EQ.ITERM) GO TO 90
      READ (LF1,706) RID,M1,M2,(RWO(LTM-1+I),I=1,M1),
     *                         (RWO(LS0-1+I),I=1,M2),
     *                         (RWO(LR0-1+I),I=1,M12)
      IF(RID.EQ.0.) GO TO 80
      IF( JG.GT.0   .AND. JG.NE.IG ) GO TO 70
      IF(RMT.NE.0.0 .AND. ABS(RID-RMT).GT.0.01) GO TO 70
      NRT=NRT+1
      IF(ISEL.EQ.10 .AND. NRT.NE.1) GO TO 70
      IF(ISEL.EQ.11 .AND. NRT.NE.2) GO TO 70
C* Determine the SigB interpolation table
      LBL=LR0 +M12
      LS1=LBL
      LR1=LS1+NSG
      DSG=EXP( ALOG(RWO(LS0+M2-1)/RWO(LS0)) / (NSG-1) )
      SG0=RWO(LS0)
      DO 72 I=1,NSG
      RWO(LS1-1+I)=SG0
      SG0 = SG0*DSG
   72 CONTINUE
      CALL INTERI(M2,NSG,RWO(LS0),RWO(LS1),RWO(LR0),RWO(LR1),INT)
C* Printout, convert WIMS SigB to Bondarenko Sif0
      WRITE(COM(44:50),699) IG
      WRITE(LF2,692) COM
      DO 74 I=1,NSG
      WRITE(LF2,601) RWO(LS1-1+I)-PLG(KG),RWO(LR1-1+I)
   74 CONTINUE
      WRITE(LF2,692)
      GO TO 70
C* Group resonance tables processed - check the file mark
   80 READ (LF1,701,ERR=98) JTERM
      IF(JTERM.NE.ITERM) GO TO 98
   90 CONTINUE
      RETURN
C* Library read error
   98 STOP 'PTABRI Read error'
  601 FORMAT(1P,2E11.4)
  692 FORMAT(A80)
  699 FORMAT('.GR.',I3)
  701 FORMAT(I15)
  706 FORMAT(1P,E15.8,2I6/(5E15.8))
      END
      SUBROUTINE SMTXTR(LKB,LTT,RWO,IWO,MXRW,MXIW)
C-Title  : SMTXTR Subroutine
C-Purpose: Correct the self-scattering term of the scatt.matrix
C-Description:
C-D  A cross section file such as produced by WILLIE option COPY
C-D  is processed. It generously allows labelled, unlabelled
C-D  as well as no-filemark formats. Cross sections and scattering
C-D  matrices are read and checked, a correction to the scattering
C-D  matrix is performed and a new WILLIE cross section file for
C-D  a material is written. Any P1 scattering matrices are ignored.
C-D
      CHARACTER*40 FLN1,FLN2,FLNM
      CHARACTER*80 REC
      DIMENSION RWO(*),IWO(*)
      COMMON /TERWOR/ ITERM,ALDO(2)
C* Default group structure (fast/resonance/thermal)
      DATA NG1,NG2,NG3/ 14, 13, 42 /
C* Local file units (unit 2 flagged -ve before opening)
      DATA LF1,LF2,LOU / 1,-2, 3 /
C* Define the source cross section filename
      WRITE(LTT,691) ' SOURCE CROSS SECTION DATA:             '
      GO TO 12
   11 WRITE(LTT,691) '                   ERROR reading file : ',FLN2
   12 WRITE(LTT,691) '$                   Enter the filename: '
      READ (LKB,691) FLN2
C***** VAX *****
C     OPEN(UNIT=LF1,FILE=FLN2,STATUS='OLD',ERR=11,READONLY)
C***** VAX *****
C***** EXPORT *****
      OPEN(UNIT=LF1,FILE=FLN2,STATUS='OLD',ERR=11)
C***** EXPORT *****
C* Define the output cross section filename
      IF(LF2.GT.0) GO TO 18
      LF2=-LF2
      WRITE(LTT,691) ' MODIFIED CROSS SECTION DATA:           '
      WRITE(LTT,691) '$                   Enter the filename: '
      READ (LKB,691) FLNM
      IF(FLNM.NE.'                                        ') FLN2=FLNM
C***** VAX *****
C     OPEN (UNIT=LF2,FILE=FLN2,STATUS='NEW',CARRIAGECONTROL='LIST')
C***** VAX *****
C***** EXPORT *****
      OPEN (UNIT=LF2,FILE=FLN2,STATUS='UNKNOWN')
C***** EXPORT *****
C* Try to interpret the filemark record
   18 REWIND LF2
      READ (LF1,701,ERR=26) JTERM, NTYP,JG1,JG2,JG3
      WRITE(LF2,701       ) JTERM, NTYP,JG1,JG2,JG3
      IF(NTYP.EQ.0) GO TO 32
   20 IF(NTYP - 4 ) 30,32,28
C* No cross section data found
   28 WRITE(LTT,691) '        No cross section data on file : ',FLN2
      GO TO 12
C* No labelled filemark present
   26 REWIND LF1
      GO TO 400
C* Inappropriate labelled filemark found - skip the data
   30 READ (LF1,693) REC
      WRITE(LF2,693) REC
      IF(REC(1:15).NE.'      999999999') GO TO 30
      READ (REC,701) JTERM, NTYP,JG1,JG2,JG3
      GO TO 20
C* Labelled filemark for cross section data found
   32 IF(JG1.GT.0) NG1=JG1
      IF(JG2.GT.0) NG2=JG2
      IF(JG3.GT.0) NG3=JG3
      NG12=NG1 +NG2
      NG = NG12+NG3
C* Begin processing the cross sections
  400 READ (LF1,704) MT1,AW1,IZ1,NF1,NT1,NR1
      WRITE(LF2,704) MT1,AW1,IZ1,NF1,NT1,NR1
C*
C* Epithermal cross sections processing
C*
  402 KLN=4*NG2+2*NG12
      KLF=2*NG12
      LS =1
C* Read the source epithermal data
      L1 =LS
      READ (LF1,702) (RWO(LS-1+I),I=1,KLN)
      WRITE(LF2,702) (RWO(LS-1+I),I=1,KLN)
      LS =LS+KLN
      IF(NF1.GE.2) READ (LF1,702) (RWO(LS-1+I),I=1,KLF)
      IF(NF1.GE.2) WRITE(LF2,702) (RWO(LS-1+I),I=1,KLF)
      LS =LS+KLF
      READ (LF1,705) KL1,(RWO(LS-1+I),I=1,KL1)
      LX1=LS
      LS =LS+KL1+NG12
      LO1=LS
C* Sum the scattering matrix elements
      CALL XSMSUM(NG12,0,RWO(LX1),RWO(LO1))
C* Calculate the necessary correction to the self-scattering term
      LZ1= L1+2*NG2
      DO 418 I=1,NG12
      RWO(LO1-1+I)=RWO(LO1-1+I)+RWO(LZ1-1+NG12+I) - RWO(LZ1-1+I)
  418 CONTINUE
C* Subtract the difference from the self-scattering term
      LSS=LX1
      DO 420 I=1,NG12
      NU =RWO(LSS  )+0.1
      NS =RWO(LSS+1)+0.1
      RWO(LSS+1+NU)=RWO(LSS+1+NU)-RWO(LO1-1+I)
      LSS=LSS+NS+2
  420 CONTINUE
      WRITE(LF2,705) KL1,(RWO(LX1-1+I),I=1,KL1)
C*
C* Thermal cross sections processing
C*
  430 KLN=2*NG3
      KLF=2*NG3
      LS =1
C* Read temperature list for thermal cross section tables
      READ (LF1,702) (RWO(LS-1+I),I=1,NT1)
      WRITE(LF2,702) (RWO(LS-1+I),I=1,NT1)
      LT1=LS
      LS =LS+NT1
      L1 =LS
C* Read the reference thermal data for one temperature
      IT1=0
  440 IT1=IT1+1
      IF(IT1.GT.NT1) GO TO 500
      LS =L1
      READ (LF1,702) (RWO(LS-1+I),I=1,KLN)
      WRITE(LF2,702) (RWO(LS-1+I),I=1,KLN)
      LS =LS+KLN
      IF(NF1.GE.2) READ (LF1,702) (RWO(LS-1+I),I=1,KLF)
      IF(NF1.GE.2) WRITE(LF2,702) (RWO(LS-1+I),I=1,KLF)
      LS =LS+KLF
      READ (LF1,705) KL1,(RWO(LS-1+I),I=1,KL1)
      LX1=LS
      LS =LS+KL1
      LO1=LS
C* Sum the scattering matrix elements
      CALL XSMSUM(NG3 ,0,RWO(LX1),RWO(LO1))
C* Calculate the necessary correction to the self-scattering term
      LZ1= L1
      DO 448 I=1,NG3
      RWO(LO1-1+I)=RWO(LO1-1+I)+RWO(LZ1-1+NG3 +I) - RWO(LZ1-1+I)
  448 CONTINUE
C* Subtract the difference from the self-scattering term
      LSS=LX1
      DO 450 I=1,NG3
      NU =RWO(LSS  )+0.1
      NS =RWO(LSS+1)+0.1
      RWO(LSS+1+NU)=RWO(LSS+1+NU)-RWO(LO1-1+I)
      LSS=LSS+NS+2
  450 CONTINUE
      WRITE(LF2,705) KL1,(RWO(LX1-1+I),I=1,KL1)
      GO TO 440
C* Rrocess resonance integral data if any
  500 IF(NF1.LT.1 .OR. NF1.GT.3) GO TO 600
C* Read the filemark and check for labels
      JRG=NR1
  510 READ (LF1,701,ERR=591,END=592) JTERM,N1,N2,N3,N4
      IF(JTERM.NE.ITERM) GO TO 514
      WRITE(LF2,701                ) JTERM,N1,N2,N3,N4
      IF(N1.NE.0 .AND. N1.NE.5) GO TO 594
      IF(N2.NE.0) JRG=N2
      IF(N3.NE.0) NG1=N3
      IF(N4.NE.0) NG2=N4
      READ (LF1,701,ERR=591,END=592) JTERM
      JRG=JRG+1
C* Read the resonance data
  514 WRITE(LF2,701                ) JTERM
      READ (LF1,706) AM1,NT1,NS1
      READ (LF2,706) AM1,NT1,NS1
      LL =NT1+NS1+NT1*NS1
      READ (LF1,702) (RWO(LS-1+J),J=1,LL)
      WRITE(LF2,702) (RWO(LS-1+J),J=1,LL)
C* Check if more groups to be processed, else finish
      IF(JRG.LT.NG1+NG2) GO TO 510
      GO TO 600
C* Error traps
  591 WRITE(LTT,611) ' COMPMT Error reading res. data on unit ',LF1
      GO TO 600
  592 WRITE(LTT,611) ' COMPMT E-O-F reading res. data on unit ',LF1
      GO TO 600
  594 WRITE(LTT,611) ' COMPMT incorrect file mark label found ',N1
C* All data compared
  600 WRITE(LF2,701                ) ITERM
      CLOSE (UNIT=LF1)
      CLOSE (UNIT=LF2)
      LF2=-LF2
      RETURN
  607 FORMAT(//    ' WILLIE - SCATTERING MATRIX TRANSPORT CORRECTION'/
     1             ' ==============================================='/)
  611 FORMAT(A40,2I2)
  691 FORMAT(2A40)
  693 FORMAT(A80)
  701 FORMAT(5I15)
  702 FORMAT(1P,5E15.8)
  704 FORMAT(1P,I6,E15.8,4I6)
  705 FORMAT(1P,I15/(5E15.8))
  706 FORMAT(1P,E15.8,2I6)
      END
      SUBROUTINE INCLMT(LKB,LTT,RWO,IWO,MXRW,MXIW)
C-Title  : INCLMT Subroutine
C-Purpose: Add data for a material into the WIMS library
C-Description:
C-D  A deta set extracted previously by the COPY option or
C-D  prepared otherwise can be inserted into the WIMS library
C-D  with a different nuclide identification number.
C-D
      CHARACTER*75    REC , REN
      CHARACTER*40    BLNK, FLNM, FLWI, FLWO, FLNI
      DIMENSION       RWO(*),IWO(*)
      COMMON /TERWOR/ ITERM,ALDO(2)
      DATA BLNK /'                                        '/
     1    ,FLWI /'WIMS.LIB'/
     1    ,FLWO /'WIMS.LIB'/
C* Default file units
      DATA LF1,LF2,LF3/ 1, 2, 3 /
C*
      NDAT1=0
      NFBU =0
      KR   =0
      KF   =0
      KG0  =0
C* Define the filenames
      GO TO 12
   11 WRITE(LTT,691) '                   ERROR opening file : ',FLWI
   12 WRITE(LTT,691) ' Default source formatted lib.filename: ',FLWI
      WRITE(LTT,691) '$             Enter filename to change: '
      READ (LKB,691,END=684) FLNM
      IF(FLNM.NE.BLNK) FLWI=FLNM
C***** VAX *****
C     OPEN (UNIT=LF1,FILE=FLWI,STATUS='OLD',ERR=11,READONLY)
C***** VAX *****
C***** EXPORT *****
      OPEN (UNIT=LF1,FILE=FLWI,STATUS='OLD',ERR=11)
C***** EXPORT *****
      GO TO 14
   13 WRITE(LTT,691) '                   ERROR opening file : ',FLNI
   14 WRITE(LTT,691) '$Enter nuclide data input filename    : '
      READ (LKB,691) FLNI
      IF(FLNI.EQ.BLNK) GO TO 683
C***** VAX *****
C     OPEN (UNIT=LF2,FILE=FLNI,STATUS='OLD',ERR=13,READONLY)
C***** VAX *****
C***** EXPORT *****
      OPEN (UNIT=LF2,FILE=FLNI,STATUS='OLD',ERR=13)
C***** EXPORT *****
      GO TO 16
   15 WRITE(LTT,691) '                   ERROR opening file : ',FLWO
   16 WRITE(LTT,691) ' Default new  formatted  lib. filename: ',FLWO
      WRITE(LTT,691) '$             Enter filename to change: '
      READ (LKB,691,END=682) FLNM
      IF(FLNM.NE.BLNK) FLWO=FLNM
C***** VAX *****
C     OPEN (UNIT=LF3,FILE=FLWO,STATUS='NEW',ERR=15
C    1     ,CARRIAGECONTROL='LIST')
C***** VAX *****
C***** EXPORT *****
      IF(FLWO.EQ.FLWI) GO TO 15
      OPEN (UNIT=LF3,FILE=FLWO,STATUS='UNKNOWN',ERR=15)
C***** EXPORT *****
C*
C* Verification printout
      WRITE(LTT,691)
      WRITE(LTT,691) ' Processing:                            '
      WRITE(LTT,691) '         Source WIMS-D library filename : ',FLWI
      WRITE(LTT,691) '           New  WIMS-D library filename : ',FLWO
      WRITE(LTT,691) '                Cross sections filename : ',FLNI
      WRITE(LTT,691)
C* Check the data to be inserted
      MAT=-1
      LGB=0
      LSP=0
      LBU=0
      LXS=0
      LRI=0
      LP1=0
      LSC=1000
      READ (LF2,701,ERR=102) JTERM, N1,N2,N3,N4
      GO TO 110
C* If file mark not found, assume only cross sections given
  102 REWIND LF2
      N1=0
      N2=0
      N3=0
      N4=0
      GO TO 140
  110 IF(N1.EQ.0 .OR. N1.GT.1) GO TO 120
C* - Group boundaries to be inserted
      IF(N2.GT.0) NG1=N2
      IF(N3.GT.0) NG2=N3
      IF(N4.GT.0) NG3=N4
      NG =NG1+NG2+NG3
      LGB=LSC
      LSC=LSC+NG+1
      READ (LF2,702) (RWO(LGB+I),I=1,NG+1)
      READ (LF2,701) JTERM, N1,N2,N3,N4
  120 IF(N1.EQ.0 .OR. N1.GT.2) GO TO 130
C* - Spectrum to be inserted
      IF(N2.GT.0) KG0=N2
      LSP=LSC
      LSC=LSC+KG0+1
      READ (LF2,702) (RWO(LSP+I),I=1,KG0)
      READ (LF2,701,END=141) JTERM, N1,N2,N3,N4
  130 IF(N1.EQ.0 .OR. N1.GT.3) GO TO 140
C* - Burnup data to be inserted
      READ (LF2,701) NDAT1
      LBU=LSC
      LSC=LSC+NDAT1/2
      READ (LF2,703) (RWO(LBU+I),IWO(LBU+I),I=1,NDAT1/2)
      READ (LF2,701,END=141) JTERM, N1,N2,N3,N4
C* Save the NF flag for consistency checks
      IF(NDAT1.EQ.8) NFBU=IWO(LBU+4)
C* - Cross section data to be inserted
  140 IF(N1.NE.0 .AND. N1.NE.4) GO TO 141
      READ (LF2,704,END=141) MAT,WW,KZ,KF,KT,KR
C*     Check NF in burnup data and cross sections consistency
      IF(KF.GT.1 .AND. NFBU.LT.0) THEN
        IF(KF.EQ.2 .AND. NFBU.NE.-2) THEN
        WRITE(LTT,691) ' WARNING - Absorption RI data present - '
     1                ,'Parameter NF should be -2               '
        END IF
        IF(KF.EQ.3) THEN
          WRITE(LTT,691) ' ERROR - Fissile material with fission  '
     1                  ,'RI tables is used as a fission product  '
          STOP 'WILLIE ERROR in burnup data'
        END IF
        WRITE(LTT,691) ' WARNING - Fissile material is used as a'
     1                ,' fission product                        '
        WRITE(LTT,691) '           Fission cross section deleted'
        NFBU= 0
        KF  =-KF
      ELSE
        NFBU= KF
      END IF
C* - Check for the material identifier
      WRITE(LTT,693) ' Default material ident. on file is   : ',MAT
      WRITE(LTT,691) '                Enter blank to accept , '
      WRITE(LTT,691) '                negative to quit      , '
      WRITE(LTT,691) '$               new value to redefine : '
      READ (LKB,696) RMT
C*     - Desired material is MAT
      IF(RMT.GT.0) MAT=RMT+0.01
      IF(RMT.LT.0) GO TO 681
      MAT1=MAT
C* Read the source library header and list of nuclides
  141 READ (LF1,701) NEL,NG,NG0,NG1,NG2,NG3,NNFD,NFPD
      READ (LF1,701) (IWO(I),I=1,NEL)
      KEL =NEL
      IF (KG0.LE.0) KG0=NG0
      KNFD=NNFD
      KFPD=NFPD
C* - Case: no new material data to be processed
      IF(MAT.LE.0) GO TO 146
      DO 144 I=1,NEL
      IF(IWO(I).NE.MAT) GO TO 144
C* - Case: material already exists - Define MAT1 to insert before MAT
      WRITE(LTT,693) ' Material ident. already exists    MAT: ',MAT
      WRITE(LTT,691) '        Enter blank to replace MAT      '
      WRITE(LTT,691) '        negative to quit                '
      WRITE(LTT,691) '$       new ident to insert before MAT: '
      READ (LKB,696) RMT
      WRITE(LTT,691)
      IF(RMT.GT.0) MAT1=RMT+0.01
      IF(RMT.LT.0) GO TO 681
C*      -- Material MAT is to be replaced MAT=MAT1
      IF(MAT.EQ.MAT1) GO TO 146
C*      -- Material MAT1 is to be inserted before material MAT
      MT2=IWO(I)
      IWO(I)=MAT1
      DO 142 J=I,NEL
      MT1=IWO(J+1)
      IWO(J+1)=MT2
      MT2=MT1
  142 CONTINUE
      GO TO 145
  144 CONTINUE
C* - Case: material is to be inserted
      IWO(NEL+1)=MAT
C*         Add burnup data if missing
  145 IF(LBU.LE.0) THEN
        NDAT1=2
        LBU=LSC
        LSC=LSC+NDAT1/2
        RWO(LBU+1)=0.
      END IF
      IWO(LBU+1)=MAT1
      KEL =NEL+1
      KNFD=NNFD
      KFPD=NFPD
      IF(NDAT1.GT.8) THEN
        KNFD=KNFD+1
      ELSE IF(NDAT1.EQ.8) THEN
         IF (IWO(LBU+4).LT.2) THEN
           KFPD=KFPD+1
         ELSE
           KNFD=KNFD+1
         ENDIF
      ENDIF
C* Write the library header
  146 WRITE(LF3,701) KEL,NG,KG0,NG1,NG2,NG3,KNFD,KFPD
      WRITE(LF3,701) (IWO(I),I=1,KEL)
C* Write the group boundaries
      KLEN=NG+1
      READ (LF1,702) (RWO(    I),I=1,KLEN)
      WRITE(LF3,702) (RWO(LGB+I),I=1,KLEN)
C* Write the fission spectrum
      READ (LF1,702) (RWO(    I),I=1,NG0)
      WRITE(LF3,702) (RWO(LSP+I),I=1,KG0)
C* Process the burnup chains data
      DO 324 J=1,NEL
      READ (LF1,701) JDAT1
      READ (LF1,703) (RWO(  I),IWO(  I),I=1,JDAT1/2)
      L =0
      IF(IWO(1).NE.MAT .OR. LBU.EQ.0) GO TO 322
      IF(MAT.EQ.MAT1) GO TO 321
C* - Insert the burnup data before MAT
      WRITE(LF3,701) NDAT1
      WRITE(LF3,703) (RWO(LBU+I),IWO(LBU+I),I=1,NDAT1/2)
      WRITE(LTT,693) ' Burnup data added for material         ',MAT1
      GO TO 322
C* - Replace the burnup data if same material is processed
  321 L =LBU
      IF (JDAT1.EQ.2 .AND. NDAT1.GT.2) THEN
        WRITE(LTT,691) ' WARNING - A non burnable material repla'
     1                ,'ced by a burnable one.                  '
        WRITE(LTT,691) ' Run WILLIE CHCK Option...              '
      ELSE IF (JDAT1.EQ.8) THEN
        IF (NDAT1.LT.8) THEN
        WRITE(LTT,691) ' WARNING - A burnable material replaced '
     1                ,'by a non-burnable one.                  '
        WRITE(LTT,691) ' Run WILLIE CHCK Option...              '
        ELSE IF ((IWO(4).LT.2) .AND. (IWO(L+4).GT.2)) THEN
        WRITE(LTT,691) ' WARNING - A burnable material replaced '
     1                ,'by a fissile one.                       '
        WRITE(LTT,691) ' Run WILLIE CHCK Option...              '
        ELSE IF ((IWO(4).GT.2) .AND. (IWO(L+4).LT.2)) THEN
        WRITE(LTT,691) ' WARNING - A fissile material replaced b'
     1                ,'y a burnable one.                       '
        WRITE(LTT,691) ' Run WILLIE CHCK Option...              '
        ENDIF
      ELSE
        IF (NDAT1.LT.8) THEN
        WRITE(LTT,691) ' WARNING - A fissile material replaced b'
     1                ,'y a non-burnable one.                   '
        WRITE(LTT,691) ' Run WILLIE CHCK Option...              '
        ELSE IF ((NDAT1.EQ.8) .AND. (IWO(L+4).LT.2)) THEN
        WRITE(LTT,691) ' WARNING - A fissile material replaced b'
     1                ,'y a burnable one.                       '
        WRITE(LTT,691) ' Run WILLIE CHCK Option...              '
        ENDIF
      ENDIF
      JDAT1=NDAT1
      WRITE(LTT,693) ' Burnup data replaced for material      ',MAT
  322 WRITE(LF3,701) JDAT1
      WRITE(LF3,703) (RWO(L+I),IWO(L+I),I=1,JDAT1/2)
  324 CONTINUE
      IF(KEL.EQ.NEL .OR. MAT.NE.MAT1) GO TO 326
C* - Add the burnup data for the new material
      IF(LBU.GT.0) GO TO 325
      NDAT1=2
      RWO(1)=0.
      IWO(1)=MAT
  325 WRITE(LF3,701) NDAT1
      WRITE(LF3,703) (RWO(LBU+I),IWO(LBU+I),I=1,NDAT1/2)
      WRITE(LTT,693) ' Burnup data added for material      ',MAT
C* Check for the file mark at the end of burnup data
  326 IER=51
      READ (LF1,701) JTERM
      IF(JTERM.NE.ITERM) GO TO 690
      WRITE(LF3,701) ITERM
C* Copy the nuclide cross section data from the old library
      DO 434 J=1,NEL
      LFO=LF3
      READ (LF1,704) ID,AW,IZ,NF,NT,NR
      IF(ID.NE.MAT) GO TO 328
C* Copy the new cross section data
      WRITE(LF3,704) MAT1,WW,KZ,NFBU,KT,KR
      CALL PROCXS(RWO,IWO,LF2,LF3,NG1,NG2,NG3,KF,KT)
C* Mark that resonance data need to be inserted
      IF(KR.GT.0) LRI=1
      IF(MAT.EQ.MAT1) THEN
C* If replaced material has resonance data, overwrite
        IF(NR.GT.0) LRI=0
        WRITE(LTT,693) ' Cross sections replaced for material   ',MAT
      ELSE
        WRITE(LTT,693) ' Cross sections inserted for material   ',MAT1
      END IF
      IER=51
      READ (LF2,701) JTERM, N1,N2,N3,N4
      IF(JTERM.NE.ITERM) GO TO 690
      WRITE(LF3,701) ITERM
C* To replace cross section data, skip file in the orig. library
      IF(MAT.EQ.MAT1) LFO=0
C* Copy or skip the cross section data from the original file
  328 IF(LFO.GT.0) THEN
        WRITE(LF3,704) ID,AW,IZ,NF,NT,NR
C* Mark the MAT number before which to insert resonance data
        IF(LRI.GT.0 .AND. NR.GT.0) THEN
          MAT=ID
          LRI=0
        END IF
      END IF
      CALL PROCXS(RWO,IWO,LF1,LFO,NG1,NG2,NG3,NF,NT)
      IER=51
      READ (LF1,701) JTERM, N1,N2,N3,N4
      IF(JTERM.NE.ITERM) GO TO 690
      IF(LFO.GT.0) WRITE(LF3,701) ITERM
  434 CONTINUE
      IF(KEL.EQ.NEL .OR. MAT.NE.MAT1) GO TO 500
C* Add the nuclide cross section data for the new material at the end
      WRITE(LF3,704) MAT,WW,KZ,NFBU,KT,KR
      CALL PROCXS(RWO,IWO,LF2,LF3,NG1,NG2,NG3,KF,KT)
      WRITE(LTT,693) ' Cross sections added for material      ',MAT
      IER=52
      READ (LF2,701) JTERM, N1,N2,N3,N4
      IF(JTERM.NE.ITERM) GO TO 690
      WRITE(LF3,701) ITERM
C* Loop over all groups for the resonance integrals
  500 DO 550 J=1,NG2
C* Determine the number of new resonance tables
      NRT=KR*( (KF+1)/2 )
      IF(KF.EQ.4) NRT=0
C* Read the resonance integrals from the old library
  532 L1=0
      READ (LF1,706) M12,RID,M1,M2
      READ (LF1,702)               (RWO(L1+I    ),I=1,M1),
     *                             (RWO(L1+I+100),I=1,M2),
     *                             (RWO(L1+I+200),I=1,M12)
      L2=L1+200+M12
      ID=RID+0.001
      IF(ID.GT.0 .AND. ID.NE.MAT) GO TO 536
C* Write the new resonance integrals
      IF(NRT.LE.0) GO TO 535
      DO 534 K=1,NRT
      READ (LF2,706) J12,RJD,J1,J2
      READ (LF2,702)               (RWO(L2+I    ),I=1,J1),
     *                             (RWO(L2+I+100),I=1,J2),
     *                             (RWO(L2+I+200),I=1,J12)
      IF(RMT.GT.0) RJD=RMT
      WRITE(LF3,706) J12,RJD,J1,J2
      WRITE(LF3,702)               (RWO(L2+I    ),I=1,J1),
     *                             (RWO(L2+I+100),I=1,J2),
     *                             (RWO(L2+I+200),I=1,J12)
  534 CONTINUE
      NRT=0
  535 IF(ID.EQ.MAT .AND. MAT.EQ.MAT1) GO TO 532
C* Copy the old resonance integrals
  536 WRITE(LF3,706) M12,RID,M1,M2
      WRITE(LF3,702)               (RWO(L1+I    ),I=1,M1),
     *                             (RWO(L1+I+100),I=1,M2),
     *                             (RWO(L1+I+200),I=1,M12)
C* Group resonance integral table terminated by dummy RID=0
      IF(RID.NE. 0. ) GO TO 532
C* Check the file marks
      IER=53
      READ (LF1,701) JTERM, K1,K2,K3,K4
      IF(JTERM.NE.ITERM) GO TO 690
      IER=54
      IF(KR.GT.0) READ (LF2,701) JTERM, N1,N2,N3,N4
      IF(JTERM.NE.ITERM) GO TO 690
      WRITE(LF3,701) ITERM
  550 CONTINUE
      IF(KR.GT.0)
     1WRITE(LTT,694) ' Resonance integrals written for mat.   ',RJD
C* Check for any P1 scattering data
      JP1=-1
      LBL=1
      L2 =LBL
      IC2=0
  610 IF(N1.EQ.0 .OR. N1.EQ.6) GO TO 612
      CALL SKIPWF(LF2,ITERM,JTERM,N1,N2,N3,N4)
      IF(JTERM.LT.0 .OR. N2.LT.0) GO TO 630
      GO TO 610
  612 READ (LF2,692,END=630) REN
C* P1 matrix to be added - inquire about the position
      WRITE(LTT,691) ' Enter the P1-scattering matrix position'
      WRITE(LTT,691) '$     "n" to replace, blank to append : '
      READ (LKB,695) JP1
C* Identify the format of the data to be added
      READ (REN,701,ERR=630) KL2
      READ (LF2,702) (RWO(L2-1+J),J=1,KL2)
      IC2=1
      LBL=LBL+KL2
C* Copy the P1 scattering matrices from the old library
  630 IC1=0
      NP1=0
  640 NP1=NP1+1
C* Identify the format on the original library (full or condensed)
C* Next card may be the last filemark, matrix length or data
      IER=56
      READ (LF1,692,END=690) REC
      READ (REC,701,ERR=650) KL1
      IF(KL1.NE.ITERM) GO TO 642
C* Filemark found - Check if new data had already been written
      IF(JP1.EQ.0 .OR. JP1.GE.NP1) GO TO 660
      GO TO 680
C* Case-source lib.: copy condensed P1 matrices
  642 L1 =LBL
      READ (LF1,702) (RWO(L1-1+J),J=1,KL1)
      IF(JP1.EQ.NP1) GO TO 660
      WRITE(LTT,693) '             Copy  condensed P1-matrix  ',NP1
      WRITE(LF3,701) KL1
      WRITE(LF3,702) (RWO(L1-1+J),J=1,KL1)
      GO TO 640
C* Case-source lib.: copy uncondensed P1 matrices (as char.strings)
  650 NR =(NG+4)/5
      JG =0
      IF(JP1.NE.NP1)
     1WRITE(LTT,693) '             Copy expanded P1-matrix    ',NP1
  651 JG =JG+1
      IF(JP1.NE.NP1) WRITE(LF3,692) REC
      DO 652 K=2,NR
      READ (LF1,692) REC
      IF(JP1.NE.NP1) WRITE(LF3,692) REC
  652 CONTINUE
      IF(JG.GE.NG) GO TO 654
      READ (LF1,692) REC
      GO TO 651
  654 IF(JP1.NE.NP1) GO TO 640
C* Check how the new data are to be written
  660 IF(IC2.EQ.  0) GO TO 670
      IF(IC1.EQ.  0) GO TO 664
C* Case-target lib.: New data may be written in condensed format
      WRITE(LTT,693) '             Write condensed P1-matrix  ',NP1
      WRITE(LF3,701) KL2
      WRITE(LF3,702) (RWO(L2-1+J),J=1,KL2)
      GO TO 640
C* Case-target lib.: Expand new data to uncondensed format
  664 JG=0
      LJ=L2
      LS=LBL
      WRITE(LTT,693) '             Expand new P1-matrix       ',NP1
  665 JG=JG+1
      DO 667 J=1,NG
      RWO(LS-1+J)=0.
  667 CONTINUE
      NU =RWO(LJ  )+0.1
      NS =RWO(LJ+1)+0.1
      DO 668 J=1,NS
      RWO(LS+JG-NU-1+J)=RWO(LJ+1+J)
  668 CONTINUE
      WRITE(LF3,702) (RWO(LS-1+J),J=1,NG)
      LJ=LJ+2+NS
      IF(JG.LT.NG) GO TO 665
      GO TO 640
C* Case-target lib.: New data in uncondensed format - copy as characters
  670 JG =0
      WRITE(LTT,693) '             Write expanded P1-matrix   ',NP1
  671 JG =JG+1
      WRITE(LF3,692) REN
      IER=58
      NR =(NG+4)/5
      DO 672 K=2,NR
      READ (LF2,692,ERR=690) REN
      WRITE(LF3,692)         REN
  672 CONTINUE
      IF(JG.GE.NG) GO TO 640
C* Check if any more matrices are to be processed
      READ (LF2,692) REN
      GO TO 671
C* All P1 scattering matrices processed - finish
  680 WRITE(LF3,701) ITERM
C* All processing completed
  681 CLOSE(UNIT=LF3)
  682 CLOSE(UNIT=LF2)
  683 CLOSE(UNIT=LF1)
  684 RETURN
C* Error condition reading the library
  690 CALL ERRWAR(LTT,IER)
      RETURN
  691 FORMAT(2A40)
  692 FORMAT(A75)
  693 FORMAT(A40,I8)
  694 FORMAT(A40,F8.1)
  695 FORMAT(BN,I10)
  696 FORMAT(BN,F10.0)
  701 FORMAT(5I15)
  702 FORMAT(1P,5E15.8)
  703 FORMAT(1P,3(E15.8,I6))
  704 FORMAT(1P,I6,E15.8,4I6)
  705 FORMAT(1P,I15/(5E15.8))
  706 FORMAT(1P,I15/E15.8,2I6)
      END
      SUBROUTINE MIXMAT(LKB,LTT,RWO,IWO,MXRW,MXIW)
C-Title  : MIXMAT Subroutine
C-Purpose: Mix WIMS library cross section data sets
C-Description:
C-D  The module allows wimsing of cross sections of fission spectra
C-D  to make a new composite data set
C-D    Cross section files such as produced by WILLIE option COPY
C-D  are processed. The module generously allows labelled, unlabelled
C-D  as well as no-filemark formats. If fissin spectra are processed,
C-D  the source file must be labelled (NTYPE=2). Cross sections from
C-D  several files are read, each scaled by the weighting factor
C-D  defined from input. The result is a new material which is written
C-D  to output in the WIMS-D format so that it can be processed further
C-D  by other modules if desired. One of the purposes of this module
C-D  is to generate element cross section files from isotopic data.
C-D    The WIMS-D/4 code allows resonance integrals to be specified
C-D  for materials appearing in the fuel only. Such materials are
C-D  usually given by isotopes. Mixing of the resonance integral data
C-D  is not supported by this module.
C-D
      CHARACTER*40 FLNI,FLNO,FLNL, BLNK
      DIMENSION RWO(*),IWO(*),YD(4),ID(4)
      COMMON /TERWOR/ ITERM,ALDO(2)
C* Default group structure (fast/resonance/thermal)
      DATA NG1,NG2,NG3/ 14, 13, 42 /
C* Alternative group structure
      DATA MG1,MG2,MG3/ 45, 47, 80 /
C* Default output filename
      DATA BLNK /'                                        '/
     7     FLNL /'MIXMAT.LOG'/
C* Local file units
      DATA LIN,LOU,LFL / 1, 2, 7 /
C* Limit for the number of thermal temperatures
      MXT=6
C* Initialize parameters
      AB0=0.
      AW0=0.
      ZZ0=0.
      NF0=0
      NT0=0
      NR0=0
      NMT=0
      NOD=0
C* Reserve and initialize the output cross section field
C*  L1 - pot., sl.dwn.pwr, epith.transp., absorpt., Xi and Lambda
C*  L5 - epithermal neutron fission yield and fission cross section
C*  L7 - epithermal scattering matrix
C*  L8 - thermal temperature list
C*  L9 - thermal transport and absorption cross section
C*  L10- thermal neutron fission yield and fission cross section
C*  L12- thermal scattering matrix
      L1 = 1
      LBL= 1
C...  N12= NG1+NG2
C...  NGR= N12+NG3
C...  NSP= N12
C...  L1 = 1
C...  L5 = L1 +NG2*4 +N12*2
C...  L7 = L5 +N12*2
C...  L8 = L7 +NGR*N12
C...  L9 = L8 +MXT
C...  L10= L9 +MXT*NG3*2
C...  L12= L10+MXT*NG3*2
C...  LBL= L12+MXT*NG3*NG3
C...  IF(LBL.GT.MXRW) STOP 'WILLIE MIXMAT - Array capacity exceeded 1'
C...  DO 10 I=L1,LBL
C...  RWO(I)=0.
C...10 CONTINUE
C* Open the log file for diagnostic messages
C***** VAX *****
C     OPEN(UNIT=LFL,FILE=FLNL,STATUS='NEW',CARRIAGECONTROL='LIST')
C***** VAX *****
C***** EXPORT *****
      OPEN(UNIT=LFL,FILE=FLNL,STATUS='UNKNOWN')
C***** EXPORT *****
C* Write the header to logfile and terminal
      WRITE(LFL,606)
      WRITE(LFL,607)
      GO TO 6
   5  WRITE(LTT,691) '                   ERROR opening file : ',FLNO
   6  WRITE(LTT,691) ' Enter the OUTPUT cross section filename'
      WRITE(LTT,691) '$        BLANK = Default = MIXMAT.XSW : '
      READ (LKB,691) FLNO
      IF(FLNO.EQ.BLNK)FLNO='MIXMAT.XSW'
C* Open the output cross section filename
C***** VAX *****
C     OPEN(UNIT=LOU,FILE=FLNO,STATUS='NEW',CARRIAGECONTROL='LIST',ERR=5)
C***** VAX *****
C***** EXPORT *****
      OPEN(UNIT=LOU,FILE=FLNO,STATUS='UNKNOWN',ERR=5)
C***** EXPORT *****
      WRITE(LTT,691) '    Enter WIMS ID. for the new material '
      WRITE(LTT,691) '$        ID.LE.0 = Default = 1000*Z+A : '
      READ (LKB,695) MWID
      GO TO 12
C* Define the source cross section filename
   11 WRITE(LTT,691) '                   ERROR reading file : ',FLNI
   12 WRITE(LTT,691)
      WRITE(LTT,691) ' Enter INPUT cross section data filename'
      WRITE(LTT,691) '$                   BLANK = To Finish : '
      READ (LKB,691) FLNI
      IF(FLNI.EQ.BLNK) GO TO 500
C***** VAX *****
C     OPEN(UNIT=LIN,FILE=FLNI,STATUS='OLD',ERR=11,READONLY)
C***** VAX *****
C***** EXPORT *****
      OPEN(UNIT=LIN,FILE=FLNI,STATUS='OLD',ERR=11)
C***** EXPORT *****
C* Define the abundance
      WRITE(LTT,691) ' Enter abundance ( 0  to skip) [at.%] : '
      READ (LKB,694) AB1
      IF(AB1.GT. 0 ) GO TO 18
      CLOSE(UNIT=LIN)
      GO TO 12
C* Try to interpret the filemark record
   18 READ (LIN,701,ERR=22) JTERM, NTYP,JG1,JG2,JG3
   20 IF(NTYP.EQ.0 .OR. NTYP.EQ.4) GO TO 32
      IF(NTYP.EQ.2) GO TO 40
      IF(NTYP.EQ.3) GO TO 25
      IF(NTYP.LT.4) GO TO 30
      GO TO 38
C* No labelled filemark present - define group structure
   22 REWIND LIN
      IF(NMT.GT.0) GO TO 400
C...  WRITE(LTT,691)
C...  WRITE(LTT,691) ' WARNING - No labelled filemarks on file'
C...  WRITE(LTT,691) '$         Enter number of fast groups : '
C...  READ (LKB,695) JG1
C...  WRITE(LTT,691) '$    Enter number of resonance groups : '
C...  READ (LKB,695) JG2
C...  WRITE(LTT,691) '$      Enter number of thermal groups : '
C...  READ (LKB,695) JG3
      GO TO 32
C* Burnup data record
   25 READ (LIN,701) NNN
      NNNN=NNN/2
      IF (NNNN.GT.4) THEN
        CLOSE(LIN)
        CLOSE(LOU)
        STOP ' WILLIE MIXMAT: Burnup Record Array capacity excedeed 2 '
      ENDIF
      IF (NOD.EQ.0) THEN
        NOD=NNN
      ELSE
        IF(NNN.NE.NOD) THEN
         WRITE(*,*)' Different burnup record length found, last assumed'
        ENDIF
      ENDIF
      READ (LIN,707) (YD(I),ID(I),I=1,NNNN)
C* Inappropriate filemark label found - skip to the next filemark
   30 READ (LIN,701,ERR=30) JTERM, NTYP,JG1,JG2,JG3
      GO TO 20
C* Labelled filemark for cross section data found
   32 IF(NMT.GT.0) GO TO 36
C* First labelled filemarks file may redefine the groups
      IF(JG1.EQ. 0 ) JG1=NG1
      IF(JG2.EQ. 0 ) JG2=NG2
      IF(JG3.EQ. 0 ) JG3=NG3
C* Redefine the group structure and re-initialize the work field
      NG1=JG1
      NG2=JG2
      NG3=JG3
      N12= NG1+NG2
      NGR= N12+NG3
      L1 = 1
      L5 = L1 +NG2*4 +N12*2
      L7 = L5 +N12*2
      L8 = L7 +NGR*N12
      L9 = L8 +MXT
      L10= L9 +MXT*NG3*2
      L12= L10+MXT+NG3*2
      LBL= L12+MXT*NG3*NG3
      IF(LBL.GT.MXRW) STOP 'MIXMAT ERROR - MXRW limit exceeded'
      DO 34 I=L1,LBL
      RWO(I)=0.
   34 CONTINUE
      GO TO 400
C* Subsequent files must have the same group structure
   36 IF(JG1.GT.0 .AND. JG1.NE.NG1) GO TO 37
      IF(JG2.GT.0 .AND. JG2.NE.NG2) GO TO 37
      IF(JG3.GT.0 .AND. JG3.NE.NG3) GO TO 37
      GO TO 400
C* Error condition on group structure
   37 WRITE(LTT,691) ' Incompatible group structure on file : ',FLNI
      GO TO 12
C* No cross section data found
   38 WRITE(LTT,691) '        No cross section data on file : ',FLNI
      GO TO 12
C* Labelled filemark for fission spectrum data found
   40 WRITE(LTT,691) ' Fission spectrum data encountered      '
      IF(NMT.GT.0) GO TO 100
C* First labelled filemarks file may redefine the spectral groups
      IF(JG1.EQ. 0 ) JG1=NSP
      NSP=JG1
      IF(LBL.LE.L1) LBL=L1+NSP
      DO 42 I=1,NSP
      RWO(L1-1+I)=0.
   42 CONTINUE
C*
C* Begin processing the fission spectra
  100 WRITE(LFL,608) MT0,AW0,IZ0,NF0,NT0,NR0,AB1,FLNI
      NMT= NMT+ 1
      AB0= AB0+ AB1
      ABF= AB1* 0.01
      READ(LIN,702) (RWO(LBL-1+I),I=1,NSP)
      DO 120 I=1,NSP
  120 RWO(L1-1+I)=RWO(L1-1+I) + ABF*RWO(LBL-1+I)
C* Fission spectrum processing completed - any additional data ignored
      CLOSE (UNIT=LIN)
      GO TO 12
C*
C* Begin processing the cross sections
  400 READ (LIN,704) MT1,AW1,IZ1,NF1,NT1,NR1
C* Request additional information for the current material
      WRITE(LTT,607)
      WRITE(LTT,608) MT1,AW1,IZ1,NF1,NT1,NR1,AB1,FLNI
C* Check the parameter for the thermal temperature list
  401 WRITE(LFL,608) MT1,AW1,IZ1,NF1,NT1,NR1,AB1,FLNI
      IF(NT0.EQ.0) NT0=NT1
      IF(NT1.EQ.1 .AND. NT0.GT.1) WRITE(LTT,691)
     1 ' MIXMAT WARNING - No temperature depende'
     2,'nce for this material                   '
      IF(NT1.GT.1 .AND. NT0.NE.NT1) THEN
        WRITE(LTT,691) ' MIXMAT ERROR - Incompatible temperature'
     1                ,' list - data abandoned                  '
        CLOSE(UNIT=LIN)
        GO TO 12
      END IF
C* Check the fission flag parameter
      IF(NF1.GT.0 .AND. NF1.NE.4) WRITE(LTT,691)
     1 ' MIXMAT WARNING - Res. tables ignored   '
      IF(NF1.GE.2) NF0=4
C* Check the resonance tables parameter
      IF(NR1.GT.0) WRITE(LTT,691)
     1 ' MIXMAT WARNING - Res. tables ignored   '
C* Calculate averages
      NMT= NMT+ 1
      AB0= AB0+ AB1
      ABF= AB1* 0.01
      AW0= AW0+ ABF*AW1
      ZZ0= ZZ0+ ABF*FLOAT(IZ1)
C*
C* Epithermal cross sections processing
      KLN=4*NG2+2*N12
      KLF=2*N12
      LSC=MAX(LBL+N12*NGR, LBL+KLN, LBL+KLF)
      IF(LSC.GT.MXRW) STOP 'WILLIE MIXMAT - Array capacity exceeded 2'
C* Process the epithermal cross sections
      READ(LIN,702,ERR=490) (RWO(LBL-1+I),I=1,KLN)
      DO 414 I=1,KLN
      RWO(L1-1+I)=RWO(L1-1+I) + ABF*RWO(LBL-1+I)
  414 CONTINUE
C* Process the epithermal fission yield and x-set. (if present)
      IF(NF1.LT.2) GO TO 420
      READ(LIN,702) (RWO(LBL-1+I),I=1,KLF)
      DO 416 I=1,KLF
      RWO(L5-1+I)=RWO(L5-1+I) + ABF*RWO(LBL-1+I)
  416 CONTINUE
C* Process the epithermal scattering matrix
  420 READ(LIN,705,ERR=490) KL1,(RWO(LBL-1+I),I=1,KL1)
      LB1=LBL
      DO 422 I=1,N12
      LBB=LB1
      LBS=RWO(LBB)  +0.1
      LBT=RWO(LBB+1)+0.1
      LB1=LBB+LBT+2
      J12=L7+(I-1)*NGR + I-LBS
      DO 422 J=1,LBT
      RWO(J12-1+J)=RWO(J12-1+J) + ABF*RWO(LBB+1+J)
  422 CONTINUE
C*
C* Thermal cross sections processing
      KLN=2*NG3
      KLF=2*NG3
      K9 =LBL
      K10=K9 +KLN
      K12=K10+KLF
      LSC=K12+NG3*NG3
      IF(LSC.GT.MXRW) STOP 'WILLIE MIXMAT - Array capacity exceeded 3'
C* Read and check the thermal cross sections temperature list
      READ(LIN,702) (RWO(LBL-1+I),I=1,NT1)
      DO 432 I=1,NT1
      IF(NMT.EQ.1) RWO(L8-1+I)=RWO(LBL-1+I)
      IF(ABS(RWO(L8-1+I)-RWO(LBL-1+I)).GT. 0.5) WRITE(LFL,691)
     1 ' MIXMAT WARNING - Incompatible temperatu'
     2,'re list encountered                     '
  432 CONTINUE
C* Loop over thermal temperatures
      DO 480 IT0=1,NT0
      M9 = L9+(IT0-1)*KLN
      M10=L10+(IT0-1)*KLF
      M12=L12+(IT0-1)*NG3*NG3
C* Read all thermal data for one temperature
      IF(IT0.GT.NT1) GO TO 450
      READ(LIN,702) (RWO(K9-1+I),I=1,KLN)
      IF(NF1.GE.2) READ(LIN,702) (RWO(K10-1+I),I=1,KLF)
      READ(LIN,705) KL1,(RWO(K12-1+I),I=1,KL1)
C* Process the thermal cross sections
  450 DO 454 I=1,KLN
      RWO( M9-1+I)=RWO( M9-1+I) + ABF*RWO( K9-1+I)
  454 CONTINUE
C* Process the thermal fission yield and x-set. (if present)
      IF(NF1.LT.2) GO TO 460
      DO 456 I=1,KLF
      RWO(M10-1+I)=RWO(M10-1+I) + ABF*RWO(K10-1+I)
  456 CONTINUE
C* Process the thermal scattering matrix
  460 LB1=K12
      DO 462 I=1,NG3
      LBB=LB1
      LBS=RWO(LBB)  +0.1
      LBT=RWO(LBB+1)+0.1
      LB1=LBB+LBT+2
      J12=M12+(I-1)*NG3
      DO 462 J=1,LBT
C*      Suppress upscattering into the epithermal groups
      JJ =MAX(0, J-1+I-LBS)
      RWO(J12+JJ)=RWO(J12+JJ) + ABF*RWO(LBB+1+J)
  462 CONTINUE
  480 CONTINUE
C* Cross section data processing completed - any additional data ignored
      CLOSE (UNIT=LIN)
      GO TO 12
C* On read error try for 172-group library
  490 IF(NGR.EQ.172 .OR. NMT.GT.1)
     1 STOP 'MIXMAT ERROR - Unknown group structure'
      NMT=NMT-1
      NG1=MG1
      NG2=MG2
      NG3=MG3
      JG1=0
      JG2=0
      JG3=0
      NGR=NG1+NG2+NG3
      REWIND LIN
      WRITE(LTT,691)
      WRITE(LTT,691) ' MIXMAT WARNING - Undefined group struct'
     1              ,'ure -  Try 172-group scheme             '
      GO TO 18
C*
C* Write the new WIMS-D library file
  500 XAB0=ABS(1.0-AB0/100.0)
      IF (XAB0.GT.1.0E-5) THEN
        AW0=100.0*AW0/AB0
        ZZ0=100.0*ZZ0/AB0
        IL0=3*NG2+2*N12
        DO IL=1,NG2
          RWO( L1-1+IL0+IL)=100.0*RWO(L1-1+IL0+IL)/AB0
        END DO
      ENDIF
      IZ0=ZZ0+0.5
      IA0=AW0+0.5
      MT0=IZ0*1000+IA0
      IF(MWID.GT.0) MT0=MWID
      WRITE(LFL,691) '========================================'
      WRITE(LFL,608) MT0,AW0,IZ0,NF0,NT0,NR0,AB0,FLNO
      IF(NTYP.NE.2) GO TO 510
C*
C* Write the fission spectrum
      WRITE(LOU,701) ITERM, NTYP,NSP
      WRITE(LOU,702) (RWO(L1 -1+I),I=1,NSP)
      GO TO 600
C*
C* Write burnup information, if any
  510 IF(NOD.GT.0) THEN
        NTYP=3
        WRITE(LOU,701) ITERM, NTYP
        NNNN=NNN/2
        ID(1)=MT0
        WRITE(LOU,701) NNN
        WRITE(LOU,707)(YD(I),ID(I),I=1,NNNN)
        NTYP=4
        WRITE(LOU,701) ITERM, NTYP
      ENDIF
C*
C* Write the nuclide header information
      WRITE(LOU,704) MT0,AW0,IZ0,NF0,NT0,NR0
C* Write the epithermal cross sections
      KLN=4*NG2+2*N12
      KLF=2*N12
      WRITE(LOU,702) (RWO( L1-1+I),I=1,KLN)
C* Write the epithermal fission yield and x-set. (if present)
      IF(NF1.LT.2) GO TO 520
      WRITE(LOU,702) (RWO( L5-1+I),I=1,KLF)
C* Process the epithermal scattering matrix
  520 LBB=LBL
      LSC=LBL+N12*NGR
      IF(LSC.GT.MXRW) STOP 'WILLIE MIXMAT - Array capacity exceeded 4'
      DO 540 I=1,N12
      M7 =L7+(I-1)*NGR
C* Find the self-scattering position in the reduced scatt.matrix
      LBS=I
  522 LB1=I-LBS
      IF(RWO(M7+LB1).GT.0 .OR. LBS.LE.1) GO TO 524
      LBS=LBS-1
      GO TO 522
C* Find the current row length of the reduced scattering matrix
  524 LBT=NGR-LB1
  525 IF(RWO(M7-1+LBT+LB1).GT.0 .OR. LBT.LE.LBS) GO TO 526
      LBT=LBT-1
      GO TO 525
C* Move the current row to a scratch array
  526 RWO(LBB  )=LBS
      RWO(LBB+1)=LBT
      DO 528 J=1,LBT
  528 RWO(LBB+1+J)=RWO(M7+LB1-1+J)
      LBB=LBB+LBT+2
  540 CONTINUE
      KL1=LBB-LBL
      WRITE(LOU,705) KL1,(RWO(LBL-1+I),I=1,KL1)
C*
C* Write the temperature list
      WRITE(LOU,702) (RWO( L8-1+I),I=1,NT0)
      KLN=2*NG3
      KLF=2*NG3
C* Loop over all thermal temperatures
      DO 580 IT0=1,NT0
      M9 = L9+(IT0-1)*KLN
      M10=L10+(IT0-1)*KLF
      M12=L12+(IT0-1)*NG3*NG3
C* Write the thermal cross sections
      WRITE(LOU,702) (RWO( M9-1+I),I=1,KLN)
C* Write the epithermal fission yield and x-set. (if present)
      IF(NF1.LT.2) GO TO 560
      WRITE(LOU,702) (RWO(M10-1+I),I=1,KLF)
C* Process the epithermal scattering matrix
  560 LBB=LBL
      LSC=LBL+NG3*NG3
      IF(LSC.GT.MXRW) STOP 'WILLIE MIXMAT - Array capacity exceeded 4'
      DO 570 I=1,NG3
      J12=M12+(I-1)*NG3
C* Find the self-scattering position in the reduced scatt.matrix
      LBS=I
  562 LB1=I-LBS
      IF(RWO(J12+LB1).GT.0 .OR. LBS.LE.1) GO TO 564
      LBS=LBS-1
      GO TO 562
C* Find the current row length of the reduced scattering matrix
  564 LBT=NG3-LB1
  565 IF(RWO(J12-1+LBT+LB1).GT.0 .OR. LBT.LE.LBS) GO TO 566
      LBT=LBT-1
      GO TO 565
C* Move the current row to a scratch array
  566 RWO(LBB  )=LBS
      RWO(LBB+1)=LBT
      DO 568 J=1,LBT
  568 RWO(LBB+1+J)=RWO(J12+LB1-1+J)
      LBB=LBB+LBT+2
  570 CONTINUE
      KL1=LBB-LBL
      WRITE(LOU,705) KL1,(RWO(LBL-1+I),I=1,KL1)
  580 CONTINUE
C* New file written
  600 WRITE(LOU,701)ITERM
      CLOSE (UNIT=LOU)
      CLOSE (UNIT=LFL)
      RETURN
  606 FORMAT(//    ' WILLIE - X-SECT. MIXING UTILITY '/
     1             ' ================================'/)
  607 FORMAT(/'  Mat.ID   At.Wt.   Z Nf Nt Nr   Abund. Filename')
  608 FORMAT(        I8,    F9.4, I4,I3,I3,I3,    F9.4,1X,A40)
  691 FORMAT(2A40)
  694 FORMAT(BN,F20.0)
  695 FORMAT(BN,I10)
  701 FORMAT(5I15)
  702 FORMAT(1P,5E15.8)
C 703 FORMAT(1P,3(E15.8,I6))
  704 FORMAT(1P,I6,E15.8,4I6)
  705 FORMAT(1P,I15/(5E15.8))
C 706 FORMAT(1P,E15.8,2I6)
  707 FORMAT(1P,(3(E15.8,I6)))
      END
      SUBROUTINE DELEMT(LKB,LTT,RWO,IWO,MXRW,MXIW)
C-Title  : Subroutine DELEMT
C-Purpose: Delete a material from the WIMS-D library
      CHARACTER*75    REC
      CHARACTER*40    BLNK, FLNM, FLWI,FLWO
      DIMENSION       RWO(*),IWO(*)
      COMMON /TERWOR/ ITERM,ALDO(2)
      DATA BLNK /'                                        '/
     1    ,FLWI /'WIMS.LIB'/
     1    ,FLWO /'WIMS.LIB'/
C* Default file units
      DATA LF1,LF3/ 1, 3 /
C* Define the filenames
      GO TO 12
   11 WRITE(LTT,691) '                   ERROR opening file : ',FLWI
   12 WRITE(LTT,691) ' Default source formatted lib.filename: ',FLWI
      WRITE(LTT,691) '$             Enter filename to change: '
      READ (LKB,691,END=684)   FLNM
      IF(FLNM.NE.BLNK) FLWI=FLNM
C***** VAX *****
C     OPEN (UNIT=LF1,FILE=FLWI,STATUS='OLD',ERR=11,READONLY)
C***** VAX *****
C***** EXPORT *****
      OPEN (UNIT=LF1,FILE=FLWI,STATUS='OLD',ERR=11)
C***** EXPORT *****
      GO TO 16
   15 WRITE(LTT,691) '                   ERROR opening file : ',FLWO
   16 WRITE(LTT,691) ' Default new  formatted  lib. filename: ',FLWO
      WRITE(LTT,691) '$             Enter filename to change: '
      READ (LKB,691,END=683) FLNM
      IF(FLNM.NE.BLNK) FLWO=FLNM
C***** EXPORT *****
      IF(FLWI.EQ.FLWO) GO TO 15
C***** EXPORT *****
C***** VAX *****
C     OPEN (UNIT=LF3,FILE=FLWO,STATUS='NEW',ERR=15
C    1     ,CARRIAGECONTROL='LIST')
C***** VAX *****
C***** EXPORT *****
      OPEN (UNIT=LF3,FILE=FLWO,STATUS='UNKNOWN',ERR=15)
C***** EXPORT *****
C* Read the MAT number of the material to be deleted
      WRITE(LTT,691) '$Enter MAT No.of material to remove   : '
      READ (LKB,696) RMT
      IF(RMT.GT.0) MAT=RMT+0.01
C*
C* Verification printout
      WRITE(LTT,691)
      WRITE(LTT,691) ' Processing:                            '
      WRITE(LTT,691) '         Source WIMS-D library filename : ',FLWI
      WRITE(LTT,691) '           New  WIMS-D library filename : ',FLWO
      WRITE(LTT,694) '               Removing material MAT No.: ',RMT
      WRITE(LTT,691)
C*
C* Read the source library header and list of nuclides
  141 READ (LF1,701) NEL,NG,NG0,NG1,NG2,NG3,NNFD,NFPD
      READ (LF1,701) (IWO(I),I=1,NEL)
      KNFD=NNFD
      KFPD=NFPD
C* Check the MAT number validity
      DO 142 I=1,NEL
      IF(IWO(I).EQ.MAT) GO TO 144
  142 CONTINUE
      WRITE(LTT,693) ' DELM ERROR - Can not find material MAT ',MAT
      STOP
C* Check the burnup data
  144 KLEN=NG+1
      READ (LF1,702) (RWO(    I),I=1,KLEN)
      READ (LF1,702) (RWO(    I),I=1,NG0)
      DO 154 J=1,NEL
      READ (LF1,701) JDAT1
      READ (LF1,703) (RWO(  I),IWO(  I),I=1,JDAT1/2)
      IF(IWO(1).EQ.MAT) GO TO 162
  154 CONTINUE
      WRITE(LTT,693) ' DELM ERROR - Error in burnup data  MAT ',MAT
      STOP
  162 IF(JDAT1.GT.8) THEN
        KNFD =KNFD-1
        WRITE(LTT,693) '              Fissile material deleted '
      ELSE IF(JDAT1.EQ.8) THEN
        IF(IWO(4).GE.2) THEN
          KNFD =KNFD-1
          WRITE(LTT,693) '              Fissile material deleted '
        ELSE
          KFPD=KFPD-1
          WRITE(LTT,693) '              Burnable material deleted '
        END IF
      END IF
C*
C* Process the library, deleting material MAT
      REWIND LF1
      READ (LF1,701) NEL,NG,NG0,NG1,NG2,NG3,NNFD,NFPD
      READ (LF1,701) (IWO(I),I=1,NEL)
      KEL=0
      DO 164 I=1,NEL
      IWO(KEL+1)=IWO(I)
      IF(IWO(I).NE.MAT) KEL=KEL+1
  164 CONTINUE
C* Write the library header
      WRITE(LF3,701) KEL,NG,NG0,NG1,NG2,NG3,KNFD,KFPD
      WRITE(LF3,701) (IWO(I),I=1,KEL)
C* Write the group boundaries
      KLEN=NG+1
      READ (LF1,702) (RWO(I),I=1,KLEN)
      WRITE(LF3,702) (RWO(I),I=1,KLEN)
C* Write the fission spectrum
      READ (LF1,702) (RWO(I),I=1,NG0)
      WRITE(LF3,702) (RWO(I),I=1,NG0)
C* Process the burnup chains data
      DO 324 J=1,NEL
      READ (LF1,701) JDAT1
      READ (LF1,703) (RWO(I),IWO(I),I=1,JDAT1/2)
      IF(IWO(1).EQ.MAT) GO TO 324
      WRITE(LF3,701) JDAT1
      WRITE(LF3,703) (RWO(I),IWO(I),I=1,JDAT1/2)
  324 CONTINUE
C* Check for the file mark at the end of burnup data
  326 IER=51
      READ (LF1,701) JTERM
      IF(JTERM.NE.ITERM) GO TO 690
      WRITE(LF3,701) ITERM
C* Copy the nuclide cross section data from the old library
      DO 434 J=1,NEL
      LFO=LF3
      READ (LF1,704) ID,AW,IZ,NF,NT,NR
      IF(ID.EQ.MAT) LFO=0
C* Copy or skip the cross section data from the original file
      IF(LFO.GT.0) WRITE(LF3,704) ID,AW,IZ,NF,NT,NR
      CALL PROCXS(RWO,IWO,LF1,LFO,NG1,NG2,NG3,NF,NT)
      IER=51
      READ (LF1,701) JTERM, N1,N2,N3,N4
      IF(JTERM.NE.ITERM) GO TO 690
      IF(LFO.GT.0) WRITE(LF3,701) ITERM
  434 CONTINUE
C* Loop over all groups for the resonance integrals
  500 DO 550 J=1,NG2
C* Read the resonance integrals from the old library
  532 L1=0
      READ (LF1,706) M12,RID,M1,M2
      READ (LF1,702)               (RWO(L1+I    ),I=1,M1),
     *                             (RWO(L1+I+100),I=1,M2),
     *                             (RWO(L1+I+200),I=1,M12)
      ID=RID+0.001
      IF(ID.EQ.MAT) GO TO 537
C* Copy the old resonance integrals
      WRITE(LF3,706) M12,RID,M1,M2
      WRITE(LF3,702)               (RWO(L1+I    ),I=1,M1),
     *                             (RWO(L1+I+100),I=1,M2),
     *                             (RWO(L1+I+200),I=1,M12)
C* Group resonance integral table terminated by dummy RID=0
  537 IF(RID.NE. 0. ) GO TO 532
C* Check the file marks
      IER=53
      READ (LF1,701) JTERM, K1,K2,K3,K4
      IF(JTERM.NE.ITERM) GO TO 690
      IER=54
      WRITE(LF3,701) ITERM
  550 CONTINUE
C* Copy the P1 scattering matrices from the old library
      NP1=0
  640 NP1=NP1+1
C* Identify the format on the original library (full or condensed)
C* Next card may be the last filemark, matrix length or data
      IER=56
      READ (LF1,692,END=690) REC
C* Expanded matrix form if read error occurs
      READ (REC,701,ERR=650) KL1
C* Finish if Filemark found
      IF(KL1.EQ.ITERM) GO TO 680
C* Case-source lib.: copy condensed P1 matrices
  642 L1 =1
      READ (LF1,702) (RWO(L1-1+J),J=1,KL1)
      WRITE(LTT,693) '             Copy  condensed P1-matrix  ',NP1
      WRITE(LF3,701) KL1
      WRITE(LF3,702) (RWO(L1-1+J),J=1,KL1)
      GO TO 640
C* Case-source lib.: copy uncondensed P1 matrices (as char.strings)
  650 NR =(NG+4)/5
      JG =0
      WRITE(LTT,693) '             Copy expanded P1-matrix    ',NP1
  651 JG =JG+1
      WRITE(LF3,692) REC
      DO 652 K=2,NR
      READ (LF1,692) REC
      WRITE(LF3,692) REC
  652 CONTINUE
      IF(JG.GE.NG) GO TO 640
      READ (LF1,692) REC
      GO TO 651
C* All P1 scattering matrices processed - finish
  680 WRITE(LF3,701) ITERM
C* All processing completed
      CLOSE(UNIT=LF3)
  683 CLOSE(UNIT=LF1)
  684 RETURN
C* Error condition reading the library
  690 CALL ERRWAR(LTT,IER)
      RETURN
  691 FORMAT(2A40)
  692 FORMAT(A75)
  693 FORMAT(A40,I8)
  694 FORMAT(A40,F8.1)
  695 FORMAT(BN,I10)
  696 FORMAT(BN,F10.0)
  701 FORMAT(5I15)
  702 FORMAT(1P,5E15.8)
  703 FORMAT(1P,3(E15.8,I6))
  704 FORMAT(1P,I6,E15.8,4I6)
  706 FORMAT(1P,I15/E15.8,2I6)
      END
      SUBROUTINE CHKLIB(LKB,LTT,RWO,IWO,MXRW,MXIW)
C-Title  : Subroutine CHKLIB
C-Purpose: Check WIMS-D library integrity
      CHARACTER*75    REC
      CHARACTER*40    BLNK, FLNM, FLWI,FLWO
      DIMENSION       RWO(*),IWO(*)
      COMMON /TERWOR/ ITERM,ALDO(2)
      DATA BLNK /'                                        '/
     1    ,FLWI /'WIMS.LIB'/
     2    ,FLWO /'WIMS.LIB'/
C* Default file units
      DATA LF1,LF3/ 1, 3 /
C* Define the filenames
      GO TO 12
   11 WRITE(LTT,691) '                   ERROR opening file : ',FLWI
   12 WRITE(LTT,691) ' Default source formatted lib.filename: ',FLWI
      WRITE(LTT,691) '$             Enter filename to change: '
      READ (LKB,691)   FLNM
      IF(FLNM.NE.BLNK) FLWI=FLNM
C***** VAX *****
C     OPEN (UNIT=LF1,FILE=FLWI,STATUS='OLD',ERR=11,READONLY)
C***** VAX *****
C***** EXPORT *****
      OPEN (UNIT=LF1,FILE=FLWI,STATUS='OLD',ERR=11)
C***** EXPORT *****
      GO TO 16
   15 WRITE(LTT,691) '                   ERROR opening file : ',FLWO
   16 WRITE(LTT,691) ' Default new  formatted  lib. filename: ',FLWO
      WRITE(LTT,691) '$             Enter filename to change: '
      READ (LKB,691) FLNM
      IF(FLWO.NE.BLNK) FLWO=FLNM
C***** EXPORT *****
      IF(FLWI.EQ.FLWO) GO TO 15
C***** EXPORT *****
C*
C* Verification printout
      WRITE(LTT,691)
      WRITE(LTT,691) ' Processing:                            '
      WRITE(LTT,691) '         Source WIMS-D library filename : ',FLWI
      WRITE(LTT,691) '           New  WIMS-D library filename : ',FLWO
      WRITE(LTT,691)
C*
C* Begin reading the library
      READ (LF1,695,ERR=810) NEL,NG,NG0,NG1,NG2,NG3,NNFD,NNFPD
      IF(NG1+NG2+NG3 .NE. NG) THEN
        WRITE(LTT,691) '  Fast/Resonance/Thermal groups mismatch'
        GO TO 810
      END IF
C*
C* Read MAT numbers and check for duplicate entries
      READ (LF1,695,ERR=810) (IWO(J),J=1,NEL)
      IER=0
      DO 24 I=2,NEL
      MAT=IWO(I-1)
      DO 22 J=I,NEL
      IF(MAT.EQ.IWO(J)) THEN
        WRITE(LTT,693) '                   Duplicate MAT number ',MAT
        IER=1
      END IF
   22 CONTINUE
   24 CONTINUE
      IF(IER.NE.0) GO TO 810
C*
C* Read the energy group boundaries and check they are monotonic
      NGB=NG+1
      READ (LF1,696,ERR=810) (RWO(J),J=1,NGB)
      IER=0
      DO 32 J=1,NG
      IF(RWO(J).LE.RWO(J+1)) THEN
        WRITE(LTT,693) '           Non-monotonic energy in group',J
        IER=1
      END IF
   32 CONTINUE
      IF(IER.NE.0) GO TO 810
C*
C* Read the fission spectrum fraction
      READ (LF1,696,ERR=810) (RWO(J),J=1,NG0)
      SP=0.0
      DO 42 J=1,NG0
      SP=SP+RWO(J)
   42 CONTINUE
      IF(ABS(SP-1.).GT.0.001)
     1  WRITE(LTT,694) ' CHKLIB WARNING - Unnormalised spectrum ',SP
C*
C* Process the burnup data
      L1= 1+NEL
      L2=L1+NEL
      KNFD =0
      KNFPD=0
      DO 120 I=1,NEL
      READ (LF1,695) NDT
      ND2=NDT/2
      IF( ((ND2*2).NE.NDT) .OR.
     1  ((NDT.LT.8) .AND. (NDT.NE.2)) ) THEN
        WRITE(LTT,693) ' CHKLIB WARNING - Illegal Bu.length MAT',IWO(I)
      END IF
      READ (LF1,697,ERR=810) (RWO(J),J=1,NDT)
      MAT=NINT(RWO(2))
      IF(MAT.NE.IWO(I)) THEN
        WRITE(LTT,693) ' CHKLIB ERROR - Burnup data MAT found : ',MAT
        WRITE(LTT,693) '                             Expected : ',IWO(I)
      END IF
      IWO(L1-1+I)=2*ND2
      IF(NDT.GT.8) THEN
        KNFD =KNFD +1
      ELSE IF(NDT.EQ.8) THEN
        JF=NINT(RWO(8))
        IF(JF.GE.2) THEN
          KNFD =KNFD +1
        ELSE
          KNFPD=KNFPD+1
        END IF
      END IF
C*
  120 CONTINUE
      IF(KNFD .NE.NNFD ) THEN
        WRITE(LTT,693) ' CHKLIB WARNING -          NNFD Found : ',NNFD
        WRITE(LTT,693) '                             Expected : ',KNFD
      END IF
      IF(KNFPD.NE.NNFPD) THEN
        WRITE(LTT,693) ' CHKLIB WARNING -         NNFPD Found : ',NNFPD
        WRITE(LTT,693) '                             Expected : ',KNFPD
      END IF
C* Check that the next record is the library delimiter
      READ (LF1,695,ERR=810) JTERM
      IF(JTERM.NE.ITERM) THEN
        WRITE(LTT,691) ' Library delimiter record expected      '
        GO TO 810
      END IF
C*
C* Rewrite the general information and the burnup data
C***** VAX *****
C     OPEN (UNIT=LF3,FILE=FLWO,STATUS='NEW',ERR=15
C    1     ,CARRIAGECONTROL='LIST')
C***** VAX *****
C***** EXPORT *****
      OPEN (UNIT=LF3,FILE=FLWO,STATUS='UNKNOWN',ERR=15)
C***** EXPORT *****
C*
  200 REWIND LF1
C* Indices and MAT numbers
      READ (LF1,695) NEL,NG,NG0,NG1,NG2,NG3,NNFD,NNFPD
      WRITE(LF3,695) NEL,NG,NG0,NG1,NG2,NG3,KNFD,KNFPD
C*
      READ (LF1,695) (IWO(J),J=1,NEL)
      WRITE(LF3,695) (IWO(J),J=1,NEL)
C* Energy group boundaries
      READ (LF1,696) (RWO(J),J=1,NGB)
      WRITE(LF3,702) (RWO(J),J=1,NGB)
C*
      READ (LF1,696) (RWO(J),J=1,NG0)
      WRITE(LF3,702) (RWO(J),J=1,NG0)
C*
C* Nuclide decay and burnup data
      DO 220 I=1,NEL
      ND1=IWO(L1-1+I)
      DO 202 J=1,ND1
      RWO(J)=0.
  202 CONTINUE
      READ (LF1,695) NDT
      READ (LF1,697) (RWO(J),J=1,NDT)
      MAT=NINT(RWO(2))
C* Check the MAT numbers
      DO 218 J=4,ND1,2
      IF(J.EQ.8) GO TO 218
      MT1=NINT(RWO(J))
      IF(MT1.EQ.0) GO TO 218
      DO 212 K=1,NEL
      IF(MT1.NE.IWO(K)) GO TO 212
        IF(IWO(L1-1+K).GE.8) GO TO 218
        WRITE(LTT,693) ' CHKLIB WARNING - Burnup data err.MAT : ',MAT
        WRITE(LTT,693) '       Non-burnable product specified : ',MT1
        IWO(L1-1+K)=8
        IF(K.LT.I) THEN
          REWIND LF3
          GO TO 200
        END IF
  212 CONTINUE
      WRITE(LTT,693) ' CHKLIB ERROR - Burnup data error MAT : ',MAT
      WRITE(LTT,693) '          Non-existent burnup product : ',MT1
  218 CONTINUE
      WRITE(LF3,695) ND1
      WRITE(LF3,703) (RWO(J),NINT(RWO(J+1)),J=1,ND1,2)
  220 CONTINUE
C* Next record is the file delimiter
      READ (LF1,695,ERR=810) JTERM
      WRITE(LF3,695)         ITERM
      IF(JTERM.NE.ITERM) THEN
        WRITE(LTT,691) ' CHKLIB ERROR - File delimiter expected '
        GO TO 810
      END IF
C*
C* Process the nuclide cross section files
      JEL=0
      NP1=4*NG2+2*(NG1+NG2)
      NP2=      2*(NG1+NG2)
      NP3=      2* NG3
C* Read the nuclide header record
  300 READ (LF1,698,ERR=810) MAT,AA,IA,NF,NT,NR
      WRITE(LF3,704)         MAT,AA,IA,NF,NT,NR
      JEL=JEL+1
      MT1=IWO(JEL)
      IF(MAT.NE.MT1) THEN
        WRITE(LTT,693) ' CHKLIB ERROR -   x.s. data MAT found : ',MAT
        WRITE(LTT,693) '                             Expected : ',MT1
      END IF
C* Read the fast cross section data
      READ (LF1,696,ERR=810) (RWO(J),J=1,NP1)
      WRITE(LF3,702)         (RWO(J),J=1,NP1)
      IF(NF.GE.2) THEN
        READ (LF1,696,ERR=810) (RWO(J),J=1,NP2)
        WRITE(LF3,702)         (RWO(J),J=1,NP2)
      END IF
C* Read the fast scattering matrix
      READ (LF1,695,ERR=810) LMX
      READ (LF1,696,ERR=810) (RWO(J),J=1,LMX)
C* Analyse the fast scattering matrix
      LL=1
      IT=1
      NG12=NG1+NG2
      IER=0
      DO 322 IG=1,NG12
      JER=0
      LSS=NINT(RWO(LL))
      LST=NINT(RWO(LL+1))
C* Check that self-scattering is within tabulated range
      IF(LSS.LT.1 .OR. LSS.GT.LST) THEN
C*
        WRITE(LTT,693) ' CHKLIB ERROR - Incorrect sct.matrix MAT',MAT
        WRITE(LTT,693) '              Fast group/self-sc/length '
     1                                    ,IG   ,LSS    ,LST
        GO TO 810
      END IF
C* No upscattering in the fast range is allowed
C***** NOUPSCATTERING
C     IF(LSS.GT.1) THEN
C       IF(IER.EQ.0)
C    1  WRITE(LTT,693) ' CHKLIB WARNING - Corr.Scatt.matrix MAT',MAT
C       WRITE(LTT,693) '              Fast group/self-sc/length '
C    1                                    ,IG   ,LSS    ,LST
C       IER=1
C       JER=1
C       J1=LL+1+LSS
C       J2=LSS-1
C       DO 312 J=J1,LMX
C       RWO(J-J2)=RWO(J)
C 312   CONTINUE
C       LST=LST-LSS+1
C       LSS=1
C     END IF
C***** NOUPSCATTERING
C* Check that upscattering is within the group range
      IF(LSS.GT.IG) THEN
        IF(IER.EQ.0)
     1  WRITE(LTT,693) ' CHKLIB WARNING - Corr.Scatt.matrix MAT',MAT
         IF(JER.EQ.0)
     1  WRITE(LTT,693) '              Fast group/self-sc/length '
     1                                    ,IG   ,LSS    ,LST
        J1=LL+2
        J2=LSS-IG
        DO 313 J=J1,LMX
        RWO(J-J2)=RWO(J)
  313   CONTINUE
        LSS=IG
        LST=LST-J2
      END IF
C* Check that downscattering is within the total number of groups
      IF((IG+LST-LSS).GT.NG) THEN
        IF(IER.EQ.0)
     1  WRITE(LTT,693) ' CHKLIB WARNING - Corr.Scatt.matrix MAT',MAT
         IF(JER.EQ.0)
     1  WRITE(LTT,693) '              Fast group/self-sc/length '
     1                                    ,IG   ,LSS    ,LST
        J1=LL+2+LST
        J2=IG+LST-LSS-NG
        DO 314 J=J1,LMX
        RWO(J-J2)=RWO(J)
  314   CONTINUE
        LST=LST-J2
      END IF
      RWO(LL  )=LSS
      RWO(LL+1)=LST
  321 LL=LL+LST+2
  322 CONTINUE
      LMX=LL-1
      WRITE(LF3,695) LMX
      WRITE(LF3,702) (RWO(J),J=1,LMX)
C*
C* Read the thermal data
      READ (LF1,696) (RWO(J),J=1,NT)
      WRITE(LF3,702) (RWO(J),J=1,NT)
      DO 348 IT=1,NT
      READ (LF1,696) (RWO(J),J=1,NP3)
      WRITE(LF3,702) (RWO(J),J=1,NP3)
      IF(NF.GE.2) THEN
        READ (LF1,696) (RWO(J),J=1,NP3)
        WRITE(LF3,702) (RWO(J),J=1,NP3)
      END IF
      READ (LF1,695) LMX
      READ (LF1,696) (RWO(J),J=1,LMX)
C* Analyse the fast scattering matrix
      LL=1
      NG12=NG1+NG2
      DO 342 I=1,NG12
      IG =NG1+NG2+I
      LSS=NINT(RWO(LL))
      LST=NINT(RWO(LL+1))
C      IF(LSS.LT.1 .OR. LSS.GT.LST) WRITE(LF3,99) MAT,IT,IG,LSS,LST
C      IF(LST.LT.1)                 WRITE(LF3,99) MAT,IT,IG,LSS,LST
C      IF(LST+1-LSS.GT.NG+1-IG)     WRITE(LF3,99) MAT,IT,IG,LSS,LST
C      IF( IG+1-LSS.LT.NG-NG3 )     WRITE(LF3,99) MAT,IT,IG,LSS,LST
      LL=LL+LST+2
  342 CONTINUE
      WRITE(LF3,695) LMX
      WRITE(LF3,702) (RWO(J),J=1,LMX)
  348 CONTINUE
C* Next record is the file delimiter
      READ (LF1,695,ERR=810) JTERM
      WRITE(LF3,695)         ITERM
      IF(JTERM.NE.ITERM) THEN
        WRITE(LTT,691) ' CHKLIB ERROR - File delimiter expected '
        GO TO 810
      END IF
      IF(JEL.LT.NEL) GO TO 300
C*
C* Process the resonance files
      IG=NG1
C* Next group
  400 IG=IG+1
C* Next material
  410 READ (LF1,695,ERR=810) NDT
      READ (LF1,699,ERR=810) RMT,NT,NS
      IF(NT*NS.NE.NDT) THEN
        WRITE(LTT,694) '    Incorrect resonance table for MAT : ',RMT
        WRITE(LTT,693) '                      Resonance group : ',IG
        GO TO 810
      END IF
      WRITE(LF3,695) NDT
      WRITE(LF3,706) RMT,NT,NS
      NP=NT+NS+NT*NS
      READ (LF1,696,ERR=810) (RWO(J),J=1,NP)
      WRITE(LF3,702)         (RWO(J),J=1,NP)
      IF(RMT.NE.0) GO TO 410
C* Resonance group processed - next record is file delimiter
      READ (LF1,695,ERR=810) JTERM
      WRITE(LF3,695)         ITERM
      IF(JTERM.NE.ITERM) THEN
        WRITE(LTT,691) ' CHKLIB ERROR - File delimiter expected '
        GO TO 810
      END IF
      IF(IG.LT.NG1+NG2) GO TO 400
C*
C* process the P1 matrices
      NP1=0
  640 NP1=NP1+1
C* Identify the format on the original library (full or condensed)
C* Next card may be the last filemark, matrix length or data
      IER=56
      READ (LF1,692,END=810) REC
C* Expanded matrix form if read error occurs
      READ (REC,701,ERR=650) KL1
C* Finish if Filemark found
      IF(KL1.EQ.ITERM) GO TO 680
C* Case-source lib.: copy condensed P1 matrices
  642 L1 =1
      READ (LF1,702) (RWO(L1-1+J),J=1,KL1)
      WRITE(LTT,693) '             Copy  condensed P1-matrix  ',NP1
      WRITE(LF3,701) KL1
      WRITE(LF3,702) (RWO(L1-1+J),J=1,KL1)
      GO TO 640
C* Case-source lib.: copy uncondensed P1 matrices (as char.strings)
  650 NR =(NG+4)/5
      JG =0
      WRITE(LTT,693) '             Copy expanded P1-matrix    ',NP1
  651 JG =JG+1
      WRITE(LF3,692) REC
      DO 652 K=2,NR
      READ (LF1,692) REC
      WRITE(LF3,692) REC
  652 CONTINUE
      IF(JG.GE.NG) GO TO 640
      READ (LF1,692) REC
      GO TO 651
C* All P1 scattering matrices processed - finish
  680 WRITE(LF3,701) ITERM
C* All processing completed
      CLOSE(UNIT=LF3)
      CLOSE(UNIT=LF1)
      RETURN
C*
C* Error traps
  810 WRITE(LTT,691) ' CHKLIB ERROR - Incorrect library format'
  890 STOP 'CHKLIB ERROR'
C*
  691 FORMAT(2A40)
  692 FORMAT(A75)
  693 FORMAT(A40,3I8)
  694 FORMAT(A40,F8.1)
  695 FORMAT(BN,5I15)
  696 FORMAT(BN,5F15.0)
  697 FORMAT(3(F15.0,F6.0))
  698 FORMAT(I6,F15.0,4I6)
  699 FORMAT(F15.0,2I6)
  701 FORMAT(   5I15)
  702 FORMAT(1P,5E15.8)
  703 FORMAT(1P,3(E15.8,I6))
  704 FORMAT(1P,I6,E15.8,4I6)
  706 FORMAT(1P,E15.8,2I6)
      END
      SUBROUTINE NEWLIB(LKB,LTT,RWO,IWO,MXRW,MXIW)
C-Title  : Subroutine NEWLIB
C-Purpose: Make a starter file for a new library
C-Description:
C-D  The starter file for a new library is written. Make sure that
C-D  the energy boundaries and the spectrum are entered with the
C-D  INCL command before the library is used.
C-
      CHARACTER*40    BLNK, FLNM, FLWO
      REAL*8          ZERO
      DIMENSION       RWO(*),IWO(*)
      COMMON /TERWOR/ ITERM,ALDO(2)
      DATA BLNK /'                                        '/
     2    ,FLWO /'NEW.LIB'/
C* Default file units
      DATA LFO/ 2 /
C* Initialise
      DATA ZERO,NG1,NG2,NG3,NG/ 0.D0, 14, 13, 42, 69 /
C* Define the new library filename
      GO TO 16
   15 WRITE(LTT,691) ' ERROR - Opening file                 : ',FLWO
   16 WRITE(LTT,691) ' Default new  formatted  lib. filename: ',FLWO
      WRITE(LTT,691) '$             Enter filename to change: '
      READ (LKB,691) FLNM
      IF(FLNM.NE.BLNK) FLWO=FLNM
C***** VAX *****
C     OPEN (UNIT=LFO,FILE=FLWO,STATUS='NEW',ERR=15
C    1     ,CARRIAGECONTROL='LIST')
C***** VAX *****
C***** EXPORT *****
      OPEN (UNIT=LFO,FILE=FLWO,STATUS='UNKNOWN',ERR=15)
C***** EXPORT *****
C*
      GO TO 18
   17 WRITE(LTT,691) ' ERROR - defining energy groups - redo    '
   18 WRITE(LTT,691) '$          Enter total number of groups : '
      READ (LKB,801) NGI
      IF(NGI.NE.0)   NG =NGI
      WRITE(LTT,691) '$   Enter number of fast neutron groups : '
      READ (LKB,801) NGI
      IF(NGI.NE.0)   NG1=NGI
      WRITE(LTT,691) '$            Number of resonance groups : '
      READ (LKB,801) NGI
      IF(NGI.NE.0)   NG2=NGI
      NG3=NG-NG1-NG2
      IF(NG1.LE.0 .OR.
     1   NG2.LE.0 .OR.
     2   NG3.LE.0) GO TO 17
C* Verification printout
      WRITE(LTT,691)
      WRITE(LTT,691) ' Processing:                            '
      WRITE(LTT,691) '         New  WIMS-D library filename : ',FLWO
      WRITE(LTT,692) ' Number of fast neutron energy groups : ',NG1
      WRITE(LTT,692) '    Number of resonance energy groups : ',NG2
      WRITE(LTT,692) '      Number of thermal energy groups : ',NG3
      WRITE(LTT,692) '           Total number energy groups : ',NG
      WRITE(LTT,691)
C*
C* Begin writing the library starter file
      NEL=0
      NG0=NG1
      NNFD=0
      NNFPD=0
C* Library header index record
      WRITE(LFO,695) NEL,NG,NG0,NG1,NG2,NG3,NNFD,NNFPD
C* No MAT numbers
C     WRITE(LFO,695)
C* Energy group boundaries
      NGB=NG+1
      WRITE(LFO,696) (ZERO,J=1,NGB)
C* Fission spectrum fraction
      WRITE(LFO,696) (ZERO,J=1,NG0)
C* File marks before the nuclide files
      WRITE(LFO,695) ITERM
C* File marks before the resonance files
      DO 30 I=1,NG2
      WRITE(LFO,695) ITERM
      WRITE(LFO,695) 1
      WRITE(LFO,697) ZERO,1,1
      WRITE(LFO,696) ZERO,ZERO,ZERO
   30 CONTINUE
C* File mark before the P1 matrix
      WRITE(LFO,695) ITERM
C* Dummy P1 matrices
      DO 40 I=1,4
      DO 38 IG=1,NG
      WRITE(LFO,696) (ZERO,JG=1,NG)
   38 CONTINUE
   40 CONTINUE
C* End-of-library filemark
      WRITE(LFO,695) ITERM
      CLOSE(UNIT=LFO)
C*
  691 FORMAT(2A40)
  692 FORMAT(A40,I5)
  695 FORMAT(5I15)
  696 FORMAT(5F15.12)
  697 FORMAT(F15.0,2I6)
  801 FORMAT(BN,I10)
      END
*deck wimsie 
      program wimsie
c-title  : program wimsie
c-purpose: prepare a wimsd dosimetry file
c-author : d. l. aldama
c-version: 08/2001 original code
c-m
c-m  manual for program wimsie
c-m  =========================
c-m  the required data is read as input and a WIMSD formatted
c-m  dosimetry file is written.
c-m  especial dosimetry material options are also available.
c-m  (see below)
c-m
c-m  input data:
c-m  the following parameters should be entered from keyboard:
c-m   1. (ng, ng1, ng2) : library energy structure, where
c-m                       ng:  number of energy groups
c-m                       ng1: number of fast groups
c-m                       ng2: number of resonance groups
c-m
c-m   2. IDWIMS : wims identification number
c-m
c-m   3. ZA0: ZA Trigger
c-m       if ZA0= +ZA number general dosimetry material assumed
c-m
c-m       if ZA0 < 0  special options are available:
c-m
c-m        if ZA0= -1  the resonance part of the input WIMSD formatted
c-m                    cross section file is extracted.
c-m                    fast and thermal cross section are set to zero.
c-m        if Za0= -2  change the sign of the input WIMSD
c-m                    formatted dosimetry file.
c-m        if Za0= -3  a dosimetry file is created containing
c-m                    the inverse lethargy intervals.
c-m                    (energy boundaries should be supplied
c-m                    on the input data file)
c-m        if Za0= -4  a dosimetry file is created for
c-m                    a constant = 1.0 absorber.
c-m
c-m   4. output WIMSD fomatted dosimetry file name (*.xsw)
c-m
c-m   5. log (listing) output file name (*.lst)
c-m
c-m   6. input data file (only if ZA0 > -4)
c-m      if ZA0 > 0 then the file is an endfb6 histogram formatted file
c-m      if ZA0 =-1 or -2: WIMSD formatted dosimetry cross section file
c-m      if ZA0=-3 : WILLIE formatted energy boundary data file
c-m      if ZA0=-4 : NOT REQUIRED !!!
c-m
c-m   7. mfrr,mtrr: file and section numbers of the dosimetry reaction
c-m                 (only if ZA0=+ZA number)
c-m
c-m  files used:
c-m       input file:
c-m          1. input data file (unit lib=1)
c-m              a) endfb6 histogram formatted file (if ZA0 = +ZA)
c-m              b) WIMSD formatted dosimetry cross section
c-m                 file (if ZA0=-1 or -2)
c-m              c) WILLIE formatted energy boundary data file
c-m                 (if ZA0=-3)
c-m       output files:
c-m          1.  WIMSD formatted dosimetry file
c-m          2.  listing file
c-m
c-m    maximum number of energy groups: 200  ==> ngg=201
c-m
c-
       parameter(lib=1,nout=2,nlog=3,lkb=5,ltt=6,nng=201)
       dimension e(nng),xs(nng)
       character*66 line,tape
       character*40 fli,fou,flo,flnm,blnk
       character*11 zasym
       data blnk/'                                        '/
       data fli/'wimsie.dat'/
       data fou/'wimsie.xsw'/
       data flo/'wimsie.lst'/
       data zasym/'           '/,temp/300.0/,aw/.9914095/
       write(ltt,15) ' wimsie: prepare wimsd dosimetry file   '
       write(ltt,15) '         from groupie endfb6 output     '
       write(ltt,15) ' ======================================='
       write(ltt,15)
c
c      read energy structure and wims id
c
       write(ltt,15) '   Enter energy structure (NG,NG1,NG2): '
       write(ltt,15) '   -----------------------------------  '
       write(ltt,15) '$             enter=default (69 14 13): '
       read(lkb,15)flnm
       if(flnm.eq.blnk) then
         ngrp=69
         nfast=14
         nreso=13
       else
         read(flnm,*)ngrp,nfast,nreso
       endif
       write(ltt,15) '                         enter wims id: '
       write(ltt,15) '                         -------------  '
       write(ltt,15) '$                enter=default (9999) : '
       read(lkb,15)flnm
       if(flnm.eq.blnk) then
        idwims=9999
       else
        read(flnm,*)idwims
       endif
c
c      read ZA0 trigger
c
       write(ltt,15) '                     enter ZA0 trigger: '
       write(ltt,15) '                     -----------------  '
       write(ltt,15) '    general dosimetry material: za0=ZA  '
       write(ltt,15) '    resonance part of input xs: za0=-1  '
       write(ltt,15) '                  xs(g)=-xs(g): za0=-2  '
       write(ltt,15) '    inverse lethargy intervals: za0=-3  '
       write(ltt,15) '$                 constant=1.0: za0=-4  '
       read(lkb,15)flnm
       if(flnm.eq.blnk) then
         za0=-4.0
       else
        read(flnm,*)za0
       endif
c
c    open i/o files
c
       flnm=blnk
    2  write(ltt,15) 'enter output dosimetry file name(.xsw): '
       write(ltt,15) '--------------------------------------  '
       write(ltt,15) '                     default file name: ',fou
       write(ltt,15) '$       enter new name (enter=default): '
       read (lkb,15) flnm
       if(flnm.ne.blnk) fou=flnm
       open(unit=nout,file=fou,err=2)
       flnm=blnk
    3  write(ltt,15) ' enter output listing file name (.lst): '
       write(ltt,15) ' -------------------------------------  '
       write(ltt,15) '                     default file name: ',flo
       write(ltt,15) '$       enter new name (enter=default): '
       read (lkb,15) flnm
       if(flnm.ne.blnk) flo=flnm
       open(unit=nlog,file=flo,err=3)
       if (za0.ne.-4) then
         flnm=blnk
    4    write(ltt,15) '            enter input data file name: '
         write(ltt,15) '            --------------------------  '
         write(ltt,15) '                     default file name: ',fli
         write(ltt,15) '$       enter new name (enter=default): '
         read (lkb,15) flnm
         if(flnm.ne.blnk) fli=flnm
         open(unit=lib, file=fli, status='old',err=4)
       else
        fli=blnk
       endif
       write(nlog,*)' WIMSIE listing file'
       write(nlog,*)' Input data file: ',fli
       write(nlog,*)' Output WIMSD formatted dosimetry file: ',fou
       write(nlog,*)idwims,ngrp,nfast,nreso
       write(nlog,*)za0
       if (za0.lt.0.0) then
c
c        special dosimetry materials
c
c        za0= -1   resonant part of the input dosimetry xs
c        za0= -2   xs(i) = -xs(i)
c        za0= -3   inverse lethargy intervals
c        za0= -4   constant = 1.0
c
         nza0=INT(abs(za0)+0.01)
         za0=0.0
         if(nza0.le.3) then
           call readxs(lib,xs,ngr1,ngf1,ngres1,temp,n3)
           if (n3.ne.4.and.n3.ne.1) then
             write(nlog,*)' Error reading input data file. n3= ',n3
             write(ltt,*)' Error reading input data file. n3= ',n3
             stop
           endif
           if (ngr1.ne.ngrp) then
             write(nlog,*)' Incompatible energy structure.',ngr1,ngrp
             write(ltt,*)' Incompatible energy structure.',ngr1,ngrp
             stop
           endif
           if(nza0.eq.1) then
c
c            resonant part of the input dosimetry xs
c
             if (nfast.ne.ngf1) then
              write(nlog,*)' Incompatible fast energy range.',nfast,ngf1
              write(ltt,*)' Incompatible fast energy range.',nfast,ngf1
              stop
             endif
             if (nreso.ne.ngres1) then
              write(nlog,*)' Incompatible resonance range.',nreso,ngres1
              write(ltt,*)' Incompatible resonance range.',nreso,ngres1
              stop
             endif
             do i=1,nfast
               xs(i)=0.0
             enddo
             nepi1=nfast+nreso+1
             do i=nepi1,ngrp
               xs(i)=0.0
             enddo
           else if (nza0.eq.2) then
c
c          xs(i)=-xs(i)
c
             do i=1,ngrp
               xs(i)=-xs(i)
             enddo
           else
c
c          inverse lethargy intervals
c
             do i=1,ngrp
               xs(i)=1.0/log(xs(i)/xs(i+1))
             enddo
           endif
         else
c
c        constant = 1.0
c
           do i=1,ngrp
             xs(i)=1.0
           enddo
         endif
         call wimsxs(nout,za0,aw,xs,ngrp,nfast,nreso,idwims,temp)
         write(nlog,*)za0,aw,temp
         write(nlog,*)' Cross section = '
         write(nlog,'(1x,1p5e15.8)')(xs(i),i=1,ngrp)
       else
c
c        general dosimetry material
c
         write(ltt,15) '     endfb6 dosimetry reaction (mf,mt): '
         write(ltt,15) '     ---------------------------------  '
         write(ltt,15) '$               enter=default (3 102) : '
         read(lkb,15)flnm
         if(flnm.eq.blnk) then
           mfrr=3
           mtrr=102
         else
           read(flnm,*)mfrr,mtrr
         endif
         write(nlog,*)mfrr,mtrr
c
c        process evaluated groupwise nuclear data file
c
         call rdhead(lib,tape,mat,mf,mt,ns)
         write(nlog,*)tape
         imf=0
         do while (mat.ne.-1 .and. imf.eq.0)
           call rdhead(lib,line,mat,mf,mt,ns)
           if (mf.eq.1.and.mt.eq.451) then
             backspace(lib)
 
c
c           get general data from 1/451 if any
c
             call getgd(lib,za0,zasym,temp)
           else if (mf.eq.mfrr.and.mt.eq.mtrr) then
             backspace(lib)
c
c          get cross section data form mfrr/mtrr
c
             call getxs(lib,za0,aw,e,xs,ngrp,imf)
             if (imf.gt.0) then
               write(nlog,*)za0,aw,temp,zasym
               if (imf.gt.1) then
                 write(nlog,*)' Warning: check data and energies'
                 write(nlog,*)' Energies'
                 write(nlog,'(1x,1p5e15.8)')(e(i),i=1,ngrp+1)
                 write(ltt,*)' Warning: check data and energies'
               endif
c
c              prepare a wimsd cross section file
c              for dosimetry materials
c
               call wimsxs(nout,za0,aw,xs,ngrp,nfast,nreso,idwims,temp)
               write(nlog,*)' Cross section (mf/mt) = ',mfrr,mtrr
               write(nlog,'(1x,1p5e15.8)')(xs(i),i=1,ngrp)
             else if (imf.lt.0) then
               write(nlog,*)' Error reading input data file. ERRC= ',imf
               write(ltt,*)' Error reading input data file. ERRC= ',imf
               stop
             endif
           endif
         end do
         if (imf.eq.0) then
           write(nlog,*)' Material data not found ERRC= -2'
           write(ltt,*)' Material data not found ERRC= -2'
         endif
       endif
       close(lib)
       close(nout)
       close(nlog)
15     format(2a40)
20     format(a5,i5,a5,a12,a5,f7.1,a5,f10.6,a5,i7)
      end
c
c      getgd: get general data from file 1
c
      subroutine getgd(lib,za0,zsymam,temp)
       character*66 text
       character*11 zsymam, zsym
       call rdcont(lib,za,c2,l1,l2,n1,n2,mat,mf,mt,ns)
       call rdhead(lib,text,mat,mf,mt,ns)
       call rdhead(lib,text,mat,mf,mt,ns)
       call rdcont(lib,c1,c2,l1,l2,n1,n2,mat,mf,mt,ns)
       call rdhead(lib,text,mat,mf,mt,ns)
       read(text,10)zsym
       if (za0.eq.0.0) za0=za
       delta=abs(za0-za)
       if (delta.le.0.01) then
          temp=c1
          zsymam=zsym
       endif
       do while(mt.eq.451)
         call rdhead(lib,text,mat,mf,mt,ns)
       enddo
       return
10     format(a11)
      end
c
c     getxs :  get cross section data in ENDFB-6 histogram format
c
      subroutine getxs(lib,za0,aw,e,xs,ngrp,imf)
       parameter (ntt=10, ngg=201,e69=10.0e6,e172=19.64e6,erel0=0.01)
       dimension e(*),xs(*),y(ngg),nb(ntt),itl(ntt)
       do i=1,ngrp+1
         e(i)=0.
         y(i)=0.
         xs(i)=0.
       enddo
       call rdcont(lib,za,aw,l1,l2,n1,n2,mat,mf,mt,ns)
       call rdtab1(lib,c1,c2,l1,l2,n1,n2,nb,itl,e,y,mat,mf,mt,ns)
       if (za0.eq.0.0) za0=za
       delta=abs(za0-za)
       if (delta.gt.0.01) return
       if (ngrp.eq.69) then
         erel=abs(e(n2)/e69 - 1.0)
       else if (ngrp.eq.172) then
         erel=abs(e(n2)/e172 - 1.0)
       else
         erel=0.0
       endif
       if (itl(1).eq.1.and.n1.eq.1.and.n2.eq.nb(1)) then
         do ig=1,n2-1
          xs(ig)=y(n2-ig)
         enddo
         if (erel.gt.erel0) then
           imf=10
         else
           imf=1
         endif
         return
       else
         imf=-1
         return
       endif
      end
c
c     rdhead, rdcont, rdtab1: read ENDFB6 records
c
      subroutine rdhead(lib,text,mat,mf,mt,ns)
       character*66 text
       read(lib,10)text,mat,mf,mt,ns
       return
10     format(a66,i4,i2,i3,i5)
      end
      subroutine rdcont(lib,c1,c2,l1,l2,n1,n2,mat,mf,mt,ns)
       read(lib,10)c1,c2,l1,l2,n1,n2,mat,mf,mt,ns
       return
10     format(2e11.0,4i11,i4,i2,i3,i5)
      end
      subroutine rdtab1(lib,c1,c2,l1,l2,n1,n2,nb,itl,x,y,mat,mf,mt,ns)
       dimension nb(*),itl(*),x(*),y(*)
       read(lib,10)c1,c2,l1,l2,n1,n2,mat,mf,mt,ns
       read(lib,20)(nb(i),itl(i),i=1,n1)
       read(lib,30)(x(i),y(i),i=1,n2)
       return
10     format(2e11.0,4i11,i4,i2,i3,i5)
20     format(6i11)
30     format(6e11.0)
      end
c
c     readxs: read a WIMSD formatted cross section file
c             or an energy boundary data file
c
      subroutine readxs(lib,xs,ngr1,ngf1,ngres1,temp,n3)
       dimension xs(*)
       read(lib,30)nz,n3,ngf1,ngres1,nth1
       if (n3.eq.1) then
        ngr1=ngf1-1
        read(lib,20)(xs(i),i=1,ngf1)
        return
       endif
       if(n3.eq.3) then
         read(lib,30)nz
         nz=nz/2
         read(lib,40)(z0,n2,i=1,nz)
         read(lib,30)nz,n3,ngf1,ngres1,nth1
       endif
       if (n3.eq.4) then
         nepi=ngf1+ngres1
         nres2=2*ngres1
         ngr1=nepi+nth1
         nepi1=nepi+1
         read(lib,10)nz,xz,nz,n2,nz
         read(lib,20)(z0,i=1,nres2),
     &                (xs(i),i=1,nepi),(xs(i),i=1,nepi),
     &                (z0,i=1,nres2)
         if (n2.gt.1) then
           read(lib,20)(z0,i=1,nepi),(z0,i=1,nepi)
         endif
         read(lib,30)nz
         read(lib,20)(z0,i=1,nz)
         read(lib,20)z0
         temp=z0
         read(lib,20)(xs(i),i=nepi1,ngr1),(xs(i),i=nepi1,ngr1)
         return
       endif
       n3=-1
       return
10     format(i6,e15.0,4i6)
20     format(5e15.0)
30     format(5i15)
40     format(3(e15.0,i6))
      end
c
c     wimsxs: prepare a wimsd formatted cross section file
c             for dosimetry materials
c
      subroutine wimsxs(nout,za0,aw,xs,ngrp,nfast,nreso,idwims,temp)
       parameter(xmass=1.008665,z0=0.,z1=1.,naldo=999999999,n2=2,nt=1)
       dimension xs(*)
       nz=za0/1000
       nepi=nfast+nreso
       nepi1=nepi+1
       nth=ngrp-nepi
       nres2=2*nreso
       write(nout,30)naldo,3
       write(nout,30)n2
       write(nout,40)z0,idwims
       write(nout,30)naldo,4,nfast,nreso,nth
       write(nout,10)idwims,aw*xmass,nz,0,nt,0
       write(nout,20)(z0,i=1,nres2),
     &               (xs(i),i=1,nepi),(xs(i),i=1,nepi),
     &               (z0,i=1,nres2)
       write(nout,30)3*nepi
       write(nout,20)(z1,z1,z0,i=1,nepi)
       write(nout,20)temp
       write(nout,20)(xs(i),i=nepi1,ngrp),(xs(i),i=nepi1,ngrp)
       write(nout,30)3*nth
       write(nout,20)(z1,z1,z0,i=1,nth)
       write(nout,30)naldo
10     format(i6,1pe15.8,4i6)
20     format(1p5e15.8)
30     format(5i15)
40     format(3(1pe15.8,i6))
      end
*deck WWERCR 
      PROGRAM WWERCR
C-Title  : WWERCR Program
C-T
C-Purpose: Post-process the output generated by running WIMSD5B for
C-P        the WWER-type lattice benchmarks. (see wwercr.win)
C-P
C-Description: Search for K-eff and Critical Bucklings in chain 14.
C-D         The deviation from Keff=1 is calculated for the input
C-D         (experimental) bucklings. The material buckling
C-D         estimated by calculations is compared directly with the
C-D         experimental values, which are read from the reference file
C-D         (default WWERCR.REF). A comparison with the experimental
C-D         uncertainties is printed.
C-D
C-M Input Files:
C-M     1.-  File containing the WIMSD5 output for the WWER
C-M          criticality benchmarks.
C-M     2.-  File containing the experimental value. (WWERCR.REF)
C-M
C-M Output file:
C-M     3.-  Summary file contaning the comparison between
C-M          calculated and experimental values.
C-M
C-Author : D.L.Aldama, CTN
C-A
C-Version: 15/04/1999
C-
      PARAMETER (NL=100, NR=100)
      CHARACTER*120 LINE
      CHARACTER*40  BLNK,FLNM,FLST,FINP,FREF
      CHARACTER*17 LIDW(NL),LIDR(NL),LATT
      CHARACTER*1 SYM
      DIMENSION ILEAK(2),BR(3),BZ(3),IPOINT(NL),BINP(NL)
      DIMENSION IDAT(2,NL),XK(2,NL),BR2(2,NL,3),BZ2(2,NL,3),B2(2,NL,3)
      DIMENSION B2REF(NR),DELTAB(NR),XKINF(2,NL)
      DATA LIN,LRE,LOU,LKB,LTT / 1, 2, 3, 5, 6 /
      DATA BLNK/'                                        '/
     &     FLST/'WWERCR.LST'/
     &     FINP/'WWERCR.OUT'/
     &     FREF/'WWERCR.REF'/
      WRITE(LTT,91)
      WRITE(LTT,91) ' WWER-LATTICE CRITICALITY BENCHMARKS    '
      WRITE(LTT,91) ' ===================================    '
      WRITE(LTT,91)
      WRITE(LTT,91) ' Criticality prediction                 '
      WRITE(LTT,91)
C*
C* Define I/O filenames
C*
   1  WRITE(LTT,91) '        Enter the WIMS output filename: '
      WRITE(LTT,91) '                      Default filename: ',FINP
      WRITE(LTT,91) '$                     Blank = Default : '
      READ (LKB,91) FLNM
      IF(FLNM.NE.BLNK) FINP=FLNM
      OPEN (UNIT=LIN,FILE=FINP,STATUS='OLD',ERR=1)
      WRITE(LTT,91)
   2  WRITE(LTT,91) '          Enter the REFERENCE filename: '
      WRITE(LTT,91) '                      Default filename: ',FREF
      WRITE(LTT,91) '$                     Blank = Default : '
      READ (LKB,91) FLNM
      IF(FLNM.NE.BLNK) FREF=FLNM
      OPEN (UNIT=LRE,FILE=FREF,STATUS='OLD',ERR=2)
      I=1
      READ(LRE,20,ERR=500) LINE
      READ(LRE,20,ERR=500) LINE
      DO WHILE (LINE(1:40).NE.BLNK)
        READ(LINE,30) LIDR(I),B2REF(I),DELTAB(I)
        I=I+1
        READ(LRE,20, END=4, ERR=500) LINE
        IF(I.GT.NR) THEN
          STOP ' Error 1: Array capacity exceeded'
        ENDIF
      END DO
   4  KR=I-1
      CLOSE(LRE)
      WRITE(LTT,91)
   11 WRITE(LTT,91) ' Enter output report filename (*.LST) : '
      WRITE(LTT,91) '                    Default filename  : ',FLST
      WRITE(LTT,91) '           Enter new name to redefine : '
      READ (LKB,91) FLNM
      IF(FLNM.NE.BLNK) FLST=FLNM
      OPEN(UNIT=LOU,FILE=FLST,STATUS='UNKNOWN',ERR=11)
      DO I=1,NL
        BINP(I)=0.0
        DO K=1,2
          XK(K,I)=0.0
          IDAT(K,I)=-1
          DO J=1,3
            BR2(K,I,J)=0.0
            BZ2(K,I,J)=0.0
            B2(K,I,J)=0.0
          END DO
        END DO
      END DO
      IW=0
      IL=0
      LATT=BLNK(1:17)
      DO WHILE (IW.EQ.0)
        READ(LIN,'(A120)',ERR=500)LINE
        IF (LINE(7:23).EQ.'**** WWER-LATTICE') THEN
          READ(LINE,'(23X,A17)')LATT
        ELSE IF (LINE(27:34).EQ.'chain 14') THEN
          IL=IL+1
          IF (IL.GT.NL) STOP ' Error 2: Array storage exceeded '
          LIDW(IL)=LATT
          LATT=BLNK(1:17)
        ELSE IF(LINE(2:43).EQ.
     &          'diagonal transport corrected flux solution') THEN
          CALL GETKB(LIN,XK(1,IL),XKINF(1,IL),1,BR,BZ)
          IDAT(1,IL)=1
          DO K=1,3
            BR2(1,IL,K)=BR(K)*10000.
            BZ2(1,IL,K)=BZ(K)*10000.
            B2(1,IL,K)=BR2(1,IL,K)+BZ2(1,IL,K)
          END DO
            BINP(IL)=BR2(1,IL,2)+BZ2(1,IL,3)
        ELSE IF(LINE(2:20).EQ.'b(1) flux solution') THEN
          CALL GETKB(LIN,XK(2,IL),XKINF(2,IL),1,BR,BZ)
          IDAT(2,IL)=1
          DO K=1,3
            BR2(2,IL,K)=BR(K)*10000.
            BZ2(2,IL,K)=BZ(K)*10000.
            B2(2,IL,K)=BR2(2,IL,K)+BZ2(2,IL,K)
          END DO
            BINP(IL)=BR2(2,IL,2)+BZ2(2,IL,3)
        ELSE IF (LINE(2:24).EQ.'END OF FILE ON DATASET') THEN
          IW=1
        ENDIF
      END DO
  400 CLOSE(LIN)
      KL=IL
      DO IL=1,KL
        IR=1
        IFIND=0
        DO WHILE(IR.LE.KR.AND.IFIND.EQ.0)
          IF(LIDW(IL).NE.LIDR(IR)) THEN
            IR=IR+1
          ELSE
            IFIND=1
            IPOINT(IL)=IR
          ENDIF
        END DO
        IF (IFIND.EQ.0) THEN
          WRITE(LTT,*)' NO EXPERIMENTAL DATA FOR LATTICE ',LIDW(IL)
          IPOINT(IL)=-1
        ENDIF
      END DO
      DO K=1,2
        ILEAK(K)=-1
        IL=1
        DO WHILE(IL.LE.KL.AND.ILEAK(K).LT.0)
          IF(IDAT(K,IL).LT.0) THEN
            IL=IL+1
          ELSE
            ILEAK(K)=1
          ENDIF
        END DO
      END DO
      WRITE(LOU,91)
      WRITE(LOU,91)
      WRITE(LOU,91)' WWER-LATTICE CRITICALITY BENCHMARKS    '
      WRITE(LOU,91)' ===================================    '
      WRITE(LOU,91)
      WRITE(LOU,91)' Criticality prediction                 '
      WRITE(LOU,91)
      WRITE(LOU,92)' WIMSD5 input file: ',FINP
      WRITE(LOU,92)'    Reference file: ',FREF
      WRITE(LOU,92)
      DO K=1,2
        IF (ILEAK(K).GT.0) THEN
          IF (K.EQ.1) THEN
            WRITE(LOU,91)' Diffusion corrected solution           '
            WRITE(LOU,91)' ----------------------------           '
          ELSE
            WRITE(LOU,91)' B(1) corrected solution                '
            WRITE(LOU,91)' -----------------------                '
          ENDIF
          WRITE(LOU,93)' No.','LATTICE',' Kinf    ',' Keff    ',
     &                 'Keff-1.0','Cal. B2[1/m2]','Exp. B2[1/m2]'
          WRITE(LOU,93)'    ','       ','         ','         ',
     &                 '  [pcm] ',' Diff. [1/m2]','  Std. [1/m2]'
          WRITE(LOU,93)'    ','       ','         ','         ',
     &                 '        ',' Diff. [%]   ','  Std. [%]   '
          DO I=1,KL
            IF (IDAT(K,I).GT.0) THEN
              J=IPOINT(I)
              XKEFF=XK(K,I)
              XINF=XKINF(K,I)
              IDK=NINT((XKEFF-1.0)*100000.0+0.5)
              B2W=B2(K,I,3)
              IF (J.GT.0) THEN
                BB=ABS(BINP(I)-B2REF(J))
                IF (BB.GT.1.0E-4) THEN
                  WRITE(LOU,*)' *** WARNING ***  LATTICE ',LIDW(I)
                  WRITE(LOU,*)' Reference and Input Bucklings ',
     &                        'do not match ',B2REF(J),BINP(I)
                END IF
                DIFBA=B2W-B2REF(J)
                DIFBR=DIFBA/B2REF(J)*100.0
                DIFRR=DELTAB(J)/B2REF(J)*100.0
                X=ABS(DIFBR)
                Y=ABS(DIFRR)
                IF (X.GT.Y) THEN
                  SYM='*'
                ELSE
                  SYM=' '
                ENDIF
                WRITE(LOU,94)I,SYM,LIDW(I),XINF,XKEFF,IDK,B2W,B2REF(J)
                WRITE(LOU,95)DIFBA,DELTAB(J)
                WRITE(LOU,95)DIFBR,DIFRR
              ELSE
                WRITE(LOU,94)I,'?',LIDW(I),XINF,XKEFF,IDK,B2W
                WRITE(LOU,92)
                WRITE(LOU,92)
              ENDIF
            ENDIF
          END DO
          WRITE(LOU,92)
        ENDIF
      END DO
      CLOSE(LOU)
      STOP ' Normal ending'
  500 STOP ' Error 3: Error reading input files'
   20 FORMAT(A120)
   30 FORMAT(A17,7E8.0)
   91 FORMAT(2A40)
   92 FORMAT(A20,A40)
   93 FORMAT(A4,7X,A7,6X,A9,A9,A8,1X,2(1X,A13))
   94 FORMAT(I3,1X,A1,1X,A17,F8.5,F9.5,I8,1X,F12.2,F14.2)
   95 FORMAT(49X,F12.2,F14.2)
      END
      SUBROUTINE GETKB(LIN,XKEFF,XKINF,IKK,BR,BZ)
C*      Subroutine GETKB: Get Keff and Kinf from chain 14 output.
C*                        Get critical bucklings.
C*      Parameters:
C*        LIN: FORTRAN unit for the WIMSD5 output file
C*      XKEFF: Returned multiplication factor K
C*      XKINF: K-infinity
C*        IKK: Trigger
C*         if  IKK>0 --> few group K is retrieved
C*             IKK<0 --> 2 group K is retrieved
C*         BR: Array containing radial bucklings of the 3
C*             critical search.
C*         BZ: Array containing axial bucklings of the 3
C*             critical search.
C*
C*      Version: 1.0a
C*
      CHARACTER*120 LINE
      DIMENSION BR(*), BZ(*)
      READ(LIN,'(A120)',ERR=10)LINE
      IFIND=0
      DO WHILE(LINE(16:31).NE.'entry into chain'.AND.IFIND.EQ.0)
        IF (LINE(26:35).EQ.'k-infinity') THEN
          READ(LINE,'(36X,E13.0,15X,E13.0)')XINF,XEFF
          READ(LIN,'(36X,E13.0,15X,E13.0)')XINF2,XEFF2
          IF (IKK.GT.0) THEN
            XKINF=XINF
            XKEFF=XEFF
          ELSE
            XKINF=XINF2
            XKEFF=XEFF2
          END IF
        ELSE IF (LINE(9:38).EQ.'buckling search         given') THEN
          READ(LIN,'(A120)',ERR=10)LINE
          DO K=1,3
            READ(LIN,'(2E14.0)')BR(K),BZ(K)
          END DO
          IFIND=1
        END IF
        READ(LIN,'(A120)',ERR=10)LINE
      END DO
      BACKSPACE(LIN)
      RETURN
   10 WRITE(*,*)' Warning: Error found reading chain 14'
      RETURN
      END
*deck xspmix 
      PROGRAM XSPMIX
C-Title  : XSPMIX Program
C-Purpose: Mix fission spectra for the WIMS-D Library
C-Author : A.Trkov, Institute Jozef Stefan, Ljubljana Slovenia
C-Version:
C-V  00/01 Compatibility with direct NJOY output.
C-V  01/05 Correct NG0 initialisation.
C-M
C-M  Manual for Program XSPMIX
C-M  =========================
C-M  A block of numbers (format 5F15.0) is expected on two or more
C-M  separate files to represent the fission spectra of fissile
C-M  isotopes. The block of numbers may be preceeded by the header
C-M  record separating entries in the WIMS-D library, which is
C-M  appropriate for the fission spectrum data and has the form:
C-M  "      999999999              i             gg"
C-M  where "i" and "gg" are optional. If present, "i"=2 (obligatory)
C-M  and "gg" is the number of groups in which the spectrum is given.
C-M    By specifying the fraction of the isotope, the spectra
C-M  are weighted to get the average, which is written on output.
C-M  The average spectrum is written with the header shown above,
C-M  which is recognized automatically by the WILLIE code. The
C-M  spectrum is normalised to 1.
C-M
C-M  Input instructions:
C-M  The filenames are requested interactively from keyboard. On
C-M  error (eg. specifying a non-existent input file) the request for
C-M  a filename is repeated. The fraction of the isotope is also
C-M  requested in a similar way. It can be expressed arbitrarily
C-M  (i.e. percent, fraction, etc.) since the final spectrum is
C-M  normalised to 1. No other input is required.
C-M
C-M  NOTE:
C-M  To enable automatic processing of the files produced with NJOY,
C-M  which do not adhere strictly to the label conventions on the
C-M  delimiter record, the first entry in the spectrum should be
C-M  less than 1.
C-
      PARAMETER (MXSP=200)
      CHARACTER*40 BLNK,FLNM,FLSP,FLNO
      DIMENSION    SP1(MXSP),SP2(MXSP)
      DATA SP2/MXSP*0./
      DATA BLNK/'                                        '/
C* Default filenames
      DATA FLSP/'ISOTOPE.XSP'/
     3     FLNO/'FISSION.XSP'/
C* Default number of groups for fission spectrum
      DATA MG0,NG0/ 0, 0 /
C* Default fraction of fissions in the first isotope
      DEL28=0.06
      DELTO=0.
      WRITE(6,91) ' XSPMIX - Fission Spectrum Mixing       '
      WRITE(6,91) ' ================================       '
      WRITE(6,91)
      NISO =0
C* Define filenames
   10 WRITE(6,91) ' Default output spectrum filename     : ',FLNO
      WRITE(6,91) '$          Enter new name to redefine : '
      READ (5,91) FLNM
      IF(FLNM.NE.BLNK) FLNO=FLNM
      OPEN (UNIT=3,FILE=FLNO,STATUS='UNKNOWN',ERR=10)
   20 WRITE(6,91)
      WRITE(6,91) '$Enter fission spectrum filename      : '
      READ (5,91) FLNM
      IF(FLNM.EQ.BLNK) GO TO 40
      FLSP=FLNM
      OPEN (UNIT=1,FILE=FLSP,STATUS='OLD',ERR=20)
   28 WRITE(6,91) '$Enter the fission spectrum fraction  : '
      DEL28=1-DELTO
      READ (5,91) FLNM
      IF(FLNM.NE.BLNK) READ(FLNM,*,ERR=28) DEL28
      DELTO=DELTO+DEL28
      NG0  =0
C*
C* Process the spectrum file
      NISO =NISO+1
      READ (1,91) FLNM
      REWIND 1
      IF(FLNM(7:15).NE.'999999999') GO TO 33
C* Find the appropriate header identifying the spectrum
   32 READ (1,91,END=81) FLNM
      IF(FLNM(7:15).NE.'999999999') GO TO 32
      READ (FLNM,95) JTERM,NSP,JG0
      IF(NSP.GT.0 .AND. NSP.NE.2) GO TO 32
      IF(JG0.GT.0) NG0=JG0
   33 IF(NG0.GT.0) THEN
        READ (1,96,ERR=32) (SP1(J),J=1,NG0)
        IF(SP1(1).GE.1) GO TO 32
      ELSE
        KG1=0
   34   KG0=KG1+1
        KG1=KG1+5
        READ (1,96,END=35,ERR=32) (SP1(J),J=KG0,KG1)
        IF(SP1( 1 ).GE. 1       ) GO TO 32
        IF(SP1(KG0).GT.999999000) GO TO 35
        GO TO 34
   35   NG0=KG0-1
   36   IF(NG0.LE.1) STOP 'XSPMIX ERROR - Zero spectrum'
        IF(SP1(NG0).GT.0) GO TO 37
        NG0=NG0-1
        GO TO 36
      END IF
   37 IF(NISO.GT.1 .AND. MG0.NE.NG0)
     1WRITE(6,92) ' WARNING - Different No. of spectrum gr.',NG0
      MG0=NG0
C* Add the contribution
      DO 38 J=1,NG0
      SP2(J)=SP2(J)+SP1(J)*DEL28
   38 CONTINUE
      GO TO 20
C*
C* Normalize the spectrum
   40 IF(NISO.LT.1) GO TO 82
      WRITE(6,92) ' Number of spectrum files processed   : ',NISO
      SS2=0.
      DO 46 I=1,MG0
      SS2=SS2+SP2(I)
   46 CONTINUE
      IF(SS2.LE.0) GO TO 84
C*
C* Write the spectrum to output
      WRITE(3,95) 999999999,2,MG0
      WRITE(3,94) (SP2(J)/SS2,J=1,MG0)
      STOP 'XSPMIX Completed'
C*
C* Error traps
   81 WRITE(6,91) ' XSPMIX ERROR - Processing spectr.file: ',FLSP
      STOP 'XSPMIX ERROR - invalid spectrum file'
   82 WRITE(6,91) ' XSPMIX ERROR - No spectra to average   '
      STOP 'XSPMIX ERROR - No spectrum files given'
   84 WRITE(6,91) ' XSPMIX ERROR - Zero spectrum on file   '
      STOP 'XSPMIX ERROR - Zero spectrum'
C*
   91 FORMAT(2A40)
   92 FORMAT(A40,I5)
   93 FORMAT(A40,F10.6)
   94 FORMAT(1P,5E15.8)
   95 FORMAT(5I15)
   96 FORMAT(5F15.0)
      END
