C This file is part of PREPRO.
C
C    Author: Dermott (Red) Cullen
C Copyright: (C) International Atomic Energy Agency
C
C PREPRO is free software; you can redistribute it and/or modify it
C under the terms of the MIT License; see LICENSE file for more details.

C=======================================================================
C
C     PROGRAM SPECTRA
C     ===============
C     An extension of LINEAR to linearize ALl MF=5 spectra.
C     2012/05/28 - Added MF=15 neutron induced, photon spectra.
C     2021/01/26 - MF=6 Still NOT Implemented
C
C     First released in 2010 - Earlier below dates refer to LINEAR.
C
C     VERSION 74-1 (MAY 1974)
C     VERSION 75-1 (APRIL 1975)
C     VERSION 76-2 (OCTOBER 1976)
C     VERSION 77-1 (JANUARY 1977)
C     VERSION 78-1 (JULY 1978)
C     VERSION 79-1 (JULY 1979) CDC-7600 AND CRAY-1 VERSION.
C     VERSION 80-1 (MAY 1980) IBM, CDC AND CRAY VERSION.
C     VERSION 80-2 (DECEMBER 1980)
C     VERSION 81-1 (MARCH 1981)
C     VERSION 82-1 (JANUARY 1982) IMPROVED COMPUTER COMPATIBILITY.
C     VERSION 83-1 (JANUARY 1983) *MAJOR RE-DESIGN.
C                                 *PAGE SIZE INCREASED - 1002 TO 3006.
C                                 *ELIMINATED COMPUTER DEPENDENT CODING.
C                                 *NEW, MORE COMPATIBLE I/O UNIT NUMBER.
C                                 *ADDED OPTION TO KEEP ALL ORIGINAL
C                                  ENERGY POINTS FROM EVALUATION.
C                                 *ADDED STANDARD ALLOWABLE ERROR OPTION
C                                  (CURRENTLY 0.1 PER-CENT).
C     VERSION 83-2 (OCTOBER 1983) IMPROVED BASED ON USER COMMENTS.
C     VERSION 84-1 (APRIL 1984)   IMPROVED BASED ON USER COMMENTS.
C     VERSION 84-2 (JUNE 1984)   *UPDATED FOR ENDF/B-VI FORMATS.
C                                *SPECIAL I/O ROUTINES TO GUARANTEE
C                                 ACCURACY OF ENERGY.
C                                *DOUBLE PRECISION TREATMENT OF ENERGY
C                                 (REQUIRED FOR NARROW RESONANCES).
C     VERSION 85-1 (AUGUST 1985) *FORTRAN-77/H VERSION
C     VERSION 86-1 (JANUARY 1986)*ENDF/B-VI FORMAT
C     VERSION 87-1 (JANUARY 1987)*DOUBLE PRECISION TREATMENT OF CROSS
C                                 SECTION
C     VERSION 88-1 (JULY 1988)   *OPTION...INTERNALLY DEFINE ALL I/O
C                                 FILE NAMES (SEE, SUBROUTINE FILEIO
C                                 FOR DETAILS).
C                                *IMPROVED BASED ON USER COMMENTS.
C     VERSION 89-1 (JANUARY 1989)*PSYCHOANALYZED BY PROGRAM FREUD TO
C                                 INSURE PROGRAM WILL NOT DO ANYTHING
C                                 CRAZY.
C                                *UPDATED TO USE NEW PROGRAM CONVERT
C                                 KEYWORDS.
C                                *ADDED LIVERMORE CIVIC COMPILER
C                                 CONVENTIONS.
C     VERSION 90-1 (JUNE 1990)   *EXTENDED TO LINEARIZE PHOTON
C                                 INTERACTION DATA, MF=23 AND 27
C                                *ADDED FORTRAN SAVE OPTION
C                                *UPDATED BASED ON USER COMMENTS.
C                                *NEW MORE CONSISTENT ENERGY OUTPUT
C                                 ROUTINE.
C                                *WARNING...INPUT PARAMETER FORMAT
C                                 HAS BEEN CHANGED...SEE DESCRIPTION
C                                 BELOW.
C     VERSION 91-1 (JULY 1991)   *ADDED INTERPOLATION LAW 6 - ONLY USED
C                                 FOR CHARGED PARTICLE CROSS SECTIONS
C                                 FOR COULOMB PENETRABILITIES.
C     VERSION 92-1 (JANUARY 1992)*ADDED NU-BAR (TOTAL, DELAYED, PROMPT)
C                                 POLYNOMIAL OR TABULATED ALL CONVERTED
C                                 TO LINEARLY INTERPOLABLE
C                                *INCREASED PAGE SIZE FROM 3006 TO 5010
C                                 POINTS.
C                                *ALL ENERGIES INTERNALLY ROUNDED PRIOR
C                                 TO CALCULATIONS.
C                                *COMPLETELY CONSISTENT I/O AND ROUNDING
C                                 ROUTINES - TO MINIMIZE COMPUTER
C                                 DEPENDENCE.
C     VERSION 92-2 (JULY 1992)   *CORRECTED CONVERSION OF NU-BAR FROM
C                                 POLYNOMIAL TO TABULATED - COPY
C                                 SPONTANEOUS NU-BAR (BY DEFINITION
C                                 THE SPONTANEOUS NU-BAR IS NOT AN
C                                 ENERGY DEPENDENT QUANTITY).
C     VERSION 93-1 (MARCH 1993)  *UPDATED FOR USE WITH LAHEY COMPILER
C                                 ON IBM-PCS.
C                                *INCREASED PAGE SIZE FROM 5010 TO
C                                 30000 POINTS
C     VERSION 94-1 (JANUARY 1994)*VARIABLE ENDF/B DATA FILENAMES
C                                 TO ALLOW ACCESS TO FILE STRUCTURES
C                                 (WARNING - INPUT PARAMETER FORMAT
C                                 HAS BEEN CHANGED)
C                                *CLOSE ALL FILES BEFORE TERMINATING
C                                 (SEE, SUBROUTINE ENDIT)
C     VERSION 96-1 (JANUARY 1996) *COMPLETE RE-WRITE
C                                 *IMPROVED COMPUTER INDEPENDENCE
C                                 *ALL DOUBLE PRECISION
C                                 *ON SCREEN OUTPUT
C                                 *UNIFORM TREATMENT OF ENDF/B I/O
C                                 *IMPROVED OUTPUT PRECISION
C                                 *DEFINED SCRATCH FILE NAMES
C                                 *ALWAYS INCLUDE THERMAL VALUE
C                                 *INCREASED PAGE SIZE FROM 30000 TO
C                                  60000 POINTS
C     VERSION 99-1 (MARCH 1999)   *CORRECTED CHARACTER TO FLOATING
C                                  POINT READ FOR MORE DIGITS
C                                 *UPDATED TEST FOR ENDF/B FORMAT
C                                  VERSION BASED ON RECENT FORMAT CHANGE
C                                 *GENERAL IMPROVEMENTS BASED ON
C                                  USER FEEDBACK
C     VERSION 99-2 (JUNE 1999)    *ASSUME ENDF/B-VI, NOT V, IF MISSING
C                                  MF=1, MT-451.
C     VERS. 2000-1 (FEBRUARY 2000)*ADDED MF = 9 AND 10 LINEARIZATION
C                                 *GENERAL IMPROVEMENTS BASED ON
C                                  USER FEEDBACK
C     VERS. 2002-1 (MAY 2002)     *OPTIONAL INPUT PARAMETERS
C     VERS. 2004-1 (JAN. 2004)    *GENERAL UPDATE BASED ON USER FEEDBACK
C     VERS. 2005-1 (JAN. 2005)    *ALWAYS KEEP ORIGINAL TABULATED
C                                  NU-BAR POINTS.
C     VERS. 2006-1 (FEB. 2006)    *CORRECTED INT=6 NEAR THRESHOLD
C                                 *NO SUBDIVIDE BELOW MINIMUM XCMIN
C     VERS. 2007-1 (JAN. 2007)    *CHECKED AGAINST ALL ENDF/B-VII.
C                                 *INCREASED PAGE SIZE FROM 60,000 TO
C                                  600,000 POINTS
C     VERS. 2010-1 (JUNE 2010)    *ADDED MF = 5 - MF = 6 STILL PLANNED.
C                                 *72 CHARACTER FILE NAMES.
C                                 *ONLY PROCESS MF=5 - SKIP ALL OTHERS
C                                  TO PREVENT CONFLICT WITH LINEAR
C                                  THINNING.
C     VERS. 2012-1 (Aug. 2012)    *Added MF=15, neutron induced photon
C                                  spectra.
C                                 *Added CODENAME
C                                 *32 and 64 bit Compatible
C                                 *Added ERROR stop
C     VERS. 2015-1 (Jan. 2015)    *Extended OUT9.
C                                 *Replaced ALL 3 way IF Statements.
C                                 *Corrected MF=15 Data - it was adding
C                                  SEND between sub-sections.
C                                 *Deleted unused parts, e.g., NUBAR.
C     VERS. 2017-1 (May  2017)    *Increased page size to 3,000,000
C                                 *Updated based on user feedback
C                                 *Changed DGAMMA to REDGAMMA to avoid
C                                  conflict with possble RESERVED NAME
C                                 *All floating input parameters changed
C                                  to character input + IN9 conversion.
C     VERS. 2018-1 (Jan. 2018)    *On-line output for ALL ENDERROR
C     VERS. 2019-1 (June 2019)    *Additional Interpolation Law Tests
C                                 *Check Maximum Tabulated Energy to
C                                  insure it is the same for all MTs -
C                                  if not, print WARNING messages.
C                                 *Corrected END Histogram linearized -
C                                  Previously deleted last point - ERROR
C                                  to assume this has Y=0 - now keep
C                                  point, but insure Y = 0.
C     VERS. 2020-1 (Mar. 2020)    *Added Target Isomer State
C     VERS. 2021-1 (Jan. 2021)    *Updated for FORTRAN 2018
C
C     OWNED, MAINTAINED AND DISTRIBUTED BY
C     ------------------------------------
C     THE NUCLEAR DATA SECTION
C     INTERNATIONAL ATOMIC ENERGY AGENCY
C     P.O. BOX 100
C     A-1400, VIENNA, AUSTRIA
C     EUROPE
C
C     ORIGINALLY WRITTEN BY
C     ------------------------------------
C     Dermott E. Cullen
C
C     PRESENT CONTACT INFORMATION
C     ---------------------------
C     Dermott E. Cullen
C     1466 Hudson Way
C     Livermore, CA 94550
C     U.S.A.
C     Telephone  925-443-1911
C     E. Mail    RedCullen1@Comcast.net
C     Website    RedCullen1.net/HOMEPAGE.NEW
C
C     AUTHORS MESSAGE
C     ---------------
C     THE REPORT DESCRIBED ABOVE IS THE LATEST PUBLISHED DOCUMENTATION
C     FOR THIS PROGRAM. HOWEVER, THE COMMENTS BELOW SHOULD BE CONSIDERED
C     THE LATEST DOCUMENTATION INCLUDING ALL RECENT IMPROVEMENTS. PLEASE
C     READ ALL OF THESE COMMENTS BEFORE IMPLEMENTATION.
C
C     AT THE PRESENT TIME WE ARE ATTEMPTING TO DEVELOP A SET OF COMPUTER
C     INDEPENDENT PROGRAMS THAT CAN EASILY BE IMPLEMENTED ON ANY ONE
C     OF A WIDE VARIETY OF COMPUTERS. IN ORDER TO ASSIST IN THIS PROJECT
C     IT WOULD BE APPECIATED IF YOU WOULD NOTIFY THE AUTHOR OF ANY
C     COMPILER DIAGNOSTICS, OPERATING PROBLEMS OR SUGGESTIONS ON HOW TO
C     IMPROVE THIS PROGRAM. HOPEFULLY, IN THIS WAY FUTURE VERSIONS OF
C     THIS PROGRAM WILL BE COMPLETELY COMPATIBLE FOR USE ON YOUR
C     COMPUTER.
C
C     PURPOSE
C     -------
C     THIS PROGRAM IS DESIGNED TO CONVERT ENDF/B FILE 3, 23 AND 27 DATA
C     TO LINEAR-LINEAR INTERPOLABLE FORM. ANY SECTION THAT IS ALREADY
C     LINEAR-LINEAR INTERPOLABLE WILL BE THINNED.
C
C     IN THE FOLLOWING DISCUSSION FOR SIMPLICITY THE ENDF/B TERMINOLOGY
C     ---ENDF/B TAPE---WILL BE USED. IN FACT THE ACTUAL MEDIUM MAY BE
C     TAPE, CARDS, DISK OR ANY OTHER MEDIUM.
C
C     ENDF/B FORMAT
C     -------------
C     THIS PROGRAM ONLY USES THE ENDF/B BCD OR CARD IMAGE FORMAT (AS
C     OPPOSED TO THE BINARY FORMAT) AND CAN HANDLE DATA IN ANY VERSION
C     OF THE ENDF/B FORMAT (I.E., ENDF/B-I, II,III, IV, V OR VI FORMAT).
C
C     IT IS ASSUMED THAT THE DATA IS CORRECTLY CODED IN THE ENDF/B
C     FORMAT AND NO ERROR CHECKING IS PERFORMED. IN PARTICULAR IT IS
C     ASSUMED THAT THE MAT, MF AND MT ON EACH LINE IS CORRECT. SEQUENCE
C     NUMBERS (COLUMNS 76-80) ARE IGNORED ON INPUT, BUT WILL BE
C     CORRECTLY OUTPUT ON ALL LINES. THE FORMAT OF SECTION MF=1, MT=451
C     AND ALL SECTIONS OF MF=3 MUST BE CORRECT. THE PROGRAM COPIES ALL
C     OTHER SECTION OF DATA AS HOLLERITH AND AS SUCH IS INSENSITIVE TO
C     THE CORRECTNESS OR INCORRECTNESS OF ALL OTHER SECTIONS.
C
C     OUTPUT FORMAT
C     -------------
C     IN THIS VERSION OF LINEAR ALL ENERGIES WILL BE OUTPUT IN
C     F (INSTEAD OF E) FORMAT IN ORDER TO ALLOW ENERGIES TO BE WRITTEN
C     WITH UP TO 9 DIGITS OF ACCURACY. IN PREVIOUS VERSIONS THIS WAS AN
C     OUTPUT OPTION. HOWEVER USE OF THIS OPTION TO COMPARE THE RESULTS
C     OF ENERGIES WRITTEN IN THE NORMAL ENDF/B CONVENTION OF 6 DIGITS
C     TO THE 9 DIGIT OUTPUT FROM THIS PROGRAM DEMONSTRATED THAT FAILURE
C     TO USE THE 9 DIGIT OUTPUT CAN LEAD TO LARGE ERRORS IN THE DATA
C     DUE TO TRUNCATION OF ENERGIES TO 6 DIGITS DURING OUTPUT.
C
C     CONTENTS OF OUTPUT
C     ------------------
C     ENTIRE EVALUATIONS ARE OUTPUT, NOT JUST THE LINEARIZED DATA
C     CROSS SECTIONS, E.G. ANGULAR AND ENERGY DISTRIBUTIONS ARE ALSO
C     INCLUDED.
C
C     DOCUMENTATION
C     -------------
C     THE FACT THAT THIS PROGRAM HAS OPERATED ON THE DATA IS DOCUMENTED
C     BY THE ADDITION OF 3 COMMENT LINES AT THE END OF EACH HOLLERITH
C     SECTION IN THE FORM
C
C     ***************** PROGRAM SPECTRA (2021-1) ****************
C     FOR ALL DATA GREATER THAN 1.00000-10 IN ABSOLUTE VALUE
C     DATA LINEARIZED TO WITHIN AN ACCURACY OF  0.1  PER-CENT
C
C     THE ORDER OF SIMILAR COMMENTS (FROM RECENT, SIGMA1 AND GROUPIE)
C     REPRESENTS A COMPLETE HISTORY OF ALL OPERATIONS PERFORMED ON
C     THE DATA BY THESE PROGRAMS.
C
C     THESE COMMENT LINES ARE ONLY ADDED TO EXISTING HOLLERITH SECTIONS,
C     I.E., THIS PROGRAM WILL NOT CREATE A HOLLERITH SECTION. THE FORMAT
C     OF THE HOLLERITH SECTION IN ENDF/B-V DIFFERS FROM THE THAT OF
C     EARLIER VERSIONS OF ENDF/B. BY READING AN EXISTING MF=1, MT=451
C     IT IS POSSIBLE FOR THIS PROGRAM TO DETERMINE WHICH VERSION OF
C     THE ENDF/B FORMAT THE DATA IS IN. WITHOUT HAVING A SECTION OF
C     MF=1, MT=451 PRESENT IT IS IMPOSSIBLE FOR THIS PROGRAM TO
C     DETERMINE WHICH VERSION OF THE ENDF/B FORMAT THE DATA IS IN, AND
C     AS SUCH IT IS IMPOSSIBLE FOR THE PROGRAM TO DETERMINE WHAT FORMAT
C     SHOULD BE USED TO CREATE A HOLLERITH SECTION.
C
C     REACTION INDEX
C     --------------
C     THIS PROGRAM DOES NOT USE THE REACTION INDEX WHICH IS GIVEN IN
C     SECTION MF=1, MT=451 OF EACH EVALUATION.
C
C     THIS PROGRAM DOES NOT UPDATE THE REACTION INDEX IN MF=1, MT=451.
C     THIS CONVENTION HAS BEEN ADOPTED BECAUSE MOST USERS DO NOT
C     REQUIRE A CORRECT REACTION INDEX FOR THEIR APPLICATIONS AND IT WAS
C     NOT CONSIDERED WORTHWHILE TO INCLUDE THE OVERHEAD OF CONSTRUCTING
C     A CORRECT REACTION INDEX IN THIS PROGRAM. HOWEVER, IF YOU REQUIRE
C     A REACTION INDEX FOR YOUR APPLICATIONS, AFTER RUNNING THIS PROGRAM
C     YOU MAY USE PROGRAM DICTIN TO CREATE A CORRECT REACTION INDEX.
C
C     SECTION SIZE
C     ------------
C     SINCE THIS PROGRAM USES A LOGICAL PAGING SYSTEM THERE IS NO LIMIT
C     TO THE NUMBER OF POINTS IN ANY SECTION, E.G., THE TOTAL CROSS
C     SECTION MAY BE REPRESENTED BY 200,000 DATA POINTS.
C
C     FOR ANY LINEARIZED SECTION THAT CONTAINS 60000 OR FEWER POINTS
C     THE ENTIRE OPERATION WILL BE PERFORMED IN CORE AND THE LINEARIZED
C     DATA WILL BE OUTPUT DIRECTLY TO THE ENDF/B FORMAT. FOR ANY SECTION
C     THAT CONTAINS MORE POINTS THE DATA WILL BE LINEARIZED A PAGE AT A
C     TIME (1 PAGE = 60000 POINTS) AND OUTPUT TO SCRATCH. AFTER THE
C     ENTIRE SECTION HAS BEEN LINEARIZED THE DATA WILL BE READ BACK FROM
C     SCRATCH AND OUTPUT TO THE ENDF/B FORMAT.
C
C     SELECTION OF DATA
C     -----------------
C     THE PROGRAM SELECTS DATA TO BE LINEARIZED BASED EITHER ON EITHER
C     MAT (ENDF/B MAT NO.) OR ZA AS WELL AS MF AND MT NUMBERS. THIS
C     PROGRAM ALLOWS UP TO 100 MAT/MF/MT OR ZA/MF/MT RANGES TO BE
C     SPECIFIED BY INPUT PARAMETERS. THE PROGRAM WILL ASSUME THAT THE
C     ENDF/B TAPE IS IN MAT ORDER, REGARDLESS OF THE CRITERIA USED
C     TO RETRIEVE MATERIALS. IF RETRIEVAL IS BY MAT RANGE THE PROGRAM
C     WILL TERMINATE WHEN A MAT IS FOUND THAT IS ABOVE ALL REQUESTED
C     MAT RANGES. IF RETRIEVAL IS BY ZA RANGE THE PROGRAM WILL SEARCH
C     THE ENTIRE ENDF/B TAPE.
C
C     PROGRAM OPERATION
C     -----------------
C     EACH SECTION OF DATA IS CONSIDERED SEPARATELY. EACH SECTION OF
C     ENDF/B DATA TO LINEARIZE IS REPRESENTED BY A TABLE OF ENERGY
C     VS. CROSS SECTION AND ANY ONE OF FIVE ALLOWABLE INTERPOLATION LAWS
C     BETWEEN ANY TWO TABULATED POINTS. THIS PROGRAM WILL REPLACE EACH
C     SECTION OF DATA CROSS SECTIONS BY A NEW TABLE OF ENERGY VS.
C     CROSS SECTION IN WHICH THE INTERPOLATION LAW IS ALWAYS LINEAR IN
C     ENERGY AND CROSS SECTION BETWEEN ANY TWO TABULATED POINTS.
C
C     DATA IS READ AND LINEARIZED A PAGE AT A TIME (ONE PAGE CONTAINS
C     60000 DATA POINTS). IF THE FINAL LINEARIZED SECTION CONTAINS TWO
C     PAGES OR LESS, DATA POINTS IT WILL BE ENTIRELY CORE RESIDENT
C     AFTER IT HAS BEEN LINEARIZED AND WILL BE WRITTEN DIRECTLY FROM
C     CORE TO THE OUTPUT TAPE. IF THE LINEARIZED SECTION IS LARGER THAN
C     TWO PAGES, AFTER EACH PAGE IS LINEARIZED IT WILL BE WRITTEN TO
C     SCRATCH. AFTER THE ENTIRE SECTION HAS BEEN LINEARIZED IT WILL
C     BE READ BACK FROM SCRATCH, TWO PAGES AT A TIME, AND WRITTEN TO
C     THE OUTPUT TAPE.
C
C     KEEP EVALUATED DATA POINTS
C     --------------------------
C     SOMETIMES IT IS CONVENIENT TO KEEP ALL ENERGY POINTS WHICH WERE
C     PRESENT IN THE ORIGINAL EVALUATION AND TO MERELY SUPPLEMENT THESE
C     POINTS WITH ADDITIONAL ENERGY POINTS IN ORDER TO LINEARIZE THE
C     CROSS SECTIONS. FOR EXAMPLE, IT IS OFTEN CONVENIENT TO KEEP THE
C     THERMAL VALUE (AT 0.0253 EV) OR THE VALUE AT 14.1 MEV.
C
C     THE CURRENT VERSION OF THIS PROGRAM WILL ALLOW THE USER TO KEEP
C     ALL ORIGINAL EVALUATED DATA POINTS BY SPECIFYING 1 IN COLUMNS
C     34-44 OF THE FIRST INPUT LINE. THIS WILL TURN OFF THE BACKWARD
C     THINNING (SEE UCRL-50400, VOL. 17, PART A FOR EXPLANATION) AND
C     RESULT IN ALL ORIGINAL ENERGY POINTS BEING KEPT. CAUTION SHOULD
C     BE EXERCISED IN USING THIS OPTION SINCE IT CAN RESULT IN A
C     CONSIDERABLE INCREASE IN THE NUMBER OF DATA POINTS OUTPUT BY
C     THIS CODE.
C
C     FOR ALL USERS WHO ARE NOT INTERESTED IN THIS OPTIONS NO CHANGES
C     ARE REQUIRED IN THE INPUT TO THIS PROGRAM, I. E. IF COLUMNS
C     34-44 ARE BLANK (AS FOR ALL PREVIOUS VERSIONS OF THIS CODE) THE
C     PROGRAM WILL OPERATE EXACTLY AS IT DID BEFORE.
C
C     ALLOWABLE ERROR
C     ---------------
C     ALLOWABLE ERROR MUST ALWAYS BE SPECIFIED IN THE INPUT TO THIS
C     PROGRAM AS A FRACTION, NOT A PER-CENT. FOR EXAMPLE, INPUT THE
C     ALLOWABLE FRACTIONAL ERROR 0.001 IN ORDER TO OBTAIN DATA THAT IS
C     ACCURATE TO WITHIN 0.1 PER-CENT.
C
C     THE CONVERSION OF THE DATA FROM THE GENERAL INTERPOLATION FORM TO
C     LINARLY INTERPOLABLE FORM CANNOT BE PERFORMED EXACTLY. HOWEVER, IT
C     CAN BE PERFORMED TO VIRTUALLY ANY REQUIRED ACCURACY AND MOST
C     IMPORTANTLY CAN BE PERFORMED TO A TOLERANCE THAT IS SMALL COMPARED
C     TO THE UNCERTAINTY IN THE CROSS SECTIONS THEMSELVES. AS SUCH THE
C     CONVERSION OF CROSS SECTIONS TO LINEARLY INTERPOLABLE FORM CAN BE
C     PERFORMED WITH ESSENTIALLY NO LOSE OF INFORMATION.
C
C     THE ALLOWABLE ERROR MAY BE ENERGY INDEPENDENT (CONSTANT) OR ENERGY
C     DEPENDENT. THE ALLOWABLE ERROR IS DESCRIBED BY A TABULATED
C     FUNCTION OF UP TO 20 (ENERGY,ERROR) PAIRS AND LINEAR INTERPOLATION
C     BETWEEN TABULATED POINTS. IF ONLY ONE TABULATED POINT IS GIVEN THE
C     ERROR WILL BE CONSIDERED CONSTANT OVER THE ENTIRE ENERGY RANGE.
C     WITH THIS ENERGY DEPENDENT ERROR ONE MAY OPTIMIZE THE OUTPUT FOR
C     ANY GIVEN APPLICATION BY USING A SMALL ERROR IN THE ENERGY RANGE
C     OF INTEREST AND A LESS STRINGENT ERROR IN OTHER ENERGY RANGES.
C
C     DEFAULT ALLOWABLE ERROR
C     -----------------------
C     IN ORDER TO INSURE CONVERGENCE OF THE LINEARIZING ALGORITHM THE
C     ALLOWABLE ERROR MUST BE POSITIVE. IF THE USER INPUTS AN ERROR
C     THAT IS NOT POSITIVE IT WILL AUTOMATICALLY BE SET TO THE DEFAULT
C     VALUE (CURRENTLY 0.001, CORRESPONDING TO 0.1 PER-CENT) AND
C     INDICATED AS SUCH IN THE OUTPUT LISTING.
C
C     COULOMB PENETRABILITY (INTERPOLATION LAW = 6)
C     --------------------------------------------
C     INTRODUCED FOR ENDF/B-VI. THIS IS DEFINED AS,
C
C     SIG(E) = C1*EXP(-C2/SQRT(E - T))
C
C     THIS PROGRAM ONLY CONSIDERS EXOTHERMIC REACTIONS - T = 0
C
C     SIG(E) = C1*EXP(-C2/SQRT(E))
C
C     WARNING...THIS INTERPOLATION LAW SHOULD ONLY BE USED FOR REACTIONS
C               WHICH HAVE A POSITIVE Q-VALUE (EXOTHERMIC REACTIONS),
C               SINCE HERE WE ONLY CONSIDER T = 0.0 IN THE FORMALISM.
C               IN ALL OTHER CASES A WARNING MESSAGE WILL BE PRINTED.
C
C     INPUT FILES
C     -----------
C     UNIT  DESCRIPTION
C     ----  -----------
C        2  INPUT LINES (BCD - 80 CHARACTERS/RECORD)
C       10  ORIGINAL ENDF/B DATA (BCD - 80 CHARACTERS/RECORD)
C
C     OUTPUT FILES
C     ------------
C     UNIT  DESCRIPTION
C     ----  -----------
C        3  OUTPUT REPORT (BCD - 120 CHARACTERS/RECORD)
C       11  FINAL ENDF/B DATA (BCD - 80 CHARACTERS/RECORD)
C
C     SCRATCH FILES
C     -------------
C     UNIT  DESCRIPTION
C     ----  -----------
C       12  SCRATCH FILE (BINARY - 180000 WORDS/RECORD
C
C     OPTIONAL STANDARD FILE NAMES (SEE SUBROUTINE FILEIO)
C     ----------------------------------------------------
C     UNIT  FILE NAME
C     ----  ----------
C       2   SPECTRA.INP
C       3   SPECTRA.LST
C      10   ENDFB.IN
C      11   ENDFB.OUT
C      12   (SCRATCH)
C
C
C     INPUT PARAMETERS
C     ----------------
C     FOR VERSIONS EARLIER THAN 90-1 THIS PROGRAM ONLY ALLOWED THE USER
C     TO SPECIFY BY INPUT PARAMETERS WHICH MATERIALS (MAT) TO PROCESS.
C     FOR EACH REQUESTED MATERIAL NEUTRON INTERACTION CROSS SECTIONS
C     (MF=3) WOULD BE LINEARIZED AND THE REMAINDER OF THE MATERIAL
C     WOULD BE COPIED.
C
C     FOR VERSIONS 90-1 AND LATER THIS PROGRAM WILL ALLOW THE USER TO
C     TO SPECIFY BY INPUT PARAMETERS EXACTLY WHAT SECTIONS OF DATA
C     TO PROCESS. FOR EACH SECTION OF DATA, SPECIFIED BY MAT, MF, MT
C     RANGES, SECTIONS OF MF=3, 23 AND 27 WILL BE LINEARIZED AND ALL
C     OTHER REQUESTED SECTIONS WILL BE COPIED. ALL SECTIONS WHICH ARE
C     NOT EXPLICITLY REQUESTED WILL BE SKIPPED AND WILL NOT APPEAR ON
C     ENDF/B FILE OUTPUT BY THIS PROGRAM.
C
C     WITH THIS NEW PROCEDURE YOU CAN MINIMIZE THE SIZE OF THE ENDF/B
C     FILE OUTPUT BY THIS PROGRAM, E.G., IF YOU ONLY WANT NEUTRON
C     CROSS SECTIONS FOR SUBSEQUENT PROCESSING YOU NEED ONLY REQUEST
C     ONLY MF=3 DATA.
C
C     HOWEVER, YOU MUST UNDERSTAND THAT ONLY THOSE SECTIONS WHICH YOU
C     EXPLICITLY REQUEST WILL APPEAR ON THE ENDF/B FILE OUTPUT BY
C     THIS PROGRAM. FOR EXAMPLE, IF YOU WISH TO DOCUMENT EXACTLY
C     HOW YOU LINEARIZED THE DATA BY INCLUDING COMMENTS IN MF=1, MT=451
C     THEN YOU MUST EXPLICITLY REQUEST THAT MF=1, MT=451 BE PROCESSED
C     FOR EACH MATERIAL THAT YOU REQUEST. SIMILAR IF YOU WANT THE
C     ENTIRE EVALUATION YOU MUST REQUEST ALL MF AND MT TO BE OUTPUT.
C
C     LINE  COLS.  DESCRIPTION
C     ----  -----  -----------
C        1   1-11  SELECTION CRITERIA (0=MAT, 1=ZA)
C           12-22  MONITOR MODE SELECTOR
C                  = 0 - NORMAL OPERATION
C                  = 1 - MONITOR PROGRESS OF LINEARIZING OF THE DATA.
C                        EACH TIME A PAGE OF DATA POINTS IS WRITTEN TO
C                        THE SCRATCH FILE PRINT OUT THE TOTAL NUMBER OF
C                        POINTS ON SCRATCH AND THE LOWER AND UPPER
C                        ENERGY LIMITS OF THE PAGE (THIS OPTION MAY BE
C                        USED IN ORDER TO MONITOR THE EXECUTION SPEED
C                        OF LONG RUNNING JOBS).
C           23-33  MINIMUM CROSS SECTION OF INTEREST (BARNS).
C                  (IF 0.0 OR LESS IS INPUT THE PROGRAM WILL
C                  USE 1.0E-10). ENERGY INTERVALS WILL NOT BE
C                  SUB-DIVIDED IF THE ABSOLUTE VALUE OF THE CROSS
C                  SECTION WITHIN THE INTERVAL IS LESS THAN THIS VALUE.
C                  AN EXCEPTION TO THIS RULE IS NEAR THRESHOLDS ENERGY
C                  INTERVALS WILL BE SUB-DIVIDED UNTIL CONVERGENCE
C                  REGARDLESS OF THE MAGNITUDE OF THE CROSS SECTION.
C           34-44  KEEP ORIGINAL EVALUATED DATA POINTS.
C                  = 0 - NO.
C                  = 1 - YES - ADDITIONAL POINTS MAY BE ADDED IN ORDER
C                              TO LINEARIZE DATA, BUT ALL ORIGINAL
C                              DATA POINTS WILL BE INCLUDED IN THE
C                              RESULTS.
C        2   1-72  ENDF/B INPUT DATA FILENAME
C                  (STANDARD OPTION = ENDFB.IN)
C        3   1-72  ENDF/B OUTPUT DATA FILENAME
C                  (STANDARD OPTION = ENDFB.OUT)
C      4-N   1- 6  LOWER MAT OR ZA LIMIT
C            7- 8  LOWER MF LIMIT
C            9-11  LOWER MT LIMIT
C           12-17  UPPER MAT OR ZA LIMIT
C           18-19  UPPER MF LIMIT
C           20-22  UPPER MT LIMIT
C                  UP TO 100 RANGES MAY BE SPECIFIED, ONLY ONE RANGE
C                  PER LINE. THE LIST OF RANGES IS TERMINATED BY A
C                  BLANK LINE. IF THE UPPER MAT LIMIT OF ANY REQUEST
C                  IS LESS THAN THE LOW LIMIT IT WILL BE SET EQUAL TO
C                  THE LOWER LIMIT. IF THE UPPER LIMIT IS STILL ZERO
C                  IT WILL BE SET EQUAL TO 999999. IF THE UPPER MF OR
C                  MT LIMIT IS ZERO IT WILL BE SET TO 99 OR 999
C                  RESPECTIVELY.
C      VARY  1-11  ENERGY FOR ERROR LAW
C           12-22  ALLOWABLE FRACTIONAL ERROR FOR ERROR LAW.
C                  THE ACCEPTABLE LINEARIZING ERROR MAY BE SPECIFIED TO
C                  BE EITHER ENERGY INDEPENDENT (DEFINED BY A SINGLE
C                  ERROR), OR ENERGY DEPENDENT (DEFINED BY UP TO 20
C                  ENERGY, ERROR PAIRS). FOR THE ENERGY DEPENDENT CASE
C                  LINEAR INTERPOLATION WILL BE USED TO DEFINE THE ERROR
C                  AT ENERGIES BETWEEN THOSE AT WHICH IT IS TABULATED.
C                  IN ALL CASES THE ERROR LAW IS TERMINATED BY A BLANK
C                  LINE. IF ONLY ONE ENERGY, ERROR PAIR IS GIVEN THE
C                  THE LAW WILL BE CONSIDERED TO BE ENERGY INDEPENDENT.
C                  IF MORE THAN ONE PAIR IS GIVEN IT WILL BE CONSIDERED
C                  TO BE ENERGY DEPENDENT (NOTE, ENERGY INDEPENDENT
C                  FORM WILL RUN FASTER THAN THE EQUIVALENT ENERGY
C                  DEPENDENT FORM). FOR AN ENERGY DEPENDENT ERROR LAW
C                  ALL ENERGIES MUST BE ASCENDING ENERGY ORDER. FOR
C                  CONVERGENCE OF THE LINEARIZING ALGORITHM ALL ERRORS
C                  MUST BE POSITIVE. IF AN ALLOWABLE ERROR IS NOT
C                  POSITIVE IT WILL BE SET EQUAL TO THE STANDARD OPTION
C                  (CURRENTLY 0.001, CORRESPONDING TO 0.1 PER-CENT).
C                  IF THE FIRST ERROR LINE IS BLANK IT WILL TERMINATE
C                  THE ERROR LAW AND THE ERROR WILL BE TREATED AS
C                  ENERGY INDEPENDENT, EQUAL TO THE STANDARD OPTION
C                  (CURRENTLY 0.1 PER-CENT). (SEE EXAMPLE INPUT 4).
C
C     EXAMPLE INPUT NO. 1
C     -------------------
C     RETRIEVE DATA BY ZA IN ORDER TO FIND ALL URANIUM ISOTOPES AND
C     THORIUM 232. RETRIEVE ALL NEUTRON INTERACTION CROSS SECTIONS
C     (MF=3). ALL ENERGY INTERVALS IN WHICH THE CROSS SECTION IS
C     AT LEAST 1 MICRO-BARN (1.0E-06 BARNS) WILL BE SUBDIVIDED.
C     BACKWARD THINNING WILL BE PERFORMED. FROM 0 TO 100 EV LINEARIZE
C     TO WITHIN 0.1 PER-CENT ACCURACY. FROM 100 EV TO 1 KEV VARY
C     ACCURACY BETWEEN 0.1 AND 1.0 PER-CENT. ABOVE 1 KEV USE 1
C     PER-CENT ACCURACY.
C
C     EXPLICITLY SPECIFY THE STANDARD FILENAMES.
C
C     IN THIS CASE THE FOLLOWING 11 INPUT LINES ARE REQUIRED
C
C          1          0 1.00000- 6          0
C ENDFB.IN
C ENDFB.OUT
C 92000 3  0 92999 3999
C 90232 3  0     0 3  0    (UPPER LIMIT AUTOMATICALLY SET TO 90232 3999)
C                          (END OF REQUEST LIST)
C 0.00000+ 0 1.00000-03
C 1.00000+ 2 1.00000-03
C 1.00000+ 3 1.00000-02
C 1.00000+ 9 1.00000-02
C                          (END OF ERROR LAW)
C
C     EXAMPLE INPUT NO. 2
C     -------------------
C     SAME AS THE ABOVE CASE, EXCEPT LINEARIZE ALL DATA TO WITHIN THE
C     STANDARD ACCURACY (CURRENTLY 0.1 PER-CENT). IN ORDER TO USE THE
C     STANDARD ACCURACY YOU NEED NOT SPECIFY ANY ERROR LAW AT ALL. IN
C     THIS CASE INCLUDE THE HOLLERITH SECTION, MF=1, MT=451, FOR EACH
C     MATERIAL.
C
C     LEAVE THE DEFINITION OF THE FILENAMES BLANK - THE PROGRAM WILL
C     THEN USE STANDARD FILENAMES.
C
C     IN THIS CASE THE FOLLOWING 9 INPUT LINES ARE REQUIRED
C
C          1          0 1.00000- 6          0
C                          (USE DEFAULT FILENAME = ENDFB.IN)
C                          (USE DEFAULT FILENAME = ENDFB.OUT)
C 92000 1451 92999 1451
C 92000 3  0 92999 3999
C 90232 1451     0 1451
C 90232 3  0     0 3  0    (UPPER LIMIT AUTOMATICALLY SET TO 90232 3999)
C                          (END OF REQUEST LIST)
C                          (0.1 PER-CENT ERROR, END OF ERROR LAW)
C
C     EXAMPLE INPUT NO. 3
C     -------------------
C     LINEARIZE ALL MATERIALS ON AN ENDF/B TAPE TO WITHIN AN ACCURACY
C     OF 0.5 PER-CENT (0.005 AS A FRACTION). IN THIS CASE YOU NEED NOT
C     SPECIFY THE MAT, MF, MT RANGES.
C
C     READ THE ENDF/B DATA FROM \ENDFB6\ZA092238 AND WRITE THE ENDF/B
C     DATA TO \ENDFB6\LINEAR\ZA092238.
C
C     IN THIS CASE THE FOLLOWING 6 INPUT LINES ARE REQUIRED
C
C                                             (MAT, 1.0E-10 BARNS, THIN)
C \ENDFB6\ZA092238
C \ENDFB6\LINEAR\ZA092238
C                          (RETRIEVE ALL DATA, END REQUEST LIST)
C            5.00000-03
C                          (END OF ERROR LAW)
C
C     NOTE THAT IN THIS CASE IF THE INPUT HAD SPECIFIED AN EQUIVALENT
C     ENERGY DEPENDENT ERROR LAW BY GIVING A NUMBER OF ENERGY POINTS
C     AT EACH OF WHICH THE ERROR IS 0.5 PER-CENT THE PROGRAM WOULD TAKE
C     LONGER TO RUN (I.E., ONLY USE AN ENERGY DEPENDENT ERROR LAW WHEN
C     IT IS NECESSARY).
C
C     EXAMPLE INPUT NO. 4
C     -------------------
C     IN ORDER TO LINEARIZE ALL MATERIALS ON AN ENDF/B TAPE TO THE
C     STANDARD OPTION OF 0.1 PER-CENT IT IS ADEQUATE TO INPUT A SET
C     OF COMPLETELY BLANK LINES WHICH WILL AUTOMATICALLY INVOKE ALL
C     OF THE STANDARD OPTIONS.
C
C     LEAVE THE DEFINITION OF THE FILENAMES BLANK - THE PROGRAM WILL
C     THEN USE STANDARD FILENAMES.
C
C     IN THIS CASE THE FOLLOWING THREE INPUT LINES ARE REQUIRED
C
C                                             (MAT, 1.0E-10 BARNS, THIN)
C                          (USE DEFAULT FILENAME = ENDFB.IN)
C                          (USE DEFAULT FILENAME = ENDFB.OUT)
C                          (RETRIEVE ALL DATA, END REQUEST LIST)
C                          (0.1 PER-CENT ERROR, END OF ERROR LAW)
C
C=======================================================================
      INCLUDE 'implicit.h'
C-----08/08/2012 DEFINE CODE NAME
      CHARACTER*8 CODENAME
      COMMON/NAMECODE/CODENAME
      INTEGER*4 OUTP,OTAPE
      CHARACTER*4 CARD
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/COPC/CARD(17)
      COMMON/COPI/MFIELD(3)
      COMMON/COUNTS/MATNOW,MFNOW,MATIN,MATOUT,N2TOTI,N2TOTO
      COMMON/PAGER/NPAGE,NPAGE2,NP1P1,NP2M1
      COMMON/THRESE/ETHRES
      COMMON/EGRIDCOM/EGRID(2000),NGRID
      COMMON/ENRGYCOM/EMIN,EMAX,ETHERMAL
      INCLUDE 'spectra.h'
C-----08/08/2012 DEFINE CODE NAME
      CODENAME = 'SPECTRA '
C-----INITIALIZE TIMER
      CALL TIMER
c-----------------------------------------------------------------------
C
C     DEFINE ALL I/O UNITS AND OPTIONAL DEFINE FILE NAMES.
C
c-----------------------------------------------------------------------
      CALL FILEIO
C-----DEFINE ENERGY LIMITS AND ROOM THERMAL
      EMIN     = 1.0D-05  ! 1.0D-5 eV
      EMAX     = 2.0D+07  ! 20 MeV
      ETHERMAL = 2.53D-02 ! 0.0253 eV
C-----DEFINE STANDARD ENERGY GRID (1.0D-5 EV TO 20 MEV).
      CALL EGRID50(EGRID(1),NGRID,EMIN,EMAX)
C-----DEFINE ALL PAGE SIZE DEPENDENT PARAMETERS.
      NPAGE =MAXPAGE
      NPAGE2=MAXPAGE+MAXPAGE
      NP1P1 =NPAGE+1
      NP2M1 =NPAGE2-1
C-----IF A REACTION STARTS ABOVE ETHRES (THRESHOLD ENERGY) IT WILL BE
C-----CONSIDERED TO BE A THRESHOLD REACTION AND WILL ALWAYS START WITH
C-----A ZERO CROSS SECTION (IF IT DOESN'T A POINT WILL BE INSERTED).
      ETHRES=1.0D+00
C-----WRITE OUTPUT TITLE.
      WRITE(OUTP,110)
      WRITE(*   ,110)
c-----------------------------------------------------------------------
C
C     READ AND CHECK ALL INPUT PARAMETERS.
C
c-----------------------------------------------------------------------
      CALL READIN
c-----------------------------------------------------------------------
C
C     PROCESS REQUESTED SECTION OF ENDF/B DATA SEPARATELY. ADD COMMENTS
C     TO FILE 1, LINEARIZE FILES 3, 23 AND 27. COPY ALL OTHER SECTIONS.
C
c-----------------------------------------------------------------------
C-----COPY TAPE LABEL RECORD TO LINEARIZED FILE.
      CALL COPYL
C-----LIST TAPE LABEL.
      WRITE(OUTP,90) CARD,MFIELD(1)
      WRITE(*   ,90) CARD,MFIELD(1)
C-----INITIALIZE TOTAL POINTS READ AND WRITTEN.
      N2TOTI=0
      N2TOTO=0
C-----INITIALIZE LAST MAT AND MF READ.
      MATNOW=0
      MFNOW=0
c-----------------------------------------------------------------------
C
C     LOOP OVER SECTIONS.
C
c-----------------------------------------------------------------------
C-----FIND NEXT REQUESTED SECTION.
   10 CALL NEXTMT
C-----OUTPUT FIRST LINE OF EVALUATION OR TAPE END (TEND) LINE.
      CALL CONTO
C-----CHECK FOR END OF RUN.
      IF(MATH.LE.0) GO TO 70
c-----------------------------------------------------------------------
C
C     NU-BAR IS DONE ABOVE. ALL OTHER SECTIONS ARE DONE HERE.
C
c-----------------------------------------------------------------------
C-----FIND FILE 1, SECTION 451 AND ADD COMMENTS TO INDICATE THAT
C-----THIS MATERIAL HAS BEEN PROCESSED.
      IF(MFH.lt.1) go to 30
      IF(MFH.gt.1) go to 20
      IF(MTH.lt.451) go to 30
      IF(MTH.gt.451) go to 20
C-----ADD COMMENTS.
      CALL FILE1
      GO TO 10
C-----------------------------------------------------------------------
C
C     PROGRAM SPECTRA NOW ONLY DOES MF = 5 DATA
C
C-----------------------------------------------------------------------
C-----06/20/07 - ADDED MF = 5 AND 6
C-----NEUTRON ENERGY SPECTRA MF=5
   20 IF(MFH.lt.5) go to 30
      IF(MFH.eq.5) go to 40
C-----DOUBLE DIFFERENTIAL SPECTRA MF=6
      IF(MFH.lt.6) go to 30
      IF(MFH.eq.6) go to 50
C-----NEUTRON INDUCED PHOTON SPECTRA.
      IF(MFH.eq.15) go to 60
c-----------------------------------------------------------------------
C
C     COPY SECTION.
C
c-----------------------------------------------------------------------
   30 CALL COPYS
      GO TO 10
c-----------------------------------------------------------------------
C
C     MF =5, 6 AND 15.
C
c-----------------------------------------------------------------------
   40 CALL FILE5
      GO TO 10
   50 CALL FILE6
      GO TO 10
   60 CALL FILE15
      GO TO 10
c-----------------------------------------------------------------------
C
C     END OF RUN. END AND RE-POSITION LINEARIZED TAPE. LIST REPORT
C     FOR LAST MATERIAL AND ENTIRE TAPE.
C
c-----------------------------------------------------------------------
C-----END FILE ENDF/B FORMAT OUTPUT FILE
   70 CONTINUE
C-----PRINT WARNING MESSAGE IS NO DATA WAS FOUND TO SATISFY RETRIEVAL
C-----CRITERIA.
      IF(MATNOW.GT.0) GO TO 80
      WRITE(OUTP,120)
      WRITE(*   ,120)
      CALL ENDERROR
C-----WRITE POINT TOTALS FOR TAPE.
   80 WRITE(OUTP,100) N2TOTI,N2TOTO
      WRITE(*   ,100) N2TOTI,N2TOTO
c-----Print final WARNING if data not tabulated to same MAXIMUM Energy
      CALL MAXIE4(1)
c-----End of Run - Normal
      CALL ENDIT
      GO TO 80  ! CANNOT GET TO HERE
   90 FORMAT(2X,78('-')/
     1 '  ENDF/B Tape Label'/2X,78('-')/2X,16A4,A2,I4/2X,78('-')/
     2 '    Material    MAT  MF  MT  ENDF/B  Kelvin or  Q-Value  ',
     3 '   Points Points'/
     3 '                             Format  Incident E (eV)     ',
     4 '       In    Out'/
     4 2X,78('-'))
  100 FORMAT(2X,78('-')/48X,'Tape Totals',2I7/2X,78('-'))
  110 FORMAT('  Linearize ENDF/B Spectra',
     1 ' (SPECTRA 2021-1)'/2X,78('-'))
  120 FORMAT('  WARNING - No Data Found That Satisfied Retrieval',
     1 ' Criteria.'/12X,
     2 ' Therefore No Data was Linearized or Written to Output File.'/
     1 2X,78('-'))
      END
      SUBROUTINE FILE1
C=======================================================================
C
C     ADD COMMENTS AT THE END OF FILE 1, SECTION 451 TO INDICATE
C     THAT THIS MATERIAL HAS BEEN PROCESSED BY PROGRAM SPECTRA AND
C     TO SPECIFY THE ALLOWABLE ERROR.
C
C     DEFINE FORMAT TO BE ENDF/B-IV, V OR VI.
C
C     THE ENDF/B FORMAT CAN BE DETERMINED FROM THE SECOND LINE.
C     ENDF/B-IV = N1 > 0, N2 = 0,LINE COUNT (POSITIVE)
C     ENDF/B-V  = N1 = N2 = 0
C     ENDF/B-VI =      N2 = VERSION NUMBER (6 OR MORE)
C
C     First line has already been read.
C
C=======================================================================
      INCLUDE 'implicit.h'
      CHARACTER*1 PROGDOC1
      CHARACTER*4 FMTTAB,FMTHOL
      CHARACTER*66 PROGDOC
      COMMON/LEADER/C1,C2,L1,L2,N1,N2,MAT,MF,MT
      COMMON/OKERR3/ERRXC3,KERR3,MAXER3,ENER3(21),ER3(21)
      COMMON/HOLFMT/FMTHOL
      COMMON/PARAMS/XCMIN
      COMMON/TEMPO/TEMP3,IVERSE
      COMMON/LISOCOM/LISO
      DIMENSION FMTTAB(4),PROGDOC(8),PROGDOC1(66,8)
      EQUIVALENCE (PROGDOC(1),PROGDOC1(1,1))
C-----ENDF/B VERSION
      DATA FMTTAB/'IV  ','V   ','VI  ','VII '/
c-----------------------------------------------------------------------
c
C     DOCUMENTATION TO ADD TO ENDF/B OUTPUT - EACH LINE IS 66
C     CHARACTERS LONG - FIELDS 12345678901 ARE FILLED IN WITH
C     11 CHARACTERS DURING EXECUTION.
c
c-----------------------------------------------------------------------
C               1         2         3         4         5         6
C       12345678901234567890123456789012345678901234567890123456789012
C       3456
      DATA PROGDOC/
     1 ' **************** Program SPECTRA (VERSION 2021-1) ***********',
     2 ' For All Data Greater than12345678901 barns in Absolute Value ',
     3 ' Data Linearized to Within an Accuracy of12345678901 per-cent ',
     4 ' Data Linearized Using Energy Dependent Uncertainty           ',
     5 '      Energy    Accuracy                                      ',
     6 '        (eV)  (per-cent)                                      ',
     7 ' ----------- -----------                                      ',
     8 ' 12345678901 12345678901                                      '/
C-----FILL IN REMAINDER OF FIRST LINE.
      PROGDOC1(63,1) = '*'
      PROGDOC1(64,1) = '*'
      PROGDOC1(65,1) = '*'
      PROGDOC1(66,1) = '*'
c
c     Read Second Line
c
C-----HEAD LINE OF SECTION HAS BEEN READ AND WRITTEN. READ NEXT LINE
C-----AND DETERMINE IF THIS IS THE ENDF/B-IV, V OR VI FORMAT.
      CALL CARDI(C1,C2,L1,L2,N1,N2)
      IVERSE=4
      LISOX = L2            ! Save potrential isoter number
C-----CHECK FOR ENDF/B-IV.
C-----IV N1 > 0, N2 = 0
      IF(N1.GT.0.AND.N2.EQ.0) GO TO 10
C-----NOT ENDF/B-IV. READ THIRD LINE.
      N2X=N2
      CALL CARDO(C1,C2,L1,L2,N1,N2)
c
c     Read Third Line
c
      CALL CARDI(C1,C2,L1,L2,N1,N2)
      IVERSE=5
C-----CHECK FOR ENDF/B-V FORMAT.
      IF(N2X.LE.0) GO TO 10
C-----ENDF/B-VI FORMAT. READ FOURTH LINE.
      CALL CARDO(C1,C2,L1,L2,N1,N2)
c
c     Read Fourth Line
c
      CALL CARDI(C1,C2,L1,L2,N1,N2)
      IVERSE=6
      LISO = LISOX
C-----DEFINE TEMPERATURE OF FILE 3 CROSS SECTIONS.
      TEMP3=C1
C-----SET DERIVED MATERIAL FLAG.
      L1=1
C-----DEFINE ENDF/B FORMAT NUMBER.
   10 FMTHOL=FMTTAB(IVERSE-3)
C-----INCREASE COMMENT LINE COUNT AND COPY TO END OF HOLLERITH.
C-----ALWAYS OUTPUT 1) PROGRAM I.D., 2) MINIMUM CROSS SECTION
C-----FOR CONSTANT ACCURACY, 3) ACCURACY
C-----FOR VARIABLE ACCURACY, 4 LINE TITLE + ERROR LAW
      IF(MAXER3.LE.1) N1OUT=N1+3
      IF(MAXER3.GT.1) N1OUT=N1+6+MAXER3
      CALL CARDO(C1,C2,L1,L2,N1OUT,N2)
      DO 20 N=1,N1
      CALL COPY1
   20 CONTINUE
c-----------------------------------------------------------------------
C
C     ADD COMMENTS TO DOCUMENT WHAT WAS DONE TO DATA.
C
c-----------------------------------------------------------------------
C-----OUTPUT PROGRAM NAME AND VERSION I.D.
      CALL HOLLYO(PROGDOC1(1,1))
C-----OUTPUT MINIMUM DATA OF INTEREST.
      CALL OUT9(XCMIN,PROGDOC1(27,2))
      CALL HOLLYO(PROGDOC1(1,2))
C-----CONSTANT OR ENERGY DEPENDENT ERROR LAW
      IF(MAXER3.GT.1) GO TO 30
C-----OUTPUT PER-CENT ACCURACY FOR ENERGY INDEPENDENT ERROR.
      PERCNT=100.0d0*ER3(1)
      CALL OUT9(PERCNT,PROGDOC1(42,3))
      CALL HOLLYO(PROGDOC1(1,3))
      GO TO 50
C-----WRITE FOUR COMMENT LINES PLUS ENERGY DEPENDENT ERROR LAW.
   30 CALL HOLLYO(PROGDOC1(1,4))
      CALL HOLLYO(PROGDOC1(1,5))
      CALL HOLLYO(PROGDOC1(1,6))
      CALL HOLLYO(PROGDOC1(1,7))
      DO 40 I=1,MAXER3
      PERCNT=100.0d0*ER3(I)
      CALL OUT9(ENER3(I),PROGDOC1( 2,8))
      CALL OUT9(PERCNT  ,PROGDOC1(14,8))
      CALL HOLLYO(PROGDOC1(1,8))
   40 CONTINUE
C-----COPY TO END OF SECTION.
   50 CALL COPYS
      RETURN
      END
      SUBROUTINE FILE5
C=======================================================================
C
C     LINEARIZE A SECTION OF MF=5 DATA.
C
C     LF   =  1 = ARBITRARY TABULATED FUNCTION
C          =  5 = GENERAL EVAPORATION MODEL
C          =  7 = SIMPLE FISSION SPECTRUM (MAXWELLIAN)
C          =  9 = EVAPORATION MODEL
C          = 11 = ENERGY DEPENDENT WATT
C          = 12 = ENERGY DEPENDENT FISSION (MADLAND-NIX)
C
C=======================================================================
      INCLUDE 'implicit.h'
      CHARACTER*4 FMTHOL
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/LEADER/C1,Q,L1,L2,N1,N2,MAT,MF,MT
      COMMON/OKERR3/ERRXC3,KERR3,MAXER3,ENER3(21),ER3(21)
      COMMON/HOLFMT/FMTHOL
      COMMON/PARAMS/XCMIN
      COMMON/LASTE/ELAST
      COMMON/TEMPO/TEMP3,IVERSE
      COMMON/NBTINT/NBT(100),INT(100)
      COMMON/CON5COM/U5,EFL,EFH,LF5,IMSMOOTH
      COMMON/E5P5COM/E5(1000),P5(1000),NP5
      COMMON/SLIM/ISTART,NOTHIN,ITHIN1,ITHIN2,ITHIN3,MTEND
      DATA LFOUT/1/
C-----TURN OFF KEEP ORIGINAL POINTS OPTION
      NOTHINX = NOTHIN
      NOTHIN     = 0
C-----SET INTERPOLATION TO SMOOTH
      IMSMOOTH = 1
      NK = N1H
C-----LOOP OVER SUB-SECTIONS
      DO 70 IK=1,NK
C-----READ SECTION HEAD LINE AND INTERPOLATION LAW.
      CALL CARDI(C1,Q,L1,LF5  ,NR,NP5)
      U5 = C1
      C1 = 0.0d0
      CALL CARDO(C1,Q,L1,LFOUT,NR,NP5)
      CALL TERPI(NBT,INT,NR)
c-----2019/12/3 - Additional Interpolation Law Tests
      CALL TERPTEST(NBT,INT,NR,NP5,1)
      CALL TERPO(NBT,INT,NR)
      ELAST = 0.0d0
      CALL POINTI(E5(1),P5(1),NP5)
      CALL POINTO(E5(1),P5(1),NP5)
c-----Save max. energy
      CALL MAXIE1(MATH,MFH,MTH)
      CALL MAXIE2(E5(NP5),1.0d0)
      IF(LF5.LT.1.OR.LF5.GT.12) GO TO 80
C              1   2   3   4   5   6   7   8   9  10
C             11  12
      GO TO ( 10,80,80,80, 20,80, 30,80, 40,80,
     1        50,60),LF5
C     LF   =  1 = ARBITRARY TABULATED FUNCTION
   10 CALL FILE51
      GO TO 70
C          =  5 = GENERAL EVAPORATION MODEL
   20 CALL FILE55
      GO TO 70
C          =  7 = SIMPLE FISSION SPECTRUM (MAXWELLIAN)
   30 CALL FILE57
      GO TO 70
C          =  9 = EVAPORATION MODEL
   40 CALL FILE59
      GO TO 70
C          = 11 = ENERGY DEPENDENT WATT
   50 CALL FILE511
      GO TO 70
C          = 12 = ENERGY DEPENDENT FISSION (MADLAND-NIX)
   60 CALL FILE512
      GO TO 70
   70 CONTINUE
C-----COPY TO SEND
      CALL COPYS
C-----RESET KEEP ORIGINAL POINTS OPTION
      NOTHIN = NOTHINX
      RETURN
c-----------------------------------------------------------------------
C
C     ERROR
C
c-----------------------------------------------------------------------
   80 WRITE(3,90) LF5
      WRITE(*,90) LF5
   90 FORMAT(' ERROR - LF=',I6,' (EXPECT 1, 5, 7, 9, 11 OR 12)'//)
      CALL ENDERROR
      END
      SUBROUTINE FILE15
C=======================================================================
C
C     LINEARIZE A SECTION OF MF=15 DATA.
C
C     SIMILAR TO FILE5, BUT ONLY LF=1 TABULATED DATA ALLOWED.
C
C     THIS IS BASICALLY A COPY OF FILE5 WITH OTHER OPTIONS REMOVED.
C     DO NOT BE ALARMED BY THE ROUTINE USING MF=5 TERMINOLOGY, SUCH
C     LF5, E5, P5, ETC. - IT IS EASIER AND SAFER TO LEAVE THIS AS
C     SIMILAR AS FILE5 AS POSSIBLE.
C
C=======================================================================
      INCLUDE 'implicit.h'
      CHARACTER*4 FMTHOL
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/LEADER/C1,Q,L1,L2,N1,N2,MAT,MF,MT
      COMMON/OKERR3/ERRXC3,KERR3,MAXER3,ENER3(21),ER3(21)
      COMMON/HOLFMT/FMTHOL
      COMMON/PARAMS/XCMIN
      COMMON/LASTE/ELAST
      COMMON/TEMPO/TEMP3,IVERSE
      COMMON/NBTINT/NBT(100),INT(100)
      COMMON/CON5COM/U5,EFL,EFH,LF5,IMSMOOTH
      COMMON/E5P5COM/E5(1000),P5(1000),NP5
      COMMON/SLIM/ISTART,NOTHIN,ITHIN1,ITHIN2,ITHIN3,MTEND
      DATA LFOUT/1/
C-----TURN OFF KEEP ORIGINAL POINTS OPTION
      NOTHINX = NOTHIN
      NOTHIN     = 0
C-----SET INTERPOLATION TO SMOOTH
      IMSMOOTH = 1
      NK = N1H
C-----LOOP OVER SUB-SECTIONS
      DO 10 IK=1,NK
C-----READ SECTION HEAD LINE AND INTERPOLATION LAW.
      CALL CARDI(C1,Q,L1,LF5  ,NR,NP5)
      U5 = C1
      C1 = 0.0d0
      CALL CARDO(C1,Q,L1,LFOUT,NR,NP5)
      CALL TERPI(NBT,INT,NR)
c-----2019/12/3 - Additional Interpolation Law Tests
      CALL TERPTEST(NBT,INT,NR,NP5,1)
      CALL TERPO(NBT,INT,NR)
      ELAST = 0.0d0
      CALL POINTI(E5(1),P5(1),NP5)
      CALL POINTO(E5(1),P5(1),NP5)
c-----Save max. energy
      CALL MAXIE1(MATH,MFH,MTH)
      CALL MAXIE2(E5(NP5),1.0d0)
      IF(LF5.NE.1) GO TO 20
c-----------------------------------------------------------------------
C
C     LF   =  1 = ARBITRARY TABULATED FUNCTION
C
c-----------------------------------------------------------------------
      CALL FILE51
   10 CONTINUE
C-----COPY TO SEND
      CALL COPYS
C-----RESET KEEP ORIGINAL POINTS OPTION
      NOTHIN = NOTHINX
      RETURN
c-----------------------------------------------------------------------
C
C     ERROR
C
c-----------------------------------------------------------------------
   20 WRITE(3,30) LF5
      WRITE(*,30) LF5
   30 FORMAT(' ERROR - LF=',I6,' (EXPECT 1)'//)
      CALL ENDERROR
      END
      SUBROUTINE SPACEOUT(XARRAY,YARRAY,NARRAY,NBTS,INTS,NTS)
C=======================================================================
C
C     INSURE SPECTRA PARAMETER IS NOT = 0 - THIS PROTECTS AGAINST
C     HISTOGRAM TABULATED VALUES WHERE LAST VALUE = 0.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INCLUDE 'spectra.h'
      DIMENSION XARRAY(*),YARRAY(*),NBTS(*),INTS(*),ESPACE(11)
      DATA ESPACE/
     1  .0D+6 ,  2.0D+6,  3.0D+6,  4.0D+6, 6.0D+6, 8.0D+6, 10.0D+6,
     2 12.0D+6, 14.0D+6, 16.0D+6, 18.0D+6/
c-----------------------------------------------------------------------
C
C     ELIMINATE DUPLICATES - LOTS AT 20 MEV
C
c-----------------------------------------------------------------------
      IF(NARRAY.LT.2) THEN
      WRITE(*,10) NARRAY
      WRITE(3,10) NARRAY
   10 FORMAT(' WARNING - ONLY',I6,' ENERGIES (EXPECT 2 OR MORE)')
      RETURN
      ENDIF
      KADD = 1 !ALWAYS KEEP FIRST POINT.
      DO 20 I=2,NARRAY
C-----SKIP DUPLICATE POINTS.
      IF(XARRAY(I-1).EQ.XARRAY(I).AND.
     1   YARRAY(I-1).EQ.YARRAY(I)) GO TO 20
C-----SKIP SIMILAR POINTS.
      IF(DABS(XARRAY(I-1)-XARRAY(I)).LE.0.001d0*YARRAY(I-1).AND.
     1   DABS(YARRAY(I-1)-YARRAY(I)).LE.0.001d0*YARRAY(I-1)) GO TO 20
      KADD = KADD + 1
      XARRAY(KADD) = XARRAY(I)
      YARRAY(KADD) = YARRAY(I)
   20 CONTINUE
      NARRAY = KADD
      NBTS(NTS) = NARRAY
c-----------------------------------------------------------------------
C
C     DO NOT ADD POINTS,
C     1) BELOW 100 KEV
C     2) ABOVE 16 MEV THRESHOLD
C     3) IF MORE THAN 5 ENERGY POINTS
C
c-----------------------------------------------------------------------
      IF(XARRAY(1).LE. 1.0D+5) RETURN
      IF(XARRAY(1).GE.16.0D+6) RETURN
      IF(NARRAY.GT.5) RETURN
c-----------------------------------------------------------------------
C
C     ADD ENERGY POINTS
C
c-----------------------------------------------------------------------
      WRITE(*,30)
      WRITE(3,30)
   30 FORMAT(' WARNING - INSERTING ENERGY POINTS')
      WRITE(*,40) (I,NBTS(I),INTS(I),I=1,NTS)
      WRITE(3,40) (I,NBTS(I),INTS(I),I=1,NTS)
   40 FORMAT(3I6)
      WRITE(*,50) (I,XARRAY(I),YARRAY(I),I=1,NARRAY)
      WRITE(3,50) (I,XARRAY(I),YARRAY(I),I=1,NARRAY)
   50 FORMAT(I6,1P2D12.4)
C-----FIND FIRST SPACED ENERGY ABOVE THRESHOLD
      DO IS=1,11
      IF(XARRAY(1).LT.ESPACE(IS)) GO TO 60
      ENDDO
      RETURN
c-----------------------------------------------------------------------
C
C     INSERT POINTS
C
c-----------------------------------------------------------------------
   60 INTYPE = INTS(NTS)
      WRITE(*,70)
      WRITE(3,70)
   70 FORMAT(' --------------------------------------')
      I1 = 1
      I2 = 2
      KADD = 1
      EADD(KADD) = XARRAY(I1)
      YADD(KADD) = YARRAY(I1)
      DO 110 KS=IS,11
   80 CONTINUE
      IF(XARRAY(I2).GE.ESPACE(KS)) GO TO 100
C-----USE ORIGINAL POINT
      I1 = I2
      I2 = I2 + 1
      IF(EADD(KADD).GE.XARRAY(I1)) GO TO 90
      IF(DABS(EADD(KADD)-XARRAY(I1)).LE.0.01d0*EADD(KADD)) GO TO 90
      KADD = KADD + 1
      EADD(KADD) = XARRAY(I1)
      YADD(KADD) = YARRAY(I1)
   90 IF(I1.GE.NARRAY) GO TO 130
      GO TO 80
C-----USE SPACED POINT
  100 IF(EADD(KADD).GE.ESPACE(KS)) GO TO 110
      IF(DABS(EADD(KADD)-ESPACE(KS)).LE.0.01d0*EADD(KADD)) GO TO 110
      KADD = KADD + 1
      EADD(KADD) = ESPACE(KS)
      YADD(KADD) = TERPIT(EADD(KADD),XARRAY(I1),XARRAY(I2),
     1                               YARRAY(I1),YARRAY(I2),INTYPE)
  110 CONTINUE
c-----------------------------------------------------------------------
C
C     ADD POINTS AT END
C
c-----------------------------------------------------------------------
      IF(I2.GT.NARRAY) GO TO 130
      DO 120 I1=I2,NARRAY
C-----SKIP DUPLICATE POINTS.
      IF(EADD(KADD).EQ.XARRAY(I1).AND.
     1   YADD(KADD).EQ.YARRAY(I1)) GO TO 120
C-----SKIP SIMILAR POINTS.
      IF(DABS(EADD(KADD)-XARRAY(I1)).LE.0.001d0*EADD(KADD).AND.
     1   DABS(YADD(KADD)-YARRAY(I1)).LE.0.001d0*YADD(KADD)) GO TO 120
      KADD = KADD + 1
      EADD(KADD) = XARRAY(I1)
      YADD(KADD) = YARRAY(I1)
  120 CONTINUE
c-----------------------------------------------------------------------
C
C     FINISHED - UPDATE INTERPLATION LAW AND POINTS
C
c-----------------------------------------------------------------------
  130 NBTS(NTS) = KADD
      DO I=1,KADD
      XARRAY(I) = EADD(I)
      YARRAY(I) = YADD(I)
      ENDDO
      NARRAY = KADD
      WRITE(*,40) (I,NBTS(I),INTS(I),I=1,NTS)
      WRITE(3,40) (I,NBTS(I),INTS(I),I=1,NTS)
      WRITE(*,50) (I,EADD(I),YADD(I),I=1,KADD)
      WRITE(3,50) (I,EADD(I),YADD(I),I=1,KADD)
      RETURN
      END
      SUBROUTINE NOZERO(XARRAY,YARRAY,NARRAY)
C=======================================================================
C
C     INSURE SPECTRA PARAMETER IS NOT = 0 - THIS PROTECTS AGAINST
C     HISTOGRAM TABULATED VALUES WHERE LAST VALUE = 0.
C
C=======================================================================
      INCLUDE 'implicit.h'
      DIMENSION XARRAY(*),YARRAY(*)
c-----------------------------------------------------------------------
C
C     CHECK FOR NOT POSITIVE
C
c-----------------------------------------------------------------------
      DO I1=1,NARRAY
      IF(YARRAY(I1).LE.0.0D+0) GO TO 10
      ENDDO
C-----ALL ARE POSITIVE - NOTHING TO DO
      RETURN
c-----------------------------------------------------------------------
C
C     TRY TO REPLACE NON-POSITIVE VALUES
C
c-----------------------------------------------------------------------
   10 WRITE(*,20) (I,XARRAY(I),YARRAY(I),I=1,NARRAY)
      WRITE(3,20) (I,XARRAY(I),YARRAY(I),I=1,NARRAY)
   20 FORMAT(' ERROR - Non-positive Spectra Parameter'/
     1 (I6,1P2D12.4))
c-----------------------------------------------------------------------
C
C     RE-DEFINE AS POSITIVE
C
c-----------------------------------------------------------------------
      DO 60 I2=I1,NARRAY
C-----SKIP IF POSITIVE.
      IF(YARRAY(I2).GT.0.0D+0) GO TO 60
C-----SPECIAL TREATMENT FOR FIRST TABULATED VALUE.
      IF(I2.GT.1) GO TO 50
C-----REPLACE FIRST VALUE BY FIRST POSITIVE VALUE
      DO I3=I2,NARRAY
      IF(YARRAY(I3).GT.0.0D+0) GO TO 40
      ENDDO
C-----ALL VALUES ARE NON-POSITIVE - CANNOT RE-DEFINE
      WRITE(*,30)
      WRITE(3,30)
   30 FORMAT(' All values are non-positive - Execution Terminated')
      CALL ENDERROR
C-----REPLACE FIRST VALUE BY FIRST POSITIVE VALUE
   40 YARRAY(I2) = YARRAY(I3)
      GO TO 60
C-----REPLACE OTHER VALUE - BY NOW ALL VALUES BEFORE I2 ARE POSITIVE.
   50 YARRAY(I2) = YARRAY(I2-1)
   60 CONTINUE
      WRITE(*,70) (I,XARRAY(I),YARRAY(I),I=1,NARRAY)
      WRITE(3,70) (I,XARRAY(I),YARRAY(I),I=1,NARRAY)
   70 FORMAT(' Updated Positive Values'/
     1 (I6,1P2D12.4))
      RETURN
      END
      SUBROUTINE FILE51
C=======================================================================
C
C     LF   =  1 = ARBITRARY TABULATED FUNCTION
C
C=======================================================================
      INCLUDE 'implicit.h'
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/LEADER/C1,C2,L1,L2,N1,N2,MAT,MF,MT
      COMMON/NBTINT5/NBT5(100),INT5(100),NR5
      COMMON/LASTE/ELAST
C-----TAB2 INTERPOLATION LAW
      CALL CARDIO(C1,C2,L1,L2,NR5,NE5)
      CALL TERPI(NBT5,INT5,NR5)
c-----2019/12/3 - Additional Interpolation Law Tests
      CALL TERPTEST(NBT5,INT5,NR5,NE5,1)
      CALL TERPO(NBT5,INT5,NR5)
C-----LOOP OVER INCIDENT ENERGIES
      DO 10 IE5=1,NE5
      CALL FILEX
   10 CONTINUE
c-----Save last incident energy
      if(C2.gt.0.0d0) then
      CALL MAXIE1(MATH,MFH,MTH)
      CALL MAXIE2(C2,1.0d0)
      endif
      RETURN
      END
      SUBROUTINE FILE55
C=======================================================================
C
C     LF   =  5 = GENERAL EVAPORATION MODEL
C                 F(E,E') = G(X); X = E'/THETA(E)
C
C=======================================================================
      INCLUDE 'implicit.h'
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/LEADER/C1,C2,L1,L2,N1,N2,MAT,MF,MT
      COMMON/NBTINT5/NBT5(100),INT5(100),NR5
      COMMON/PARAMS5A/ETHETA(1000),THETA(1000),IT5,NT5
      COMMON/PARAMS5B/EG5(10000),G5(10000),NG5
      COMMON/LASTE/ELAST
C-----READ TAB1 THETA
      CALL CARDI(C1,C2,L1,L2,NR5,NE5)
      CALL TERPI(NBT5,INT5,NR5)
c-----2019/12/3 - Additional Interpolation Law Tests
      CALL TERPTEST(NBT5,INT5,NR5,NE5,1)
      ELAST = 0.0d0
      CALL POINTI(ETHETA,THETA,NE5)
C-----INSURE ALL THETA ARE POSITIVE
      CALL NOZERO(ETHETA,THETA,NE5)
C-----CHECK ENERGY SPACING.
      CALL SPACEOUT(ETHETA,THETA,NE5,NBT5,INT5,NR5)
      NT5 = NE5
C-----WRITE TAB2 INTERPOLATION LAW
      CALL CARDO(C1,C2,L1,L2,NR5,NE5)
      CALL TERPO(NBT5,INT5,NR5)
C-----READ TAB1
      CALL CARDI(C1,C2,L1,L2,NR5,NF5)
      CALL TERPI(NBT5,INT5,NR5)
c-----2019/12/3 - Additional Interpolation Law Tests
      CALL TERPTEST(NBT5,INT5,NR5,NF5,1)
      ELAST = 0.0d0
      CALL POINTI(EG5,G5,NF5)
      NG5 = NF5
C-----LOOP OVER INCIDENT ENERGIES
      DO 10 IT5=1,NT5
      CALL FILE5F
   10 CONTINUE
c-----Save last incident energy
      if(C2.gt.0.0d0) then
      CALL MAXIE1(MATH,MFH,MTH)
      CALL MAXIE2(C2,1.0d0)
      endif
      RETURN
      END
      SUBROUTINE FILE57
C=======================================================================
C
C     LF   =  7 = SIMPLE FISSION SPECTRUM (MAXWELLIAN)
C                 F(E,E') = SQRT(E')*EXP[-E'/THETA(E)]
C
C=======================================================================
      INCLUDE 'implicit.h'
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/LEADER/C1,C2,L1,L2,N1,N2,MAT,MF,MT
      COMMON/NBTINT5/NBT5(100),INT5(100),NR5
      COMMON/PARAMS5A/ETHETA(1000),THETA(1000),IT5,NT5
      COMMON/PARAMS5B/EG5(10000),G5(10000),NG5
      COMMON/LASTE/ELAST
C-----READ TAB1 THETA
      CALL CARDI(C1,C2,L1,L2,NR5,NE5)
      CALL TERPI(NBT5,INT5,NR5)
c-----2019/12/3 - Additional Interpolation Law Tests
      CALL TERPTEST(NBT5,INT5,NR5,NE5,1)
      ELAST = 0.0d0
      CALL POINTI(ETHETA,THETA,NE5)
C-----INSURE ALL THETA ARE POSITIVE
      CALL NOZERO(ETHETA,THETA,NE5)
C-----CHECK ENERGY SPACING.
      CALL SPACEOUT(ETHETA,THETA,NE5,NBT5,INT5,NR5)
c-----------------------------------------------------------------------
C
C     OUTPUT
C
c-----------------------------------------------------------------------
      NT5 = NE5
C-----WRITE TAB2 INTERPOLATION LAW
      CALL CARDO(C1,C2,L1,L2,NR5,NE5)
      CALL TERPO(NBT5,INT5,NR5)
C-----LOOP OVER INCIDENT ENERGIES
      DO 10 IT5=1,NT5
      CALL FILE5F
   10 CONTINUE
c-----Save last incident energy
      if(C2.gt.0.0d0) then
      CALL MAXIE1(MATH,MFH,MTH)
      CALL MAXIE2(C2,1.0d0)
      endif
c-----Save last incident energy
      if(C2.gt.0.0d0) then
      CALL MAXIE1(MATH,MFH,MTH)
      CALL MAXIE2(C2,1.0d0)
      endif
      RETURN
      END
      SUBROUTINE FILE59
C=======================================================================
C
C     LF   =  9 = EVAPORATION MODEL
C                 F(E,E') = E'*EXP[-E'/THETA(E)]; E' = 0 TO E' - U
C
C=======================================================================
      INCLUDE 'implicit.h'
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/LEADER/C1,C2,L1,L2,N1,N2,MAT,MF,MT
      COMMON/NBTINT5/NBT5(100),INT5(100),NR5
      COMMON/PARAMS5A/ETHETA(1000),THETA(1000),IT5,NT5
      COMMON/PARAMS5B/EG5(10000),G5(10000),NG5
      COMMON/LASTE/ELAST
C-----READ TAB1 THETA
      CALL CARDI(C1,C2,L1,L2,NR5,NE5)
      CALL TERPI(NBT5,INT5,NR5)
c-----2019/12/3 - Additional Interpolation Law Tests
      CALL TERPTEST(NBT5,INT5,NR5,NE5,1)
      ELAST = 0.0d0
      CALL POINTI(ETHETA,THETA,NE5)
C-----INSURE ALL THETA ARE POSITIVE
      CALL NOZERO(ETHETA,THETA,NE5)
C-----CHECK ENERGY SPACING.
      CALL SPACEOUT(ETHETA,THETA,NE5,NBT5,INT5,NR5)
c-----------------------------------------------------------------------
C
C     OUTPUT
C
c-----------------------------------------------------------------------
      NT5 = NE5
C-----WRITE TAB2 INTERPOLATION LAW
      CALL CARDO(C1,C2,L1,L2,NR5,NE5)
      CALL TERPO(NBT5,INT5,NR5)
C-----LOOP OVER INCIDENT ENERGIES
      DO 10 IT5=1,NT5
      CALL FILE5F
   10 CONTINUE
c-----Save last incident energy
      if(C2.gt.0.0d0) then
      CALL MAXIE1(MATH,MFH,MTH)
      CALL MAXIE2(C2,1.0d0)
      endif
      RETURN
      END
      SUBROUTINE FILE511
C=======================================================================
C
C     LF   = 11 = ENERGY DEPENDENT WATT
C                 F(E,E') = EXP[-E'/A(E)]*SINH[SQART*B*E')]
C
C=======================================================================
      INCLUDE 'implicit.h'
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/LEADER/C1,C2,L1,L2,N1,N2,MAT,MF,MT
      COMMON/NBTINT5/NBT5(100),INT5(100),NR5
      COMMON/PARAMS5A/ETHETA(1000),THETA(1000),IT5,NT5
      COMMON/PARAMS5B/EG5(10000),G5(10000),NG5
      COMMON/PARAMS5C/EAWATT(1000),AWATT(1000)
      COMMON/PARAMS5D/EBWATT(1000),BWATT(1000)
      COMMON/LASTE/ELAST
C-----READ TAB1 THETA
      CALL CARDI(C1,C2,L1,L2,NR5,NE5)
      CALL TERPI(NBT5,INT5,NR5)
c-----2019/12/3 - Additional Interpolation Law Tests
      CALL TERPTEST(NBT5,INT5,NR5,NE5,1)
      ELAST = 0.0d0
      CALL POINTI(EAWATT,AWATT,NE5)
      NT5 = NE5
C-----INSURE ALL AWATT ARE POSITIVE
      CALL NOZERO(EAWATT,AWATT,NE5)
C-----WRITE TAB2 INTERPOLATION LAW
      CALL CARDO(C1,C2,L1,L2,NR5,NE5)
      CALL TERPO(NBT5,INT5,NR5)
C-----READ TAB1
      CALL CARDI(C1,C2,L1,L2,NR5,NF5)
      CALL TERPI(NBT5,INT5,NR5)
c-----2019/12/3 - Additional Interpolation Law Tests
      CALL TERPTEST(NBT5,INT5,NR5,NF5,1)
      ELAST = 0.0d0
      CALL POINTI(EBWATT,BWATT,NF5)
      NG5 = NF5
C-----INSURE ALL BWATT ARE POSITIVE
      CALL NOZERO(EBWATT,BWATT,NF5)
C-----LOOP OVER INCIDENT ENERGIES
      DO 10 IT5=1,NT5
      CALL FILE5F
   10 CONTINUE
c-----Save last incident energy
      if(C2.gt.0.0d0) then
      CALL MAXIE1(MATH,MFH,MTH)
      CALL MAXIE2(C2,1.0d0)
      endif
      RETURN
      END
      SUBROUTINE FILE512
C=======================================================================
C
C     LF   = 12 = ENERGY DEPENDENT FISSION (MADLAND-NIX)
C                 F(E,E') = 0.5*[G(E',EFL)+G(E',EFH)]
C
C                 U1 = [SQRT(E') - SQRT(EFk)]^2/TM(E)
C                 U2 = [SQRT(E') + SQRT(EFk)]^2/TM(E)
C
C                 G(E',EF) = [U2^3/2*DE1(U2) - U1^3/2*DE1(U1)]+
C                            [GAM(3/2,U2) - GAM(3/2,U1)]
C                            ---------------------------------
C                            3[EFk* TM(E)]^1/2
C
C=======================================================================
      INCLUDE 'implicit.h'
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/LEADER/C1,C2,L1,L2,N1,N2,MAT,MF,MT
      COMMON/NBTINT5/NBT5(100),INT5(100),NR5
      COMMON/CON5COM/U5,EFL,EFH,LF5,IMSMOOTH
      COMMON/PARAMS5A/ETHETA(1000),THETA(1000),IT5,NT5
      COMMON/PARAMS5E/ETM(1000),TM(1000)
      COMMON/LASTE/ELAST
C-----READ TAB1 THETA
      CALL CARDI(C1,C2,L1,L2,NR5,NE5)
      CALL TERPI(NBT5,INT5,NR5)
c-----2019/12/3 - Additional Interpolation Law Tests
      CALL TERPTEST(NBT5,INT5,NR5,NE5,1)
      ELAST = 0.0d0
      CALL POINTI(ETM,TM,NE5)
      EFL = C1
      EFH = C2
C-----INSURE ALL TM ARE POSITIVE
      CALL NOZERO(ETM,TM,NE5)
C-----CHECK ENERGY SPACING.
      CALL SPACEOUT(ETM,TM,NE5,NBT5,INT5,NR5)
c-----------------------------------------------------------------------
C
C     OUTPUT
C
c-----------------------------------------------------------------------
      NT5 = NE5
C-----WRITE TAB2 INTERPOLATION LAW
      C1  = 0.0d0
      C2  = 0.0d0
      CALL CARDO(C1,C2,L1,L2,NR5,NE5)
      CALL TERPO(NBT5,INT5,NR5)
C-----LOOP OVER INCIDENT ENERGIES
      DO 10 IT5=1,NT5
      CALL FILE5F
   10 CONTINUE
c-----Save last incident energy
      if(C2.gt.0.0d0) then
      CALL MAXIE1(MATH,MFH,MTH)
      CALL MAXIE2(C2,1.0d0)
      endif
      RETURN
      END
      SUBROUTINE FILE6
C=======================================================================
C
C     LINEARIZE A SECTION OF MF=6 DATA.
C
C     WARNING - NOT YET IMPLEMENTED - NOW SECTION IS COPIED.
C
C=======================================================================
      INCLUDE 'implicit.h'
      CHARACTER*4 FMTHOL
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/LEADER/C1,C2,L1,L2,N1,N2,MAT,MF,MT
      COMMON/OKERR3/ERRXC3,KERR3,MAXER3,ENER3(21),ER3(21)
      COMMON/HOLFMT/FMTHOL
      COMMON/PARAMS/XCMIN
      COMMON/TEMPO/TEMP3,IVERSE
      COMMON/WHATZA/IZA
      COMMON/LISOCOM/LISO
      CHARACTER*1 ZABCD(12)
c-----2020/3/21 - Added Target Isomer State
      CALL ZAHOLM(IZA,LISO,ZABCD)
      WRITE(*,10) ZABCD,MATH,MFH,MTH
      WRITE(3,10) ZABCD,MATH,MFH,MTH
   10 FORMAT(2X,12A1,I5,2I4,'   WARNING - MF=6 NOT YET IMPLEMENTED',
     1 ' - Section Copied')
      CALL COPYS
      RETURN
      END
      SUBROUTINE FILEX
C=======================================================================
C
C     READ TAB1 RECORD
C     CONVERT DATA TO LINEAR-LINEAR FORM. IF LESS THAN MAXP1 POINTS
C     ARE GENERATED THEY WILL BE CORE RESIDENT. OTHERWISE THEY WILL
C     BE ON SCRATCH FILE (ISCR)
C
C=======================================================================
      INCLUDE 'implicit.h'
      INTEGER*4 OUTP,OTAPE
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/NBTINT/NBT(100),INT(100)
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/LEADER/C1,Q,L1,L2,N1,N2IN,MAT,MF,MT
      COMMON/OLDTAB/IXYLOW,IXYHI,LEFT
      COMMON/THRESE/ETHRES
      COMMON/WHATZA/IZA
      COMMON/NEWTAB/N2CORE,N2SCR,N2TOT,N2P1,N2P2
      COMMON/OKERR3/ERRXC3,KERR3,MAXER3,ENER3(21),ER3(21)
      COMMON/PARAMS/XCMIN
      COMMON/LASTE/ELAST
      COMMON/PAGER/NPAGE,NPAGE2,NP1P1,NP2M1
      COMMON/SLIM/ISTART,NOTHIN,ITHIN1,ITHIN2,ITHIN3,MTEND
      COMMON/CON5COM/U5,EFL,EFH,LF5,IMSMOOTH
      COMMON/ENRGYCOM/EMIN,EMAX,ETHERMAL
      INCLUDE 'spectra.h'
      DATA ZERO/0.0D+00/
      DATA HALF/5.0D-01/
c-----------------------------------------------------------------------
C
C     READ AND CHECK SECTION LEADER LINE AND INTERPOLATION LAW. IF
C     INTERPOLATION LAW IS ILLEGAL (BAD INTERPOLATION TYPE OR IMPROPER
C     INTERPOLATION BOUNDARY) TERMINATE EXECUTION.
C
c-----------------------------------------------------------------------
C-----READ SECTION HEAD LINE AND INTERPOLATION LAW.
      CALL CARDI(C1,Q,L1,L2,N1,N2IN)
      CALL TERPI(NBT,INT,N1)
c-----2019/12/3 - Additional Interpolation Law Tests
      CALL TERPTEST(NBT,INT,N1,N2IN,1)
C-----Check for LAW = 6
      IM6=0
      do IR=1,N1
      IF(INT(IR).EQ.6) IM6=1
      enddo
c-----------------------------------------------------------------------
C
C     INITIALIZE ALL PARAMETERS FOR THIS SECTION.
C
c-----------------------------------------------------------------------
C-----INITIALIZE FLAG TO INDICATE BEGINNING OF SECTION.
      ISTART=1
C-----INITIALIZE PAGING SYSTEM INDICES.
      IXYLOW=0
      IXYHI=0
      LEFT=N2IN
C-----INITIALIZE LAST ENERGY USED (FOR ASCENDING ENERGY ORDER TEST).
      ELAST=ZERO
C-----INITIALIZE END OF SECTION FLAG OFF.
      MTEND=0
C-----INITIALIZE THINNING INDICES.
      ITHIN1=1
      ITHIN2=2
      ITHIN3=2
C-----INITIALIZE COUNT OF POINTS IN CORE AND ON SCRATCH.
      N2CORE=1
      N2P1=2
      N2P2=3
      N2SCR=0
C-----DEFINE FIRST POINT IN TABLE.
      CALL XYPAGE(XOUT(1),YOUT(1),1)
C-----DO NOT CONSIDER THRESHOLD FOR PHOTON DATA.
      IF(MFH.NE.3) GO TO 10
C-----IF THIS A THRESHOLD REACTION INSERT POINT AT THRESHOLD WITH ZERO
C-----CROSS SECTION IF THERE IS NOT ONE THERE ALREADY.
      IF(XOUT(1).LE.ETHRES.OR.YOUT(1).EQ.0.0d0) GO TO 10
      XOUT(2)=XOUT(1)
      YOUT(2)=YOUT(1)    ! Original first Y, now second
      YOUT(1)=0.0d0      ! New      first Y = 0
      N2CORE=2
      N2P1=3
      N2P2=4
c-----------------------------------------------------------------------
C
C     LINEARIZE DATA CONSIDERING EACH INTERPOLATION LAW REGION
C     SEPARATELY.
C
c-----------------------------------------------------------------------
C-----SET UP LOOP OVER INTERPOLATION RANGES.
   10 NR2=1
      DO 210 IR=1,N1
C-----DEFINE POINTS IN INTERPOLATION RANGE AND TYPE OF INTERPOLATION.
      NR1=NR2+1
      NR2=NBT(IR)
      INTYPE=INT(IR)
C-----HISTOGRAM OR LINEAR-LINEAR DOES NOT REQUIRE FURTHER SUBDIVISION.
      IF(INTYPE.eq.2) go to 40
      IF(INTYPE.gt.2) go to 80
c-----------------------------------------------------------------------
C
C     FOR HISTOGRAM REPLACE EACH ENERGY POINT THAT IS INTERNAL TO THE
C     INTERPOLATION ENERGY RANGE BY TWO ENERGY POINTS AND REPLACE EACH
C     END POINT OF THE INTERPOLATION ENERGY RANGE BY A SINGLE ENERGY
C     POINT (START OF INTERVAL HAS ALREADY BEEN STORED).
C
c-----------------------------------------------------------------------
c
c     Histogram: Insure last Y value = 0
c
c-----------------------------------------------------------------------
      DO 30 NPT=NR1,NR2
C-----CORE SPACE FOR TWO MORE POINTS REQUIRED. IF NO ROOM IN CORE, THIN
C-----AND UNLOAD ONE PAGE OF POINTS TO SCRATCH.
      IF(N2CORE.GE.NP2M1) CALL THINIT
      N2CORE=N2CORE+2
      N2P1=N2CORE+1
      N2P2=N2P1+1
      CALL XYPAGE(XOUT(N2CORE),YOUT(N2CORE),NPT)
C-----ELIMINATE DUPLICATE POINTS.
      IF(XOUT(N2CORE).NE.XOUT(N2CORE-2)) GO TO 20
      XOUT(N2CORE-1)=XOUT(N2CORE)
      YOUT(N2CORE-1)=YOUT(N2CORE)
      N2CORE=N2CORE-1
      N2P1=N2CORE+1
      N2P2=N2P1+1
      GO TO 30
   20 XOUT(N2CORE-1)=XOUT(N2CORE)
      YOUT(N2CORE-1)=YOUT(N2CORE-2)
   30 CONTINUE
c-----2019/6/30 - Keep last histogram point (previously deleted =
c-----            eroneously assumed = 0 - input isn't always = 0
c-----            here keep poinr and insure Y = 0
      if(IR.eq.N1.and.INTYPE.eq.1) then
      YOUT(N2CORE) = 0.0d0
      endif
      GO TO 210
c-----------------------------------------------------------------------
C
C     FOR LINEAR-LINEAR INTERPOLATION JUST COPY POINTS TO OUTPUT ARRAY.
C
c-----------------------------------------------------------------------
C-----FOR MF=5 OR 6, IF SMOOTHING IS ON SWITCH TO LOG-LOG AND LINEARIZE
   40 IF(IMSMOOTH.LE.0) GO TO 50
      IF(MFH.EQ.5.OR.MFH.EQ.6) THEN
      INTYPE = 5
      GO TO 90
      ENDIF
   50 DO 70 NPT=NR1,NR2
C-----DEFINE UPPER ENERGY LIMIT OF INTERVAL.
      CALL XYPAGE(XEND,YEND,NPT)
c-----------------------------------------------------------------------
C
C     IF NECESSARY INSERT THERMAL POINT
C
c-----------------------------------------------------------------------
C-----ONLY FOR MF = 3
      IF(MFH.NE.3) GO TO 60
      IF(XEND        .LE.ETHERMAL.OR.
     1   XOUT(N2CORE).GE.ETHERMAL) GO TO 60
      YTHERMAL=TERPIT(ETHERMAL,XEND,XOUT(N2CORE),
     1                         YEND,YOUT(N2CORE),INTYPE)
C-----CORE SPACE FOR ONE MORE POINT REQUIRED. IF NO ROOM IN CORE, THIN
C-----AND UNLOAD ONE PAGE OF POINTS TO SCRATCH.
      IF(N2CORE.GE.NPAGE2) CALL THINIT
C-----INSERT THERMAL VALUE
      N2CORE=N2CORE+1
      XOUT(N2CORE)=ETHERMAL
      YOUT(N2CORE)=YTHERMAL
C-----CORE SPACE FOR ONE MORE POINT REQUIRED. IF NO ROOM IN CORE, THIN
C-----AND UNLOAD ONE PAGE OF POINTS TO SCRATCH.
   60 IF(N2CORE.GE.NPAGE2) CALL THINIT
      N2CORE=N2CORE+1
      N2P1=N2CORE+1
      N2P2=N2P1+1
      XOUT(N2CORE)=XEND
      YOUT(N2CORE)=YEND
   70 CONTINUE
      GO TO 210
c-----------------------------------------------------------------------
C
C     NON-LINEAR INTERPOLATION LAW REQUIRES SUB-DIVISION. SET UP LOOP
C     OVER POINTS IN CURRENT INTERPOLATION REGION.
C
c-----------------------------------------------------------------------
   80 IF(IMSMOOTH.LT.0) GO TO 90
      IF(MFH.EQ.5.OR.MFH.EQ.6) INTYPE = 5
   90 DO 200 NPT=NR1,NR2
C-----INITIALIZE TO RANGE NOT SAVED
      IMSAVED=0
C-----DEFINE UPPER ENERGY LIMIT OF INTERVAL.
      CALL XYPAGE(XEND,YEND,NPT)
c-----------------------------------------------------------------------
C
C     IF NECESSARY INSERT MAX. ENERGY OR THERMAL POINT
C
c-----------------------------------------------------------------------
  100 XTOP=XEND
C-----ONLY FOR MF = 3
      IF(MFH.NE.3) GO TO 110
      IF(XTOP.GT.ETHERMAL.AND.XOUT(N2CORE).LT.ETHERMAL)
     1 XTOP=ETHERMAL
C-----CANNOT DOUBLE 0.0 - JUST USE INTERVAL FROM 0.0
  110 IF(XOUT(N2CORE).LE.0.0d0) GO TO 120
      IF(XTOP.GT.2.0d0*XOUT(N2CORE)) XTOP=2.0d0*XOUT(N2CORE)
      IF(XTOP.GE.XEND) GO TO 120
C-----INTERPOLATE CROSS SECTION TO NEW END
      YTOP=TERPIT(XTOP,XEND,XOUT(N2CORE),
     1                 YEND,YOUT(N2CORE),INTYPE)
C-----SAVE END AND SET RANGE SAVED FLAG
      IMSAVED=1
      XSAVE=XEND
      YSAVE=YEND
C-----DEFINE END OF INTERVAL AT THERMAL
      XEND=XTOP
      YEND=YTOP
C-----DEFINE ENERGY AND CROSS SECTION AT TWO ENDS OF INTERVAL.
  120 XN2P2=XEND
      YN2P2=YEND
      XN2=XOUT(N2CORE)
      YN2=YOUT(N2CORE)
C-----DO NOT SUBDIVIDE IF CROSS SECTION IS CONSTANT.
      IF(YN2.EQ.YN2P2) GO TO 180
c-----------------------------------------------------------------------
C
C     DO NOT SUB-DIVIDE INTERVALS WITHIN WHICH THE ABSOLUTE VALUE OF
C     THE CROSS SECTION IS LESS THAN THE MINIMUM CROSS SECTION OF
C     INTEREST.
C
c-----------------------------------------------------------------------
      IF(DABS(YN2).LE.XCMIN.AND.DABS(YN2P2).LE.XCMIN) GO TO 180
c-----------------------------------------------------------------------
C
C     DEFINE ENERGY AT MIDDLE OF INTERVAL.
C
c-----------------------------------------------------------------------
C-----INTYPE IS NOW 3, 4, 5 OR 6.
C-----CANNOT DOUBLE 0.0 - JUST USE INTERVAL TO 0.0
  130 if(XN2.le.0.0d0) go to 140
      IF(INTYPE.ne.4) go to 150
C-----LINEAR ENERGY.
  140 XN2P1=HALF*(XN2+XN2P2)
      GO TO 160
C-----LOG ENERGY.
  150 XN2P1=DSQRT(XN2*XN2P2)
C-----ROUND MIDPOINT.
  160 CALL INCORE10(XN2P1)
c-----------------------------------------------------------------------
C
C     SMALL ENERGY INTERVAL CONVERGENCE TESTS.
C
C     IF ENERGY AT MIDDLE OF INTERVAL IS LESS THAN ALLOWABLE ENERGY
C     SPACING ONLY KEEP THE TWO ENDS OF THE INTERVAL.
c
c-----------------------------------------------------------------------
      IF(XN2P1.LE.XN2.OR.XN2P1.GE.XN2P2) GO TO 180
C-----06/02/09 - ADDED SMALL CROSS SECTION TEST
c-----------------------------------------------------------------------
C
C     SMALL CROSS SECTION CONVERGENCE TESTS.
C
c-----------------------------------------------------------------------
C-----IF CROSS SECTION AT BOTH ENDS IS LESS THAN XCMIN ONLY KEEP
C-----KEEP THE TWO ENDS OF THE INTERVAL.
      IF(DABS(YN2).LT.XCMIN.AND.DABS(YN2P2).LT.XCMIN) GO TO 180
c-----------------------------------------------------------------------
C
C     DEFINE CROSS SECTION AT MIDDLE OF INTERVAL BY INTERPOLATION LAW
C     AND LINEAR-LINEAR INTERPOLATION.
C
c-----------------------------------------------------------------------
      YN2P1=TERPIT(XN2P1,XN2,XN2P2,YN2,YN2P2,INTYPE)
      YAPROX=TERPIT(XN2P1,XN2,XN2P2,YN2,YN2P2,2)
C-----DEFINE ALLOWABLE ERROR.
      IF(KERR3.NE.0) CALL ERROK3(XN2P1)
C-----TEST FOR CONVERGENCE. IF CONVERGENCE KEEP MIDPOINT OF INTERVAL
C-----IN ORDER TO ALLOW ACCURATE BACKWARD THINNING BEFORE OUTPUT.
      IF(DABS(YN2P1-YAPROX).LE.DABS(YN2P1*ERRXC3)) GO TO 170
c-----------------------------------------------------------------------
C
C     NO CONVERGENCE. SHORTEN INTERVAL.
C
c-----------------------------------------------------------------------
      XN2P2=XN2P1
      YN2P2=YN2P1
      GO TO 130
c-----------------------------------------------------------------------
C
C     CONVERGENCE. KEEP INTERVAL MIDPOINT IF BACKWARD THINNING WILL BE
C     PERFORMED. OTHERWISE ONLY KEEP ENDS OF INTERVAL.
C
c-----------------------------------------------------------------------
  170 IF(NOTHIN.GT.0) GO TO 180
C-----CORE SPACE FOR TWO MORE POINTS REQUIRED. IF NO ROOM IN CORE, THIN
C-----AND UNLOAD ONE PAGE OF POINTS TO SCRATCH.
      IF(N2CORE.GE.NP2M1) CALL THINIT
C-----KEEP INTERVAL MIDPOINT AND ENDPOINT.
      XOUT(N2P1)=XN2P1
      YOUT(N2P1)=YN2P1
      XOUT(N2P2)=XN2P2
      YOUT(N2P2)=YN2P2
      N2CORE=N2P2
      N2P1=N2CORE+1
      N2P2=N2P1+1
      GO TO 190
C-----CORE SPACE FOR ONE MORE POINT REQUIRED. IF NO ROOM IN CORE, THIN
C-----AND UNLOAD ONE PAGE OF POINTS TO SCRATCH.
  180 IF(N2CORE.GE.NPAGE2) CALL THINIT
C-----MIDPOINT OF INTERVAL IS NOT REQUIRED. ONLY KEEP ENDPOINT OF
C-----INTERVAL.
      XOUT(N2P1)=XN2P2
      YOUT(N2P1)=YN2P2
      N2CORE=N2P1
      N2P1=N2CORE+1
      N2P2=N2P1+1
C-----IF NOT END OF CURRENT INTERVAL CONTINUE. OTHERWISE
C-----MOVE TO NEXT INTERVAL.
  190 IF(XOUT(N2CORE).LT.XEND) GO TO 120
C-----IF RANGE SAVED, RESTORE POINT AND RESET FLAG
      IF(IMSAVED.LE.0) GO TO 200
      IMSAVED=0
      XEND=XSAVE
      YEND=YSAVE
      GO TO 100
  200 CONTINUE
  210 CONTINUE
C-----EACH OF SECTION. SET END OF SECTION FLAG AND SET UP LINEARIZED,
C-----THINNED SECTION TO READ.
      MTEND=1
      CALL THINIT
C-----OUTPUT SECTION TO LINEARIZED FILE.
      CALL COPOUT
C-----PRINT ERROR MESSAGE IF INTERPOLATION LAW = 6 IS USED WITH A
C-----REACTION WITH A NEGATIVE Q-VALUE.
      IF(IM6.GT.0.AND.Q.LT.0.0d0) WRITE(OUTP,220)
      RETURN
  220 FORMAT(19X,'WARNING - the Above Section Uses Interpolation Law 6'/
     1 19X,'but, Has a Negative Q-Value? Results Will be Unreliable.')
      END
      SUBROUTINE FILE5F
C=======================================================================
C
C     START FROM IN CORE FILE 5 DATA
C     CONVERT DATA TO LINEAR-LINEAR FORM. IF LESS THAN MAXP1 POINTS
C     ARE GENERATED THEY WILL BE CORE RESIDENT. OTHERWISE THEY WILL
C     BE ON SCRATCH FILE (ISCR)
C
C=======================================================================
      INCLUDE 'implicit.h'
      CHARACTER*1 ZABCD
      INTEGER*4 OUTP,OTAPE
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/NBTINT/NBT(100),INT(100)
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/LEADER/C1,Q,L1,L2,N1,N2IN,MAT,MF,MT
      COMMON/OLDTAB/IXYLOW,IXYHI,LEFT
      COMMON/THRESE/ETHRES
      COMMON/WHATZA/IZA
      COMMON/NEWTAB/N2CORE,N2SCR,N2TOT,N2P1,N2P2
      COMMON/OKERR3/ERRXC3,KERR3,MAXER3,ENER3(21),ER3(21)
      COMMON/PARAMS/XCMIN
      COMMON/LASTE/ELAST
      COMMON/PAGER/NPAGE,NPAGE2,NP1P1,NP2M1
      COMMON/SLIM/ISTART,NOTHIN,ITHIN1,ITHIN2,ITHIN3,MTEND
C----- FILE 5 PARAMETERS
      COMMON/CON5COM/U5,EFL,EFH,LF5,IMSMOOTH
      COMMON/E5P5COM/E5(1000),P5(1000),NP5
      COMMON/NBTINT5/NBT5(100),INT5(100),NR5
      COMMON/PARAMS5A/ETHETA(1000),THETA(1000),IT5,NT5
      COMMON/PARAMS5B/EG5(10000),G5(10000),NG5
      COMMON/PARAMS5C/EAWATT(1000),AWATT(1000)
      COMMON/PARAMS5D/EBWATT(1000),BWATT(1000)
      COMMON/PARAMS5E/ETM(1000),TM(1000)
      COMMON/EGRIDCOM/EGRID(2000),NGRID
      COMMON/ENRGYCOM/EMIN,EMAX,ETHERMAL
      COMMON/LISOCOM/LISO
      INCLUDE 'spectra.h'
      DIMENSION ZABCD(12)
      DATA ZERO/0.0D+00/
      DATA HALF/5.0D-01/
c-----------------------------------------------------------------------
C
C     READ AND CHECK SECTION LEADER LINE AND INTERPOLATION LAW. IF
C     INTERPOLATION LAW IS ILLEGAL (BAD INTERPOLATION TYPE OR IMPROPER
C     INTERPOLATION BOUNDARY) TERMINATE EXECUTION.
C
c-----------------------------------------------------------------------
      IF(LF5.LT.1.OR.LF5.GT.12) GO TO 350
C              1   2   3   4   5   6   7   8   9  10
C             11  12
      GO TO (350,350,350,350,  10,350,  20,350,  30,350,
     1         50,  60),LF5
C-----------------------------------------------------------------------
C
C     LF = 5 = DEFINE SCALED, TABULATED G(X) AND INTERPOLATION LAW
C
C-----------------------------------------------------------------------
   10 N1 = NR5
      DO I=1,N1
      NBT(I) = NBT5(I)
      INT(I) = INT5(I)
      ENDDO
      N2IN = NG5
      Q    = ETHETA(IT5)
      DO I=1,N2IN
      XIN(I) = EG5(I)*THETA(IT5)
      YIN(I) =  G5(I)
      ENDDO
      GO TO 80
C-----------------------------------------------------------------------
C
C     LF = 7 = MAXWELLIAN
C
C-----------------------------------------------------------------------
   20 N2IN = NGRID
      Q    = ETHETA(IT5)
      DO I=1,N2IN
      XIN(I) = EGRID(I)
      YIN(I) = DSQRT(XIN(I))*DEXP(-XIN(I)/THETA(IT5))
      ENDDO
C-----USE COMMON LINEAR INTERPOLATION LAW
      GO TO 70
C-----------------------------------------------------------------------
C
C     LF = 9 = EVAPORATION MODEL
C
C-----------------------------------------------------------------------
   30 Q    = ETHETA(IT5)
      ETOP = Q - U5
c-----ALLOW FOR THRESHOLD POINT = REPLACE BY SPIKE
      IF(ETOP.LE.EMIN) THEN
      XIN(1) = EMIN
      YIN(1) = 0.0d0
      XIN(2) = 1.1d0*EMIN
      YIN(2) = 1.0d0
      XIN(3) = 1.2d0*EMIN
      YIN(3) = 0.0d0
      N2IN   = 3
      N1     = 1
      NBT(1) = N2IN
      INT(1) = 2
      GO TO 80
      ENDIF
      DO I=1,NGRID
      XIN(I) = EGRID(I)
      IF(XIN(I).GE.ETOP) XIN(I) = ETOP
      YIN(I) = XIN(I)*DEXP(-XIN(I)/THETA(IT5))
      IF(XIN(I).GE.ETOP) GO TO 40
      ENDDO
      I = NGRID
   40 N2IN = I
C-----USE COMMON LINEAR INTERPOLATION LAW
      GO TO 70
C-----------------------------------------------------------------------
C
C     LF = 11 = GENERAL WATT
C
C-----------------------------------------------------------------------
   50 N2IN = NGRID
      Q    = EAWATT(IT5)
      DO I=1,N2IN
      XIN(I) = EGRID(I)
      ARGA   = XIN(I)/AWATT(IT5)
      ARGB   = DSQRT(XIN(I)*BWATT(IT5))
      SINHB  = 0.5d0*(DEXP(ARGB)-DEXP(-ARGB))
      YIN(I) = DEXP(-ARGA)*SINHB
      ENDDO
C-----USE COMMON LINEAR INTERPOLATION LAW
      GO TO 70
C-----------------------------------------------------------------------
C
C     LF = 12 = MADLAND-NIX
C
C-----------------------------------------------------------------------
   60 N2IN = NGRID
      Q    = ETM(IT5)
      DO I=1,N2IN
      XIN(I) = EGRID(I)
      U1L    = (DSQRT(XIN(I))-DSQRT(EFL))**2/TM(IT5)
      U2L    = (DSQRT(XIN(I))+DSQRT(EFL))**2/TM(IT5)
      U1H    = (DSQRT(XIN(I))-DSQRT(EFH))**2/TM(IT5)
      U2H    = (DSQRT(XIN(I))+DSQRT(EFH))**2/TM(IT5)
      AL     = (U2L**1.5D+0)*DE1(U2L) - (U1L**1.5D+0)*DE1(U1L)
      BL     = DGAMI(1.5D+0,U2L)     -  DGAMI(1.5D+0,U1L)
      GL     = (AL+BL)/(3.0d0*DSQRT(EFL*TM(IT5)))
      AH     = (U2H**1.5d0)*DE1(U2H) - (U1H**1.5d0)*DE1(U1H)
      BH     = DGAMI(1.5d0,U2H)     -  DGAMI(1.5d0,U1H)
      GH     = (AH+BH)/(3.0d0*DSQRT(EFH*TM(IT5)))
      YIN(I) = 0.5d0*(GL + GH)
      ENDDO
C-----USE COMMON LINEAR INTERPOLATION LAW
      GO TO 70
C-----------------------------------------------------------------------
C
C     COMMON LINEAR INTERPOLATION LAW TO SMOOTH MF=5 DATA
C
C-----------------------------------------------------------------------
   70 N1 = 1
      NBT(1) = N2IN
      INT(1) = 5
      GO TO 80
C-----CHECK INTERPOLATION LAW (LAWS = 1 TO 6 AND BOUNDARIES IN
C-----ASCENDING ORDER).
   80 IM6=0
      DO 90 IR=1,N1
      IF(INT(IR).LT.1.OR.INT(IR).GT.6) GO TO 100
      IF(INT(IR).EQ.6) IM6=1
      IF(IR.EQ.1) GO TO 90
      IF(NBT(IR).LE.NBT(IR-1)) GO TO 100
   90 CONTINUE
      IF(NBT(N1).EQ.N2IN) GO TO 110
  100 IZA = C1H
c-----2020/3/21 - Added Target Isomer State
      CALL ZAHOLM(IZA,LISO,ZABCD)
      WRITE(OUTP,330) ZABCD,MATH,MFH,MTH,N2IN,(NBT(I),INT(I),I=1,N1)
      WRITE(*   ,330) ZABCD,MATH,MFH,MTH,N2IN,(NBT(I),INT(I),I=1,N1)
      CALL ENDERROR
c-----------------------------------------------------------------------
C
C     INITIALIZE ALL PARAMETERS FOR THIS SECTION.
C
c-----------------------------------------------------------------------
C-----INITIALIZE FLAG TO INDICATE BEGINNING OF SECTION.
  110 ISTART=1
C-----INITIALIZE PAGING SYSTEM INDICES.
      IXYLOW=0
      IXYHI=0
      LEFT=N2IN
C-----INITIALIZE LAST ENERGY USED (FOR ASCENDING ENERGY ORDER TEST).
      ELAST=ZERO
C-----INITIALIZE END OF SECTION FLAG OFF.
      MTEND=0
C-----INITIALIZE THINNING INDICES.
      ITHIN1=1
      ITHIN2=2
      ITHIN3=2
C-----INITIALIZE COUNT OF POINTS IN CORE AND ON SCRATCH.
      N2CORE=1
      N2P1=2
      N2P2=3
      N2SCR=0
C-----DEFINE FIRST POINT IN TABLE.
      XOUT(1) = XIN(1)
      YOUT(1) = YIN(1)
C-----DO NOT CONSIDER THRESHOLD EXCEPT FOR NEUTRON CROSS SECTIONS
      IF(MFH.NE.3) GO TO 120
C-----IF THIS A THRESHOLD REACTION INSERT POINT AT THRESHOLD WITH ZERO
C-----CROSS SECTION IF THERE IS NOT ONE THERE ALREADY.
      IF(XOUT(1).LE.ETHRES.OR.YOUT(1).EQ.0.0d0) GO TO 120
      XOUT(2)=XOUT(1)
      YOUT(2)=YOUT(1)
      YOUT(1)=0.0d0
      N2CORE=2
      N2P1=3
      N2P2=4
c-----------------------------------------------------------------------
C
C     LINEARIZE DATA CONSIDERING EACH INTERPOLATION LAW REGION
C     SEPARATELY.
C
c-----------------------------------------------------------------------
C-----SET UP LOOP OVER INTERPOLATION RANGES.
  120 NR2=1
      DO 320 IR=1,N1
C-----DEFINE POINTS IN INTERPOLATION RANGE AND TYPE OF INTERPOLATION.
      NR1=NR2+1
      NR2=NBT(IR)
      INTYPE=INT(IR)
C-----HISTOGRAM OR LINEAR-LINEAR DOES NOT REQUIRE FURTHER SUBDIVISION.
      IF(INTYPE.eq.2) go to 150
      IF(INTYPE.gt.2) go to 190
c-----------------------------------------------------------------------
C
C     FOR HISTOGRAM REPLACE EACH ENERGY POINT THAT IS INTERNAL TO THE
C     INTERPOLATION ENERGY RANGE BY TWO ENERGY POINTS AND REPLACE EACH
C     END POINT OF THE INTERPOLATION ENERGY RANGE BY A SINGLE ENERGY
C     POINT (START OF INTERVAL HAS ALREADY BEEN STORED).
C
c-----------------------------------------------------------------------
      DO 140 NPT=NR1,NR2
C-----CORE SPACE FOR TWO MORE POINTS REQUIRED. IF NO ROOM IN CORE, THIN
C-----AND UNLOAD ONE PAGE OF POINTS TO SCRATCH.
      IF(N2CORE.GE.NP2M1) CALL THINIT
      N2CORE=N2CORE+2
      N2P1=N2CORE+1
      N2P2=N2P1+1
      XOUT(N2CORE) = XIN(NPT)
      YOUT(N2CORE) = YIN(NPT)
C-----ELIMINATE DUPLICATE POINTS.
      IF(XOUT(N2CORE).NE.XOUT(N2CORE-2)) GO TO 130
      XOUT(N2CORE-1)=XOUT(N2CORE)
      YOUT(N2CORE-1)=YOUT(N2CORE)
      N2CORE=N2CORE-1
      N2P1=N2CORE+1
      N2P2=N2P1+1
      GO TO 140
  130 XOUT(N2CORE-1)=XOUT(N2CORE)
      YOUT(N2CORE-1)=YOUT(N2CORE-2)
  140 CONTINUE
C-----IF TABLE ENDS WITH HISTOGRAM DO NOT EXTEND CROSS SECTION AS ZERO
C-----(I.E. IGNOR LAST...USUALLY ZERO...CROSS SECTION VALUE).
      IF(IR.NE.N1) GO TO 320
      N2CORE=N2CORE-1
      N2P1=N2CORE+1
      N2P2=N2P1+1
      GO TO 320
c-----------------------------------------------------------------------
C
C     FOR LINEAR-LINEAR INTERPOLATION JUST COPY POINTS TO OUTPUT ARRAY.
C
c-----------------------------------------------------------------------
  150 IF(IMSMOOTH.LE.0) GO TO 160
      INTYPE = 5
      GO TO 200
  160 DO 180 NPT=NR1,NR2
C-----DEFINE UPPER ENERGY LIMIT OF INTERVAL.
      XEND = XIN(NPT)
      YEND = YIN(NPT)
c-----------------------------------------------------------------------
C
C     IF NECESSARY INSERT THERMAL POINT
C
c-----------------------------------------------------------------------
C-----ONLY FOR MF = 3
      IF(MFH.NE.3) GO TO 170
      IF(XEND        .LE.ETHERMAL.OR.
     1   XOUT(N2CORE).GE.ETHERMAL) GO TO 170
      YTHERMAL=TERPIT(ETHERMAL,XEND,XOUT(N2CORE),
     1                         YEND,YOUT(N2CORE),INTYPE)
C-----CORE SPACE FOR ONE MORE POINT REQUIRED. IF NO ROOM IN CORE, THIN
C-----AND UNLOAD ONE PAGE OF POINTS TO SCRATCH.
      IF(N2CORE.GE.NPAGE2) CALL THINIT
C-----INSERT THERMAL VALUE
      N2CORE=N2CORE+1
      XOUT(N2CORE)=ETHERMAL
      YOUT(N2CORE)=YTHERMAL
C-----CORE SPACE FOR ONE MORE POINT REQUIRED. IF NO ROOM IN CORE, THIN
C-----AND UNLOAD ONE PAGE OF POINTS TO SCRATCH.
  170 IF(N2CORE.GE.NPAGE2) CALL THINIT
      N2CORE=N2CORE+1
      N2P1=N2CORE+1
      N2P2=N2P1+1
      XOUT(N2CORE)=XEND
      YOUT(N2CORE)=YEND
  180 CONTINUE
      GO TO 320
c-----------------------------------------------------------------------
C
C     NON-LINEAR INTERPOLATION LAW REQUIRES SUB-DIVISION. SET UP LOOP
C     OVER POINTS IN CURRENT INTERPOLATION REGION.
C
c-----------------------------------------------------------------------
  190 IF(IMSMOOTH.GT.0) INTYPE = 5
  200 DO 310 NPT=NR1,NR2
C-----INITIALIZE TO RANGE NOT SAVED
      IMSAVED=0
C-----DEFINE UPPER ENERGY LIMIT OF INTERVAL.
      XEND = XIN(NPT)
      YEND = YIN(NPT)
c-----------------------------------------------------------------------
C
C     IF NECESSARY INSERT MAX. ENERGY OR THERMAL POINT
C
c-----------------------------------------------------------------------
  210 XTOP=XEND
C-----ONLY FOR MF = 3
      IF(MFH.NE.3) GO TO 220
      IF(XTOP.GT.ETHERMAL.AND.XOUT(N2CORE).LT.ETHERMAL)
     1 XTOP=ETHERMAL
C-----CANNOT DOUBLE 0.0 - JUST USE INTERVAL FROM 0.0
  220 IF(XOUT(N2CORE).LE.0.0d0) GO TO 230
      IF(XTOP.GT.2.0d0*XOUT(N2CORE)) XTOP=2.0d0*XOUT(N2CORE)
      IF(XTOP.GE.XEND) GO TO 230
C-----INTERPOLATE CROSS SECTION TO NEW END
      YTOP=TERPIT(XTOP,XEND,XOUT(N2CORE),
     1                 YEND,YOUT(N2CORE),INTYPE)
C-----SAVE END AND SET RANGE SAVED FLAG
      IMSAVED=1
      XSAVE=XEND
      YSAVE=YEND
C-----DEFINE END OF INTERVAL AT THERMAL
      XEND=XTOP
      YEND=YTOP
C-----DEFINE ENERGY AND CROSS SECTION AT TWO ENDS OF INTERVAL.
  230 XN2P2=XEND
      YN2P2=YEND
      XN2=XOUT(N2CORE)
      YN2=YOUT(N2CORE)
C-----DO NOT SUBDIVIDE IF CROSS SECTION IS CONSTANT.
      IF(YN2.EQ.YN2P2) GO TO 290
c-----------------------------------------------------------------------
C
C     DO NOT SUB-DIVIDE INTERVALS WITHIN WHICH THE ABSOLUTE VALUE OF
C     THE CROSS SECTION IS LESS THAN THE MINIMUM CROSS SECTION OF
C     INTEREST.
C
c-----------------------------------------------------------------------
      IF(DABS(YN2).LE.XCMIN.AND.DABS(YN2P2).LE.XCMIN) GO TO 290
c-----------------------------------------------------------------------
C
C     DEFINE ENERGY AT MIDDLE OF INTERVAL.
C
c-----------------------------------------------------------------------
C-----INTYPE IS NOW 3, 4, 5 OR 6.
C-----CANNOT DOUBLE 0.0 - USE LINEAR SPACING
  240 IF(XN2.LE.0.0d0) GO TO 250
      IF(INTYPE.ne.4) go to 260
C-----LINEAR ENERGY.
  250 XN2P1=HALF*(XN2+XN2P2)
      GO TO 270
C-----LOG ENERGY.
  260 XN2P1=DSQRT(XN2*XN2P2)
C-----ROUND MIDPOINT.
  270 CALL INCORE10(XN2P1)
c-----------------------------------------------------------------------
C
C     SMALL ENERGY INTERVAL CONVERGENCE TESTS.
C
C     IF ENERGY AT MIDDLE OF INTERVAL IS LESS THAN ALLOWABLE ENERGY
C     SPACING ONLY KEEP THE TWO ENDS OF THE INTERVAL.
c
c-----------------------------------------------------------------------
      IF(XN2P1.LE.XN2.OR.XN2P1.GE.XN2P2) GO TO 290
C-----06/02/09 - ADDED SMALL CROSS SECTION TEST
c-----------------------------------------------------------------------
C
C     SMALL CROSS SECTION CONVERGENCE TESTS.
C
c-----------------------------------------------------------------------
C-----IF CROSS SECTION AT BOTH ENDS IS LESS THAN XCMIN ONLY KEEP
C-----KEEP THE TWO ENDS OF THE INTERVAL.
      IF(DABS(YN2).LT.XCMIN.AND.DABS(YN2P2).LT.XCMIN) GO TO 290
c-----------------------------------------------------------------------
C
C     DEFINE CROSS SECTION AT MIDDLE OF INTERVAL BY INTERPOLATION LAW
C     AND LINEAR-LINEAR INTERPOLATION.
C
c-----------------------------------------------------------------------
      YN2P1=TERPIT(XN2P1,XN2,XN2P2,YN2,YN2P2,INTYPE)
      YAPROX=TERPIT(XN2P1,XN2,XN2P2,YN2,YN2P2,2)
C-----DEFINE ALLOWABLE ERROR.
      IF(KERR3.NE.0) CALL ERROK3(XN2P1)
C-----TEST FOR CONVERGENCE. IF CONVERGENCE KEEP MIDPOINT OF INTERVAL
C-----IN ORDER TO ALLOW ACCURATE BACKWARD THINNING BEFORE OUTPUT.
      IF(DABS(YN2P1-YAPROX).LE.DABS(YN2P1*ERRXC3)) GO TO 280
c-----------------------------------------------------------------------
C
C     NO CONVERGENCE. SHORTEN INTERVAL.
C
c-----------------------------------------------------------------------
      XN2P2=XN2P1
      YN2P2=YN2P1
      GO TO 240
c-----------------------------------------------------------------------
C
C     CONVERGENCE. KEEP INTERVAL MIDPOINT IF BACKWARD THINNING WILL BE
C     PERFORMED. OTHERWISE ONLY KEEP ENDS OF INTERVAL.
C
c-----------------------------------------------------------------------
  280 IF(NOTHIN.GT.0) GO TO 290
C-----CORE SPACE FOR TWO MORE POINTS REQUIRED. IF NO ROOM IN CORE, THIN
C-----AND UNLOAD ONE PAGE OF POINTS TO SCRATCH.
      IF(N2CORE.GE.NP2M1) CALL THINIT
C-----KEEP INTERVAL MIDPOINT AND ENDPOINT.
      XOUT(N2P1)=XN2P1
      YOUT(N2P1)=YN2P1
      XOUT(N2P2)=XN2P2
      YOUT(N2P2)=YN2P2
      N2CORE=N2P2
      N2P1=N2CORE+1
      N2P2=N2P1+1
      GO TO 300
C-----CORE SPACE FOR ONE MORE POINT REQUIRED. IF NO ROOM IN CORE, THIN
C-----AND UNLOAD ONE PAGE OF POINTS TO SCRATCH.
  290 IF(N2CORE.GE.NPAGE2) CALL THINIT
C-----MIDPOINT OF INTERVAL IS NOT REQUIRED. ONLY KEEP ENDPOINT OF
C-----INTERVAL.
      XOUT(N2P1)=XN2P2
      YOUT(N2P1)=YN2P2
      N2CORE=N2P1
      N2P1=N2CORE+1
      N2P2=N2P1+1
C-----IF NOT END OF CURRENT INTERVAL CONTINUE. OTHERWISE
C-----MOVE TO NEXT INTERVAL.
  300 IF(XOUT(N2CORE).LT.XEND) GO TO 230
C-----IF RANGE SAVED, RESTORE POINT AND RESET FLAG
      IF(IMSAVED.LE.0) GO TO 310
      IMSAVED=0
      XEND=XSAVE
      YEND=YSAVE
      GO TO 210
  310 CONTINUE
  320 CONTINUE
C-----END OF SECTION. SET END OF SECTION FLAG AND SET UP LINEARIZED,
C-----THINNED SECTION TO READ.
      MTEND=1
      CALL THINIT
C-----RENORMALIZE
      RENORM = 0.0d0
      DO I=2,N2TOT
      RENORM = RENORM + (XOUT(I)-XOUT(I-1))*(YOUT(I)+YOUT(I-1))
      ENDDO
      RENORM = 0.5d0*RENORM
      DO I=1,N2TOT
      YOUT(I) = YOUT(I)/RENORM
      ENDDO
C-----OUTPUT SECTION TO LINEARIZED FILE.
      CALL COPOUT
C-----PRINT ERROR MESSAGE IF INTERPOLATION LAW = 6 IS USED WITH A
C-----REACTION WITH A NEGATIVE Q-VALUE.
      IF(IM6.GT.0.AND.Q.LT.0.0d0) WRITE(OUTP,340)
      RETURN
  330 FORMAT(2X,12A1,I5,I4,I4/
     1 '  Error in Interpolation Law---Execution Terminated'/
     2 '  N2 =',I6/'   NBT  INT'/(I6,I5))
  340 FORMAT(19X,'WARNING - the Above Section Uses Interpolation Law 6'/
     1 19X,'but, Has a Negative Q-Value? Results Will be Unreliable.')
  350 WRITE(3,360) LF5
      WRITE(*,360) LF5
  360 FORMAT(' LF=',I6,' (EXPECT 1, 5, 7, 9, 11 OR 12)'//)
      CALL ENDERROR
      END
      SUBROUTINE THINIT
C=======================================================================
C
C     THIN LINEARIZED DATA AND IF NECESSARY OUTPUT ONE PAGE TO
C     SCRATCH.
C
C     FOUR INDICES TO IN CORE ARRAYS ARE USED IN THIS ROUTINE
C
C     N2CORE = NUMBER OF LINEARIZED POINTS (TO BE THINNED).
C     ITHIN1 = NUMBER OF THINNED POINTS
C     ITHIN2 = INDEX TO NEXT POINT TO CONSIDER FOR THINNING
C     ITHIN3 = INDEX TO FIRST POINT OF CURRENT INTERVAL TO BE THINNED
C              (ITHIN3 IS ONLY USED TO DECIDE WHEN TO INITIALIZE THE
C               LIMITS OF THE SLOPE).
C
C     IN ADDITION TO NORMAL CHANGES DUE TO THINNING ALL OF THESE
C     INDICES WILL BE UPDATED IF A PAGE OF DATA IS TRANSFERRED TO
C     SCRATCH.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INTEGER*4 OUTP,OTAPE
      CHARACTER*1 FIELD
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/UNITS/ISCR
      COMMON/NEWTAB/N2CORE,N2SCR,N2TOT,N2P1,N2P2
      COMMON/OKERR3/ERRXC3,KERR3,MAXER3,ENER3(21),ER3(21)
      COMMON/SLIM/ISTART,NOTHIN,ITHIN1,ITHIN2,ITHIN3,MTEND
      COMMON/PAGER/NPAGE,NPAGE2,NP1P1,NP2M1
      COMMON/IWATCH/MONITR
      COMMON/FIELDC/FIELD(11,6)
      COMMON/ENRGYCOM/EMIN,EMAX,ETHERMAL
      INCLUDE 'spectra.h'
C-----INITIALIZE FLAG TO INDICATE SCRATCH FILE HAS NOT BEEN WRITTEN
C-----ON YET.
      DATA IMUSED/0/
C-----SHOULD POINTS BE THINNED.
      IF(NOTHIN.EQ.0) GO TO 10
c-----------------------------------------------------------------------
C
C     POINTS WILL NOT BE THINNED. SET INDEX TO KEEP ALL POINTS.
C
c-----------------------------------------------------------------------
      ITHIN1=N2CORE
      ITHIN3=N2CORE+1
      GO TO 160
c-----------------------------------------------------------------------
C
C     POINTS WILL BE THINNED.
C
c-----------------------------------------------------------------------
C-----IF NO POINTS FOR THINNING SKIP TO END OF THINNING SECTION.
   10 IF(ITHIN2.GT.N2CORE) GO TO 160
c-----------------------------------------------------------------------
C
C     INITIALIZE SIGN OF DERIVATIVE AT BEGINNING OF SECTION.
C
c-----------------------------------------------------------------------
      IF(ISTART.le.0) go to 20
      ISTART=0
      SIGNT=1.0d0
      IF(YOUT(1).GT.YOUT(2)) SIGNT=-1.0d0
c-----------------------------------------------------------------------
C
C     SET UP LOOP TO THIN DATA.
C
c-----------------------------------------------------------------------
C-----SET UP LOOP OVER POINTS TO THIN.
   20 DO 150 M=ITHIN2,N2CORE
      MM1=M-1
      DXC=YOUT(M)-YOUT(MM1)
c-----------------------------------------------------------------------
C
C     KEEP ALL MAXIMA AND MINIMA.
C
C     PRECEDING POINT WAS MAXIMUM OR MINIMUM IF SIGN OF CHANGE IN
C     CROSS SECTION HAS REVERSED.
c
c-----------------------------------------------------------------------
      IF(DXC*SIGNT.ge.0.0d0) go to 30
      SIGNT=-SIGNT
C-----IF ENERGIES OF TWO POINTS ARE THE SAME TREAT AS DISCONTINUITY.
      IF(XOUT(M).LE.XOUT(MM1)) GO TO 50
C-----ENERGY NOT THE SAME. SAVE MAXIMUM OR MINIMUM IF IT HAS NOT
C-----ALREADY BEEN SAVED.
      IF(M.gt.ITHIN3) go to 110
C-----MAXIMUM OR MINIMUM ALREADY SAVED.
c-----------------------------------------------------------------------
C
C     KEEP PRECEDING AND PRESENT POINTS IF SIGN OF CROSS SECTION HAS
C     CHANGED.
C
c-----------------------------------------------------------------------
   30 IF(YOUT(M)*YOUT(MM1).ge.0.0d0) go to 40
C-----IF PRECEDING POINT HAS NOT BEEN KEPT KEEP PRECEDING AND CURRENT
C-----POINTS, OTHERWISE KEEP ONLY CURRENT POINT.
      IF(M.le.ITHIN3) go to 130
      go to 120
c-----------------------------------------------------------------------
C
C     KEEP DISCONTINUITY.
C
c-----------------------------------------------------------------------
C-----IS ENERGY OF TWO POINTS THE SAME.
   40 IF(XOUT(M).GT.XOUT(MM1)) GO TO 80
C-----YES. CHECK FOR SAME CROSS SECTION.
   50 DXC=DABS(DXC)
C-----CHECK FOR BEGINNING OF THINNING INTERVAL.
      IF(M.NE.ITHIN3) GO TO 60
C-----BEGINNING OF INTERVAL (M-1 ALREADY SAVED). IF CROSS SECTIONS ARE,
C-----(1) SAME -SKIP M AND UPDATE INDEX DEFINING M+1 BEGINNING INTERVAL.
C-----(2) DIFFERENT -KEEP POINT M.
      IF(DXC.le.0.0d0) go to 140
      go to 70
C-----NOT BEGINNING OF INTERVAL (M-1 NOT SAVED). IF CROSS SECTIONS ARE,
C-----(1) SAME -KEEP M, SKIP M-1.
C-----(2) DIFFERENT -KEEP POINTS M-1 AND M.
   60 IF(DXC.gt.0.0d0) go to 120
   70 IF(M.le.ITHIN3) go to 130
      go to 120
c-----------------------------------------------------------------------
C
C     KEEP THERMAL POINT AND PRECEDING POINT, IF NOT ALREADY KEPT.
C
c-----------------------------------------------------------------------
C-----ONLY FOR MF = 3
   80 IF(MFH.NE.3) GO TO 90
      IF(XOUT(M).NE.ETHERMAL) GO TO 90
      IF(M.le.ITHIN3) go to 130
      go to 120
c-----------------------------------------------------------------------
C
C     KEEP POINTS THAT CANNOT BE ACCURATELY INTERPOLATED.
C
C     DEFINE ENERGY INTERVAL BETWEEN CURRENT POINT AND LAST CONVERGED
C     POINT.
c
c-----------------------------------------------------------------------
   90 DXN=XOUT(M)-XOUT(ITHIN1)
c-----------------------------------------------------------------------
C
C     DEFINE SLOPE OF STRAIGHT LINE THAT WILL PASS WITHIN THE ALLOWABLE
C     ERROR OF EACH POINT. KEEP ELIMINATING POINTS UNTIL ONE OR MORE
C     POINTS CANNOT BE APPROXIMATED TO WITHIN THE ALLOWABLE ERROR. AT
C     THAT POINT KEEP THE LAST PRECEDING POINT (I.E., KEEP THE LAST
C     POINT THAT PASSED THE TEST).
C
c-----------------------------------------------------------------------
      SLOPE=(YOUT(M)-YOUT(ITHIN1))/DXN
C-----INITIALIZE MAXIMUM AND MINIMUM ALLOWABLE SLOPE AT FIRST POINT OF
C-----INTERVAL.
      IF(M.NE.ITHIN3) GO TO 100
      IF(KERR3.NE.0) CALL ERROK3(XOUT(M))
      DSLOPE=ERRXC3*YOUT(M)/DXN
      SLPMAX=SLOPE+DSLOPE
      SLPMIN=SLOPE-DSLOPE
      GO TO 150
C-----AFTER FIRST POINT OF INTERVAL SEE IF SLOPE TO CURRENT POINT PASSES
C-----WITHIN THE ALLOWABLE ERROR OF ALL PRECEDING POINTS IN CURRENT
C-----INTERVAL.
  100 IF(SLOPE.GT.SLPMAX.OR.SLOPE.LT.SLPMIN) GO TO 110
C-----CAN ELIMINATE CURRENT POINT. UPDATE SLOPE LIMITS.
      IF(KERR3.NE.0) CALL ERROK3(XOUT(M))
      DSLOPE=ERRXC3*YOUT(M)/DXN
      SLP1=SLOPE+DSLOPE
      IF(SLP1.LT.SLPMAX) SLPMAX=SLP1
      SLP2=SLOPE-DSLOPE
      IF(SLP2.GT.SLPMIN) SLPMIN=SLP2
      GO TO 150
C-----NEED TO KEEP LAST PRECEDING POINT (LAST ONE TO PASS TEST).
  110 ITHIN1=ITHIN1+1
      XOUT(ITHIN1)=XOUT(MM1)
      YOUT(ITHIN1)=YOUT(MM1)
C-----RE-DEFINE INDEX TO BEGINNING OF NEXT INTERVAL.
      ITHIN3=M
      GO TO 80
C-----NEED TO KEEP LAST PRECEDING AND CURRENT POINTS.
  120 ITHIN1=ITHIN1+1
      XOUT(ITHIN1)=XOUT(MM1)
      YOUT(ITHIN1)=YOUT(MM1)
C-----NEED TO KEEP CURRENT POINT.
  130 ITHIN1=ITHIN1+1
      XOUT(ITHIN1)=XOUT(M)
      YOUT(ITHIN1)=YOUT(M)
C-----RE-DEFINE INDEX TO BEGINNING OF NEXT INTERVAL.
  140 ITHIN3=M+1
C-----END OF THINNING LOOP.
  150 CONTINUE
C-----TEST FOR END OF SECTION.
  160 IF(MTEND.GT.0) GO TO 230
c-----------------------------------------------------------------------
C
C     NOT THE END OF SECTION. IF CONVERGED POINTS FILL ENTIRE FIRST
C     PAGE PLUS AT LEAST TWO POINTS IN SECOND PAGE (FOR HISTOGRAM
C     LOOK BACK) UNLOAD ONE PAGE TO SCRATCH AND SHIFT ALL INCORE
C     INDICES. OTHERWISE NOTHING TO DO.
C
c-----------------------------------------------------------------------
C-----ELIMINATE ALL POINTS THAT ARE NOT REQUIRED FOR FURTHER THINNING.
      N2OLD=N2CORE
      N2CORE=ITHIN1
      N2P1=N2CORE+1
      N2P2=N2P1+1
C-----IF LAST POINT WAS NOT SAVED, ADD IT TO THE END OF THE ARRAY.
      IF(ITHIN3.GT.N2OLD) GO TO 170
      N2P=ITHIN1+1
      XOUT(N2P)=XOUT(N2OLD)
      YOUT(N2P)=YOUT(N2OLD)
      N2CORE=N2P
      N2P1=N2CORE+1
      N2P2=N2P1+1
C-----TEST FOR FULL PAGE + 2.
  170 IF(ITHIN1.LE.NP1P1) GO TO 200
C-----OUTPUT PAGE TO SCRATCH. REWIND SCRATCH BEFORE FIRST WRITE
      IF(N2SCR.LE.0.AND.IMUSED.GT.0) REWIND ISCR
C-----OUTPUT ONE PAGE OF LINEARIZED DATA AND INCREASE POINT COUNT
      WRITE(ISCR) XPAGE1,YPAGE1
      IMUSED=1
      N2SCR=N2SCR+NPAGE
      IF(MONITR.LE.0) GO TO 180
      ES1=XOUT(1)
      ES2=XOUT(NPAGE)
      CALL OUT9(ES1,FIELD(1,1))
      CALL OUT9(ES2,FIELD(1,2))
      WRITE(OUTP,280) N2SCR,((FIELD(M,KK),M=1,11),KK=1,2)
      WRITE(*   ,280) N2SCR,((FIELD(M,KK),M=1,11),KK=1,2)
C-----MOVE REMAINING CONVERGED POINTS FORWARD IN CORE AND RE-DEFINE
C-----ALL INDICES.
  180 LL=0
      DO 190 LLL=NP1P1,N2CORE
      LL=LL+1
      XOUT(LL)=XOUT(LLL)
      YOUT(LL)=YOUT(LLL)
  190 CONTINUE
      ITHIN1=ITHIN1-NPAGE
      N2CORE=N2CORE-NPAGE
      N2P1=N2CORE+1
      N2P2=N2CORE+2
C-----DEFINE INDICES TO ENERGY INTERVAL TO BE USED THE NEXT TIME THAT
C-----THIS ROUTINE IS CALLED (ITHIN2 ALWAYS REFERS TO THE NEXT POINT
C-----THAT WILL BE LINEARIZED. ITHIN3 SHOULD REFER TO THIS POINT TOO
C-----IF LAST POINT WAS SAVED. IF NOT SET ITHIN3 TO PREVENT INITIALIZING
C-----SLOPES THE NEXT TIME THAT THIS ROUTINE IS CALLED).
  200 ITHIN2=N2CORE+1
      IF(ITHIN3.GT.N2OLD) GO TO 210
      ITHIN3=0
      GO TO 220
  210 ITHIN3=ITHIN2
  220 RETURN
c-----------------------------------------------------------------------
C
C     END OF SECTION. SAVE LAST POINT. IF ALL DATA IS CORE RESIDENT
C     LEAVE IT THERE. OTHERWISE MOVE DATA TO SCRATCH AND POSITION
C     SCRATCH TO BE READ.
C
c-----------------------------------------------------------------------
C-----IF LAST POINT WAS NOT SAVED, SAVE IT NOW.
  230 IF(ITHIN3.GT.N2CORE) GO TO 240
      ITHIN1=ITHIN1+1
      XOUT(ITHIN1)=XOUT(N2CORE)
      YOUT(ITHIN1)=YOUT(N2CORE)
C-----IF DATA ALREADY ON SCRATCH COPY REMAINING DATA TO SCRATCH (IF
C-----THERE ARE LESS THAN TWO PAGES OF DATA, SECTION WILL BE IN CORE)
  240 IF(N2SCR.LE.0) GO TO 270
      WRITE(ISCR) XPAGE1,YPAGE1
      IF(MONITR.LE.0) GO TO 250
      NPOUT=NPAGE
      IF(ITHIN1.LT.NPAGE) NPOUT=ITHIN1
      ES1=XOUT(1)
      ES2=XOUT(NPOUT)
      N2SCRP=N2SCR+NPOUT
      CALL OUT9(ES1,FIELD(1,1))
      CALL OUT9(ES2,FIELD(1,2))
      WRITE(OUTP,280) N2SCRP,((FIELD(M,KK),M=1,11),KK=1,2)
      WRITE(*   ,280) N2SCRP,((FIELD(M,KK),M=1,11),KK=1,2)
  250 IF(ITHIN1.LE.NPAGE) GO TO 260
      WRITE(ISCR) XPAGE2,YPAGE2
      IF(MONITR.LE.0) GO TO 260
      ES1=XOUT(NP1P1)
      ES2=XOUT(ITHIN1)
      N2SCRP=N2SCR+ITHIN1
      CALL OUT9(ES1,FIELD(1,1))
      CALL OUT9(ES2,FIELD(1,2))
      WRITE(OUTP,280) N2SCRP,((FIELD(M,KK),M=1,11),KK=1,2)
      WRITE(*   ,280) N2SCRP,((FIELD(M,KK),M=1,11),KK=1,2)
C-----DEFINE NUMBER OF POINTS ON SCRATCH AND INDICATE THAT NO POINTS
C-----REMAIN IN CORE.
  260 N2SCR=N2SCR+ITHIN1
      ITHIN1=0
C-----END FILE AND POSITION SCRATCH TO BE READ
      END FILE ISCR
      REWIND ISCR
C-----DEFINE FINAL POINT TOTAL FOR SECTION
  270 N2TOT=N2SCR+ITHIN1
      RETURN
  280 FORMAT(34X,I8,11A1,' to',11A1,' eV Finished')
      END
      SUBROUTINE XYPAGE(X,Y,N)
C=======================================================================
C
C     LOGICAL PAGING SYSTEM FOR X AND Y ARRAYS. NOTE THAT THIS ROUTINE
C     CAN ONLY BE USED TO ADVANCE FORWARD THROUGH AN ENDF/B
C     SECTION, SINCE IT READS THE DATA DIRECTLY FROM THE ENDF/B
C     DATA FILE A PAGE AT A TIME AND DOES NOT SAVE PAST PAGES.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INTEGER*4 OUTP,OTAPE
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/LEADER/C1,Q,L1,L2,N1,N2IN,MAT,MF,MT
      COMMON/OLDTAB/IXYLOW,IXYHI,LEFT
      COMMON/PAGER/NPAGE,NPAGE2,NP1P1,NP2M1
      INCLUDE 'spectra.h'
C-----INSURE THAT INDEX IS IN LEGAL RANGE.
      IF(N.le.IXYLOW) go to 10
      IF(N.le.N2IN) go to 20
C-----INDEX ERROR.
   10 WRITE(OUTP,40) N,MATH,MFH,MTH
      X=0.0d0
      Y=0.0d0
      RETURN
C-----DETERMINE IF REQUIRED POINT IS IN CORE YET.
   20 IF(N.le.IXYHI) go to 30
C-----NO. READ NEXT PAGE INTO CORE.
      NN=NPAGE
      IF(LEFT.LT.NN) NN=LEFT
      LEFT=LEFT-NN
      IXYLOW=IXYHI
      IXYHI=IXYHI+NN
      CALL POINTI(XIN,YIN,NN)
C-----DEFINE INDEX RELATIVE TO BEGINNING OF IN CORE TABLE AND
C-----RETURN VALUE
   30 INDEX=N-IXYLOW
      X=XIN(INDEX)
      Y=YIN(INDEX)
      RETURN
   40 FORMAT(' Paging Index Error...Index=',I5,'MAT/MF/MT=',I5,I3,I4)
      END
      SUBROUTINE COPOUT
C=======================================================================
C
C     COPY LINEARIZED SECTION TO OUTPUT FILE IN ENDF/B FORMAT. IF
C     LESS THAN MAXP1 POINTS IN SECTION THEY ARE CORE RESIDENT.
C     OTHERWISE THEY ARE READ FROM SCRATCH FILE (ISCR) A PAGE AT
C     A TIME AND WRITTEN OUT.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INTEGER*4 OUTP,OTAPE
      CHARACTER*1 ZABCD,FIELD
      CHARACTER*4 FMTHOL
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/UNITS/ISCR
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/LEADER/C1,Q,L1,L2,N1,N2IN,MAT,MF,MT
      COMMON/NEWTAB/N2CORE,N2SCR,N2TOT,N2P1,N2P2
      COMMON/COUNTS/MATNOW,MFNOW,MATIN,MATOUT,N2TOTI,N2TOTO
      COMMON/WHATZA/IZA
      COMMON/PAGER/NPAGE,NPAGE2,NP1P1,NP2M1
      COMMON/FLAGS/MINUS3,IMPLUS
      COMMON/TEMPO/TEMP3,IVERSE
      COMMON/HOLFMT/FMTHOL
      COMMON/FIELDC/FIELD(11,6)
      COMMON/LISOCOM/LISO
      INCLUDE 'spectra.h'
      DIMENSION NBTO(1),INTO(1),ZABCD(12)
      DATA INTO/2/
c-----------------------------------------------------------------------
C
C     OUTPUT TAB1 LEADER LINE AND INTERPOLATION LAW (LINEAR-LINEAR).
C
c-----------------------------------------------------------------------
C-----OUTPUT TAB1 LEAD LINE (SECTION HEAD LINE OUTPUT IN MAIN)
      N1XX=1
      CALL CARDO(C1,Q,L1,L2,N1XX,N2TOT)
C-----OUTPUT INTERPOLATION LAW.
      NBTO(1)=N2TOT
      CALL TERPO(NBTO,INTO,1)
c-----2020/3/21 - Added Target Isomer State
      CALL ZAHOLM(IZA,LISO,ZABCD)
c-----------------------------------------------------------------------
C
C     DEFINE TEMPERATURE. FOR ENDF/B-V AND EARLIER VERSIONS C1 OF THE
C     TAB1 LEAD LINE IS EITHER THE TEMPERATURE (L2=0) OR THE Q-VALUE
C     CORRESPONDING TO THE REACTION WITH MT=L2. IN THE LATTER CASE
C     ASSUME THE SAME TEMPERATURE AS FOR THE TOTAL. FOR THE ENDF/B-VI
C     FORMAT THE TEMPERATURE OF THE FILE 3 CROSS SECTIONS HAS ALREADY
C     BEEN DEFINE FROM FILE 1 (TEMP3).
C
c-----------------------------------------------------------------------
C-----FOR PHOTON DATA OMIT TEMPERATURE AND Q FROM OUTPUT REPORT
      IF(MFH.EQ.3) GO TO 10
      IF(MFH.EQ.5.OR.MFH.EQ.6) GO TO 50
      WRITE(OUTP,130) ZABCD,MATH,MFH,MTH,FMTHOL,N2IN,N2TOT
      WRITE(*   ,130) ZABCD,MATH,MFH,MTH,FMTHOL,N2IN,N2TOT
      GO TO 70
c-----------------------------------------------------------------------
C
C     MF = 3
C
c-----------------------------------------------------------------------
C-----TEST FOR ENDF/B-VI FORMAT.
   10 IF(IVERSE.LT.6) GO TO 20
C-----ENDF/B-VI FORMAT. USE TEMPERATURE FROM FILE 1.
      TEMP=TEMP3
      GO TO 40
C-----NOT ENDF/B-VI. USE C1 FIELD OR TEMPERATURE FROM TOTAL CROSS
C-----SECTION.
   20 IF(L2.LE.0)  GO TO 30
      TEMP=TEMP3
      GO TO 40
   30 TEMP=C1
      IF(MTH.EQ.1) TEMP3=TEMP
   40 CALL OUT9(TEMP,FIELD(1,1))
      CALL OUT9(Q   ,FIELD(1,2))
      GO TO 60
c-----------------------------------------------------------------------
C
C     MF = 5 OR 6
C
c-----------------------------------------------------------------------
   50 CALL OUT9(Q   ,FIELD(1,1))
      DO M=1,11
      FIELD(M,2) = ' '
      ENDDO
   60 WRITE(OUTP,120) ZABCD,MATH,MFH,MTH,FMTHOL,
     1 ((FIELD(M,L),M=1,11),L=1,2),N2IN,N2TOT
      WRITE(*   ,120) ZABCD,MATH,MFH,MTH,FMTHOL,
     1 ((FIELD(M,L),M=1,11),L=1,2),N2IN,N2TOT
C-----INCREMENT TOTAL POINTS READ AND WRITTEN.
   70 MATIN=MATIN+N2IN
      MATOUT=MATOUT+N2TOT
c-----------------------------------------------------------------------
C
C     OUTPUT DATA EITHER DIRECTLY FROM CORE OR FROM SCRATCH TWO PAGES
C     AT A TIME.
C
c-----------------------------------------------------------------------
C-----INITIALIZE NEGATIVE CROSS SECTION FLAG OFF.
      MINUS3=0
      IMPLUS=0
C-----IS DATA CORE RESIDENT OR ON SCRATCH.
      IF(N2SCR.GT.0) GO TO 80
C-----CORE RESIDENT. OUTPUT ALL OF IT.
      CALL POINTO(XOUT,YOUT,N2TOT)
c-----Save MAT/MF/MT and max. energy
      CALL MAXIE1(MATH,MFH,MTH)
      CALL MAXIE2(XOUT(N2TOT),YOUT(N2TOT))
      GO TO 110
C-----ON SCRATCH. SET UP LOOP TO COPY FROM SCRATCH TO CORE TO OUTPUT
C-----FILE TWO PAGES AT A TIME.
   80 ITHINX=NPAGE2
      LOOP=1
C-----POSITION UP TO TWO PAGES OF DATA IN CORE.
   90 READ(ISCR) XPAGE1,YPAGE1
      IF(N2SCR.LE.NPAGE) GO TO 100
      READ(ISCR) XPAGE2,YPAGE2
C-----DEFINE NUMBER OF POINTS IN CORE AND REMAINING ON SCRATCH.
  100 IF(ITHINX.GT.N2SCR) ITHINX=N2SCR
      N2SCR=N2SCR-NPAGE2
C-----OUTPUT POINTS.
      CALL POINTO(XOUT,YOUT,ITHINX)
      LOOP=LOOP+NPAGE2
      IF(LOOP.LE.N2TOT) GO TO 90
c-----Save MAT/MF/MT and max. energy
      CALL MAXIE1(MATH,MFH,MTH)
      CALL MAXIE2(XOUT(ITHINX),YOUT(ITHINX))
C-----2014/11/09 - Corrected for MF=15
C-----ADD SEND LINE - NOT FOR MF = 5, 6, 9, 10 OR 15.
  110 IF(MFH.NE. 5.AND.MFH.NE. 6.AND.
     1   MFH.NE. 9.AND.MFH.NE.10.AND.
     2   MFH.NE.15                   ) CALL OUTS(MATH,MFH)
C-----IF ANY OUTPUT CROSS SECTIONS ARE NEGATIVE PRINT WARNING MESSAGE.
      IF(MINUS3.GT.0) WRITE(OUTP,140) MINUS3
      IF(MINUS3.GT.0) WRITE(*   ,140) MINUS3
C-----PRINT WARNING IF CROSS SECTION IS NOT POSITIVE AT ANY ENERGY.
      IF(IMPLUS.LE.0) WRITE(OUTP,150)
      IF(IMPLUS.LE.0) WRITE(*   ,150)
      RETURN
  120 FORMAT(2X,12A1,I5,I4,I4,3X,A2,3X,2(1X,11A1),2I7)
  130 FORMAT(2X,12A1,I5,I4,I4,3X,A2,3X,24X,2I7)
  140 FORMAT(21X,'WARNING - Above Spectra Negative at',I6,
     1 ' Energies')
  150 FORMAT(21X,'WARNING - Above Spectra NOT',
     1 ' Positive at Any Energy')
      END
      SUBROUTINE READIN
C=======================================================================
C
C     READ AND CHECK ALL INPUT PARAMETERS.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INTEGER*4 OUTP,OTAPE
      CHARACTER*1 FIELD
      CHARACTER*4 MESS1,MESS2
      CHARACTER*72 NAMEIN,NAMEOUT
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/IOSTATUS/ISTAT1,ISTAT2
      COMMON/MATZA/MODGET,NMATZA,MATMIN(101),MFMIN(101),MTMIN(101),
     1 MATMAX(101),MFMAX(101),MTMAX(101)
      COMMON/OKERR3/ERRXC3,KERR3,MAXER3,ENER3(21),ER3(21)
      COMMON/IWATCH/MONITR
      COMMON/PARAMS/XCMIN
      COMMON/SLIM/ISTART,NOTHIN,ITHIN1,ITHIN2,ITHIN3,MTEND
      COMMON/FIELDC/FIELD(11,6)
      COMMON/NAMEX/NAMEIN,NAMEOUT
      COMMON/CON5COM/U5,EFL,EFH,LF5,IMSMOOTH
      DIMENSION MESS1(2),MESS2(2)
C-----DEFINE STANDARD OPTION FOR ALLOWABLE ERROR (CURRENTLY 0.1 PERCENT)
      DATA ERRMIN/1.0D-03/
C-----DEFINE DEFAULT OPTION FOR LOWEST SPECTRA OF INTEREST
C-----(WARNING - THIS IS MUCH LOWER THAN MINIMUM CROSS SECTION)
      DATA XCLOW/1.0D-20/
C-----DEFINE LABELS TO INDICATE RETRIEVAL BY ZA OR MAT.
      DATA MESS1/' MAT','  ZA'/
C-----DEFINE LABELS TO INDICATE WHETHER MONITOR MODE IS OFF OR ON.
      DATA MESS2/' Off','  On'/
C-----INITIALIZE MF = 5 AND 6 SMOOTHING OFF.
      IMSMOOTH = 0
C-----DEFINE MINIMUM ENERGY SPACING FOR 9 DIGIT CALCULATIONS AND OUTPUT.
c-----------------------------------------------------------------------
C
C     READ, TEST AND LIST
C     (1) MAT OR ZA SELECTOR
C     (2) 6/9 DIGIT OUTPUT SELECTOR (NO LONGER AN OPTION. ALWAYS 9)
C     (3) MINIMUM CROSS SECTION OF INTEREST
C     (4) KEEP ORIGINAL POINTS OPTION
C
c-----------------------------------------------------------------------
      IF(ISTAT1.EQ.1) GO TO 20
c-----2017/5/6 - Converted floating point to character
      READ(INP,10,END=20,ERR=20)
     1 MODGET,MONITR,(FIELD(KK,1),KK=1,11),NOTHIN
   10 FORMAT(2I11,11A1,I11)
c-----2017/5/6 - Converted floating point to character
      GO TO 30
C-----DEFINE DEFAULT VALUES
   20 ISTAT1 = 1
      MODGET = 0
      MONITR = 0
      XCMIN  = 0.0d0
      NOTHIN = 1
      GO TO 40
C-----CONVERT MINIMUM CROSS SECTION FROM CHARACTER TO FLOATING POINT.
   30 CALL IN9(XCMIN,FIELD(1,1))
   40 IF(MODGET.LE.0) MODGET=0
      IF(MODGET.GT.0) MODGET=1
      IF(MONITR.LE.0) MONITR=0
      IF(MONITR.GT.0) MONITR=1
      IF(NOTHIN.LE.0) NOTHIN=0
      IF(NOTHIN.GT.0) NOTHIN=1
      WRITE(OUTP,330) MESS1(MODGET+1),MESS2(MONITR+1)
      WRITE(*   ,330) MESS1(MODGET+1),MESS2(MONITR+1)
      IF(XCMIN.LE.0.0) GO TO 50
      CALL OUT9(XCMIN,FIELD(1,1))
      WRITE(OUTP,340) (FIELD(M,1),M=1,11)
      WRITE(*   ,340) (FIELD(M,1),M=1,11)
      GO TO 60
   50 XCMIN=XCLOW
      CALL OUT9(XCMIN,FIELD(1,1))
      WRITE(OUTP,350) (FIELD(M,1),M=1,11)
      WRITE(*   ,350) (FIELD(M,1),M=1,11)
   60 IF(NOTHIN.EQ.0) WRITE(OUTP,360)
      IF(NOTHIN.GT.0) WRITE(OUTP,370)
      IF(NOTHIN.EQ.0) WRITE(*   ,360)
      IF(NOTHIN.GT.0) WRITE(*   ,370)
c-----------------------------------------------------------------------
C
C     READ FILENAMES - IF BLANK USE STANDARD FILENAMES
C
c-----------------------------------------------------------------------
C-----INPUT DATA.
      IF(ISTAT1.EQ.1) GO TO 80
      READ(INP,70,END=80,ERR=80) NAMEIN
   70 FORMAT(A72)
      IF(NAMEIN.EQ.' ') NAMEIN = 'ENDFB.IN'
C-----OUTPUT DATA.
      READ(INP,70,END=90,ERR=90) NAMEOUT
      IF(NAMEOUT.EQ.' ') NAMEOUT = 'ENDFB.OUT'
      GO TO 100
C-----USE DEFAULT FILENAMES
   80 NAMEIN  = 'ENDFB.IN'
   90 NAMEOUT = 'ENDFB.OUT'
      ISTAT1 = 1
C-----PRINT FINAL FILENAMES
  100 WRITE(OUTP,110) NAMEIN,NAMEOUT
      WRITE(*   ,110) NAMEIN,NAMEOUT
  110 FORMAT(2X,78('-')/
     1 '  ENDF/B Input and Output Data Filenames'/2X,A72/
     2 2X,A72)
c-----------------------------------------------------------------------
C
C     OPEN ENDF/B DATA FILES
C
c-----------------------------------------------------------------------
      CALL FILIO2
c-----------------------------------------------------------------------
C
C     TERMINATE IF ERROR OPENING ENDF/B DATA FILE
C
c-----------------------------------------------------------------------
      IF(ISTAT2.EQ.1) THEN
      WRITE(OUTP,120) NAMEIN
      WRITE(   *,120) NAMEIN
  120 FORMAT(//' ERROR - Opening ENDF/B data file'/1X,A72//)
      CALL ENDERROR
      ENDIF
c-----------------------------------------------------------------------
C
C     READ SELECTION RANGES (EITHER MAT OR ZA). IF MINIMUM AND MAXIMUM
C     OF FIRST REQUEST ARE BOTH ZERO SET LIMITS TO RETRIEVE ALL DATA.
C     IF MAXIMUM OF REQUEST IS LESS THAN MINIMUM SET MAXIMUM EQUAL TO
C     MINIMUM (I.E., ONLY RETRIEVE ONE MAT OR ZA FOR THIS REQUEST,
C     NAMELY THAT CORRESPONDING TO THE MAT OR ZA SPECIFIED FOR THE
C     LOWER LIMIT).
C
c-----------------------------------------------------------------------
      IF(MODGET.EQ.0) WRITE(OUTP,380)
      IF(MODGET.EQ.1) WRITE(OUTP,390)
      IF(MODGET.EQ.0) WRITE(*   ,380)
      IF(MODGET.EQ.1) WRITE(*   ,390)
      IF(ISTAT1.EQ.1) GO TO 140
      READ(INP,130,END=140,ERR=140)
     1 MATMIN(1),MFMIN(1),MTMIN(1),MATMAX(1),MFMAX(1),MTMAX(1)
  130 FORMAT(I6,I2,I3,I6,I2,I3)
      GO TO 150
C-----DEFINE DEFAULT VALUES
  140 ISTAT1    = 1
      MATMIN(1) = 0
      MFMIN(1)  = 0
      MTMIN(1)  = 0
      MATMAX(1) = 0
      MFMAX(1)  = 0
      MTMAX(1)  = 0
c-----Check input and define defaults
  150 IF(MATMIN(1).LE.0) MATMIN(1)=0
      IF(MFMIN (1).LE.0) MFMIN (1)=0
      IF(MTMIN (1).LE.0) MTMIN (1)=0
      IF(MATMIN(1).GT.0.OR.MFMIN(1).GT.0.OR.MTMIN(1).GT.0.OR.
     1   MATMAX(1).GT.0.OR.MFMAX(1).GT.0.OR.MTMAX(1).GT.0) GO TO 160
      MATMAX(1)=9999
      MFMAX (1)=99
      MTMAX (1)=999
      MODGET=0
      WRITE(OUTP,410) MATMIN(1),MFMIN(1),MTMIN(1),MATMAX(1),MFMAX(1),
     1 MTMAX(1)
      WRITE(*   ,410) MATMIN(1),MFMIN(1),MTMIN(1),MATMAX(1),MFMAX(1),
     1 MTMAX(1)
      NMATZA=2
      GO TO 190
c-----Check input and define defaults
  160 IF(MATMAX(1).LT.MATMIN(1)) MATMAX(1)=MATMIN(1)
      IF(MATMAX(1).LE.0.AND.MODGET.EQ.0) MATMAX(1)=9999
      IF(MATMAX(1).LE.0.AND.MODGET.NE.0) MATMAX(1)=999999
      IF(MFMAX (1).LE.0) MFMAX(1)=99
      IF(MTMAX (1).LE.0) MTMAX(1)=999
      WRITE(OUTP,400) MATMIN(1),MFMIN(1),MTMIN(1),MATMAX(1),MFMAX(1),
     1 MTMAX(1)
      WRITE(*   ,400) MATMIN(1),MFMIN(1),MTMIN(1),MATMAX(1),MFMAX(1),
     1 MTMAX(1)
      DO 170 NMATZA=2,101
      IF(ISTAT1.EQ.1) GO TO 190
      READ(INP,130,END=180,ERR=180)
     1 MATMIN(NMATZA),MFMIN(NMATZA),MTMIN(NMATZA),
     2 MATMAX(NMATZA),MFMAX(NMATZA),MTMAX(NMATZA)
C-----Check and define defaults
      IF(MATMIN(NMATZA).LE.0.AND.MFMIN (NMATZA).LE.0.AND.
     1    MTMIN(NMATZA).LE.0.AND.MATMAX(NMATZA).LE.0.AND.
     2    MFMAX(NMATZA).LE.0.AND.MTMAX (NMATZA).LE.0) GO TO 190
      IF(MATMIN(NMATZA).LE.0) MATMIN(NMATZA)=0
      IF(MFMIN (NMATZA).LE.0) MFMIN (NMATZA)=0
      IF(MTMIN (NMATZA).LE.0) MTMIN (NMATZA)=0
      IF(MATMAX(NMATZA).LT.MATMIN(NMATZA)) MATMAX(NMATZA)=MATMIN(NMATZA)
      IF(MATMAX(NMATZA).LE.0.AND.MODGET.EQ.0) MATMAX(NMATZA)=9999
      IF(MATMAX(NMATZA).LE.0.AND.MODGET.NE.0) MATMAX(NMATZA)=999999
      IF(MFMAX(NMATZA).LE.0) MFMAX(NMATZA)=99
      IF(MTMAX(NMATZA).LE.0) MTMAX(NMATZA)=999
c-----Print
      WRITE(OUTP,400) MATMIN(NMATZA),MFMIN(NMATZA),MTMIN(NMATZA),
     1 MATMAX(NMATZA),MFMAX(NMATZA),MTMAX(NMATZA)
      WRITE(*   ,400) MATMIN(NMATZA),MFMIN(NMATZA),MTMIN(NMATZA),
     1 MATMAX(NMATZA),MFMAX(NMATZA),MTMAX(NMATZA)
  170 CONTINUE
      GO TO 290
  180 ISTAT1 = 1
  190 NMATZA=NMATZA-1
c-----------------------------------------------------------------------
C
C     READ AND LIST DATA ERROR LAW. ENERGIES MUST BE IN ASCENDING
C     ORDER. IF ENERGY AND ERROR OF FIRST POINT ARE ZERO ASSUME
C     ENERGY INDEPENDENT ERROR LAW USING STANDARD ERROR OPTION
C     (CURRENTLY 0.1 PER-CENT). ENERGIES MUST BE IN ASCENDING ENERGY
C     ORDER. IF ANY ERROR IS NOT POSITIVE USE STANDARD OPTION.
C
c-----------------------------------------------------------------------
      IF(ISTAT1.EQ.1) GO TO 210
c-----2017/5/6 - Converted floating point to character
      READ(INP,200,END=210,ERR=210) ((FIELD(j,k),j=1,11),k=1,2)
  200 FORMAT(22A1)
      CALL IN9(ENER3(1),FIELD(1,1))
      CALL IN9(ER3  (1),FIELD(1,2))
c-----2017/5/6 - Converted floating point to character
      GO TO 220
  210 ISTAT1   = 1
      ENER3(1) = 0.0d0
      ER3(1)   = 0.0d0
  220 CALL OUT9(ENER3(1),FIELD(1,1))
      IF(ER3(1).LE.0.0d0) GO TO 230
      PERCNT=100.0d0*ER3(1)
      CALL OUT9(ER3(1),FIELD(1,2))
      WRITE(OUTP,460) ((FIELD(M,I),M=1,11),I=1,2),PERCNT
      WRITE(*   ,460) ((FIELD(M,I),M=1,11),I=1,2),PERCNT
      GO TO 240
  230 ER3(1)=ERRMIN
      PERCNT=100.0d0*ERRMIN
      CALL OUT9(ER3(1),FIELD(1,2))
      WRITE(OUTP,470) ((FIELD(M,I),M=1,11),I=1,2),PERCNT
      WRITE(*   ,470) ((FIELD(M,I),M=1,11),I=1,2),PERCNT
      IF(ENER3(1).GT.0.0d0) GO TO 240
      MAXER3=2
      GO TO 280
  240 DO 270 MAXER3=2,21
      IF(ISTAT1.EQ.1) GO TO 280
c-----2017/5/6 - Converted floating point to character
      READ(INP,200,END=210,ERR=210) ((FIELD(j,k),j=1,11),k=1,2)
      CALL IN9(ENER3(MAXER3),FIELD(1,1))
      CALL IN9(ER3  (MAXER3),FIELD(1,2))
c-----2017/5/6 - Converted floating point to character
      IF(ENER3(MAXER3).LE.0.0d0.AND.ER3(MAXER3).LE.0.0d0) GO TO 280
      CALL OUT9(ENER3(MAXER3),FIELD(1,1))
      IF(ER3(MAXER3).LE.0.0d0) GO TO 250
      PERCNT=100.0d0*ER3(MAXER3)
      CALL OUT9(ER3(MAXER3),FIELD(1,2))
      WRITE(OUTP,430) ((FIELD(M,I),M=1,11),I=1,2),PERCNT
      WRITE(*   ,430) ((FIELD(M,I),M=1,11),I=1,2),PERCNT
      GO TO 260
  250 ER3(MAXER3)=ERRMIN
      PERCNT=100.0d0*ERRMIN
      CALL OUT9(ER3(MAXER3),FIELD(1,2))
      WRITE(OUTP,440) ((FIELD(M,I),M=1,11),I=1,2),PERCNT
      WRITE(*   ,440) ((FIELD(M,I),M=1,11),I=1,2),PERCNT
  260 IF(ENER3(MAXER3).LT.ENER3(MAXER3-1)) GO TO 320
  270 CONTINUE
      GO TO 300
C-----DEFINE SIZE OF ERROR LAW (MAXER3), TYPE OF ERROR LAW (KERR3=0 -
C-----CONSTANT, =1 - ENERGY DEPENDENT). INITIALIZE ERROR LAW INDICES
C-----AND CONSTANT VALUE.
  280 MAXER3=MAXER3-1
      KERR3=0
      IF(MAXER3.GT.1) KERR3=1
      ERRXC3=ER3(1)
      RETURN
c-----------------------------------------------------------------------
C
C     ERROR MESSAGE SECTION. PRINT ERROR IN INPUT MESSAGE AND TERMINATE.
C
c-----------------------------------------------------------------------
C-----OVER 100 MAT OR ZA RANGES.
  290 WRITE(OUTP,420)
      WRITE(*   ,420)
      CALL ENDERROR
C-----OVER 20 ENTRIES IN ERROR LAW.
  300 WRITE(OUTP,450)
      WRITE(*   ,450)
  310 CALL ENDERROR
C-----ERROR LAW ENERGIES NOT IN ASCENDING ORDER.
  320 WRITE(OUTP,480)
      WRITE(*   ,480)
      GO TO 310
  330 FORMAT(
     1 '  Retrieval Criteria-----------',7X,A4/
     1 '  Monitor Mode-----------------',7X,A4)
  340 FORMAT('  Minimum Spectra--------------',11A1)
  350 FORMAT('  Minimum Spectra--------------',11A1,
     1 ' (Default Option)')
  360 FORMAT('  Keep Evaluated Data Points---         No')
  370 FORMAT('  Keep Evaluated Data Points---        Yes')
  380 FORMAT(2X,78('-')/'  Requested Ranges'/2X,78('-')/
     1 '       Minimum       Maximum   '/
     2 '     MAT MF  MT    MAT MF  MT'/2X,78('-'))
  390 FORMAT(2X,78('-')/'  Requested Ranges'/2X,78('-')/
     1 '       Minimum       Maximum   '/
     2 '      ZA MF  MT     ZA MF  MT'/2X,78('-'))
  400 FORMAT(2X,I6,I3,I4,I7,I3,I4)
  410 FORMAT(2X,I6,I3,I4,I7,I3,I4,' (Default Option)')
  420 FORMAT('  Over 100 Ranges----Execution Terminated')
  430 FORMAT(1X,11A1,1X,11A1,F11.4)
  440 FORMAT(1X,11A1,1X,11A1,F11.4,' (Default Option)')
  450 FORMAT('  Over 20 Ranges----Execution Terminated')
  460 FORMAT(2X,78('-')/'  Allowable Uncertainty'/2X,78('-')/
     1 6X,'Energy',1X,'Uncertainty',3X,'per-cent'/2X,78('-')/
     2 1X,11A1,1X,11A1,F11.4)
  470 FORMAT(2X,78('-')/'  Allowable Uncertainty'/2X,78('-')/
     1 6X,'Energy',1X,'Uncertainty',3X,'per-cent'/2X,78('-')/
     2 1X,11A1,1X,11A1,F11.4,' (Default Option)')
  480 FORMAT('  Energies MUST be in Ascending Order----',
     1 'Execution Terminated')
      END
      SUBROUTINE NEXTMT
C=======================================================================
C
C     FIND NEXT REQUESTED MATERIAL BASED EITHER ON ZA OR MAT.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INTEGER*4 OUTP,OTAPE
      CHARACTER*4 FMTHOL
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/MATZA/MODGET,NMATZA,MATMIN(101),MFMIN(101),MTMIN(101),
     1 MATMAX(101),MFMAX(101),MTMAX(101)
      COMMON/COUNTS/MATNOW,MFNOW,MATIN,MATOUT,N2TOTI,N2TOTO
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/WHATZA/IZA
      COMMON/HOLFMT/FMTHOL
      COMMON/TEMPO/TEMP3,IVERSE
      DIMENSION IZAMIN(101),IZAMAX(101)
      EQUIVALENCE (MATMIN(1),IZAMIN(1)),(MATMAX(1),IZAMAX(1))
C-----READ NEXT LINE AND CHECK FOR END OF ENDF/B TAPE.
   10 CALL CONTI
      IF(MTH.gt.0) go to 20
      IF(MATH.lt.0) go to 90
      go to 10
C-----DEFINE FIXED POINT ZA.
   20 IZA=C1H
C-----COMPARE MAT OR ZA TO SELECTION CRITERIA.
      LOW=0
      IF(MODGET.NE.0) LOW=1
C-----INITIALIZE TO SKIP MAT.
      IWAY=1
      DO 80 IMATZA=1,NMATZA
      IF(MODGET.NE.0) GO TO 30
C-----TEST MAT RANGE.
      IF(MATH.lt.MATMIN(IMATZA)) go to 70
      IF(MATH.eq.MATMIN(IMATZA)) go to 40
      IF(MATH.le.MATMAX(IMATZA)) go to 40
      go to 80
C-----TEST ZA RANGE.
   30 IF(IZA.lt.IZAMIN(IMATZA)) go to 80
      IF(IZA.eq.IZAMIN(IMATZA)) go to 50
      IF(IZA.le.IZAMAX(IMATZA)) go to 50
      go to 80
C-----INDICATE IN REQUESTED MAT RANGE.
   40 LOW=1
C-----MAT OR ZA REQUESTED. RESET TO SKIP MF (ONLY IF NOT ALREADY RESET
C-----TO ONLY SKIP SECTION).
   50 IF(IWAY.LT.2) IWAY=2
C-----TEST MF RANGE.
      IF(MFH.lt.MFMIN(IMATZA)) go to 80
      IF(MFH.eq.MFMIN(IMATZA)) go to 60
      IF(MFH.gt.MFMAX(IMATZA)) go to 80
C-----MAT/MF OR ZA/MF REQUESTED. RESET TO SKIP MT.
   60 IWAY=3
C-----TEST MT RANGE.
      IF(MTH.lt.MTMIN(IMATZA)) go to 80
      IF(MTH.eq.MTMIN(IMATZA)) go to 110
      IF(MTH.le.MTMAX(IMATZA)) go to 110
      go to 80
C-----INDICATE BELOW REQUESTED MAT RANGE. MORE DATA TO READ.
   70 LOW=1
   80 CONTINUE
C-----THIS SECTION HAS NOT BEEN REQUESTED. IF BEYOND RANGE OF ALL MAT
C-----REQUESTS RUN IS COMPLETED. IF NOT SKIP TO NEXT SECTION.
      IF(LOW.LE.0) GO TO 90
C-----SKIP MAT, MF OR MT.
      IF(IWAY.EQ.1) CALL SKIPM
      IF(IWAY.EQ.2) CALL SKIPF
      IF(IWAY.EQ.3) CALL SKIPS
      GO TO 10
c-----------------------------------------------------------------------
C
C     END OF RUN. IF ANY DATA OUTPUT ADD FEND AND MEND.
C
c-----------------------------------------------------------------------
   90 IF(MATNOW.LE.0) GO TO 100
C-----ADD FEND AND MEND LINES
      CALL OUTF(MATNOW)
      CALL OUTM
C-----WRITE POINT TOTAL FOR LAST MAT AND ADD TO TAPE TOTALS.
      IF(MATIN.LE.0.AND.MATOUT.LE.0) GO TO 100
      WRITE(OUTP,140) MATIN,MATOUT
      WRITE(*   ,140) MATIN,MATOUT
c-----Check MT table for MAT
      CALL MAXIE3(1)
C-----PRINT TIME
      CALL TIMEMAT
      N2TOTI=N2TOTI+MATIN
      N2TOTO=N2TOTO+MATOUT
C-----RETURN NEGATIVE MATH AS END OF RUN INDICATOR.
  100 MATH=-1
      MFH=0
      MTH=0
      NOSEQ=0
      MATIN=0
      MATOUT=0
      RETURN
c-----------------------------------------------------------------------
C
C     THIS SECTION REQUESTED. IF NEW MF OR MAT ADD FEND AND MEND LINES
C     AS REQUIRED.
C
c-----------------------------------------------------------------------
  110 IF(MATNOW.LE.0) GO TO 120
      IF(MATNOW.EQ.MATH.AND.MFNOW.EQ.MFH) GO TO 130
C-----ADD FEND LINE.
      CALL OUTF(MATNOW)
      IF(MATNOW.EQ.MATH) GO TO 130
C-----ADD MEND LINE.
      CALL OUTM
C-----WRITE POINT TOTAL FOR LAST MAT AND ADD TO TAPE TOTALS.
      IF(MATIN.LE.0.AND.MATOUT.LE.0) GO TO 120
      WRITE(OUTP,140) MATIN,MATOUT
      WRITE(*   ,140) MATIN,MATOUT
c-----Check MT table for MAT
C-----PRINT TIME
      CALL TIMEMAT
      N2TOTI=N2TOTI+MATIN
      N2TOTO=N2TOTO+MATOUT
c-----------------------------------------------------------------------
C
C     START OF NEW MAT.
C
c-----------------------------------------------------------------------
C-----INITIALIZE SEQUENCE NUMBER AND POINT COUNTS FOR NEW MAT.
  120 NOSEQ=1
      MATIN=0
      MATOUT=0
C-----BLANK OUTPUT ENDF/B FORMAT I.D., INITIALIZE TO ENDF/B-V FORMAT AND
C-----FILE 3 TEMPERATURE TO ZERO.
      FMTHOL='VI  '
      IVERSE=6
      TEMP3=0.0d0
c-----Initialze MT table for new MAT
      CALL MAXIE0
C-----SAVE CURRENT MAT, MF AND MT.
  130 MATNOW=MATH
      MFNOW=MFH
      RETURN
  140 FORMAT(2X,78('-')/48X,' MAT Totals',2I7/2X,78('-'))
      END
      SUBROUTINE ERROK3(E)
C=======================================================================
C
C     DEFINE ALLOWABLE ERROR FOR LINEARIZED CROSS SECTIONS.
C     THE ERROR LAW CAN BE ENERGY INDEPENDENT (CONSTANT) OR ENERGY
C     DEPENDENT (GIVEN BY A LINEARLY INTERPOLABLE TABLE IN ENERGY
C     VS. ERROR).
C
C=======================================================================
      INCLUDE 'implicit.h'
      COMMON/OKERR3/ERRXC3,KERR3,MAXER3,ENER3(21),ER3(21)
C-----INITIALIZE INDEX TO INTERPOLATION TABLE.
      DATA MINER3/2/
C-----ENERGY DEPENDENT. WITHIN ENERGY RANGE OF ERROR LAW USE LINEAR
C-----INTERPOLATION. OUTSIDE RANGE EXTEND ERROR AS CONSTANT FROM
C-----CLOSEST END OF TABLE.
      IF(E.le.ENER3(1)) go to 80
      DO 10 NOWER3=MINER3,MAXER3
      IF(E.lt.ENER3(NOWER3)) go to 20
      IF(E.eq.ENER3(NOWER3)) go to 70
   10 CONTINUE
C-----EXTEND TO HIGHER ENERGIES AS CONSTANT.
      GO TO 90
   20 NM1=NOWER3-1
      IF(E.eq.ENER3(NM1)) go to 60
      IF(E.gt.ENER3(NM1)) go to 50
      DO 30 NOWER3=2,MAXER3
      IF(E.lt.ENER3(NOWER3)) go to 40
      IF(E.eq.ENER3(NOWER3)) go to 70
   30 CONTINUE
      GO TO 90
C-----INTERPOLATE BETWEEN ENERGIES.
   40 NM1=NOWER3-1
   50 MINER3=NOWER3
      ERRXC3=((ENER3(NOWER3)-E)*ER3(NM1)+(E-ENER3(NM1))*ER3(NOWER3))/
     1 (ENER3(NOWER3)-ENER3(NM1))
      RETURN
C-----EXACT ENERGY MATCH.
   60 MINER3=NM1
      IF(MINER3.LE.1) MINER3=2
      ERRXC3=ER3(NM1)
      RETURN
C-----EXACT ENERGY MATCH.
   70 MINER3=NOWER3
      ERRXC3=ER3(NOWER3)
      RETURN
C-----EXTEND TO LOWER ENERGIES AS CONSTANT.
   80 MINER3=2
      ERRXC3=ER3(1)
      RETURN
C-----EXTEND TO HIGHER ENERGIES AS CONSTANT.
   90 MINER3=MAXER3
      ERRXC3=ER3(MAXER3)
      RETURN
      END
      SUBROUTINE FILEIO
C=======================================================================
C
C     DEFINE ALL I/O UNITS AND OPTIONAL DEFINE FILE NAMES.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INTEGER*4 OUTP,OTAPE
      CHARACTER*72 NAMEIN,NAMEOUT
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/IOSTATUS/ISTAT1,ISTAT2
      COMMON/UNITS/ISCR
      COMMON/NAMEX/NAMEIN,NAMEOUT
C-----DEFINE ALL UNIT NUMBERS.
      INP=2
      OUTP=3
      ITAPE=10
      OTAPE=11
      ISCR=12
C-----DEFINE ALL FILE NAMES.
      OPEN(OUTP,FILE='SPECTRA.LST',STATUS='UNKNOWN')
      CALL SCRATCH1(ISCR,'SPECTRA.001  ')
      OPEN(INP,FILE='SPECTRA.INP',STATUS='OLD',ERR=10)
      ISTAT1 = 0
      RETURN
   10 ISTAT1 = 1
      RETURN
      ENTRY FILIO2
C=======================================================================
C
C     DEFINE ENDF/B DATA FILE NAMES.
C
C=======================================================================
      OPEN(OTAPE,FILE=NAMEOUT,STATUS='UNKNOWN')
      OPEN(ITAPE,FILE=NAMEIN,STATUS='OLD',ERR=20)
      ISTAT2 = 0
      RETURN
   20 ISTAT2 = 1
      RETURN
      END
      SUBROUTINE EGRID50(EGRID,NGRID,ELOW,EHIGH)
C===============================================================
C
C     DEFINE ENERGY GRID OF 100 POINTS PER DECADE
C     ===========================================
C     GRID IS 1.0D-05 EV TO 1 GEV
C     ALLOW UP TO 1401 POINTS.
C
C===============================================================
      INCLUDE 'implicit.h'
      DIMENSION EGRID(*)
C-----LOWER ENERGY LIMITS
      DATA ENRGYMIN/1.0D-05/
C-----INCREMENT FOR 100 PER ENERGY DECADE
      DE=DEXP(DLOG(10.0d0)/100.0d0)
      ENOW=ENRGYMIN
      EGRID(1) = ELOW
      NGRID    = 1
C-----DEFINE GROUPS UP TO MAXIMUM ENERGY
      DO 20 I=1,2000
      IF(ENOW.le.EGRID(1)) go to 10
      NGRID = NGRID + 1
      EGRID(NGRID)=ENOW
      IF(EGRID(NGRID).ge.EHIGH) go to 30
   10 ENOW=ENOW*DE
   20 CONTINUE
C-----DEFINE END OF GROUP AT MAXIMUM ENERGY
   30 EGRID(NGRID)=EHIGH
      RETURN
      END
c-----------------------------------------------------------------------
c
c  This is the math.f package supplied by Bob MacFarlane. The original
c  allowed for single or double precision. This version only allows
c  double precision.
c
c ----------------------------------------------------------------------
c some mathematical routines taken from the slatec library.  the
c purpose of this section is to compute the following:
c
c     E1(x)        the first-order exponential integral
c     GAMI(a,x)    the incomplete gamma function
c
c-----------------------------------------------------------------------
      REAL*8 FUNCTION DE1(x)
C=======================================================================
C
c     compute the exponential integral E1(x).
c     taken from the slatec library fnlib DE1.
C
C=======================================================================
      INCLUDE 'implicit.h'
      DIMENSION ae10cs(50),ae11cs(60),ae12cs(41),e11cs(29),
     &  e12cs(25),ae13cs(50),ae14cs(64)
      data ae10cs(  1) / +.3284394579 6166990878 7384420188 1 d-1      /
      data ae10cs(  2) / -.1669920452 0313628514 7618434338 7 d-1      /
      data ae10cs(  3) / +.2845284724 3613468074 2489985325 2 d-3      /
      data ae10cs(  4) / -.7563944358 5162064894 8786693853 3 d-5      /
      data ae10cs(  5) / +.2798971289 4508591575 0484318087 9 d-6      /
      data ae10cs(  6) / -.1357901828 5345310695 2556392625 5 d-7      /
      data ae10cs(  7) / +.8343596202 0404692558 5610290490 6 d-9      /
      data ae10cs(  8) / -.6370971727 6402484382 7524298853 2 d-10     /
      data ae10cs(  9) / +.6007247608 8118612357 6083156158 4 d-11     /
      data ae10cs( 10) / -.7022876174 6797735907 5062615008 8 d-12     /
      data ae10cs( 11) / +.1018302673 7036876930 9665234688 3 d-12     /
      data ae10cs( 12) / -.1761812903 4308800404 0630996642 2 d-13     /
      data ae10cs( 13) / +.3250828614 2353606942 4403035387 7 d-14     /
      data ae10cs( 14) / -.5071770025 5058186788 2487225904 4 d-15     /
      data ae10cs( 15) / +.1665177387 0432942981 7248608415 6 d-16     /
      data ae10cs( 16) / +.3166753890 7975144006 7700353655 5 d-16     /
      data ae10cs( 17) / -.1588403763 6641415151 3311834353 8 d-16     /
      data ae10cs( 18) / +.4175513256 1380188330 0303461848 4 d-17     /
      data ae10cs( 19) / -.2892347749 7071419067 1071447885 2 d-18     /
      data ae10cs( 20) / -.2800625903 3966081035 0634058966 9 d-18     /
      data ae10cs( 21) / +.1322938639 5392709037 0758002378 1 d-18     /
      data ae10cs( 22) / -.1804447444 1773016272 8388783355 7 d-19     /
      data ae10cs( 23) / -.7905384086 5226160762 9164481760 4 d-20     /
      data ae10cs( 24) / +.4435711366 3695701039 4623583802 7 d-20     /
      data ae10cs( 25) / -.4264103994 9781208688 6530920655 5 d-21     /
      data ae10cs( 26) / -.3920101766 9371175415 5371316204 8 d-21     /
      data ae10cs( 27) / +.1527378051 3439942663 4375232697 1 d-21     /
      data ae10cs( 28) / +.1024849527 0493723393 1030878311 7 d-22     /
      data ae10cs( 29) / -.2134907874 7714335762 6271140588 2 d-22     /
      data ae10cs( 30) / +.3239139475 1600282670 6169470036 6 d-23     /
      data ae10cs( 31) / +.2142183762 2998899547 6264316829 6 d-23     /
      data ae10cs( 32) / -.8234609419 6010184147 0034808231 2 d-24     /
      data ae10cs( 33) / -.1524652829 6458094796 1369440114 0 d-24     /
      data ae10cs( 34) / +.1378208282 4606391346 6848036432 5 d-24     /
      data ae10cs( 35) / +.2131311202 8339478795 2322499925 3 d-26     /
      data ae10cs( 36) / -.2012649651 5264841218 1746676312 7 d-25     /
      data ae10cs( 37) / +.1995535662 2633580161 0631178267 3 d-26     /
      data ae10cs( 38) / +.2798995808 9840034649 4868652031 9 d-26     /
      data ae10cs( 39) / -.5534511845 3896266376 4081927782 3 d-27     /
      data ae10cs( 40) / -.3884995396 1599688616 8254402614 6 d-27     /
      data ae10cs( 41) / +.1121304434 5073593828 5068035467 9 d-27     /
      data ae10cs( 42) / +.5566568152 4237409482 5656383351 4 d-28     /
      data ae10cs( 43) / -.2045482929 8104997004 4853393817 6 d-28     /
      data ae10cs( 44) / -.8453813992 7123362334 1145749367 4 d-29     /
      data ae10cs( 45) / +.3565758433 4312915628 1611111628 7 d-29     /
      data ae10cs( 46) / +.1383653872 1256347055 3994909887 1 d-29     /
      data ae10cs( 47) / -.6062167864 4513724365 8453376477 8 d-30     /
      data ae10cs( 48) / -.2447198043 9893132674 3765511918 9 d-30     /
      data ae10cs( 49) / +.1006850640 9339983480 1154818048 0 d-30     /
      data ae10cs( 50) / +.4623685555 0148690156 6434146167 4 d-31     /
      data ae11cs(  1) / +.2026315064 7078889499 4012365173 81 d+0     /
      data ae11cs(  2) / -.7365514099 1203130439 5368987280 34 d-1     /
      data ae11cs(  3) / +.6390934911 8361915862 7532838400 20 d-2     /
      data ae11cs(  4) / -.6079725270 5247911780 6531533639 99 d-3     /
      data ae11cs(  5) / -.7370649862 0176629330 6814114934 84 d-4     /
      data ae11cs(  6) / +.4873285744 9450183453 4649924880 76 d-4     /
      data ae11cs(  7) / -.2383706484 0448290766 5884894602 35 d-5     /
      data ae11cs(  8) / -.3051861262 8561521027 0273322461 21 d-5     /
      data ae11cs(  9) / +.1705033157 2564559009 6880329929 07 d-6     /
      data ae11cs( 10) / +.2383420452 7487747258 6015981364 03 d-6     /
      data ae11cs( 11) / +.1078177255 6163166562 5968723640 20 d-7     /
      data ae11cs( 12) / -.1795569284 7399102653 6426914465 99 d-7     /
      data ae11cs( 13) / -.4128407234 1950457727 9123946404 36 d-8     /
      data ae11cs( 14) / +.6862214858 8631968618 3468445266 64 d-9     /
      data ae11cs( 15) / +.5313018312 0506356147 6020096759 61 d-9     /
      data ae11cs( 16) / +.7879688026 1490694831 3050228935 15 d-10    /
      data ae11cs( 17) / -.2626176232 9356522290 3416752712 32 d-10    /
      data ae11cs( 18) / -.1548368763 6308261963 1257562941 00 d-10    /
      data ae11cs( 19) / -.2581896237 7261390492 8024051225 91 d-11    /
      data ae11cs( 20) / +.5954287919 1591072658 9035299593 52 d-12    /
      data ae11cs( 21) / +.4645140038 7681525833 7849193214 05 d-12    /
      data ae11cs( 22) / +.1155785502 3255861496 2880062037 31 d-12    /
      data ae11cs( 23) / -.1047523687 0835799012 3175471896 70 d-14    /
      data ae11cs( 24) / -.1189665350 2709004368 1044892609 29 d-13    /
      data ae11cs( 25) / -.4774907749 0261778752 6430193499 50 d-14    /
      data ae11cs( 26) / -.8107764961 5772777976 2497347541 35 d-15    /
      data ae11cs( 27) / +.1343556925 0031554199 3769879981 78 d-15    /
      data ae11cs( 28) / +.1413453002 2913106260 2488738812 87 d-15    /
      data ae11cs( 29) / +.4945159257 3953173115 5206632328 83 d-16    /
      data ae11cs( 30) / +.7988404848 0080665648 8585873993 67 d-17    /
      data ae11cs( 31) / -.1400863218 8089809829 2487119353 93 d-17    /
      data ae11cs( 32) / -.1481424695 8417372107 7228040016 80 d-17    /
      data ae11cs( 33) / -.5582617364 6025601904 0106939371 13 d-18    /
      data ae11cs( 34) / -.1144207454 2191647264 7830725445 98 d-18    /
      data ae11cs( 35) / +.2537182387 9566853500 5240184799 23 d-20    /
      data ae11cs( 36) / +.1320532815 4805359813 2788633890 97 d-19    /
      data ae11cs( 37) / +.6293026108 1586809166 2874267894 85 d-20    /
      data ae11cs( 38) / +.1768827042 4882713734 9992613325 48 d-20    /
      data ae11cs( 39) / +.2326618798 5146045209 6742968874 32 d-21    /
      data ae11cs( 40) / -.6780306081 1125233043 7738318441 13 d-22    /
      data ae11cs( 41) / -.5944087695 9676373802 8741505318 91 d-22    /
      data ae11cs( 42) / -.2361821453 1184415968 5325925034 66 d-22    /
      data ae11cs( 43) / -.6021449972 4601478214 1684787445 76 d-23    /
      data ae11cs( 44) / -.6551790647 4348299071 3704441446 39 d-24    /
      data ae11cs( 45) / +.2938875529 7497724587 0420386993 49 d-24    /
      data ae11cs( 46) / +.2260160620 0642115173 2157287585 10 d-24    /
      data ae11cs( 47) / +.8953436924 5958628745 0912068730 87 d-25    /
      data ae11cs( 48) / +.2401592347 1098457555 7720674577 06 d-25    /
      data ae11cs( 49) / +.3411837688 8907172955 6664230434 13 d-26    /
      data ae11cs( 50) / -.7161707169 4630342052 3550133452 79 d-27    /
      data ae11cs( 51) / -.7562039065 9281725157 9286519807 99 d-27    /
      data ae11cs( 52) / -.3377461215 7467324637 9529207808 00 d-27    /
      data ae11cs( 53) / -.1047932570 3300941711 5264303322 45 d-27    /
      data ae11cs( 54) / -.2165455025 2170342240 8548802013 86 d-28    /
      data ae11cs( 55) / -.7529712574 5288269994 6892984320 00 d-30    /
      data ae11cs( 56) / +.1910317939 2798935768 6380840004 26 d-29    /
      data ae11cs( 57) / +.1149210496 6530338547 7907288337 06 d-29    /
      data ae11cs( 58) / +.4389697058 2661751514 4103591936 00 d-30    /
      data ae11cs( 59) / +.1232088323 9205686471 6471577258 66 d-30    /
      data ae11cs( 60) / +.2222017445 7553175317 5385811626 66 d-31    /
      data ae12cs(  1) / +.6362958979 6747038767 1298878068 03 d+0     /
      data ae12cs(  2) / -.1308116867 5067634385 8126711211 35 d+0     /
      data ae12cs(  3) / -.8436741021 3053930014 4876621297 52 d-2     /
      data ae12cs(  4) / +.2656849153 1006685413 0294280689 06 d-2     /
      data ae12cs(  5) / +.3282272178 1658133778 7921701425 17 d-3     /
      data ae12cs(  6) / -.2378344777 1430248269 5798078510 50 d-4     /
      data ae12cs(  7) / -.1143980430 8100055514 4470767970 47 d-4     /
      data ae12cs(  8) / -.1440594343 3238338455 2397176993 23 d-5     /
      data ae12cs(  9) / +.5241595665 1148829963 7728180616 64 d-8     /
      data ae12cs( 10) / +.3840730640 7844323480 9792030597 16 d-7     /
      data ae12cs( 11) / +.8588024486 0267195879 6605157593 44 d-8     /
      data ae12cs( 12) / +.1021922662 5855003286 3399695539 11 d-8     /
      data ae12cs( 13) / +.2174913232 3289724542 8213398059 92 d-10    /
      data ae12cs( 14) / -.2209023814 2623144809 5235038117 41 d-10    /
      data ae12cs( 15) / -.6345753354 4928753294 3836222088 01 d-11    /
      data ae12cs( 16) / -.1083774656 6857661115 3405397329 19 d-11    /
      data ae12cs( 17) / -.1190982287 2222586730 2622004402 77 d-12    /
      data ae12cs( 18) / -.2843868238 9265590299 5087660086 61 d-14    /
      data ae12cs( 19) / +.2508032702 6686769668 5871954875 46 d-14    /
      data ae12cs( 20) / +.7872964152 8559842431 5977264212 65 d-15    /
      data ae12cs( 21) / +.1547506634 7785217148 4843346373 29 d-15    /
      data ae12cs( 22) / +.2257532283 1665075055 2726081972 90 d-16    /
      data ae12cs( 23) / +.2223335286 7266608760 2813808366 93 d-17    /
      data ae12cs( 24) / +.1696781956 3544153513 4641946623 99 d-19    /
      data ae12cs( 25) / -.5760831625 5947682105 3100873045 33 d-19    /
      data ae12cs( 26) / -.1759123577 4646878055 6253694088 53 d-19    /
      data ae12cs( 27) / -.3628605637 5103174394 7553286826 66 d-20    /
      data ae12cs( 28) / -.5923556979 7328991652 5581434880 00 d-21    /
      data ae12cs( 29) / -.7603038092 6310191114 4291368959 99 d-22    /
      data ae12cs( 30) / -.6254784352 1711763842 6414284799 99 d-23    /
      data ae12cs( 31) / +.2548336075 9307648606 0376064000 00 d-24    /
      data ae12cs( 32) / +.2559861573 1739857020 1688746666 66 d-24    /
      data ae12cs( 33) / +.7137623935 7899318800 2070528000 00 d-25    /
      data ae12cs( 34) / +.1470375993 9567568181 5789568000 00 d-25    /
      data ae12cs( 35) / +.2510552476 5386733555 1986346666 66 d-26    /
      data ae12cs( 36) / +.3588666638 7790890886 5836373333 33 d-27    /
      data ae12cs( 37) / +.3988603515 6771301763 3177599999 99 d-28    /
      data ae12cs( 38) / +.2176367694 7356220478 8053333333 33 d-29    /
      data ae12cs( 39) / -.4614699848 7618942367 6074666666 66 d-30    /
      data ae12cs( 40) / -.2071351787 7481987707 1530666666 66 d-30    /
      data ae12cs( 41) / -.5189037856 3534371596 9706666666 66 d-31    /
      data e11cs(  1) / -.1611346165 5571494025 7206639275 66180 d+2   /
      data e11cs(  2) / +.7794072778 7426802769 2722458917 41497 d+1   /
      data e11cs(  3) / -.1955405818 8631419507 1272838128 14491 d+1   /
      data e11cs(  4) / +.3733729386 6277945611 5171908656 90209 d+0   /
      data e11cs(  5) / -.5692503191 0929019385 2638922200 51166 d-1   /
      data e11cs(  6) / +.7211077769 6600918537 8477248126 35813 d-2   /
      data e11cs(  7) / -.7810490144 9841593997 7151840890 64148 d-3   /
      data e11cs(  8) / +.7388093356 2621681878 9748813661 77858 d-4   /
      data e11cs(  9) / -.6202861875 8082045134 3581336079 09712 d-5   /
      data e11cs( 10) / +.4681600230 3176735524 4058238683 62657 d-6   /
      data e11cs( 11) / -.3209288853 3298649524 0725530272 28719 d-7   /
      data e11cs( 12) / +.2015199748 7404533394 8262622130 19548 d-8   /
      data e11cs( 13) / -.1167368681 6697793105 3562716950 15419 d-9   /
      data e11cs( 14) / +.6276270667 2039943397 7887483796 15573 d-11  /
      data e11cs( 15) / -.3148154167 2275441045 2467818023 93600 d-12  /
      data e11cs( 16) / +.1479904174 4493474210 8944722517 33333 d-13  /
      data e11cs( 17) / -.6545709158 3979673774 2634015880 53333 d-15  /
      data e11cs( 18) / +.2733687222 3137291142 5080127487 99999 d-16  /
      data e11cs( 19) / -.1081352434 9754406876 7217276245 33333 d-17  /
      data e11cs( 20) / +.4062832804 0434303295 3003485866 66666 d-19  /
      data e11cs( 21) / -.1453553935 8960455858 9143722666 66666 d-20  /
      data e11cs( 22) / +.4963274618 1648636830 1984426666 66666 d-22  /
      data e11cs( 23) / -.1620861269 6636044604 8665600000 00000 d-23  /
      data e11cs( 24) / +.5072144803 8607422226 4319999999 99999 d-25  /
      data e11cs( 25) / -.1523581113 3372207813 9733333333 33333 d-26  /
      data e11cs( 26) / +.4400151125 6103618696 5333333333 33333 d-28  /
      data e11cs( 27) / -.1223614194 5416231594 6666666666 66666 d-29  /
      data e11cs( 28) / +.3280921666 1066001066 6666666666 66666 d-31  /
      data e11cs( 29) / -.8493345226 8306432000 0000000000 00000 d-33  /
      data e12cs(  1) / -.3739021479 22027951166 869820482 7 d-1       /
      data e12cs(  2) / +.4272398606 2209577260 4917917652 8 d-1       /
      data e12cs(  3) / -.1303182079 8497005441 5392055219 726 d+0     /
      data e12cs(  4) / +.1441912402 4698890734 1095893982 137 d-1     /
      data e12cs(  5) / -.1346170780 5106802211 6121527983 553 d-2     /
      data e12cs(  6) / +.1073102925 3063779997 6115850970 073 d-3     /
      data e12cs(  7) / -.7429999516 1194364961 0283062223 163 d-5     /
      data e12cs(  8) / +.4537732569 0753713938 6383211511 827 d-6     /
      data e12cs(  9) / -.2476417211 3906013184 6547423802 912 d-7     /
      data e12cs( 10) / +.1220765813 7459095370 0228167846 102 d-8     /
      data e12cs( 11) / -.5485141480 6409239382 1357398028 261 d-10    /
      data e12cs( 12) / +.2263621421 3007879929 3688162377 002 d-11    /
      data e12cs( 13) / -.8635897271 6980097940 4172916282 240 d-13    /
      data e12cs( 14) / +.3062915536 6933299758 1032894881 279 d-14    /
      data e12cs( 15) / -.1014857188 5594414755 7128906734 933 d-15    /
      data e12cs( 16) / +.3154821740 3406987754 6855328426 666 d-17    /
      data e12cs( 17) / -.9236042407 6924095448 4015923200 000 d-19    /
      data e12cs( 18) / +.2555042679 7081400244 0435029333 333 d-20    /
      data e12cs( 19) / -.6699128056 8456684721 7882453333 333 d-22    /
      data e12cs( 20) / +.1669254054 3538731943 1987199999 999 d-23    /
      data e12cs( 21) / -.3962549251 8437964185 6000000000 000 d-25    /
      data e12cs( 22) / +.8981358965 9851133201 0666666666 666 d-27    /
      data e12cs( 23) / -.1947633669 9301643332 2666666666 666 d-28    /
      data e12cs( 24) / +.4048360190 2463003306 6666666666 666 d-30    /
      data e12cs( 25) / -.8079815676 9984512000 0000000000 000 d-32    /
      data ae13cs(  1) / -.6057732466 4060345999 3193827377 47 d+0     /
      data ae13cs(  2) / -.1125352434 8366090030 6497688527 18 d+0     /
      data ae13cs(  3) / +.1343226624 7902779492 4878593294 14 d-1     /
      data ae13cs(  4) / -.1926845187 3811457249 2468389913 03 d-2     /
      data ae13cs(  5) / +.3091183377 2060318335 5867374753 68 d-3     /
      data ae13cs(  6) / -.5356413212 9618418776 3935597951 47 d-4     /
      data ae13cs(  7) / +.9827812880 2474923952 4918827172 37 d-5     /
      data ae13cs(  8) / -.1885368984 9165182826 9028919389 10 d-5     /
      data ae13cs(  9) / +.3749431935 6894735406 9640421905 31 d-6     /
      data ae13cs( 10) / -.7682345587 0552639273 7334656805 56 d-7     /
      data ae13cs( 11) / +.1614327056 7198777552 9563000608 68 d-7     /
      data ae13cs( 12) / -.3466802211 4907354566 3090602260 27 d-8     /
      data ae13cs( 13) / +.7587542091 9036277572 8897470541 14 d-9     /
      data ae13cs( 14) / -.1688643332 9881412573 5145266367 03 d-9     /
      data ae13cs( 15) / +.3814570674 9552265682 8042509272 72 d-10    /
      data ae13cs( 16) / -.8733026632 4446292706 8517182723 34 d-11    /
      data ae13cs( 17) / +.2023672864 5867960961 7943110643 30 d-11    /
      data ae13cs( 18) / -.4741328303 9555834655 2103408201 60 d-12    /
      data ae13cs( 19) / +.1122117204 8389864324 7317999289 20 d-12    /
      data ae13cs( 20) / -.2680422543 4840309912 8268090933 95 d-13    /
      data ae13cs( 21) / +.6457851441 7716530343 5803690672 12 d-14    /
      data ae13cs( 22) / -.1568276050 1666478830 3057028491 94 d-14    /
      data ae13cs( 23) / +.3836786539 9315404861 8215164414 08 d-15    /
      data ae13cs( 24) / -.9451717302 7579130478 8710489325 56 d-16    /
      data ae13cs( 25) / +.2343481228 8949573293 8966664391 33 d-16    /
      data ae13cs( 26) / -.5845866158 0214714576 1231944198 82 d-17    /
      data ae13cs( 27) / +.1466622986 7947778605 8736174191 95 d-17    /
      data ae13cs( 28) / -.3699392347 6444472706 5925382744 74 d-18    /
      data ae13cs( 29) / +.9379015993 6721242136 0142918178 13 d-19    /
      data ae13cs( 30) / -.2389367322 1937873136 3082240873 81 d-19    /
      data ae13cs( 31) / +.6115062462 9497608051 9342238378 66 d-20    /
      data ae13cs( 32) / -.1571858532 7554025507 7198532881 06 d-20    /
      data ae13cs( 33) / +.4057238728 5585397769 5192944913 06 d-21    /
      data ae13cs( 34) / -.1051402655 4738034990 5663671227 73 d-21    /
      data ae13cs( 35) / +.2734966493 0638667785 8060031317 33 d-22    /
      data ae13cs( 36) / -.7140160408 0205796099 3555742719 99 d-23    /
      data ae13cs( 37) / +.1870555243 2235079986 7569242111 99 d-23    /
      data ae13cs( 38) / -.4916746816 6870480520 4780209493 33 d-24    /
      data ae13cs( 39) / +.1296498811 9684031730 9160871253 33 d-24    /
      data ae13cs( 40) / -.3429251568 8362864461 6239404373 33 d-25    /
      data ae13cs( 41) / +.9097224164 3887034329 1048209066 66 d-26    /
      data ae13cs( 42) / -.2420211231 4316856489 9348479999 99 d-26    /
      data ae13cs( 43) / +.6456361293 4639510757 6704750933 33 d-27    /
      data ae13cs( 44) / -.1726913273 5340541122 3159876266 66 d-27    /
      data ae13cs( 45) / +.4630861165 9151500715 1942314666 66 d-28    /
      data ae13cs( 46) / -.1244870363 7214131241 7551701333 33 d-28    /
      data ae13cs( 47) / +.3354457409 0520678532 9070079999 99 d-29    /
      data ae13cs( 48) / -.9059886852 1070774437 5439359999 99 d-30    /
      data ae13cs( 49) / +.2452414705 1474238587 2732160000 00 d-30    /
      data ae13cs( 50) / -.6652817873 3552062817 1079679999 99 d-31    /
      data ae14cs(  1) / -.1892918000 7530168254 9567994282 0 d+0      /
      data ae14cs(  2) / -.8648117855 2598714899 6881705682 4 d-1      /
      data ae14cs(  3) / +.7224101543 7465947470 2151483918 4 d-2      /
      data ae14cs(  4) / -.8097559457 5573861971 5965561018 1 d-3      /
      data ae14cs(  5) / +.1099913443 2661388671 7925115700 2 d-3      /
      data ae14cs(  6) / -.1717332998 9377673714 9535881448 7 d-4      /
      data ae14cs(  7) / +.2985627514 4792833228 2534249500 3 d-5      /
      data ae14cs(  8) / -.5659649145 7719300565 6016726715 5 d-6      /
      data ae14cs(  9) / +.1152680839 7141400192 2658350166 3 d-6      /
      data ae14cs( 10) / -.2495030440 2693382288 4212876506 5 d-7      /
      data ae14cs( 11) / +.5692324201 8337543670 3937036814 0 d-8      /
      data ae14cs( 12) / -.1359957664 8056003384 9003093917 6 d-8      /
      data ae14cs( 13) / +.3384662888 7608845901 8451292585 9 d-9      /
      data ae14cs( 14) / -.8737853904 4746819523 5084931658 0 d-10     /
      data ae14cs( 15) / +.2331588663 2226597186 1261340047 0 d-10     /
      data ae14cs( 16) / -.6411481049 2137859697 5316519632 6 d-11     /
      data ae14cs( 17) / +.1812246980 2048164333 8435948468 2 d-11     /
      data ae14cs( 18) / -.5253831761 5584606888 1940384046 6 d-12     /
      data ae14cs( 19) / +.1559218272 5919256988 5502860982 5 d-12     /
      data ae14cs( 20) / -.4729168297 0803987184 7642936946 6 d-13     /
      data ae14cs( 21) / +.1463761864 3932435020 7619949380 8 d-13     /
      data ae14cs( 22) / -.4617388988 7129241022 3217362360 4 d-14     /
      data ae14cs( 23) / +.1482710348 2893693237 8923966037 1 d-14     /
      data ae14cs( 24) / -.4841672496 2392291469 7316573441 7 d-15     /
      data ae14cs( 25) / +.1606215575 7002904081 1657196618 8 d-15     /
      data ae14cs( 26) / -.5408917538 9571709478 9502378425 2 d-16     /
      data ae14cs( 27) / +.1847470159 3468978813 7023140231 0 d-16     /
      data ae14cs( 28) / -.6395830792 7590944705 0061042505 0 d-17     /
      data ae14cs( 29) / +.2242780721 6997594572 5023327617 0 d-17     /
      data ae14cs( 30) / -.7961369173 9839475527 4455530864 6 d-18     /
      data ae14cs( 31) / +.2859308111 5401974598 0861992927 2 d-18     /
      data ae14cs( 32) / -.1038450244 7011371459 0069713744 6 d-18     /
      data ae14cs( 33) / +.3812040607 0979757808 6684100831 9 d-19     /
      data ae14cs( 34) / -.1413795417 7172007687 1756272369 6 d-19     /
      data ae14cs( 35) / +.5295367865 1827409583 0544259481 5 d-20     /
      data ae14cs( 36) / -.2002264245 0268259021 3721113143 9 d-20     /
      data ae14cs( 37) / +.7640262751 2751960147 3684861091 8 d-21     /
      data ae14cs( 38) / -.2941119006 8687878833 1126352336 2 d-21     /
      data ae14cs( 39) / +.1141823539 0789271930 3769148358 6 d-21     /
      data ae14cs( 40) / -.4469308475 9552984252 4702071848 9 d-22     /
      data ae14cs( 41) / +.1763262410 5717507706 3049140852 0 d-22     /
      data ae14cs( 42) / -.7009968187 9259023563 5151826234 0 d-23     /
      data ae14cs( 43) / +.2807573556 5583789222 8775750751 5 d-23     /
      data ae14cs( 44) / -.1132560944 9810864321 4188889156 2 d-23     /
      data ae14cs( 45) / +.4600574684 3750179461 5676423372 7 d-24     /
      data ae14cs( 46) / -.1881448598 9761334598 6460914810 8 d-24     /
      data ae14cs( 47) / +.7744916111 5077308454 4432847803 7 d-25     /
      data ae14cs( 48) / -.3208512760 5853689267 0270382626 1 d-25     /
      data ae14cs( 49) / +.1337445542 9108397606 1993042138 4 d-25     /
      data ae14cs( 50) / -.5608671881 8022170488 9477173521 0 d-26     /
      data ae14cs( 51) / +.2365839716 5285374837 1006947327 9 d-26     /
      data ae14cs( 52) / -.1003656195 0253053340 6583452685 6 d-26     /
      data ae14cs( 53) / +.4281490878 0941611312 8664255692 7 d-27     /
      data ae14cs( 54) / -.1836345261 8153181996 9132695825 0 d-27     /
      data ae14cs( 55) / +.7917798231 3495400000 9746867814 4 d-28     /
      data ae14cs( 56) / -.3431542358 7422203610 2501577523 1 d-28     /
      data ae14cs( 57) / +.1494705493 8971032374 7506600891 7 d-28     /
      data ae14cs( 58) / -.6542620279 8657054397 3904242005 3 d-29     /
      data ae14cs( 59) / +.2877581395 1991711143 4048735368 5 d-29     /
      data ae14cs( 60) / -.1271557211 7960247110 2798120004 2 d-29     /
      data ae14cs( 61) / +.5644615555 6487225223 8804462250 6 d-30     /
      data ae14cs( 62) / -.2516994994 2840951060 8061683029 3 d-30     /
      data ae14cs( 63) / +.1127259818 9275102063 7036880418 1 d-30     /
      data ae14cs( 64) / -.5069814875 8004608555 6258471936 0 d-31     /
c-----Initialize on first call.
      data IFIRST/1/
      if (IFIRST.ne.0) then
      eta=0.1d0*   D1MACH(3)
      ntae10=INITDS(ae10cs,50,eta)
      ntae11=INITDS(ae11cs,60,eta)
      ntae12=INITDS(ae12cs,41,eta)
      nte11=INITDS(e11cs,29,eta)
      nte12=INITDS(e12cs,25,eta)
      ntae13=INITDS(ae13cs,50,eta)
      ntae14=INITDS(ae14cs,64,eta)
      xmaxt=-DLOG(D1MACH(1))
      xmax=xmaxt-DLOG(xmaxt)
      IFIRST = 0
      endif
c
      if (x.le.(-32.d0)) then
      DE1=DEXP(-x)/x*(1.d0+DCSEVL(64.d0/x+1.d0,ae10cs,ntae10))
      else if (x.le.(-8.d0)) then
      DE1=DEXP(-x)/x*(1.d0+DCSEVL((64.d0/x+5.d0)/3.d0,ae11cs,ntae11))
      else if (x.le.(-4.d0)) then
      DE1=DEXP(-x)/x*(1.d0+DCSEVL(16.d0/x+3.d0,ae12cs,ntae12))
      else if (x.le.(-1.d0)) then
      DE1=-DLOG(-x)+DCSEVL((2.d0*x+5.d0)/3.d0,e11cs,nte11)
      else if (x.le.1.0d0) then
c-----x = 0, return 0
      if (x.eq.0.d0) then
      DE1 = 0.0d0
      return
      endif
      DE1=(-DLOG(DABS(x))-0.6875d0+x)+DCSEVL(x,e12cs,nte12)
      else if (x.le.4.0d0) then
      DE1=DEXP(-x)/x*(1.d0+DCSEVL((8.d0/x-5.d0)/3.d0,ae13cs,ntae13))
      else if (x.le.xmax) then
      DE1=DEXP(-x)/x*(1.d0+DCSEVL(8.d0/x-1.d0,ae14cs,ntae14))
      else
C-----x is so big DE1 underflows
      DE1=0.d0
      endif
      return
      END
      REAL*8 FUNCTION DGAMI(a,x)
C=======================================================================
C
c     evaluate the incomplete gamma function.
c     from the slatec library fnlib DGAMI.
C
C=======================================================================
      INCLUDE 'implicit.h'
c
      if (a.le.0.0d0.or.x.lt.0.0d0) then
      DGAMI = 0.0d0
      return
      endif
c
      DGAMI=0.d0
      if (x.ne.0.0d0) then
      factor=DEXP(DLNGAM(a)+a*DLOG(x))
      DGAMI=factor*DGAMIT(a,x)
      endif
      return
      END
      SUBROUTINE DLGAMS(x,dlgam,sgngam)
C=======================================================================
C
c     compute the logarithm of the absolute value of the gamma function.
c     from the slatec library fnlib DLGAMS.
C
C=======================================================================
      INCLUDE 'implicit.h'
c
      dlgam=DLNGAM(x)
      sgngam=1.0d0
      if (x.gt.0.d0) return
      intx=int(mod(-aint(x),2.0d0)+0.1d0)
      if (intx.eq.0) sgngam=-1.0d0
      return
      END
      REAL*8 FUNCTION DLNGAM(x)
C=======================================================================
C
c     compute the logarithm of the absolute value of the gamma function.
c     from the slatec library fnlib DLNGAM.
C
C=======================================================================
      INCLUDE 'implicit.h'
      data sq2pil / 0.9189385332 0467274178 0329736405 62 d0 /
      data sqpi2l / 0.2257913526 4472743236 3097614947 441 d0 /
      data pi / 3.1415926535 8979323846 2643383279 50 d0 /
c-----Initialize on first call.
      data IFIRST/1/
      if (IFIRST.ne.0) then
      temp=1.d0/DLOG(D1MACH(2))
      xmax=temp*D1MACH(2)
      IFIRST = 0
      endif
c
      y=DABS(x)
      if (y.le.10.d0) then
      DLNGAM=DLOG(DABS(REDGAMMA(x)))
      else
      if (y.gt.xmax) then
      DLNGAM = 0.0d0
      return
      endif
      if (x.gt.0.d0) then
      DLNGAM=sq2pil+(x-0.5d0)*DLOG(x)-x+d9lgmc(y)
      else
      sinpiy=DABS(DSIN(pi*y))
      if (sinpiy.eq.0.d0) then
      DLNGAM = 0.0d0
      return
      endif
      DLNGAM=sqpi2l+(x-0.5d0)*DLOG(y)-x-DLOG(sinpiy)-d9lgmc(y)
      endif
      endif
      return
      END
      REAL*8 FUNCTION DCSEVL(x,cs,n)
C=======================================================================
C
c     evaluate a chebyshev series.
c     from the slatec library fnlib DCSEVL.
C
C     WARNING - local variable onepl NEVER USED?
C
C=======================================================================
      INCLUDE 'implicit.h'
      DIMENSION cs(*)
c
      b1=0.0d0
      b0=0.0d0
      twox=2.0d0*x
      do i=1,n
      b2=b1
      b1=b0
      ni=n+1-i
      b0=twox*b1-b2+cs(ni)
      enddo
      DCSEVL=0.5d0*(b0-b2)
      return
      END
      REAL*8 FUNCTION D9LGIT(a,x,algap1)
C=======================================================================
C
c     subsidiary routine.
c     compute the logarithm of tricomi's incomplete gamma function with
c     perron's continued fraction for large x and a .ge. x.
c     from the slatec library fnlib d9lgit.
C
C=======================================================================
      INCLUDE 'implicit.h'
c-----Initialize on first call.
      data IFIRST/1/
      if (IFIRST.ne.0) then
      eps=0.5d0*D1MACH(3)
      sqeps=DSQRT(D1MACH(4))
      IFIRST = 0
      endif
c
      if (x.le.0.d0.or.a.lt.x) then
      d9lgit = 0.0d0
      return
      endif
      ax=a+x
      a1x=ax+1.0d0
      r=0.0d0
      p=1.0d0
      s=p
      do k=1,1000
      fk=k
      t=(a+fk)*x*(1.d0+r)
      r=t/((ax+fk)*(a1x+fk)-t)
      p=r*p
      s=s+p
      if(DABS(p).lt.eps*s) go to 10
      enddo
   10 hstar=1.0d0-x*s/a1x
      d9lgit=-x-algap1-DLOG(hstar)
      return
      END
      REAL*8 FUNCTION D9LGMC(x)
C=======================================================================
C
c     subsidiary routine.
c     compute the DLOG gamma correction factor so that
c     DLOG(REDGAMMA(x)) = DLOG(DSQRT(2*pi))+(x-5.)*DLOG(x)-x+d9lgmc(x)
c     from the slatec library fnlib d9lgmc.
C
C=======================================================================
      INCLUDE 'implicit.h'
      DIMENSION algmcs(15)
      data algmcs(  1) / +.1666389480 4518632472 0572965082 2 d+0      /
      data algmcs(  2) / -.1384948176 0675638407 3298605913 5 d-4      /
      data algmcs(  3) / +.9810825646 9247294261 5717154748 7 d-8      /
      data algmcs(  4) / -.1809129475 5724941942 6330626671 9 d-10     /
      data algmcs(  5) / +.6221098041 8926052271 2601554341 6 d-13     /
      data algmcs(  6) / -.3399615005 4177219443 0333059966 6 d-15     /
      data algmcs(  7) / +.2683181998 4826987489 5753884666 6 d-17     /
      data algmcs(  8) / -.2868042435 3346432841 4462239999 9 d-19     /
      data algmcs(  9) / +.3962837061 0464348036 7930666666 6 d-21     /
      data algmcs( 10) / -.6831888753 9857668701 1199999999 9 d-23     /
      data algmcs( 11) / +.1429227355 9424981475 7333333333 3 d-24     /
      data algmcs( 12) / -.3547598158 1010705471 9999999999 9 d-26     /
      data algmcs( 13) / +.1025680058 0104709120 0000000000 0 d-27     /
      data algmcs( 14) / -.3401102254 3167487999 9999999999 9 d-29     /
      data algmcs( 15) / +.1276642195 6300629333 3333333333 3 d-30     /
c-----Initialize on first call.
      data IFIRST/1/
      if (IFIRST.ne.0) then
      nalgm=INITDS (algmcs,15,     D1MACH(3) )
      xbig=1.0d0/DSQRT(D1MACH(3))
      xmax=DEXP(DMIN1(DLOG(D1MACH(2)/12.d0),-DLOG(12.d0*D1MACH(1))))
      IFIRST = 0
      endif
c
      if (x.lt.10.d0) then
      d9lgmc = 0.0d0
      return
      endif
      if (x.lt.xmax) then
      d9lgmc=1.d0/(12.d0*x)
      if (x.lt.xbig) d9lgmc=DCSEVL(2.0d0*(10.d0/x)**2-1.d0,algmcs,
     &     nalgm)/x
      else
c-----x so big d9lgmc underflows
      d9lgmc=0.d0
      endif
      return
      END
      REAL*8 FUNCTION DGAMIT(a,x)
C=======================================================================
C
c     calculate tricomi's form of the incomplete gamma function.
c     from the slatec library fnlib DGAMIT.
C
C=======================================================================
      INCLUDE 'implicit.h'
c-----Initialize on first call.
      data IFIRST/1/
      if (IFIRST.ne.0) then
      alneps=-DLOG(D1MACH(3))
      sqeps=DSQRT(D1MACH(4))
      bot=DLOG(D1MACH(1))
      IFIRST = 0
      endif
c
      if (x.lt.0.0d0) then
      DGAMIT = 0.0d0
      return
      endif
c
      if (x.ne.0.0d0) alx=DLOG(x)
      sga=1.0d0
      if (a.ne.0.0d0) sga=DSIGN(1.0d0,a)
      ainta=aint(a+0.5d0*sga)
      aeps=a-ainta
c
      if (x.le.0.0d0) then
      DGAMIT=0.0d0
      if (ainta.gt.0.0d0.or.aeps.ne.0.0d0) DGAMIT=DGAMR(a+1.0d0)
c
      else if (x.le.1.d0) then
      if (a.ge.(-0.5d0).or.aeps.ne.0.d0) then
      call DLGAMS(a+1.0d0,algap1,sgngam)
      endif
      DGAMIT=D9GMIT(a,x,algap1,sgngam)
c***** 2017/5/4 - delete unused argument alx
c     DGAMIT=D9GMIT(a,x,algap1,sgngam,alx)
c***** 2017/5/4 - delete unused argument alx
c
      else if (a.ge.x) then
      t=d9lgit(a,x,DLNGAM(a+1.0d0))
      DGAMIT=DEXP (t)
c
      else
      alng=D9LGIC(a,x,alx)
c        evaluate DGAMIT in terms of DLOG (dgamic (a, x))
      h=1.0d0
      if (aeps.eq.0.d0.and.ainta.le.0.d0) then
      t=-a*alx+DLOG(DABS(h))
      DGAMIT=DSIGN(DEXP(t),h)
      else
      call DLGAMS(a+1.0d0,algap1,sgngam)
      t=DLOG(DABS(a))+alng-algap1
      if (t.gt.alneps) then
      t=t-a*alx
      DGAMIT=-sga*sgngam*DEXP(t)
      else
      if (t.gt.(-alneps)) h=1.0d0-sga*sgngam*DEXP(t)
      t=-a*alx+DLOG(DABS(h))
      DGAMIT=DSIGN(DEXP(t),h)
      endif
      endif
      endif
      return
      END
      SUBROUTINE DGAMLM(xmin,xmax)
C=======================================================================
C
c     compute the minimum and maximum bounds for the argument in
c     the gamma function.
c     from the slatec library fnlib DGAMLM.
C
C=======================================================================
      INCLUDE 'implicit.h'
c
      alnsml=DLOG(D1MACH(1))
      xmin=-alnsml
      do i=1,1000
      xold=xmin
      xln=DLOG(xmin)
      xmin=xmin-xmin*((xmin+0.5d0)*xln-xmin-0.2258d0+alnsml)
     &     /(xmin*xln+0.5d0)
      if(DABS(xmin-xold).lt.0.005d0) go to 10
      enddo
   10 xmin=-xmin+0.01d0
c
      alnbig=DLOG(D1MACH(2))
      xmax=alnbig
      do i=1,1000
      xold=xmax
      xln=DLOG(xmax)
      xmax=xmax-xmax*((xmax-0.5d0)*xln-xmax+0.9189d0-alnbig)
     &     /(xmax*xln-0.5d0)
      if(DABS(xmax-xold).lt.0.005d0) go to 20
      enddo
   20 xmax=xmax-0.01d0
      xmin=DMAX1(xmin,-xmax+1.d0)
      return
      END
      REAL*8 FUNCTION REDGAMMA(x)
C=======================================================================
C
c     compute the complete gamma function.
c     from the slatec library fnlib REDGAMMA.
C
C=======================================================================
      INCLUDE 'implicit.h'
      DIMENSION gamcs(42)
      data gamcs(  1) / +.8571195590 9893314219 2006239994 2 d-2      /
      data gamcs(  2) / +.4415381324 8410067571 9131577165 2 d-2      /
      data gamcs(  3) / +.5685043681 5993633786 3266458878 9 d-1      /
      data gamcs(  4) / -.4219835396 4185605010 1250018662 4 d-2      /
      data gamcs(  5) / +.1326808181 2124602205 8400679635 2 d-2      /
      data gamcs(  6) / -.1893024529 7988804325 2394702388 6 d-3      /
      data gamcs(  7) / +.3606925327 4412452565 7808221722 5 d-4      /
      data gamcs(  8) / -.6056761904 4608642184 8554829036 5 d-5      /
      data gamcs(  9) / +.1055829546 3022833447 3182350909 3 d-5      /
      data gamcs( 10) / -.1811967365 5423840482 9185589116 6 d-6      /
      data gamcs( 11) / +.3117724964 7153222777 9025459316 9 d-7      /
      data gamcs( 12) / -.5354219639 0196871408 7408102434 7 d-8      /
      data gamcs( 13) / +.9193275519 8595889468 8778682594 0 d-9      /
      data gamcs( 14) / -.1577941280 2883397617 6742327395 3 d-9      /
      data gamcs( 15) / +.2707980622 9349545432 6654043308 9 d-10     /
      data gamcs( 16) / -.4646818653 8257301440 8166105893 3 d-11     /
      data gamcs( 17) / +.7973350192 0074196564 6076717535 9 d-12     /
      data gamcs( 18) / -.1368078209 8309160257 9949917230 9 d-12     /
      data gamcs( 19) / +.2347319486 5638006572 3347177168 8 d-13     /
      data gamcs( 20) / -.4027432614 9490669327 6657053469 9 d-14     /
      data gamcs( 21) / +.6910051747 3721009121 3833697525 7 d-15     /
      data gamcs( 22) / -.1185584500 2219929070 5238712619 2 d-15     /
      data gamcs( 23) / +.2034148542 4963739552 0102605193 2 d-16     /
      data gamcs( 24) / -.3490054341 7174058492 7401294910 8 d-17     /
      data gamcs( 25) / +.5987993856 4853055671 3505106602 6 d-18     /
      data gamcs( 26) / -.1027378057 8722280744 9006977843 1 d-18     /
      data gamcs( 27) / +.1762702816 0605298249 4275966074 8 d-19     /
      data gamcs( 28) / -.3024320653 7353062609 5877211204 2 d-20     /
      data gamcs( 29) / +.5188914660 2183978397 1783355050 6 d-21     /
      data gamcs( 30) / -.8902770842 4565766924 4925160106 6 d-22     /
      data gamcs( 31) / +.1527474068 4933426022 7459689130 6 d-22     /
      data gamcs( 32) / -.2620731256 1873629002 5732833279 9 d-23     /
      data gamcs( 33) / +.4496464047 8305386703 3104657066 6 d-24     /
      data gamcs( 34) / -.7714712731 3368779117 0390152533 3 d-25     /
      data gamcs( 35) / +.1323635453 1260440364 8657271466 6 d-25     /
      data gamcs( 36) / -.2270999412 9429288167 0231381333 3 d-26     /
      data gamcs( 37) / +.3896418998 0039914493 2081663999 9 d-27     /
      data gamcs( 38) / -.6685198115 1259533277 9212799999 9 d-28     /
      data gamcs( 39) / +.1146998663 1400243843 4761386666 6 d-28     /
      data gamcs( 40) / -.1967938586 3451346772 9510399999 9 d-29     /
      data gamcs( 41) / +.3376448816 5853380903 3489066666 6 d-30     /
      data gamcs( 42) / -.5793070335 7821357846 2549333333 3 d-31     /
      data pi / 3.1415926535 8979323846 2643383279 50 d0 /
      data sq2pil / 0.9189385332 0467274178 0329736405 62 d0 /
c-----Initialize on first call.
      data IFIRST/1/
      if (IFIRST.ne.0) then
      ngam=INITDS(gamcs,42,0.1d0*   D1MACH(3) )
      call DGAMLM(xmin,xmax)
      IFIRST = 0
      endif
c
      y=DABS(x)
      if (y.le.10.d0) then
c
c        compute gamma(x) for -xbnd .le. x .le. xbnd.  reduce interval
c        and find gamma(1+y) for 0.0 .le. y .lt. 1.0 first of all.
c
      n=int(x)
      if (x.lt.0.d0) n=n-1
      y=x-n
      n=n-1
      REDGAMMA=0.9375d0+DCSEVL(2.d0*y-1.d0,gamcs,ngam)
c
      if (n.lt.0) then
      n=-n
      if (x.eq.0.d0) then
      REDGAMMA = 0.0d0
      return
      endif
      if (x.lt.0.0d0.and.x+n-2.eq.0.d0) then
      REDGAMMA = 0.0d0
      return
      endif
      do i=1,n
      REDGAMMA=REDGAMMA/(x+i-1)
      enddo
      else if (n.gt.0) then
      do i=1,n
      REDGAMMA=(y+i)*REDGAMMA
      enddo
      endif
c
      else
c
c        gamma(x) for DABS(x) .gt. 10.0.  recall y = DABS(x).
c
      if (x.ge.xmin) then
      REDGAMMA=DEXP((y-0.5d0)*DLOG(y)-y+sq2pil+d9lgmc(y))
      if (x.le.0.d0) then
      sinpiy=DSIN(pi*y)
      REDGAMMA=-pi/(y*sinpiy*REDGAMMA)
      endif
      endif
      endif
c
      return
      END
      REAL*8 FUNCTION DGAMR(x)
C=======================================================================
C
c     compute the reciprocal of the gamma function.
c     from the slatec library fnlib DGAMR.
C
C=======================================================================
      INCLUDE 'implicit.h'
c
      DGAMR=0.0d0
      if (x.le.0.0d0.and.aint(x).eq.x) return
      if (DABS(x).le.10.0d0) then
      DGAMR=1.0d0/REDGAMMA(x)
      else
      call DLGAMS(x,alngx,sgngx)
      DGAMR=sgngx*DEXP(-alngx)
      endif
      return
      END
      INTEGER*4 FUNCTION INITDS(os,nos,eta)
C=======================================================================
C
c     determine the number of terms needed in an orthogonal
c     polynomial series so that it meets a specified accuracy.
c     from the slatec library fnlib INITDS.
C
C=======================================================================
      INCLUDE 'implicit.h'
      DIMENSION os(*)
c
      err=0.
      do i=nos,1,-1
      err=err+DABS(     os(i) )
      if(err.gt.eta) go to 10
      enddo
      i = 1
   10 INITDS=i
      return
      END
      REAL*8 FUNCTION D9GMIT(a,x,algap1,sgngam)
c***** 2017/5/4 - delete unused argument alx
c     REAL*8 FUNCTION D9GMIT(a,x,algap1,sgngam,alx)
c***** 2017/5/4 - delete unused argument alx
C=======================================================================
C
c     subsidiary routine.
c     compute tricomi's incomplete gamma function for small arguments.
c     from the slatec library fnlib D9GMIT.
C
C=======================================================================
      INCLUDE 'implicit.h'
c-----Initialize on first call.
      data IFIRST/1/
      if (IFIRST.ne.0) then
      eps=0.5d0*D1MACH(3)
      bot=DLOG(D1MACH(1))
      IFIRST = 0
      endif
c
      if (x.le.0.d0) then
      D9GMIT = 0.0d0
      return
      endif
c
      ma=int(a+0.5d0)
      if (a.lt.0.d0) ma=int(a-0.5d0)
      aeps=a-ma
c
      ae=a
      if (a.lt.(-0.5d0)) ae=aeps
c
      t=1.d0
      te=ae
      s=t
      do k=1,1000
      fk=k
      te=-x*te/fk
      t=te/(ae+fk)
      s=s+t
      if(DABS(t).lt.eps*DABS(s)) go to 10
      enddo
c
   10 if (a.ge.(-0.5d0)) then
      algs=-algap1+DLOG(s)
      D9GMIT=DEXP(algs)
      else
      algs=-DLNGAM(1.d0+aeps)+DLOG(s)
      s=1.0d0
      m=-ma-1
c
      if (m.le.0) go to 20
      t=1.0d0
      do k=1,m
      t=x*t/(aeps-(m+1-k))
      s=s+t
      if(DABS(t).lt.eps*DABS(s)) go to 20
      enddo
c
   20 D9GMIT=0.0d0
      algs=-ma*DLOG(x)+algs
      if (s.eq.0.d0.or.aeps.eq.0.d0) then
      D9GMIT=DEXP(algs)
      else
      sgng2=sgngam*DSIGN(1.0d0,s)
      alg2=-x-algap1+DLOG(DABS(s))
      if (alg2.gt.bot) D9GMIT=sgng2*DEXP(alg2)
      if (algs.gt.bot) D9GMIT=D9GMIT+DEXP(algs)
      endif
      endif
      return
      END
      REAL*8 FUNCTION D9LGIC(a,x,alx)
C=======================================================================
C
c     subsidiary routine.
c     compute the DLOG complementary incomplete gamma function
c     for large x and for a .le. x.
c     from the slatec library fnlib D9LGIC.
C
C=======================================================================
      INCLUDE 'implicit.h'
      data eps /0.d0/
c
      if (eps.eq.0.d0) eps=0.5d0*D1MACH(3)
      xpa=x+1.0d0-a
      xma=x-1.d0-a
      r=0.d0
      p=1.d0
      s=p
      do k=1,1000
      fk=k
      t=fk*(a-fk)*(1.d0+r)
      r=-t/((xma+2.d0*fk)*(xpa+2.d0*fk)+t)
      p=r*p
      s=s+p
      if(DABS(p).lt.eps*s) go to 10
      enddo
   10 D9LGIC=a*alx-x+DLOG(s/xpa)
      return
      END
      REAL*8 FUNCTION D1MACH(i)
C=======================================================================
C
c     Deleted all but PC values.
c     --------------------------
c     return floating point machine dependent constants.
c     used by slatec library routines.
c
c      D1MACH( 1) = b**(emin-1), the smallest positive magnitude.
c      D1MACH( 2) = b**emax*(1 - b**(-t)), the largest magnitude.
c      D1MACH( 3) = b**(-t), the smallest relative spacing.
c      D1MACH( 4) = b**(1-t), the largest relative spacing.
c      D1MACH( 5) = log10(b)
C
C=======================================================================
      INCLUDE 'implicit.h'
      DIMENSION DMACH(5)
c-----------------------------------------------------------------------
c
c     machine constants for the ibm pc
c     assumes that all arithmetic is done in double precision
c
c-----------------------------------------------------------------------
C-----COPIED FROM SIGMA1 VERSION
      data DMACH(1) / 2.22507385d-100  /
      data DMACH(2) / 1.79769313d+100  /
      data DMACH(3) / 1.11022302d-16   /
      data DMACH(4) / 2.22044605d-16   /
      data DMACH(5) / 0.30103001d+00   /
c
      D1MACH=DMACH(i)
      return
c
      END