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 SIGMA1
C     ==============
C     VERSION 73-1 (MARCH 1973)
C     VERSION 76-1 (FEBRUARY 1976)
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)IMPROVED BASED ON USER COMMENTS.
C     VERSION 81-1 (MARCH 1981)   DOUBLE PRECISION IBM VERSION
C     VERSION 81-2 (AUGUST 1981)  IMPROVED IBM SPEED AND STABILITY
C     VERSION 82-1 (JANUARY 1982) IMPROVED COMPUTER COMPATIBILITY
C     VERSION 83-1 (JANUARY 1983)*MAJOR RE-DESIGN.
C                                *PAGE SIZE INCREASED - 1002 TO 2004.
C                                *ELIMINATED COMPUTER DEPENDENT CODING.
C                                *NEW, MORE COMPATIBLE I/O UNIT NUMBER.
C                                *ADDED STANDARD ALLOWABLE ERROR OPTION
C                                 (CURRENTLY 0.1 PER-CENT).
C                                *UNRESOLVED RESONANCE REGION COPIED.
C                                *1/V EXTENSION OF CROSS SECTIONS
C                                 OUTSIDE OF TABULATED ENERGY RANGE AND
C                                 INTO UNRESOLVED ENERGY RANGE.
C     VERSION 83-2 (OCTOBER 1983)*IMPROVED BASED ON USER COMMENTS.
C     VERSION 84-1 (APRIL 1984)  *IMPROVED NUMERICAL STABILITY.
C                                *PARTIAL EVALUATION TREATMENT.
C     VERSION 85-1 (APRIL 1985)  *ITERATE TO CONVERGENCE (USING THE SAME
C                                 ENERGY GRID FOR HOT CROSS SECTION AS
C                                 COLD CROSS SECTIONS WAS FOUND TO BE
C                                 INACCURATE).
C                                *NEW FASTER HIGH ENERGY BROADENING.
C                                *UPDATED FOR ENDF/B-6  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-2 (AUGUST 1985) *FORTRAN-77/H VERSION
C     VERSION 86-1 (JANUARY 1986)*ENERGY DEPENDENT SCATTERING RADIUS
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)   *UPDATED BASED ON USER COMMENTS
C                                *ADDED FORTRAN SAVE OPTION
C                                *NEW MORE CONSISTENT ENERGY OUTPUT
C                                 ROUTINES
C     VERSION 91-1 (JULY 1991)   *WARNING...INPUT PARAMETER FORMAT
C                                 HAS BEEN CHANGED - SEE BELOW FOR
C                                 DETAILS.
C                                *ADDED CHARGED PARTICLE PROJECTILES
C                                *OUTPUT ENERGY RANGE IS ALWAYS AT
C                                 LEAST AS LARGE AS INPUT ENERGY RANGE.
C                                *NO 1/V EXTENSION OF CROSS SECTIONS
C                                 FROM UNRESOLVED ENERGY RANGE.
C     VERSION 92-1 (JANUARY 1992)*INSURE MINIMUM AND MAXIMUM CROSS
C                                 SECTIONS ARE ALWAYS KEPT (NOT THINNED)
C                                *MT=19 (FIRST CHANCE FISSION) TREATED
C                                 THE SAME AS FISSION.
C                                *VARIABLE MINIMUM CROSS SECTION OF
C                                 INTEREST - TO ALLOW SMALL CROSS
C                                 SECTIONS NEAR THRESHOLDS TO BE
C                                 TREATED PROPERLY.
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 BUG ASSOCIATED WITH
C                                 THRESHOLD REACTIONS.
C                                *UNRESOLVED REGION COPIED WITHOUT
C                                 THINNING (IT SHOULD BE EXACTLY THE
C                                 SAME AT ALL TEMPERATURES).
C                                *NO THINNING OF REACTIONS (MT) THAT
C                                 WERE NOT BROADENED.
C     VERSION 93-1 (APRIL 1993)  *INCREASED PAGE SIZE FROM 2004
C                                 TO 24000 ENERGY PONTS.
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     VERSION 97-1 (APRIL 1997)   *OPTIONALLY SET NEGATIVE CROSS
C                                  SECTIONS = 0 ON INPUT AND
C                                  OUTPUT.
C                                 *INCREASED PAGE SIZE FROM 24000
C                                  TO 60000 ENERGY 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                                 *TREAT LOW ENERGY INITIAL CROSS
C                                  SECTIONS AS LOG-LOG INTERPOLABLE
C                                 *CONSTANT (RATHER THAN 1/V) EXTENSION
C                                  TO HIGHER ENERGY.
C                                 *UPDATED CONSTANTS BASED ON CSEWG
C                                  SUBCOMMITTEE RECOMMENDATIONS
C                                 *GENERAL IMPROVEMENTS BASED ON
C                                  USER FEEDBACK
C     VERSION 99-2 (JUNE 1999)    *EXTENDED RANGE OF INTEGRALS FROM 4
C                                  TO 5 UNITS ON EACH SIDE OF ENERGY
C                                  POINT TO ALLOW FOR LARGER VARIATION
C                                  IN THE LOCAL CROSS SECTION
C                                 *ASSUME ENDF/B-6, NOT 5, IF MISSING
C                                  MF=1, MT-451.
C     VERSION 99-3 (OCTOBER 1999))*IMPROVED ERFC FUNCTION DEFINITION.
C                                  I THANK BOB MACFARLANE (LANL) FOR
C                                  SUPPLYING A MORE ACCURATE ERFC
C                                  FUNCTION.
C     VERS. 2000-1 (FEBRUARY 2000)*CORRECTED LOW ENERGY INTERPOLATION
C                                  FOR NON-POSITIVE CROSS SECTIONS
C                                 *GENERAL IMPROVEMENTS BASED ON
C                                  USER FEEDBACK
C     VERS. 2002-1 (MAY 2002)     *OPTIONAL INPUT PARAMETERS
C     VERS. 2004-1 (JAN. 2004)    *OPTIONALLY IGNORE UNRESOLVED REGION
C                                 *CORRECTED PROBLEM AT THE RESOLVED/
C                                  UNRESOLVED ENERGY BOUNDARY.
C                                 *CORRECTED HIGH ENERGY CONSTANT CROSS
C                                  SECTION EXTENSION.
C                                 *TIGHTER CRITERIA FOR INITIAL ENERGY
C                                  POINT SPACING
C                                 *TEMPERATURE DEPENDENT ENERGY POINT
c                                  SPACING.
C                                 *ADDED NEW REICH-MOORE (LRF=7) TO
C                                  FILE2 TO ALLOW COPY TO FIND ANY
C                                  FOLLOWING UNRESOLVED PARAMETERS
C     VERS. 2005-1 (JUNE 2005)    *CORRECTED ERROR IN EHOT3 EQUIVALENCE
C                                  TO EHOT - THIS ONLY EFFECTS VERY BIG
C                                  OUTPUT FILES.
C     VERS. 2007-1 (JAN. 2007)    *CHECKED AGAINST ALL ENDF/B-6.
C                                 *INCREASED PAGE SIZE FROM 60,000
C                                  TO 360,000 ENERGY POINTS.
C     VERS. 2008-1 (APRIL 2008)   *1/2 INITIAL ENERGY POINT SPACING
C                                 *72 CHARACTER FILE NAMES.
C     VERS. 2010-1 (Apr. 2010)    *ASSUME LOW ENERGY LOG-LOG VARIATION
C                                  UP TO 1/A (eV) FOR ALL BUT TOTAL AND
C                                  ELASTIC.
C                                 *CHANGED DEFAULT UNCERTAINTY TO 0.01%
C                                  FROM 0.1%
C                                 *ALLOW MULTIPLE, ADJACENT UNRESOLVED
C                                  RESONANCE REGIONS = COMBINE INTO ONE
C                                  LARGER ENERGY RANGE TO COPY.
C                                 *DO NOT BROADEN SECTIONS THAT START
C                                  ABOVE 1 MILLION KT - PREVIOUSLY IT
C                                  WAS ASSUMED TOTAL, ELASTIC, CAPTURE
C                                  AND FISSION, AND LARGE SECTIONS (OVER
C                                  10,000 ENERGY POINTS) WOULD BROADEN.
C     VERS. 2012-1 (Aug. 2012)    *CHANGE COPY CRITERIA TO HANDLE NEW
C                                  (N,N') DATA = THRESHOLD MAY BE VERY
C                                  HIGH (OLD CRITERIA) BUT INCLUDES MANY
C                                  TABULATED ENERGY POINTS (NEW ADDED
C                                  CRITERIA).
C                                 *ADDED STOP IF INCIDENT PARTICLE DATA
C                                  CANNOT BE DOPPLER BROADENED, E.G.,
C                                  PHOTON INCIDENT.
C                                 *Added CODENAME
C                                 *32 and 64 bit Compatible
C                                 *Added ERROR stop
C     VERS. 2013-1 (Nov. 2013)    *Added NO broadening above 10 MeV -
C                                  this is to handle newer evaluations
C                                  that extend to higher energies and
C                                  may do "strange" things to stop one
C                                  MT and then include it as part of
C                                  a sum at higher energies, e.g. this
C                                  change will copy ALL points above
C                                  10 MeV, thus avoiding problems near
C                                  transistion energies at 20. 30, etc.
C                                  MeV or higher energies.
C     VERS. 2015-1 (Jan. 2015)    *Replaced ALL 3 way IF Statements.
C                                 *Replaced ALL LOGICAL by INTEGER.
C                                 *Extended OUT9.
C     VERS. 2017-1 (May  2017)    *For MF=2 only use MT=151 = Defines
C                                  Unresolved Resonance Region (URR).
C                                  Ignore - NJOY created MT=152 and 153.
C                                 *Increased page size to 1,2000,000.
C                                 *All floating input parameters changed
C                                  to character input + IN9 conversion.
C                                 *Added NRO = energy dependent scatter
C                                  radius to copying FILE2 parameters
C                                  to define unresolved energy range.
C                                 *Corrected energy dependent scattering
C                                  radius for all resonance types (see,
C                                  the above comments).
C     VERS. 2018-1 (Nov. 2018)    *Added on-line report for ALL ENDERROR
C     VERS. 2019-1 (June 2019)    *Terminate if MF=3 Point Count and
C                                  Interpolation Law do not agree.
C                                 *Terminate if MF=3 Background
C                                  Interpolation is NOT Linear.
C                                 *Terminate if MF/MT=1/451 Input
C                                  temperature exceeds requested
C                                  Temperature - otherwise the output
C                                  by this code to MF=3 would appear
C                                  to be at the WRONG temperature.
C                                 *Additional Interpolation Law Tests
C                                 *Check consistency of Maximum
C                                  Tabulated cross sections for ALL MT
C                                  processed - print WQARNING if NOT
C                                  the same for ALL MTs.
C     VERS. 2020-1 (Dec. 2020)    *Complete Re-write of convergence
C                                 *Replaced INCORE9 by INCORE10.
C                                 *Updated minimum/maximum convergence
C                                  procedure.
C                                 *Added Target Isomer State
C                                 *Check Atomic Weight > 0
C     VERS. 2021-1 (Mar. 2021)    *Updated for FORTRAN 2018
C                                 *Minimum Cross Section is no longer
C                                  an input option - set to 1.0d-30.
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.nedt/HOMEPAGE.NEW
C
C     Acknowledgement 2004
C     --------------------
C     Currently almost all improvements to this code are based upon
C     feedback from code users who report problems. This feedback
C     benefits ALL users of this code, and ALL users are encouraged
C     to report problems.
C
C     Improvements on the 2004 version of this code based on user
C     feedback including,
C     1) Bret Beck  - reported a problem at the resolved/unresolved
C                     energy boundary.
C     2) S. Ganesan - reported a problem for small temperature changes.
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, PARTICULARLY
C     THE COMMENTS CONCERNING MACHINE DEPENDENT CODING.
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 DOPPLER BROADEN NEUTRON INDUCED
C     CROSS SECTIONS. EACH SECTION OF CROSS SECTIONS (FILE 3) IS READ
C     FROM THE ENDF/B FORMAT. THE DATA IS DOPPLER BROADENED, THINNED
C     AND OUTPUT IN THE ENDF/B FORMAT.
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-1, 2, 3, 4, 5, 6 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 CARD IS CORRECT. SEQUENCE
C     NUMBERS (COLUMNS 76-80) ARE IGNORED ON INPUT, BUT WILL BE
C     CORRECTLY OUTPUT ON ALL CARDS. 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     ALL CROSS SECTIONS THAT ARE USED BY THIS PROGRAM MUST BE TABULATED
C     AND LINEARLY INTERPOLABLE IN ENERGY AND CROSS SECTION (ENDF/B
C     INTERPOLATION LAW 2). FILE 3 CROSS SECTIONS MAY BE MADE LINEARLY
C     INTERPOLABLE BY USING PROGRAM LINEAR (UCRL-50400, VOL.17, PART A).
C     FILE 2 RESONANCE PARAMETERS MAY BE USED TO RECONSTRUCT ENERGY
C     DEPENDENT CROSS SECTIONS AND ADD IN FILE 3 BACKGROUND CROSS
C     SECTIONS TO DEFINE LINEARLY INTERPOLABLE CROSS SECTIONS BY USING
C     PROGRAM RECENT (UCRL-50400, VOL. 17, PART C). IF THIS PROGRAM
C     FINDS THAT THE FILE 3 CROSS SECTIONS ARE NOT LINEARLY INTERPOLABLE
C     THIS PROGRAM WILL TERMINATE EXECUTION.
C
C     UNRESOLVED RESONANCE REGION
C     ---------------------------
C     IN THE UNRESOLVED RESONANCE REGION IT IS NOT POSSIBLE TO EXACTLY
C     DEFINE THE ENERGY DEPENDENCE OF THE CROSS SECTIONS. THE AVERAGE
C     WIDTHS AND SPACINGS GIVEN IN ENDF/B ARE ONLY ADEQUATE TO DEFINE
C     AVERAGE VALUES OF THE CROSS SECTIONS. THEREFORE ALL CROSS SECTIONS
C     IN THE ENDF/B FORMAT FOR THE UNRESOLVED REGION ARE REALLY AVERAGE
C     VALUES WHICH CANNOT BE DOPPLER BROADENED USING THE SIGMA1 METHOD
C     (WHICH REQUIRES TABULATED, LINEARLY INTERPOLABLE, ENERGY DEPENDENT
C     CROSS SECTIONS.
C
C     THEREFORE,
C     (1) ALL TABULATED POINTS WITHIN THE UNRESOLVED RESONANCE REGION
C     WILL BE COPIED, WITHOUT MODIFICATION OR BROADENING. ADOPTION OF
C     THIS CONVENTION WILL ALLOW SUBSEQUENT PROGRAMS TO PROPERLY DEFINE
C     SELF-SHIELDED, DOPPLER BROADENED CROSS SECTIONS IN THE UNRESOLVED
C     RESONANCE REGION.
C     (2) CROSS SECTIONS WILL BE EXTENDED AS 1/V ABOVE THE UPPER ENERGY
C     LIMIT OF THE RESOLVED RESONANCE REGION AND BELOW THE LOWER ENERGY
C     LIMIT OF THE CONTINUUUM REGION (I.E. INTO THE UNRESOLVED
C     RESONANCE REGION). THIS CONVENTION WILL GUARANTEE A SMOOTH
C     BEHAVIOR CLOSE TO THE UNRESOLVED RESONANCE REGION BOUNDARIES.
C
C     OUTPUT FORMAT
C     -------------
C     IN THIS VERSION OF SIGMA1 ALL FILE 3 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     JUST DUE TO TRANSLATION OF THE ENERGIES TO THE ENDF/B FORMAT.
C
C     CONTENTS OF OUTPUT
C     ------------------
C     ENTIRE EVALUATIONS ARE OUTPUT, NOT JUST THE BROADENED FILE 3
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 THREE COMMENTS CARDS AT THE END OF EACH
C     HOLLERITH SECTION IN THE FORM
C
C     ***************** PROGRAM SIGMA1 (2021-1) ***************
C     DATA DOPPLER BROADENED TO 300.0   KELVIN AND
C     DATA THINNED TO WITHIN AN ACCURACY OF  0.1 PER-CENT
C
C     THE ORDER OF ALL SIMILAR COMMENTS (FROM LINEAR,RECENT AND GROUPY)
C     REPRESENTS A COMPLETE HISTORY OF ALL OPERATIONS PERFORMED ON
C     THE DATA.
C
C     THESE COMMENT CARDS 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-5 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     SELECTION OF DATA
C     -----------------
C     THE PROGRAM SELECTS MATERIALS TO BE BROADENED BASED EITHER ON
C     MAT (ENDF/B MAT NO.) OR ZA. THE PROGRAM ALLOWS UP TO 100 MAT OR
C     ZA RANGES TO BE SPECIFIED. THE PROGRAM WILL ASSUME THAT THE
C     ENDF/B TAPE IS IN EITHER MAT OR ZA ORDER, WHICHEVER CRITERIA IS
C     USED TO SELECT MATERIALS, AND WILL TERMINATE WHEN A MAT OR ZA
C     IS FOUND THAT IS ABOVE THE RANGE OF ALL REQUESTS.
C
C     ENERGY GRID OF BROADENED DATA
C     -----------------------------
C     THE ENERGY GRID FOR THE DOPPLER BROADENED CROSS SECTIONS IS
C     SELECTED TO INSURE THAT THE BROADENED DATA IS LINEAR-LINEAR
C     INTERPOLABLE. AS SUCH THE ENERGY GRID FOR THE BROADENED DATA
C     MAY NOT BE THE SAME AS THE ENERGY GRID FOR THE ORIGINAL
C     UNBROADENED DATA. GENERALLY AFTER BROADENING THERE WILL BE
C     FEWER DATA POINTS IN THE RESONANCE REGION, BUT AT LOW ENERGY
C     THERE MAY BE MORE POINTS, DUE TO THE 1/V LOW ENERGY EFFECT
C     CREATED BY DOPPLER BROADENING.
C
C     EFFECTIVE TEMERATURE INCREASE
C     -----------------------------
C     IF THE ORIGINAL DATA IS NOT AT ZERO KELVIN THE PROGRAM WILL
C     BROADEN THE DATA BY THE EFFECTIVE TEMPERATURE DIFFENCE TO THE
C     FINAL TEMPERATURE. IF THE DATA IS ALREADY AT A TEMPERATURE THAT
C     IS HIGHER THAN THE FINAL TEMPERATURE DOPPLER BROADENING IS
C     NATURALLY NOT PERFORMED AND THE TEMPERATURE IN THE SECTION IS LEFT
C     AT ITS ORIGINAL VALUE.
C
C     MULTIPLE FINAL TEMPERATURES
C     ---------------------------
C     THE PRESENT VERSION ONLY DOPPLER BROADENS TO ONE FINAL TEMPERATURE
C     (IF THERE IS SUFFICIENT INTEREST EXPRESSED BY USERS FUTURE
C     VERSION MAY BROADEN TO MULTIPLE TEMPERATURES. PLEASE
C     CONTACT THE AUTHOR IF YOU ARE INTERESTED IN A MULTIPLE
C     TEMPERATURE OPTION).
C
C     PROGRAM OPERATION
C     -----------------
C     EACH SECTION OF FILE 3 DATA IS CONSIDERED SEPERATELY. THE DATA
C     IS READ AND DOPPLER BROADENED A PAGE AT A TIME (ONE PAGE IS
C     60000 DATA POINTS). UP TO THREE PAGES OF DATA MAY BE IN THE CORE
C     AT ANY GIVEN TIME, THE PAGE BEING BROADENED, THE PAGE BELOW IT
C     IN ENERGY AND THE PAGE ABOVE IT IN ENERGY. AFTER A PAGE HAS BEEN
C     BROADENED IT IS THINNED, IF THE ENTIRE SECTION CONTAINS ONLY
C     ONE PAGE OR LESS, IT WILL STILL BE CORE RESIDENT AND WILL BE
C     WRITTEN DIRECTLY FROM CORE TO THE OUTPUT TAPE. IF THE BROADENED,
C     THINNED SECTION IS LARGER THAN A PAGE, AFTER A PAGE HAS BEEN
C     BROADENED AND THINNED IT IS WRITTEN TO A SCRATCH FILE. AFTER THE
C     ENTIRE SECTION HAS BEEN BROADENED AND THINNED THE DATA IS READ
C     FROM SCRATCH TO CORE, ONE PAGE AT A TIME, THE OUTPUT TO THE OUTPUT
C     TAPE.
C
C     ALLOWABLE ERROR
C     ---------------
C     AFTER DOPPLER BROADENING THE CROSS SECTION IN THE RESONANCE REGION
C     WILL GENERALLY BE MUCH SMOOTHER THAN THE UNBROADENED DATA AND CAN
C     BE REPRESENTED TO THE SAME ACCURACY BY A SMALLER NUMBER OF ENERGY
C     POINTS. THEREFORE AFTER DOPPLER BROADENING THE DATA CAN BE THINNED
C     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     INPUT FILES
C     -----------
C     UNIT  DESCRIPTION
C     ----  -----------
C        2  INPUT CARDS (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 FOR BROADENED DATA
C           (BINARY - 180000 WORDS/RECORD - DOUBLE PRECISION/
C                      42000 WORDS/RECORD - SINLGE PRECISION)
C
C     OPTIONAL STANDARD FILE NAMES (SEE SUBROUTINE FILEIO)
C     ----------------------------------------------------
C     UNIT  FILE NAME
C     ----  ----------
C       2   SIGMA1.INP
C       3   SIGMA1.LST
C      10   ENDFB.IN
C      11   ENDFB.OUT
C      12   (SCRATCH)
C
C     INPUT CARDS
C     -----------
C     CARD  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 DOPPLER BROADENING OF 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  KELVIN TEMPERATURE
C           34-44  MINIMUM CROSS SECTION OF INTEREST
C                  (DEFAULT VALUE = 1.0E-10 BARNS).
C           45-55  NEGATIVE CROSS SECTION TREATMENT
C                  = 0 - O.K.
C                  = 1 - SET = 0
C           56-66  UNRESOLVED RESONANCE REGION TREATMENT
C                  = 0 - COPY (NO BROADENING)
C                  = 1 - IGNORE (BROADEN)
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-11  LOWER MAT OR ZA LIMIT
C           12-22  UPPER MAT OR ZA LIMIT
C                  UP TO 100 MAT OR ZA RANGES MAY BE SPECIFIED, ONE
C                  RANGE PER CARD. THE LIST OF RANGES IS TERMINATED BY
C                  A BLANK CARD. IF THE UPPER LIMIT IS LESS THAN THE
C                  LOWER LIMIT THE UPPER LIMIT WILL BE SET EQUAL TO THE
C                  LOWER LIMIT. IF THE FIRST REQUEST CARD IS BLANK IT
C                  WILL TERMINATE THE LIST OF REQUESTS AND CAUSE ALL
C                  DATA TO BE RETRIEVED (SEE EXAMPLE INPUT).
C      VARY  1-11  ENERGY FOR ERROR LAW
C           12-22  ERROR FOR ERROR LAW
C                  THE ACCEPTABLE LINEARIZING ERROR CAN BE GIVEN AS AN
C                  ENERGY DEPENDENT FUNCTION SPECIFIED BY UP TO 20
C                  (ENERGY,ERROR) PAIRS AND LINEAR INTERPOLATION
C                  TABULATE POINTS. ENERGIES MUST BE IN ASCENDING ORDER.
C                  THE ERROR LAW IS TERMINATED BY A BLANK CARD. IF THE
C                  FIRST ERROR LAW CARD IS BLANK IT WILL TERMINATE THE
C                  ERROR LAW AND THE ERROR WILL BE TREATED AS ENERGY
C                  INDEPENDENT, EQUAL TO ZERO, WHICH INDICATES THAT THE
C                  BROADENED DATA SHOULD NOT BE THINNED.
C
C     EXAMPLE INPUT NO. 1
C     -------------------
C     BROADEN ALL URANIUM ISOTOPES AND THORIUM-232 TO 300 KELVIN. FROM
C     0 TO 100 EV THIN OUTPUT DATA TO 0.1 PER-CENT ACCURACY. FROM 100 EV
C     TO 1 KEV VARY THE ERROR BETWEEN 0.1 AND 1 PER-CENT. ABOVE 1 KEV
C     USE 1 PER-CENT ACCURACY.
C
C     EXPLICITLY SPECIFY THE STANDARD FILENAMES.
C
C     THE FOLLOWING 11 CARDS ARE REQUIRED
C
C          1          0 3.00000+ 2
C ENDFB.IN
C ENDFB.OUT
C      92000      92999
C      90232               (UPPER LIMIT WILL AUTOMATICALLY BE DEFINED)
C                          (BLANK CARD INDICATES 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                          (BLANK CARD INDICATES END OF ERROR LAW)
C
C     EXAMPLE INPUT NO. 2
C     -------------------
C     BROADEN ALL DATA TO 300 KELVIN AND DO NOT THIN THE BROADEN DATA.
C     ALL OF THE STANDARD OPTION MAY BE INVOKED MERELY BY SPECIFYING
C     THE KELVIN TEMPERATURE ON THE FIRST CARD. ALL OTHER FIELDS MAY
C     BE LEFT BLANK.
C
C     LEAVE THE DEFINITION OF THE FILENAMES BLANK - THE PROGRAM WILL
C     THEN USE STANDARD FILENAMES.
C
C     THE FOLLOWING 5 CARDS ARE REQUIRED
C
C                       3.00000+ 2
C                       (USE STANDARD FILENAME = ENDFB.IN)
C                       (USE STANDARD FILENAME = ENDFB.OUT)
C                       (RETRIEVE ALL DATA, TERMINATE REQUEST LIST)
C                       (0.0 ALLOWABLE ERROR, TERMINATE ERROR LAW)
C
C     EXAMPLE INPUT NO. 3
C     -------------------
C     THE SAME AS ABOVE, ONLY DEFINE THE MINIMUM CROSS SECTION OF
C     INTEREST TO BE 1.0E-30 BARNS (INSTEAD OF THE DEFAULT VALUE OF
C     1.0E-10).
C
C     READ ENDF/B DATA FROM \ENDFB6\RECENT\ZA092238 AND WRITE ENDF/B
C     DATA TO \ENDFB\SIGMA1\ZA092238
C
C     THE FOLLOWING 5 CARDS ARE REQUIRED
C
C                       3.00000+ 2 1.00000-30
C \ENDFB6\RECENT\ZA092238
C \ENDFB6\SIGMA1\ZA092238
C                       (RETRIEVE ALL DATA, TERMINATE REQUEST LIST)
C                       (0.0 ALLOWABLE ERROR, TERMINATE ERROR LAW)
C
C=======================================================================
      INCLUDE 'implicit.h'
C-----08/08/2012 DEFINE CODE NAME
      CHARACTER*8 CODENAME
      COMMON/NAMECODE/CODENAME
      INTEGER*4 OTAPE,OUTP,COLD1,COLD2,COLD1P,COLD2P,HOT1,HOT2,HOT3,
     1 HOT3M1,UNRES1,UNRES2,UREVAL,UREACT
      CHARACTER*1 FIELD6
      CHARACTER*4 CARD
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/IWATCH/MONITR,MAKEPLUS,MYUNRES
      COMMON/COPI/MFIELD(3)
      COMMON/COPC/CARD(17)
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/HOTS/ALPHA,HOTSY1,HOTSY2,TEMPK,TEMPEF,N2TAPI,N2TAPO
      COMMON/MATTOT/MATIN,MATOUT
      COMMON/CONTAC/OVPI,OVPI2,ATOP
      COMMON/EXTEND/DTMAX,MESS
      COMMON/THRESH/ETHRES,EMIN
      COMMON/INDEX/COLD1,COLD2,COLD1P,COLD2P,HOT1,HOT2,HOT3,HOT3M1,N2IN,
     1 N2TOT,N2SCR
      COMMON/PAGER/NPAGE,NPT2,NPT3,NP1P1,NP2P1
      COMMON/RESOLV/EULOW,EUHIGH,UREVAL,UREACT,UNRES1,UNRES2,IL,IH
      COMMON/MAXTEMP/DEMAXC,DEMAXH,DEMAXLOW,DEMAXHI
      COMMON/PARTIN/ATWTP,INPART
      COMMON/OKERRT/ENER3T(21),ER3T(21),KERR3T,MAXERT
      COMMON/ERRCOT/ERXC3T
      COMMON/FIELDC/FIELD6(11,6)
C-----08/20/2013 - added high energy cutoff
      COMMON/HIGHESTE/EHIGHEST,EMILLION
      INCLUDE 'sigma1.h'
C-----------------------------------------------------------------------
C
C     INITIALIZE
C
C-----------------------------------------------------------------------
C-----08/08/2012 DEFINE CODE NAME
      CODENAME = 'SIGMA1  '
C-----DEFINE PI TO DOUBLE PRECISION ACCURACY.
      PI = DACOS(-1.0d0)
C-----08/20/2013 - added high energy cutoff
      EHIGHEST = 10.1d6 ! this is eV (10.1 MeV, just above 10 MeV).
      EMILLION =  1.0d6 ! this is multiple of AE/KT
C-----INITIALIZE TIMER
      CALL TIMER
C-----INITIALIZE ERFC TABLES
      CALL TABERFC
C-----------------------------------------------------------------------
C
C     DEFINE ALL I/O UNITS.
C
C-----------------------------------------------------------------------
      CALL FILEIO
C-----INITIALIZE LAST MAT READ.
      MATNOW=0
C-----DEFINE WHERE TO START HIGH ENERGY APPROXIMATE TREATMENT (NOTE,
C-----HOTSY2 CORRESPONDS TO SQRT(A*E/KT). THEREFORE SETTING HOTSY2 EQUAL
C-----TO 1,000 CORRESPONDS TO STARTING THE HIGH ENERGY APPROXIMATION AT
C-----A*E/KT = 1,000,000, E.G., FOR U-238 DOPPLER BROADENED TO ROOM
C-----TEMPERATURE, A=238, KT=0.0253, A/KT IS APPROXIMATELY 10,000 AND
C-----THE APPROXIMATION STARTS AT ABOUT 100 EV...SAVING A GREAT DEAL OF
C-----TIME WITH ESSENTIALLY NO LOSS OF ACCURACY IN THE RESOLVED
C-----RESONANCE REGION ABOVE 100 EV).
      HOTSY1=8.0d0
      HOTSY2=1000.0d0
C-----DEFINE STARTING LOCATION FOR COLD DATA POINTS (COLD DATA WILL
C-----ALWAYS START AT FIRST LOCATION IN TABLES).
      COLD1=1
C-----DEFINE PAGE SIZE (BY CHANGING DIMENSION, COMMON STATEMENTS
C-----AND THIS NUMBER THE SIZE OF THE CORE TABLES MAY BE CHANGED).
      NPAGE=MAXPAGE
      NPT2=2*NPAGE
      NPT3=3*NPAGE
      NP1P1=NPAGE+1
      NP2P1=NPT2+1
C-----DEFINE MINIMUM ENERGY OF INTEREST (IN EV).
      EMIN=1.0d-05
C-----DEFINE MINIMUM ENERGY OF THRESHOLD (IN EV).
      ETHRES=1.0d0
C-----DEFINE REQUIRED CONSTANTS.
      ATOP=5.0d0
      OVPI=1.0d0/DSQRT(PI)
      OVPI2=2.0d0*OVPI
C-----INITIALIZE MAXIMUM ALLOWABLE TEMPERATURE STEP (TO AVOID
C-----CROSS SECTION EXTENSION).
      DTMAX=0.0d0
C-----INITIALIZE TOTAL NUMBER OF FILE3 POINTS READ AND WRITTEN.
      N2TAPI=0
      N2TAPO=0
C-----------------------------------------------------------------------
C
C     READ ALL INPUT AND CREATE OUTPUT REPORT.
C
C-----------------------------------------------------------------------
C-----LIST TITLE FOR OUTPUT.
      WRITE(OUTP,180)
      WRITE(*   ,180)
C-----READ AND CHECK ALL INPUT PARAMETERS.
      CALL READIN
C-----DEFINE MAXIMUM ALLOWABLE ENERGY SPACING TO APPROXIMATE 1/V.
C-----AT LOW AND HIGH ENERGY.
      DEMAXLOW=ESPACE(ER3T(1))
      DEMAXHI =ESPACE(ER3T(MAXERT))
C-----------------------------------------------------------------------
C
C     POSITION TO BEGINNING OF NEXT REQUESTED SECTION. IF BEGINNING OF
C     EVALUATION (NEW MAT) PRINT SUMMARY OF LAST EVALUATION (IF ANY)
C     AND INITIALIZE COUNTS AND FLAGS FOR NEW EVALUATION.
C
C-----------------------------------------------------------------------
C-----COPY TAPE LABEL TO FROM INPUT TO OUTPUT FILE.
      CALL COPYL
C-----LIST TAPE LABEL.
      WRITE(OUTP,190) CARD,MFIELD(1)
      WRITE(*   ,190) CARD,MFIELD(1)
C-----FIND NEXT REQUESTED MATERIAL.
   10 CALL NXTMAT
      CALL CONTO
C-----CHECK FOR BEGINNING OF NEW MATERIAL.
      IF(MATH.eq.MATNOW) go to 60
      IF(MATNOW.LE.0) GO TO 40
C-----WRITE TOTALS FOR LAST MATERIAL (EITHER WITH OR WITHOUT UNRESOLVED
C-----REGION ENERGY LIMITS).
      IF(UREVAL.LE.0) GO TO 20
      CALL OUT9(EULOW ,FIELD6(1,1))
      CALL OUT9(EUHIGH,FIELD6(1,2))
      WRITE(OUTP,150) ((FIELD6(M,I),M=1,11),I=1,2),MATIN,MATOUT
      WRITE(*   ,150) ((FIELD6(M,I),M=1,11),I=1,2),MATIN,MATOUT
      GO TO 30
   20 WRITE(OUTP,160) MATIN,MATOUT
      WRITE(*   ,160) MATIN,MATOUT
C-----PRINT RUNNING TIME
   30 CALL TIMEMAT
c-----2019/3/9 - MT Consisteny test
      CALL MAXIE3(1)
C-----INCREMENT TOTAL POINT COUNTS FOR TAPE.
      N2TAPI=N2TAPI+MATIN
      N2TAPO=N2TAPO+MATOUT
C-----CHECK FOR END OF RUN.
   40 IF(MATH.le.0) go to 120
C-----SAVE CURRENT MAT NUMBER AND INITIALIZE COUNT OF THE NUMBER OF
C-----FILE 3 POINTS READ AND WRITTEN.
      MATNOW=MATH
      MATIN=0
      MATOUT=0
c-----2019/3/9 - Initialize MT table for NEW MAT
      CALL MAXIE0
C-----INITIALIZE TO NEUTRON AS INCIDENT PARTICLE.
c-----3/22/2012 - INPART = 1000*Z + A = 1 for neutron, 0 for photon
      INPART=1
      CALL WHATIN
C-----INITIALIZE TO NO UNRESOLVED RESONANCE REGION AT THE BEGINNING
C-----OF EACH NEW EVALUATION. SECTION HEAD CARD ALREADY READ AND WRITTEN
      UREVAL=0
      EULOW =-1000.0d0
      EUHIGH=-1000.0d0
      GO TO 60
C-----READ HEAD CARD OF NEXT ENDF/B FILE AND CHECK FOR END OF
C-----MATERIAL.
   50 CALL CONTI
      CALL CONTO
      IF(MATH.le.0) go to 10
C-----------------------------------------------------------------------
C
C     PROCESS FILE 1 (COMMENTS), FILE 2 (RESONANCE PARAMETERS) AND
C     FILE 3 (CROSS SECTIONS).
C
C-----------------------------------------------------------------------
C-----FIND FILE 1, SECTION 451 AND ADD COMMENTS TO INDICATE THAT
C-----THIS MATERIAL HAS BEEN PROCESSED.
   60 IF(MFH.lt.1) go to 50
      IF(MFH.gt.1) go to 70
      IF(MTH.ne.451) go to 90
C-----ADD COMMENTS.
      CALL FILE1
      GO TO 100
C-----FIND FILE 2 AND DEFINE THE ENERGY RANGE OF THE UNRESOLVED
C-----RESONANCE REGION.
   70 IF(MFH.lt.2) go to 100
      IF(MFH.gt.2) go to 80
C-----2016/11/25 - Added to only allow MT=151, resonance parameters
      IF(MTH.ne.151) go to 90
C-----IF REQUESTED, IGNORE UNRESOLVED RESONANCE REGION.
      IF(MYUNRES.NE.0) GO TO 100
      CALL FILE2
      GO TO 100
C-----COPY UP TO FILE 3.
   80 IF(MFH.lt.3) go to 100
      IF(MFH.gt.3) go to 110
c-----2019/3/1 - Save MAT/MF/MT
      CALL MAXIE1(MATH,MFH,MTH)
C-----A SECTION OF FILE 3 SECTION FOUND. DOPPLER BROADEN ONE SECTION.
      CALL FILE3
C-----------------------------------------------------------------------
C
C     COPY TO END OF SECTION, FILE OR MATERIAL.
C
C-----------------------------------------------------------------------
C-----COPY TO SECTION END (SEND) CARD.
   90 CALL COPYS
      GO TO 50
C-----COPY TO NEXT FILE.
  100 CALL COPYF
      GO TO 50
C-----COPY REMAINDER OF MATERIAL.
  110 CALL COPYM
      GO TO 10
C-----------------------------------------------------------------------
C
C     END OF RUN
C
C-----------------------------------------------------------------------
C-----PRINT WARNING MESSAGE IF NO DATA WAS FOUND THAT SATISIFED
C-----REQUESTS.
  120 IF(MATNOW.GT.0) GO TO 130
      WRITE(OUTP,210)
      WRITE(*   ,210)
      CALL ENDERROR
C-----LIST TOTAL NUMBER OF FILE 3 POINTS READ AND WRITTEN.
  130 WRITE(OUTP,170) N2TAPI,N2TAPO
      WRITE(*   ,170) N2TAPI,N2TAPO
C-----WRITE WARNING MESSAGE IF CROSS SECTION EXTENSION USED.
      IF(DTMAX.LE.0.0d0) GO TO 140
      CALL OUT9(DTMAX,FIELD6(1,1))
      WRITE(OUTP,200) (FIELD6(M,1),M=1,11)
      WRITE(*   ,200) (FIELD6(M,1),M=1,11)
c-----2019/3/9 - MTs consisntcy WARNING?
  140 CALL MAXIE4(1)
C-----END ENDF/B FORMAT OUTPUT FILE.
      CALL ENDIT
      GO TO 140  ! CANNOT GET TO HERE.
  150 FORMAT(1X,79('-')/' Unresolved ',11A1,' to',11A1,
     1 ' eV',6X,'MAT Totals',2I9/1X,79('-'))
  160 FORMAT(1X,79('-')/' No Unresolved Region',25X,'MAT Totals',2I9/
     1 1X,79('-'))
  170 FORMAT(1X,79('-')/45X,'Tape Totals',2I9/1X,79('-'))
  180 FORMAT(' Doppler Broaden ENDF/B Cross Sections (SIGMA1 2021-1)'/
     1 1X,79('-'))
  190 FORMAT(1X,79('-')/' ENDF/B Tape Label'/1X,79('-')/1X,16A4,A2,I4/
     1 1X,79('-')/
     2 ' Projectile',4X,'    MAT  MT ENDF/B',5X,'Kelvin',5X,
     3 'Q-Value   Points   Points'/
     3 '       Material',11X,' Format',9X,'In',10X,'eV','       In',
     3 '      Out'/1X,79('-'))
  200 FORMAT(///' Extension'/1X,9('-')/
     1 ' Cross Section Extension Can be Avoided by'/
     2 ' Thinning Data or Doppler Broadening in Steps'/
     3 ' of Less than',11A1,' Kelvin')
  210 FORMAT(' WARNING - No Data Found that Satisfied Retrieval',
     1 ' Criteria.'/12X,
     2 ' Therefore No Data was Broadened or Written to Output File.'/
     3 1X,79('-'))
      END
      SUBROUTINE WHATIN
C=======================================================================
C
C     DEFINE MASS OF INCIDENT PROJECTILE RELATIVE TO THE MASS OF THE
C     NEUTRON.
C
C=======================================================================
      INCLUDE 'implicit.h'
      CHARACTER*4 FMTHOL,PROHOL,PROTAB
      COMMON/PARTIN/ATWTP,INPART
      COMMON/HOLFMT/FMTHOL,PROHOL
      DIMENSION NPART(6),ATWTN(6),PROTAB(6)
C-----DEFINE ZA AND MASS OF ALLOWABLE PARTICLES.
      DATA NPART/
     1     1, 1001, 1002, 1003, 2003, 2004/
C-----NEUTRON MASS UPDATED NOV. 12, 1998 AS PER CSEWG SUBCOMMITTEE
C-----RECOMMENDATION (NANCY LARSON)
c-----04/09/20 - Updated according to ENDF-102, Appendix H.
      DATA ATWTN/
     1 1.00866491578d0,     ! Neutron
     2 1.00727646688d0,     ! Proton
     3 2.01355321271d0,     ! Deuteron
     4 3.01604926800d0,     ! Triton
     5 3.01493223469d0,     ! He3
     6 4.00150617470d0/     ! Alpha
      DATA PROTAB/
     1 'n   ','p   ','d   ','t   ','He3 ','He4 '/
C-----LOOK UP ZA OF PROJECTILE.
      DO 10 I=1,6
      IF(INPART.EQ.NPART(I)) GO TO 30
   10 CONTINUE
C-----3/22/2012 - NOT FOUND = ERROR STOP
      WRITE(*,20) INPART
      WRITE(3,20) INPART
   20 FORMAT(///' ERROR...Incident Particle ZA=',I6,
     1 ' CANNOT be Doppler Broadened.'/
     2          '         Correct DATA and RE-TRY.'///)
      CALL ENDERROR
C-----FOUND. DEFINE MASS RELATIVE TO NEUTRON (ENDF Definition)
   30 ATWTP=ATWTN(I)/ATWTN(1)
      PROHOL=PROTAB(I)
      RETURN
      END
      SUBROUTINE FILE1
C=======================================================================
C
C     ADD COMMENTS AT THE END OF FILE1, SECTION 451 TO INDICATE
C     THAT THIS MATERIAL HAS BEEN PROCESSED BY PROGRAM SIGMA1 AND
C     TO SPECIFY THE TEMPERATURE AND MAXIMUM ALLOWABLE ERROR.
C
C     DEFINE FORMAT TO BE ENDF/B-4, 5 or 6.
C
C     THE ENDF/B FORMAT CAN BE DETERMINED FROM THE SECOND CARD.
C     ENDF/B-4  = N1 > 0, N2 = 0, CARD COUNT (POSITIVE)
C     ENDF/B-5  = N1 = N2 = 0
C     ENDF/B-6  =      N2 = NUMBER NUMBER (6 OR MORE)
C
C     First line has already been read.
C
C=======================================================================
      INCLUDE 'implicit.h'
      CHARACTER*1 PROGDOC1,FIELD6
      CHARACTER*4 FMTTAB,FMTHOL,PROHOL
      CHARACTER*66 PROGDOC
      COMMON/LEADER/C1,C2,L1,L2,N1,N2,MAT,MF,MT
      COMMON/OKERRT/ENER3T(21),ER3T(21),KERR3T,MAXERT
      COMMON/ERRCOT/ERXC3T
      COMMON/HOTS/ALPHA,HOTSY1,HOTSY2,TEMPK,TEMPEF,N2TAPI,N2TAPO
      COMMON/HOLFMT/FMTHOL,PROHOL
      COMMON/TEMPO/TEMP3,IVERSE
      COMMON/PARTIN/ATWTP,INPART
      COMMON/ERRCOM/ERRXC3,ERMINMAX,ERMT2,ERMT102,ERSOFT,XCLOW
      COMMON/FIELDC/FIELD6(11,6)
      COMMON/LISOCOM/LISO
      DIMENSION FMTTAB(3),PROGDOC(9),PROGDOC1(66,9)
      EQUIVALENCE (PROGDOC(1),PROGDOC1(1,1))
      DATA FMTTAB/'4   ','5   ','6   '/
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 SIGMA1 (VERSION 2021-1) ***********',
     2 ' Data Doppler Broadened to12345678901 Kelvin                  ',
     3 ' for All Data Greater than12345678901 barns in Absolute Value ',
     4 ' Data Linearized to Within an Accuracy of12345678901 per-cent ',
     5 ' Data Linearized Using Energy Dependent Uncertainty           ',
     6 '      Energy    Accuracy                                      ',
     7 '        (eV)  (per-cent)                                      ',
     8 ' ----------- -----------                                      ',
     9 ' 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 CARD OF SECTION HAS BEEN READ AND WRITTEN. READ NEXT CARD
C-----AND DETERMINE IF THIS IS THE ENDF/B-4, 5 or 6 FORMAT.
      CALL CARDI(C1,C2,L1,L2,N1,N2)
      IVERSE=4
      LISOX= L2           ! Save potental target isomer number
C-----CHECK FOR ENDF/B-4
C-----4: N1 > 0, N2 = 0
      IF(N1.GT.0.AND.N2.EQ.0) GO TO 20
C-----NOT ENDF/B-4. READ THIRD CARD.
      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-5 FORMAT.
      IF(N2X.LE.0) GO TO 20
      N1X=N1
C-----ENDF/B-6 FORMAT. READ FOURTH CARD.
      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 INCIDENT PARTICLE AND MASS RELATIVE TO NEUTRON.
      INPART=N1X/10
c---- 3/22/2012 = 0 = WRONG - that mean photon - use = 1 = neutron
      IF(INPART.LE.0) INPART=0  ! Default to Photon
      CALL WHATIN
C-----DEFINE INITIAL TEMPERATURE FROM C1 FIELD.
      TEMP3=C1
c-----------------------------------------------------------------------
c
c     IF FINAL TEMPERATURE IS HIGHER THAN INITIAL TEMPERATURE DEFINE
C     FINAL TEMPERATURE - OTHERWISE CONSIDER THIS AN ERROR AND
c     TERMINATE.
c
c-----------------------------------------------------------------------
      IF(TEMPK.ge.C1) then
      C1=TEMPK                     ! Output Temperaure
      else
      CALL OUT9(TEMP3,FIELD6(1,1)) ! Input ERROR
      CALL OUT9(TEMPK,FIELD6(1,2))
      write(3,10) ((FIELD6(K9,K8),K9=1,11),K8=1,2)
      write(*,10) ((FIELD6(K9,K8),K9=1,11),K8=1,2)
   10 FORMAT(1x,9('ERROR==='),'ERROR=='/
     1 ' Input temperature from MF/MT=1/451......',11A1,' Kelvin'/
     2 ' Exceeds Requested Output Temperarure....',11A1,' Kelvin'/
     3 ' PLEASE correct data and re-run this code.'/
     4 1x,79('=')/' EXECUTION TERMINATED')
      CALL ENDERROR
      endif
C-----SET DERIVED MATERIAL FLAG IF OUTPUT IS FOR POSITIVE TEMPERATURE.
      IF(C1.GT.0.0d0) L1=1
C-----DEFINE ENDF/B FORMAT NUMBER.
   20 FMTHOL=FMTTAB(IVERSE-3)
C-----INCREASE COMMENT CARD COUNT AND COPY TO END OF HOLLERITH.
      IF(MAXERT.LE.1) N1OUT=N1+4
      IF(MAXERT.GT.1) N1OUT=N1+7+MAXERT
      CALL CARDO(C1,C2,L1,L2,N1OUT,N2)
      DO 30 N=1,N1
      CALL COPY1
   30 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 FINAL TEMPERATURE IN KELVIN
      CALL OUT9(TEMPK,PROGDOC1(27,2))
      CALL HOLLYO(PROGDOC1(1,2))
C-----OUTPUT MINIMUM CROSS SECTION
      CALL OUT9(XCLOW,PROGDOC1(27,3))
      CALL HOLLYO(PROGDOC1(1,3))
      IF(MAXERT.GT.1) GO TO 40
C-----ENERGY INDEPENDENT UNCERTAINTY
      PERCNT=100.0d0*ER3T(1)
      CALL OUT9(PERCNT,PROGDOC1(42,4))
      CALL HOLLYO(PROGDOC1(1,4))
      RETURN
C-----ADD FOUR COMMENT CARDS PLUS ENERGY DEPENDENT UNCERTAINTY
   40 CALL HOLLYO(PROGDOC1(1,5))
      CALL HOLLYO(PROGDOC1(1,6))
      CALL HOLLYO(PROGDOC1(1,7))
      CALL HOLLYO(PROGDOC1(1,8))
      DO 50 I=1,MAXERT
      PERCNT=100.0d0*ER3T(I)
      CALL OUT9(ENER3T(I),PROGDOC1( 2,9))
      CALL OUT9(PERCNT   ,PROGDOC1(14,9))
      CALL HOLLYO(PROGDOC1(1,9))
   50 CONTINUE
      RETURN
      END
      SUBROUTINE FILE2
C=======================================================================
C
C     READ RESONANCE PARAMETERS IN ORDER TO DEFINE THE ENERGY RANGE
C     OF THE UNRESOLVED RESONANCE REGION.
C
C     INSURE THAT UNRESOLVED REGION IS THE SAME FOR ALL ISOTOPES AND
C     SPIN STATES. IF NOT, PRINT WARNING AND USE MINIMUM UNRESOLVED
C     REGION FOR ALL ISOTOPES AND SPIN STATES.
C
C     UNRESOLVED ARGUMENTS
C     --------------------
C     UREVAL = EVALUATION UNRESOLVED RESONANCE REGION INDICATOR.
C            = 0 - EVALUATION DOES NOT HAVE UNRESOLVED REGION.
C            = 1 - EVALUATION DOES HAVE UNRESOLVED REGION.
C     UREACT = REACTION UNRESOLVED RESONANCE REGION INDICATOR.
C            = UREVAL - IF REACTION (MT) IS TOTAL, ELASTIC, CAPTURE
C              OR FISSION.
C            = 0 - OTHERWISE.
C     UNRES1 = INDEX TO LAST DATA POINT BELOW LOWER ENERGY LIMIT OF
C              UNRESOLVED RESONANCE REGION.
C     UNRES2 = INDEX TO FIRST DATA POINT ABOVE UPPER ENERGY LIMIT OF
C              UNRESOLVED RESONANCE REGION.
C     EULOW  = LOWER ENERGY LIMIT OF UNRESOLVED RESONANCE REGION.
C     EUHIGH = UPPER ENERGY LIMIT OF UNRESOLVED RESONANCE REGION.
C     IL     = COUNT OF THE NUMBER OF DATA POINTS AT THE LOWER ENERGY
C              LIMIT OF THE UNRESOLVED RESONANCE REGION (IF NOT AT LEAST
C              TWO PROGRAM WILL INSERT EXTRA POINTS).
C     IH     = COUNT OF THE NUMBER OF DATA POINTS AT THE UPPER ENERGY
C              LIMIT OF THE UNRESOLVED RESONANCE REGION (IF NOT AT LEAST
C              TWO PROGRAM WILL INSERT EXTRA POINTS).
C
C=======================================================================
      INCLUDE 'implicit.h'
      CHARACTER*4 FMTHOL,PROHOL
      INTEGER*4 OUTP,OTAPE,UNRES1,UNRES2,UREVAL,UREACT
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/LEADER/C1,C2,L1,L2,N1,N2,MAT,MF,MT
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/RESOLV/EULOW,EUHIGH,UREVAL,UREACT,UNRES1,UNRES2,IL,IH
      COMMON/WHATZA/IZA
      COMMON/HOLFMT/FMTHOL,PROHOL
C-----INITIALIZE ERROR FLAG OFF.
      IBAD=0
C-----HEAD RECORD ALREADY READ. DEFINE NUMBER OF ISOTOPES.
      NIS=N1H
C-----DO LOOP OVER ALL ISOTOPES
      DO 270 IS=1,NIS
      CALL CARDIO(C1H,C2H,L1H,LFW,NER,N2H)
C-----DO LOOP OVER ALL ENERGY RANGES
      DO 260 JER=1,NER
      CALL CARDIO(EL,EH,LRU,LRF,N1H,N2H)
C-----------------------------------------------------------------------
C
C     2017/5/16 - Added energy dependent scattering radius
C
C-----------------------------------------------------------------------
      NRO = N1H
      if(NRO.eq.1) then
c-----Energy dependent scattering radius = copy TAB1 record
      CALL CARDIO(C1,C2,L1,L2,N1,N2)
      do i = 1,N1,3     ! Interpolation law (NBT,INT) Pairs
      CALL COPY1
      enddo
      do i = 1,N2,3     ! Scattering radius (X,Y) Pairs
      CALL COPY1
      enddo
      endif
C-----------------------------------------------------------------------
C
C     DEFINE LRU FOR INTERNAL USE AS ORIGINAL LRU (BEFORE RECENT).
C
C-----------------------------------------------------------------------
      IF(LRU.GT.3) LRU=LRU-3
C-----Select resolved or unresolved.
      IF(LRU.eq.1) go to 60    ! Resolved
      IF(LRU.gt.1) go to 10    ! unresolved
C-----------------------------------------------------------------------
C
C     NO RESONANCE PARAMETERS PRESENT
C
C-----------------------------------------------------------------------
C-----COPY SECTION WITH NO RESONANCE PARAMETERS.
      CALL CARDIO(C1H,C2H,L1H,L2H,N1H,N2H)
      GO TO 260
C-----------------------------------------------------------------------
C
C     UNRESONANCE
C
C-----------------------------------------------------------------------
C
C     ALLOW FOR MULTIPLE, ADJACENT UNRESOLVED REGIONS.
C
C-----------------------------------------------------------------------
C-----CHECK FOR ONLY ONE UNRESOLVED RESONANCE REGION.
   10 IF(UREVAL.LE.0) GO TO 50
C-----MULTIPLE UNRESOLVED - FIRST CHECK FOR SAME ENERGY RANGE.
      IF(DABS(EULOW-EL) .LE.0.0001d0*DABS(EULOW).AND.
     1   DABS(EUHIGH-EH).LE.0.0001d0*DABS(EUHIGH)) GO TO 60
C-----MULTIPLE UNRESOLVED - NEXT CHECK FOR ADJACENT ENERGY RANGE.
      IF(DABS(EUHIGH-EL).GT.0.0001d0*DABS(EUHIGH)) GO TO 30
C-----EUHIGH OF LAST = EL OF NEXT = ADJACENT RANGES - EXTEND RANGE UP
      WRITE(OUTP,20) EULOW,EUHIGH,EL,EH
      WRITE(*   ,20) EULOW,EUHIGH,EL,EH
   20 FORMAT(1X,79('-')/
     1       ' WARNING - Combining Adjacent Unresolved Ranges'/
     1       '          ',1pd11.4,' eV to ',1pd11.4,' eV and'/
     1       '          ',1pd11.4,' eV to ',1pd11.4,' eV'/1X,79('-'))
      EUHIGH = EH
      GO TO 60
   30 IF(DABS(EULOW-EH).GT.0.0001d0*DABS(EULOW)) GO TO 40
C-----EULOW OF LAST = EH OF NEXT = ADJACENT RANGES - EXTEND RANGE DOWN
      WRITE(OUTP,20) EL,EH,EULOW,EUHIGH
      WRITE(*   ,20) EL,EH,EULOW,EUHIGH
      EULOW = EL
      GO TO 60
C-----MULTIPLE UNRESOLVED INCOMPATIBLE RANGES
   40 IBAD=1
      GO TO 60
C-----SET FLAG TO INDICATE THE PRESENCE OF AN UNRESOLVED RESONANCE
C-----REGION AND DEFINE ENERGY LIMITS OF THE UNRESOLVED REGION.
   50 UREVAL=1
      EULOW=EL
      EUHIGH=EH
C-----------------------------------------------------------------------
C
C     RESONANCE PARAMETERS PRESENT
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C
C     LRU= 1 - RESOLVED
C     LRF= 1 - SLBW, = 2 - MLBW, = 3 - REICH-MOORE, = 4 - ADLER-ADLER
C            - NEW REICH-MOORE = 7
C
C     LRU= 2 - UNRESOLVED
C     LRF= 1 - ENERGY INDEPENDENT WIDTHS (EXCEPT POSSIBLY FISSION)
C        = 2 - ENERGY   DEPENDENT WIDTHS
C
C-----------------------------------------------------------------------
   60 IF(LRU.NE.1) GO TO 70    ! Resolved?
      IF(LRF.EQ.1.OR.          ! Single Level Breit-Wigner
     1   LRF.EQ.2.OR.          ! Multi-Level  Breit-Wigner
     2   LRF.EQ.3) GO TO 80    ! Reich=Moore
      IF(LRF.EQ.4) GO TO 110   ! Adler-Adler
      IF(LRF.EQ.7) GO TO 160   ! New Reich-Moore
C-----ILLEGAL - IGNORE REMAINDER OF FILE 2
      GO TO 280
   70 IF(LRU.NE.2) GO TO 280   ! Unresolved?
      IF(LRF.EQ.1) GO TO 180   ! Energy Independent Widths
      IF(LRF.EQ.2) GO TO 240   ! Energy   Dependent Widths
C-----ILLEGAL - IGNORE REMAINDER OF FILE 2
      GO TO 280
C-----------------------------------------------------------------------
C
C     BREIT-WIGNER (SINGLE OR MULTI-LEVEL) OR REICH-MOORE FORMALISM
C
C-----------------------------------------------------------------------
C-----READ NEXT CARD.
   80 CALL CARDIO(C1H,C2H,L1H,L2H,NLS,N2H)
C-----LOOP OVER ALL L STATES
      DO 100 ILS=1,NLS
C-----READ NEXT CARD.
      CALL CARDIO(C1H,C2H,L1H,L2H,NRS6,NRS)
C-----COPY RESONANCE PARAMETERS.
      DO 90 IRS=1,NRS
      CALL COPY1
   90 CONTINUE
  100 CONTINUE
      GO TO 260
C-----------------------------------------------------------------------
C
C     ADLER-ADLER FORMALISM
C
C-----------------------------------------------------------------------
C-----READ NEXT CARD.
  110 CALL CARDIO(C1H,C2H,L1H,L2H,NLS,N2H)
C-----READ BACKGROUND CORRECTIONS.
      CALL CARDIO(C1H,C2H,L1H,L2H,NX6,N2H)
C-----COPY BACKGROUND CORRECTION CONSTANTS.
      DO 120 I=1,NX6,6
      CALL COPY1
  120 CONTINUE
C-----LOOP OVER L STATES
      DO 150 I=1,NLS
      CALL CARDIO(C1H,C2H,L1H,L2H,NJS,N2H)
C-----LOOP OVER J STATES
      DO 140 J=1,NJS
      CALL CARDIO(C1H,C2H,L1H,L2H,N1H,NLJ)
C-----COPY ALL RESONANCE DATA
      DO 130 K=1,NLJ
      CALL COPY1
      CALL COPY1
  130 CONTINUE
  140 CONTINUE
  150 CONTINUE
      GO TO 260
C-----------------------------------------------------------------------
C
C     NEW REICH-MOORE FORMALISM
C
C-----------------------------------------------------------------------
C-----DEFINE NUMBER OF J STATES
  160 CALL CARDIO(C1,C2,L1,L2,NJS,N2)
C-----DEFINE NUMBER OF PARTICLE-PAIRS
      CALL CARDIO(C1,C2,L1,L2,NPP12,N2)
C-----COPY PARTICLE-PAIR DATA
      DO N=1,NPP12,6
      CALL COPY1
      ENDDO
C-----LOOP OVER J STATES
      DO 170 IJ=1,NJS
C-----J, PARITY, AND NUMBER OF CHANNELS
      CALL CARDIO(C1,C2,L1,L2,NCH6,N2)
C-----COPY CHANNEL DATA
      DO N=1,NCH6,6
      CALL COPY1
      ENDDO
C-----DEFINE NUMBER OF RESONANCES
      CALL CARDIO(C1,C2,L1,L2,N1,NRS)
C-----COPY RESONANCE PARAMETERS
      DO N=1,NRS
      CALL COPY1
      ENDDO
  170 CONTINUE
      GO TO 280
C-----------------------------------------------------------------------
C
C     UNRESOLVED WITH ENERGY INDEPENDENT WIDTHS.
C
C-----------------------------------------------------------------------
C-----TEST IF FISSION WIDTHS GIVEN
  180 IF(LFW.gt.0) go to 200
C-----FISSION WIDTHS NOT GIVEN
      CALL CARDIO(C1H,C2H,L1H,L2H,NLS,N2H)
C-----LOOP OVER ALL L-STATES
      DO 190 ILS=1,NLS
      CALL CARDIO(C1H,C2H,L1H,L2H,N1H,NJS)
      DO N=1,NJS
      CALL COPY1
      ENDDO
  190 CONTINUE
      GO TO 260
C-----FISSION WIDTHS GIVEN (LFW=1)
  200 CALL CARDIO(C1H,C2H,L1H,L2H,NE,NLS)
C-----COPY FISSION WIDTH ENERGY POINTS
      DO 210 I=1,NE,6
      CALL COPY1
  210 CONTINUE
C-----LOOP OVER L-STATES
      DO 230 I=1,NLS
      CALL CARDIO(C1H,C2H,L1H,L2H,NJS,N2H)
C-----LOOP OVER J STATES
      DO 220 J=1,NJS
      CALL CARDIO(C1H,C2H,L1H,L2H,NEP6,N2H)
      DO K=1,NEP6,6
      CALL COPY1
      ENDDO
  220 CONTINUE
  230 CONTINUE
      GO TO 260
C-----------------------------------------------------------------------
C
C     UNRESOLVED WITH ENERGY DEPENDENT WIDTHS.
C
C-----------------------------------------------------------------------
C-----READ NEXT CARD.
  240 CALL CARDIO(C1H,C2H,L1H,L2H,NLS,N2H)
C-----DO LOOP OVER L-STATES
      DO 250 I=1,NLS
      CALL CARDIO(C1H,C2H,L1H,L2H,NJS,N2H)
      DO J=1,NJS
      CALL CARDIO(C1H,C2H,L1H,L2H,NE6P6,N2H)
C-----COPY NUMBER OF DEGREES OF FREEDOM AND PARAMETERS.
      DO K=1,NE6P6,6
      CALL COPY1
      ENDDO
      ENDDO
  250 CONTINUE
  260 CONTINUE
  270 CONTINUE
C-----------------------------------------------------------------------
C
C     END OF RESONANCE REGION (FILE 2) DATA.
C
C-----------------------------------------------------------------------
C-----PRINT WARNING IF UNRESOLVED RESONANCE REGION IS NOT UNIQUE.
  280 IF(UREVAL.LE.0) GO TO 300
      IF(EULOW.LT.EUHIGH) GO TO 290
      UREVAL=0
      WRITE(OUTP,320) IZA,MATH,MTH,FMTHOL
      WRITE(*   ,320) IZA,MATH,MTH,FMTHOL
      GO TO 300
  290 IF(IBAD.GT.0) WRITE(OUTP,310) IZA,MATH,MTH,FMTHOL
      IF(IBAD.GT.0) WRITE(*   ,310) IZA,MATH,MTH,FMTHOL
  300 RETURN
  310 FORMAT(1X,I6,2I5,2X,A2,
     1 ' WARNING - Unresolved Resonance Energy Range NOT the Same'/
     2 29X,' for ALL Isotopes and Spin States. This Violates ENDF/B'/
     3 29X,' Conventions. The Unresolved Resonance Energy Range'/
     4 29X,' will be Considered to Extend from the Maximum Lower'/
     5 29X,' Energy Limit up to the Mimimum Upper Energy Limit'/
     6 29X,' of ALL the Unresolved Ranges Defined for this MAT.')
  320 FORMAT(1X,I6,2I5,2X,A2,
     1 ' WARNING - Unresolved Resonance Energy Range NOT the Same'/
     2 29X,' for ALL Isotopes and Spin States. This Violates ENDF/B'/
     3 29X,' Conventions. Cannot Locate ANY Energy Range that'/
     4 29X,' ONLY Contains Unresolved Resonances. Will Ignor'/
     5 29X,' Unresolved Resonance Region.')
      END
      SUBROUTINE FILE3
C=======================================================================
C
C     THIS ROUTINE IS DESIGNED TO DOPPLER BROADEN ONE ENDF/B SECTION
C     OF DATA (I.E., ONE REACTION). DATA IS READ, DOPPLER BROADENED AND
C     OUTPUT IN THE ENDF/B FORMAT. IF THE SECTION CONTAINS 180000 FEWER
C     POINTS THE ENTIRE OPERATION IS PERFORMED IN CORE. IF THE SECTION
C     CONTAINS MORE 180000 POINTS THE DATA WILL BE BROADENED A PAGE
C     (1 PAGE = 60000 POINTS) AT A TIME, WRITTEN TO SCRATCH AND AFTER
C     THE ENTIRE SECTION HAS BEEN BROADENED IT WILL BE READ BACK FROM
C     SCRATCH AND OUTPUT IN THE ENDF/B FORMAT.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INTEGER*4 OUTP,OTAPE,TOOHI,COLD1,COLD2,COLD1P,COLD2P,HOT1,HOT2,
     1 HOT3,HOT3M1,UNRES1,UNRES2,UREVAL,UREACT
      CHARACTER*1 FIELD6,ZABCD
      CHARACTER*4 FMTHOL,PROHOL
      COMMON/INDEX/COLD1,COLD2,COLD1P,COLD2P,HOT1,HOT2,HOT3,HOT3M1,N2IN,
     1 N2TOT,N2SCR
      COMMON/WHATZA/IZA
      COMMON/PAGER/NPAGE,NPT2,NPT3,NP1P1,NP2P1
      COMMON/HOTS/ALPHA,HOTSY1,HOTSY2,TEMPK,TEMPEF,N2TAPI,N2TAPO
      COMMON/LOGLOGE/ELOGLOG
      COMMON/HEADER/ZA,AWR,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/LEADER/C1,Q,L1,L2,N1,N2,MAT,MF,MT
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/FILLER/N2LEFT,TOOHI,ITHRES,LOAD1,LOAD2
      COMMON/EXTEND/DTMAX,MESS
      COMMON/RESOLV/EULOW,EUHIGH,UREVAL,UREACT,UNRES1,UNRES2,IL,IH
      COMMON/LASTE/ELAST
      COMMON/TEMPO/TEMP3,IVERSE
      COMMON/SLIM/ISTART,NOTHIN,ITHIN1,ITHIN2,ITHIN3,MTEND
      COMMON/PARTIN/ATWTP,INPART
      COMMON/MAXTEMP/DEMAXC,DEMAXH,DEMAXLOW,DEMAXHI
      COMMON/HOLFMT/FMTHOL,PROHOL
      COMMON/FIELDC/FIELD6(11,6)
c----- 2012 - number of points read in any MT
      COMMON/READN2/N2READ
      COMMON/LISOCOM/LISO
      DIMENSION ZABCD(12)
      INCLUDE 'sigma1.h'
C-----DEFINE BOLTZMANN CONSTANT IN EV/DEGREE KELVIN
C-----(ASSUMING ENERGY WILL BE EXPRESSED IN EV AND THE ATOMIC
C-----WEIGHT RATIO WILL BE EXPRESSED IN NEUTRON MASS UNITS,
C-----AS OPPOSED TO ATOMIC MASS UNITS (AMU)).
C-----UPDATED NOV. 12, 1998 AS PER CSEWG SUBCOMMITEE RECOMMENDATION
C***** DEVUG
      DATA BOLTZM/8.617385D-05/
C     DATA BOLTZM/8.6164D-05/
C***** DEVUG
C-----INITIALIZE TEMPERATURE READ FROM TOTAL CROSS SECTION (MT=1).
      DATA TEMP1/0.0d0/
C-----INITIALIZE MAXIMUM ENERGY SPACING FOR LOW ENERGY START.
      DEMAXC=DEMAXLOW
      DEMAXH=DEMAXLOW
C-----------------------------------------------------------------------
C
C     READ TAB1 LEADER CARD AND INTERPOLATION LAW. CHECK INTERPOLATION
C     LAW AND IF DATA IS NOT LINEARLY INTERPOLABLE TERMINATE EXECUTION.
C
C-----------------------------------------------------------------------
C-----READ TAB1 LEAD CARD.
      CALL CARDI(C1,Q,L1,L2,N1,N2)
C-----READ INTERPOLATION LAW.
      CALL TERPI(NBT(1),INT(1),N1)
c-----2019/1/3 - Additional Interpolation Law Tests
      CALL TERPTEST(NBT(1),INT(1),N1,N2,3)
C-----------------------------------------------------------------------
C
C     INITIALIZE ALL COUNTS AND FLAGS FOR SECTION.
C
C-----------------------------------------------------------------------
C-----INITIALIZE FLAG NOT TO PRINT EXTENSION MESSAGE WITH SECTION.
      MESS=1
C-----INITIALIZE FLAG TO DOPPLER BROADEN SECTION.
      TOOHI=-1
C-----TURN OFF DOPPLER BROADENING FLAG IF SECTION IS MU-BAR, XI OR
C-----GAMMA.
c----- 2012 - number of points read in any MT
      N2READ = N2
      IF(MTH.GE.251.AND.MTH.LE.253) TOOHI=1
C-----------------------------------------------------------------------
C
C     DEFINE ORIGINAL TEMPERATURE. FOR ENDF/B-5 AND EARLIER VERSIONS
C     C1 OF THE TAB1 LEAD CARD IS EITHER THE TEMPERATURE (L2=0) OR THE
C     Q-VALUE CORRESPONDING TO THE REACTION WITH MT=N2. IN THE LATTER
C     CASE ASSUME THE SAME TEMPERATURE AS FOR THE TOTAL. FOR ENDF/B-6
C     THE INITIAL TEMPERATURE HAS ALREADY BEEN READ FROM FILE 1 (TEMP3).
C
C-----------------------------------------------------------------------
C-----CHECK FOR ENDF/B-6 FORMAT.
      IF(IVERSE.NE.6) GO TO 10
C-----ENDF/B-6 FORMAT. INITIAL TEMPERATURE HAS ALREADY BEEN DEFINED
C-----FROM FILE 1 (TEMP3).
      TEMPEF=TEMPK-TEMP3
      GO TO 30
C-----ENDF/B-5 OR EARLIER. USE EITHER C1 FIELD OR TEMPERATURE FROM
C-----TOTAL.
   10 IF(L2.LE.0) GO TO 20
      TEMP3=TEMP1
      TEMPEF=TEMPK-TEMP3
      GO TO 30
   20 TEMP3=C1
      IF(MTH.EQ.1) TEMP1=TEMP3
      TEMPEF=TEMPK-TEMP3
C-----IN ENDF/B-5 OR EARLIER DEFINE TEMPERATURE IN C1 FIELD.
      IF(TEMPEF.GT.0.0d0.AND.TOOHI.LT.0) C1=TEMPK
c-----------------------------------------------------------------------
C
C     ERROR if Input temperature exceeds output temperature
C
c-----------------------------------------------------------------------
   30 if(TEMPK.lt.TEMP3) then
c-----Added Target Isomer State
      CALL ZAHOLM(IZA,LISO,ZABCD)
      CALL OUT9(TEMP3,FIELD6(1,1)) ! Input ERROR
      CALL OUT9(TEMPK,FIELD6(1,2))
      WRITE(3,40) PROHOL,ZABCD,MATH,MTH,FMTHOL,(FIELD6(K9,1),K9=1,11),
     1 ((FIELD6(K9,K8),K9=1,11),K8=1,2)
      WRITE(*,40) PROHOL,ZABCD,MATH,MTH,FMTHOL,(FIELD6(K9,1),K9=1,11),
     1 ((FIELD6(K9,K8),K9=1,11),K8=1,2)
   40 FORMAT(1X,A4,12A1,I5,I4,2x,A2,3X,11A1/
     1 1x,9('ERROR==='),'ERROR=='/
     2 ' Input temperature.......................',11A1,' Kelvin'/
     3 ' Exceeds Requested Output Temperarure....',11A1,' Kelvin'/
     4 ' PLEASE correct data and re-run this code.'/
     5 1x,79('=')/' EXECUTION TERMINATED')
      CALL ENDERROR
      endif
c-----------------------------------------------------------------------
C
C     SHOULD DATA BE DOPPLER BROADENED....
C
c-----------------------------------------------------------------------
      IF(TEMPEF.gt.0.0d0) go to 50
C-----NO.
      TOOHI=1
      GO TO 70
C-----YES.
c-----2020/12/11 - Check Atomic Weight
   50 if(AWR.le.0.0d0) then
      write(outp,60) MATH,MFH,MTH,AWR
      write(*   ,60) MATH,MFH,MTH,AWR
   60 format(1x,79('=')/
     1 ' MAT/MF/MT=',i5,i3,i4,' AWR=',1pd11.4,' (Must be Positive.'/
     2 ' Execution Terminated'/1x,79('='))
      CALL ENDERROR
      endif
      ALPHA=(AWR/ATWTP)/(BOLTZM*TEMPEF)   ! AWR = C2H in HEADER
C-----DEFINE CUTOFF ENERGY FOR LOW ENERGY LOG-LOG ASSUMPTION.
      IF(MTH.LE.2) THEN
      ELOGLOG = 0.0d0             ! total and elastic
      ELSE
c-----------------------------------------------------------------------
c
c     this is the same as older versions, but easier and faster
c     E * a   < 40,   a = atwt/(kT) ~ 40*atwt (room kt~ 1/40 eV)
c     E *atwt < 1
c     E       < 1/atwt
c
c-----------------------------------------------------------------------
      ELOGLOG = 1.0d0*(ATWTP/AWR) ! capture, fission, etc.
      ENDIF
C-----INITIALIZE FLAG TO INDICATE BEGINNING OF SECTION.
   70 ISTART=1
C-----INITIALIZE TOTAL NUMBER OF POINTS IN SECTION AND NUMBER OF POINTS
C-----LEFT TO READ.
      N2IN=N2
      N2LEFT=N2
C-----INITIALIZE BROADENING INDICES TO FIRST TWO PAGES.
      HOT1=1
      HOT2=NPT2
C-----INITIALIZE END OF SECTION FLAG.
      MTEND=0
C-----INITIALIZE THINNING INDICES.
      ITHIN1=1
      ITHIN2=2
      ITHIN3=2
C-----INITIALIZE COUNT OF POINTS ON SCRATCH.
      N2SCR=0
C-----INITIALIZE LAST ENERGY READ FOR ASCENDING ENERGY TEST.
      ELAST=0.0d0
C-----------------------------------------------------------------------
C
C     INITIALIZE UNRESOLVED RESONANCE REGION PARAMETERS FOR THIS SECTION
C
C-----------------------------------------------------------------------
C-----IF THERE IS AN UNRESOLVED RESONANCE REGION AND THIS SECTION IS
C-----TOTAL, ELASTIC, FISSION OR CAPTURE INITIAL INDICES.
      UREACT=UREVAL
      UNRES1=10000000
      UNRES2=10000000
      IL=0
      IH=0
      IF(UREACT.LE.0) GO TO 80
      IF(MTH.NE.1.AND.MTH.NE.2.AND.MTH.NE.18.AND.MTH.NE.19.AND.
     1 MTH.NE.102) UREACT=0
C-----------------------------------------------------------------------
C
C     LOAD DATA.
C
C-----------------------------------------------------------------------
C-----LOAD NEXT PAGE OF DATA AT ORIGINAL TEMPERATURE.
   80 CALL FILLUP
C-----SHOULD DATA BE DOPPLER BROADENED....
      IF(TOOHI.LE.0) GO TO 90
C-----NO. IF END OF SECTION BRANCH FOR FINAL THIN AND OUTPUT.
      IF(MTEND.ne.0) go to 110
C-----OTHERWISE THIN DATA AND LOAD NEXT PAGES.
      CALL THINIT
      HOT1=NP1P1
      GO TO 80
C-----------------------------------------------------------------------
C
C     BROADEN AND THIN DATA.
C
C-----------------------------------------------------------------------
C-----YES. INITIALIZE INDICES TO FIRST AND LAST POINTS TO USE IN DOPPLER
C-----BROADENING INTEGRAL TO POINT TO FIRST AND LAST POINTS THAT ARE
C-----LOADED IN CORE.
   90 COLD1P=COLD1
      COLD2P=COLD2
C-----IF UNRESOLVED RESONANCE REGION DATA IS IN CORE TRUNCATE RANGE
C-----OF INTEGRATION AT UNRESOLVED RESONANCE REGION ENERGY BOUNDARY.
C-----FOR ENERGIES BELOW UNRESOLVED REGION SET UPPER INTEGRATION LIMIT
C-----TO LOWER ENERGY LIMIT OF UNRESOLVED REGION.
      IF(HOT1.LE.UNRES1.AND.UNRES1.LE.COLD2) COLD2P=UNRES1
C-----FOR ENERGIES ABOVE UNRESOLVED REGION SET LOWER INTEGRATION LIMIT
C-----TO UPPER ENERGY LIMIT OF UNRESOLVED REGION.
      IF(HOT1.GE.UNRES2.AND.UNRES2.GT.0) COLD1P=UNRES2
C-----BROADEN DATA.
      CALL BROADN
C-----HAS THE LAST POINT BEEN BROADENED....
      IF(MTEND.ne.0) go to 110
C-----------------------------------------------------------------------
C
C     MORE POINTS TO BROADEN. SET UP DATA AND INDICES FOR NEXT PAGE
C     TO BE BROADENED.
C
C-----------------------------------------------------------------------
C-----SHIFT PAGES TWO AND THREE OF COLD DATA FORWARD ONE PAGE IN CORE.
      KK=0
      DO 100 K=NP1P1,COLD2
      KK=KK+1
      ECOLD(KK)=ECOLD(K)
      YCOLD(KK)=YCOLD(K)
      XCCOLD(KK)=XCCOLD(K)
      DCOLD(KK)=DCOLD(K)
  100 CONTINUE
C-----SET INDEX TO FIRST POINT TO DOPPLER BROADEN TO BEGINNING OF
C-----SECOND PAGE.
      HOT1=NP1P1
C-----IF ANY POINTS ARE WITHIN THE UNRESOLVED RESONANCE REGION SHIFT
C-----INDICES TO UNRESOLVED RESONANCE REGION FORWARD ONE PAGE.
      IF(UREACT.LE.0) GO TO 80
      UNRES1=UNRES1-NPAGE
      UNRES2=UNRES2-NPAGE
      GO TO 80
C-----------------------------------------------------------------------
C
C     END OF SECTION. THIN REMAINDER OF SECTION AND OUTPUT SECTION
C     (FROM CORE OR SCRATCH).
C
C-----------------------------------------------------------------------
  110 MTEND=1
      CALL THINIT
      CALL COPOUT
      RETURN
      END
      SUBROUTINE FILLUP
C=======================================================================
C
C     LOAD NEXT PAGE OR PAGES OF CROSS SECTIONS AT THE ORIGINAL
C     TEMPERATURE INTO CORE. INSURE THAT THE MAXIMUM ENERGY
C     SPACING REQUIRED FOR LINEAR-LINEAR INTERPOLATABLE DOPPLER
C     BROADENED DATA IS NOT EXCEEDED.
C
C     IF THERE IS AN UNRESOLVED RESONANCE REGION INSURE THAT THERE IS
C     AT LEAST TWO POINTS AT THE LOWER AND UPPER ENERGY LIMITS OF THE
C     UNRESOLVED REGION AND DEFINE INDICES TO LOWER AND UPPER ENERGY
C     LIMITS OF THE UNRESOLVED REGION. DO NOT ADD ADDITIONAL ENERGY
C     POINTS WITHIN THE UNRESOLVED RESONANCE REGION.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INTEGER*4 TOOHI,COLD1,COLD2,COLD1P,COLD2P,HOT1,HOT2,HOT3,HOT3M1,
     1 UNRES1,UNRES2,UREVAL,UREACT
      COMMON/HEADER/C1H,AWR,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/HOTS/ALPHA,HOTSY1,HOTSY2,TEMPK,TEMPEF,N2TAPI,N2TAPO
      COMMON/LOGLOGE/ELOGLOG
      COMMON/SLIM/ISTART,NOTHIN,ITHIN1,ITHIN2,ITHIN3,MTEND
      COMMON/INDEX/COLD1,COLD2,COLD1P,COLD2P,HOT1,HOT2,HOT3,HOT3M1,N2IN,
     1 N2TOT,N2SCR
      COMMON/PAGER/NPAGE,NPT2,NPT3,NP1P1,NP2P1
      COMMON/FILLER/N2LEFT,TOOHI,ITHRES,LOAD1,LOAD2
      COMMON/CONTAC/OVPI,OVPI2,ATOP
      COMMON/THRESH/ETHRES,EMIN
      COMMON/FILLXY/EIN(1002),XCIN(1002)
      COMMON/RESOLV/EULOW,EUHIGH,UREVAL,UREACT,UNRES1,UNRES2,IL,IH
      COMMON/MAXTEMP/DEMAXC,DEMAXH,DEMAXLOW,DEMAXHI
      COMMON/POINT1/EIN1,EUSE1
      COMMON/IWATCH/MONITR,MAKEPLUS,MYUNRES
      COMMON/TEMPO/TEMP3,IVERSE
      COMMON/HIGHESTE/EHIGHEST,EMILLION
      COMMON/EXTEND/DTMAX,MESS
c----- 2012 - number of points read in any MT
      COMMON/READN2/N2READ
      INCLUDE 'sigma1.h'
      DATA XCKM1/0.0d0/
      DATA EKM1 /0.0d0/
C-----THERMAL ENERGY - ALWAYS KEEP
      DATA ETHERMAL/2.53d-02/
C-----------------------------------------------------------------------
C
C     AT BEGINNING OF SECTION SET INDICES TO FORCE IMMEDIATE READ AND TO
C     LOAD UP TO THREE PAGES (UP TO 180000 POINTS) OF DATA. THIS IS NOT
C     THE BEGINNING OF THE SECTION SET INDICES TO ONLY LOAD THE THIRD
C     PAGE (60000 POINTS) OF DATA.
C
C-----------------------------------------------------------------------
C-----IS THIS THE BEGINNING OF THE SECTION.
      IF(HOT1.GT.1) GO TO 10
C-----BEGINNING OF SECTION. SET INDICES TO FORCE READING WHEN FIRST DATA
C-----POINT IS REQUESTED FROM ENDF/B DATA FILE.
      IPASS=0
      IMGOOD=0       ! 2017/6/6 - added to check for cross section > 0
      NFILL=1002
      IFILL=NFILL+1
C-----INITIALIZE INDICES TO READ UP TO THREE PAGES OF DATA POINTS.
      LOAD1=1
      LOAD2=NPT3
C-----INITIALIZE SIGN OF CROSS SECTION TO POSITIVE.
      SIGNT=1.0d0
C-----INITIALIZE INDEX TO FIRST POINT TO BROADEN.
      HOT3=0
      HOT3M1=-1
      GO TO 20
C-----SET INDEX TO ONLY LOAD LAST PAGE OF DATA POINTS.
   10 LOAD1=NP2P1
C-----INITIALIZE LOAD INDEX TO FIRST LOCATION.
   20 K=LOAD1
C-----IF NO MORE POINTS IN CORE READ NEXT PAGE (IF ANY).
   30 IF(IFILL.LE.NFILL) GO TO 50
      IF(N2LEFT.GT.NFILL) GO TO 40
      IF(N2LEFT.LE.0) GO TO 310
      NFILL=N2LEFT
   40 N2LEFT=N2LEFT-NFILL
      CALL POINTI(EIN,XCIN,NFILL)
c-----2019/3/9 - save Maximum Tabulated Energy and Value.
      CALL MAXIE2(EIN(NFILL),XCIN(NFILL))
C-----Check for positive cross section
      if(IMGOOD.le.0) then
      do kk=1,NFILL
      if(XCIN(kk).gt.0.0d0) IMGOOD = 1
      enddo
      endif
C-----IF REQUESTED MAKE ALL NEGATIVE CROSS SECTIONS = 0
      IF(MAKEPLUS.EQ.1) THEN
      DO KP=1,NFILL
      IF(XCIN(KP).LT.0.0d0) XCIN(KP)=0.0d0
      ENDDO
      ENDIF
      IFILL=1
C-----SAVE FIRST ENERGY OF SECTION.
      IF(IPASS.NE.0) GO TO 50
      IPASS=1
      EIN1=EIN(1)
C-----------------------------------------------------------------------
C
C     AT THE BEGINNING OF SECTION DECIDE WHETHER OR NOT TO DOPPLER
C     BROADEN. DO NOT DOPPLER BROADEN ANY SECTION IN WHICH THE
C     THRESHOLD IS HIGHER THAN 1,000,000* KT/A (I.E. SECTIONS WHICH
C     HAVE A HIGH ENERGY THRESHOLD, ABOVE WHICH BROADENING WILL HAVE
C     A NEGLIGABLE EFFECT).
C
C-----------------------------------------------------------------------
   50 IF(TOOHI.eq.0) go to 150
      IF(TOOHI.gt.0) go to 90
c-----2017/6/4 - Copy if entire cross section = 0
      if(N2LEFT.le.0.and.IMGOOD.le.0) then
      IFILL = 1
      go to 70
      endif
C-----SKIP POINTS BELOW THRESHOLD.
      DO 60 IFILL=1,NFILL
      IF(DABS(XCIN(IFILL)).GT.0.0d0) GO TO 70
   60 CONTINUE
C-----ENTIRE PAGE IS ZERO. SET INDEX AND READ NEXT PAGE.
      IFILL=NFILL+1
      GO TO 30
C-----DEFINE INDEX TO THRESHOLD.
   70 IFILL=IFILL-1
      IF(IFILL.LE.0) IFILL=1
C-----INITIALIZE PARAMETERS AND THEN DECIDE WHETHER OR NOT TO DOPPLER
C-----BROADEN.
      AX=ALPHA*EIN(IFILL)
      TOOHI=1
      ITHRES=0
c-----2017/6/4 - Copy if entire cross section = 0
      if(N2LEFT.le.0.and.IMGOOD.le.0) go to 80
C-----NO DOPPLER BROADENING IF THRESHOLD OVER 1,000,000*KT/A.
c-----2012 - AND LESS THAN 1,000 POINTS - ADDED FOR NEW (N,N')
C-----2013 - ADDED ABSOLUTE CUTOFF AT 10 MEV.
      IF(EIN(IFILL).gt.EHIGHEST) go to 80  ! less than 10 MeV
      IF(AX        .lt.EMILLION.or.        ! less than 1,000,000 AE/KT
     1   N2READ    .ge.1000)     go to 100 ! more than 1,000 points
C-----SECTION WILL ONLY BE COPIED. TURN OFF UNRESOLVED REGION FLAG.
   80 UREACT=0
      MESS  =3
C-----DATA WILL NOT BE DOPPLER BROADENED. MAXIMUM ENERGY SPACING IS
C-----NOT REQUIRED. JUST COPY POINTS DIRECTLY INTO HOT CROSS SECTION
C-----ARRAY.
   90 HOT3M1=HOT3
      HOT3=HOT3+1
      EHOT(HOT3)=EIN(IFILL)
      XCHOT(HOT3)=XCIN(IFILL)
      IFILL=IFILL+1
      GO TO 300
C-----SECTION WILL BE DOPPLER BROADENED.
  100 TOOHI=0
C-----IF FIRST POINT IS NEGATIVE (E.G. BACKGROUND CROSS SECTION) REVERSE
C-----SIGN OF CROSS SECTION.
      IF(XCIN(IFILL).LT.0.0d0) SIGNT=-1.0d0
C-----------------------------------------------------------------------
C
C     DEFINE FIRST DATA POINT. USE EITHER FIRST TABULATED POINT OR IF
C     THIS IS A THRESHOLD REACTION CALCULATE POSITION OF NEW LABORATORY
C     EFFECTIVE THRESHOLD DUE TO DOPPLER BROADENING AND USE THIS AS
C     FIRST POINT.
C
C-----------------------------------------------------------------------
      IF(EIN(IFILL).LE.ETHRES) GO TO 120
C-----------------------------------------------------------------------
C
C     DO NOT EXTEND CROSS SECTION FROM UNRESOLVED RESONANCE REGION.
C
C-----------------------------------------------------------------------
      IF(UREACT.LE.0) GO TO 110
      IF(EIN(IFILL).GE.EULOW) GO TO 120
C-----------------------------------------------------------------------
C
C     INSERT ONE OR TWO (IF FIRST POINT CROSS SECTION IS NOT ZERO)
C     POINTS BELOW THRESHOLD.
C
C-----------------------------------------------------------------------
  110 ITHRES=1
      V=DSQRT(AX)-ATOP
      ENEXT=V*V/ALPHA
      IF(ENEXT.LT.ETHRES.OR.V.LE.0.0d0) ENEXT=EMIN
      ECOLD(K)=ENEXT
      ARG=ALPHA*ECOLD(K)
      YCOLD(K)=DSQRT(ARG)
      XCCOLD(K)=0.0d0
      IF(K.EQ.LOAD1) EUSE1=ECOLD(K)
      K=K+1
      IF(XCIN(IFILL).eq.0.0d0) go to 120
      ECOLD(K)=EIN(IFILL)
      ARG=ALPHA*ECOLD(K)
      YCOLD(K)=DSQRT(ARG)
      XCCOLD(K)=0.0d0
      IF(K.EQ.LOAD1) EUSE1=ECOLD(K)
      GO TO 130
C-----USE FIRST TABULATED POINT.
  120 ECOLD(K)=EIN(IFILL)
      XCCOLD(K)=XCIN(IFILL)
      ARG=ALPHA*ECOLD(K)
      YCOLD(K)=DSQRT(ARG)
      IFILL=IFILL+1
      IF(K.EQ.LOAD1) EUSE1=ECOLD(K)
C-----------------------------------------------------------------------
C
C     FIRST POINT DEFINED. RE-INITIALIZE UNRESOLVED RESONANCE REGION
C     INDICES IF SECTION STARTS ABOVE LOWER ENERGY OF UNRESOLVED REGION.
C
C-----------------------------------------------------------------------
  130 IF(UREACT.LE.0) GO TO 270
C-----IF SECTION STARTS ABOVE UPPER ENERGY LIMIT OF UNRESOLVED REGION
C-----TURN OFF UNRESOLVED REGION.
      IF(ECOLD(LOAD1).LT.EUHIGH) GO TO 140
      UREACT=0
      GO TO 270
C-----IF SECTION STARTS ABOVE LOWER ENERGY LIMIT OF UNRESOLVED REGION
C-----INDICATE THAT ADDITIONAL POINTS ARE NOT REQUIRED AT THE LOWER
C-----ENERGY LIMIT OF UNRESOLVED REGION.
  140 IF(ECOLD(LOAD1).LT.EULOW) GO TO 270
      IL=2
      UNRES1=1
      GO TO 270
C-----------------------------------------------------------------------
C
C     FIRST POINT DEFINED. LOAD ALL OTHER POINTS.
C
C     CHECK FOR UNRESOLVED RESONANCE REGION. IF THERE IS AN UNRESOLVED
C     RESONANCE REGION DEFINE INDICES TO THE LAST POINT BELOW THE
C     UNRESOLVED RESONANCE REGION (UNRES1) AND THE FIRST POINT ABOVE THE
C     UNRESOLVED RESONANCE REGION (UNRES2). INSURE THAT THERE ARE AT
C     LEAST TWO POINTS AT THE LOWER AND UPPER ENERGY LIMITS OF THE
C     UNRESOLVED RESONANCE REGION. WHEN THE LOWER LIMIT OF THE
C     UNRESOLVED REGION IS FOUND SET THE INDEX TO THE UPPER ENERGY LIMIT
C     TO A LARGE NUMBER TO INDICATE THAT THE UPPER ENERGY LIMIT IS STILL
C     BEYOND THE UPPER LIMIT OF THE POINTS LOADED INTO CORE SO FAR. ONCE
C     THE UPPER ENERGY LIMIT OF THE UNRESOLVED REGION IS FOUND THE INDEX
C     TO THE UPPER ENERGY LIMIT WILL BE PROPER DEFINED.
C
C-----------------------------------------------------------------------
  150 IF(UREACT.LE.0) GO TO 230
C-----INSURE THERE ARE AT LEAST TWO POINTS AT LOWER ENERGY LIMIT OF
C-----UNRESOLVED REGION.
      IF(EIN(IFILL).lt.EULOW) go to 230
      IF(EIN(IFILL).gt.EULOW) go to 160
      IF(IL.EQ.0) UNRES1=K
      IPATH=1
      XCULOW=XCIN(IFILL)
      GO TO 180
  160 IF(IL.eq.1) go to 170
      IF(IL.gt.1) go to 190
C-----THERE ARE NO POINTS AT LOWER ENERGY LIMIT. INTERPOLATE AND
C-----INSERT POINT.
      UNRES1=K
      XCULOW=((EIN(IFILL)-EULOW)*XCKM1+(EULOW-EKM1)*XCIN(IFILL))/
     1 (EIN(IFILL)-EKM1)
  170 IPATH=0
  180 ECOLD(K)=EULOW
      XCCOLD(K)=XCULOW
      ARG=ALPHA*ECOLD(K)
      YCOLD(K)=DSQRT(ARG)
      IL=IL+1
      GO TO 260
C-----INSURE THERE ARE AT LEAST TWO POINTS AT UPPER ENERGY LIMIT OF
C-----UNRESOLVED REGION.
  190 IF(EIN(IFILL).lt.EUHIGH) go to 240
      IF(EIN(IFILL).gt.EUHIGH) go to 200
      XCUHI=XCIN(IFILL)
      IPATH=1
      GO TO 220
  200 IF(IH.eq.1) go to 210
      IF(IH.gt.1) go to 230
C-----THERE ARE NO POINTS AT UPPER ENERGY LIMIT. INTERPOLATE AND
C-----INSERT FIRST POINT.
      XCUHI=((EIN(IFILL)-EUHIGH)*XCKM1+(EUHIGH-EKM1)*XCIN(IFILL))/
     1 (EIN(IFILL)-EKM1)
  210 IPATH=0
  220 ECOLD(K)=EUHIGH
      XCCOLD(K)=XCUHI
      ARG=ALPHA*ECOLD(K)
      YCOLD(K)=DSQRT(ARG)
      UNRES2=K
      IH=IH+1
      GO TO 260
C-----IF CROSS SECTION HAS CHANGED SIGN INTERPOLATE AND INSERT ENERGY
C-----POINT AT ZERO CROSS SECTION UNLESS CROSS SECTION AT LAST POINT
C-----WAS ZERO.
  230 IF(SIGNT*XCIN(IFILL).GE.0.0d0) GO TO 240
      SIGNT=-SIGNT
      IF(XCKM1.eq.0.0d0) go to 240
      IPATH=0
      XCCOLD(K)=0.0d0
      ECOLD(K)=(XCIN(IFILL)*EKM1-XCKM1*EIN(IFILL))/(XCIN(IFILL)-XCKM1)
      IF(ECOLD(K).LT.EKM1) ECOLD(K)=EKM1
      IF(ECOLD(K).GT.EIN(IFILL)) ECOLD(K)=EIN(IFILL)
      ARG=ALPHA*ECOLD(K)
      YCOLD(K)=DSQRT(ARG)
      GO TO 260
C-----CHECK MAXIMUM ENERGY SPACING.
  240 IF(EIN(IFILL).LE.ENEXT) GO TO 250
      IPATH=0
      ECOLD(K)=ENEXT
      IF(ECOLD(K).LT.EKM1) ECOLD(K)=EKM1
      IF(ECOLD(K).GT.EIN(IFILL)) ECOLD(K)=EIN(IFILL)
C-----------------------------------------------------------------------
C
C     USE LOG-LOG INTERPOLATION AT LOW ENERGY
C
C-----------------------------------------------------------------------
      ITERP=2
      IF(ENEXT.LT.ELOGLOG) THEN
      IF(XCIN(IFILL).GT.0.0d0.AND.XCKM1.GT.0.0d0) ITERP = 5
      ENDIF
      XCCOLD(K)=TERPIT(ENEXT,EIN(IFILL),EKM1,XCIN(IFILL),XCKM1,ITERP)
      ARG=ALPHA*ECOLD(K)
      YCOLD(K)=DSQRT(ARG)
      GO TO 260
C-----ENERGY SPACING IS O.K. ACCEPT NEXT TABULATED POINT.
  250 IPATH=1
      ECOLD(K)=EIN(IFILL)
      XCCOLD(K)=XCIN(IFILL)
      ARG=ALPHA*ECOLD(K)
      YCOLD(K)=DSQRT(ARG)
C-----NEXT INPUT POINT IS ACCEPTABLE.
  260 IFILL=IFILL+IPATH
C-----------------------------------------------------------------------
C
C     DEFINE SPEED-LIKE TERMS (SEE UCRL-50400, VOL. 17, PART C) AND
C     SLOPE BETWEEN POINTS.
C
C-----------------------------------------------------------------------
  270 IF(K.LE.1) GO TO 290
      DX=YCOLD(K)-YCOLD(K-1)
      DSCOLD=XCCOLD(K)-XCCOLD(K-1)
      IF(DX.eq.0.0d0) go to 280
      DCOLD(K-1)=DSCOLD/(DX*(YCOLD(K)+YCOLD(K-1)))
      GO TO 290
  280 DCOLD(K-1)=0.0d0
C-----------------------------------------------------------------------
C
C     DEFINE NEXT ALLOWABLE ENERGY INTERVAL. IF THERE IS AN UNRESOLVED
C     RESONANCE REGION INSURE THAT THERE ARE AT LEAST TWO POINTS AT THE
C     LOWER AND UPPER ENERGY LIMITS OF THE UNRESOLVED REGION. DO NOT ADD
C     ENERGY POINTS WITHIN THE UNRESOLVED ENERGY REGION.
C
C-----------------------------------------------------------------------
C-----SAVE LAST POINT FOR INTERPOLATION.
  290 EKM1=ECOLD(K)
      XCKM1=XCCOLD(K)
  300 ENEXT=DEMAXC*ECOLD(K)
C-----RELAX ENERGY STEP ABOVE 1 EV.
      IF(EKM1.GE.1.0d0) DEMAXC=DEMAXHI
C-----------------------------------------------------------------------
C
C     INSERT THERMAL POINT BY SETTING ENEXT = ETHERMAL
C     WHEN THERMAL ENERGY IS CROSSED.
C
C-----------------------------------------------------------------------
      IF(ECOLD(K).LT.ETHERMAL.AND.
     1   ENEXT   .GT.ETHERMAL) ENEXT=ETHERMAL
      K=K+1
      IF(K.LE.LOAD2) GO TO 30
C-----------------------------------------------------------------------
C
C     ALL POINTS REQUESTED, OR ALL REMAINING POINTS, HAVE BEEN LOADED.
C
C-----------------------------------------------------------------------
C-----IS THIS THE END OF THE DATA TABLE.
      IF(N2LEFT.LE.0.AND.IFILL.GT.NFILL) GO TO 320
C-----NO.
      GO TO 330
C-----END OF DATA TABLE. DEFINE NUMBER OF POINTS IN CORE AND SET INDEX
C-----TO BROADEN ALL REMAINING POINTS.
  310 LOAD2=K-1
  320 HOT2=LOAD2
      MTEND=-1
C-----DEFINE INDEX TO LAST DATA POINT IN CORE.
  330 COLD2=LOAD2
C-----Ignore for cross section = 0
      IF(COLD2.gt.0) DCOLD(COLD2)=0.0d0
      RETURN
      END
      SUBROUTINE BROADN
C=======================================================================
C
C     GIVEN A CROSS SECTION THAT IS DESCRIBED BY A TABLE OF CROSS
C     SECTION VS. E AND LINEAR-LINEAR INTERPOLATION BETWEEN POINTS
C     THIS ROUTINE WILL EXACTLY DOPPLER BROADENING THE CROSS
C     SECTION AT A PORTION OF THE ENERGIES (ONE, TWO OR THREE PAGES).
C
C     INPUT PARAMETERS
C     COLD1 =INDEX TO FIRST POINT LOADED IN CORE.
C     COLD2 =INDEX TO LAST POINT LOADED IN CORE.
C     COLD1P=INDEX TO FIRST POINT TO USE IN DOPPLER INTEGRATION
C     COLD2P=INDEX TO LAST POINT TO USE IN DOPPLER INTEGRATION
C            THE PAIRS (COLD1,COLD2) AND (COLD1P,COLD2P) WILL DIFFER
C            ONLY IF THERE IS AN UNRESOLVED RESONANCE PRESENT.
C     HOT1  =INDEX TO FIRST POINT TO BROADEN.
C     HOT2  =INDEX TO LAST POINT TO BROADEN.
C     YCOLD =TABLE OF SPEEDS CORRESPONDING TO XCCOLD.
C     XCCOLD =TABLE OF CROSS SECTIONS AT INITIAL TEMPERATURE.
C     DCOLD=SLOPE BETWEEN POINTS IN (YCOLD,XCCOLD) TABLE.
C     EHOT  =TABLE OF ENERGIES CORRESPONDING TO XCHOT (AND XCCOLD).
C     XCHOT =TABLE OF CROSS SECTIONS BROADENED TO TEMPK.
C     ALPHA =DOPPLER WIDTH (11505.3*AWR/TEMPEF)
C
C     THE TABLE OF POINTS (COLD1P,COLD2P) IS USED TO BROADEN THE
C     TABLE OF POINTS (HOT1,HOT2).
C
C     IF THERE ARE 180000 (3 PAGES) OR FEWER DATA POINTS ALL DOPPLER
C     BROADENED CROSS SECTIONS WILL BE CALCULATED IN ONE PASS THROUGH
C     THIS ROUTINE. IF THERE ARE OVER 180000 POINTS THE DATA WILL BE
C     DOPPLER BROADENED A PAGE AT A TIME. AN EXCEPTION IS THAT AT THE
C     BEGINNING OF THE SECTION THE FIRST TWO PAGES WILL BE BROADENED
C     IN ONE PASS AND AT THE END OF THE SECTION THE LAST TWO PAGES WILL
C     BE DOPPLER BROADENED.
C
C     NORMALLY ALL OF THE POINTS LOADED INTO CORE WILL BE USED IN THE
C     DOPPLER INTEGRATION, I.E. COLD1P=COLD1 AND COLD2P=COLD1P. HOWEVER
C     IF THE THREE PAGES OF DATA THAT ARE IN CORE CONTAIN ANY PORTION OF
C     THE UNRESOLVED RESONANCE REGION THE DOPPLER INTEGRATION WILL BE
C     CUT OFF AT THE EDGE OF THE UNRESOLVED REGION AND THE CROSS SECTION
C     WILL BE EXTENDED FROM THAT POINT AS 1/V. IN THIS CASE FOR DATA
C     POINTS AT ENERGIES LESS THAN THE UNRESOLVED RESONANCE REGION
C     COLD2P WILL POINT TO THE LOWER ENERGY LIMIT OF THE UNRESOLVED
C     REGION AND COLD1P WILL POINT TO THE FIRST POINT IN CORE. SIMILARLY
C     FOR POINTS ABOVE THE UPPER ENERGY LIMIT OF THE UNRESOLVED REGION
C     COLD1P WILL POINT TO THE UPPER ENERGY LIMIT OF THE UNRESOLVED
C     REGION AND COLD2P WILL POINT TO THE LAST POINT LOADED IN CORE.
C     WITHIN THE UNRESOLVED ENERGY RANGE THE ORIGINAL DATA POINT WILL
C     JUST BE COPIED WITHOUT DOPPLER BROADENING AND COLD1P AND COLD2P
C     ARE NOT USED.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INTEGER*4 COLD1,COLD2,COLD1P,COLD2P,HOT1,HOT2,HOT3,HOT3M1,
     1 HEATER,HIHEAT,UREVAL,UREACT,UNRES1,UNRES2,HEATM1,HEATM2,HOTEND
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/INDEX/COLD1,COLD2,COLD1P,COLD2P,HOT1,HOT2,HOT3,HOT3M1,N2IN,
     1 N2TOT,N2SCR
      COMMON/PAGER/NPAGE,NPT2,NPT3,NP1P1,NP2P1
      COMMON/HOTS/ALPHA,HOTSY1,HOTSY2,TEMPK,TEMPEF,N2TAPI,N2TAPO
      COMMON/CONTAC/OVPI,OVPI2,ATOP
      COMMON/INDICE/HEATER,LOHEAT,HIHEAT
      COMMON/EXTEND/DTMAX,MESS
      COMMON/MAXTEMP/DEMAXC,DEMAXH,DEMAXLOW,DEMAXHI
      COMMON/RESOLV/EULOW,EUHIGH,UREVAL,UREACT,UNRES1,UNRES2,IL,IH
      COMMON/OKERR3/ENER3C(21),ER3C(21),KERR3C,MAXERC
      COMMON/ERRCOM/ERRXC3,ERMINMAX,ERMT2,ERMT102,ERSOFT,XCLOW
      COMMON/SLIM/ISTART,NOTHIN,ITHIN1,ITHIN2,ITHIN3,MTEND
C-----08/20/2013 - added high energy cutoff
      COMMON/HIGHESTE/EHIGHEST,EMILLION
      INCLUDE 'sigma1.h'
      DATA SIGY  /0.0d0/
      DATA XCIHM1/0.0d0/
      DATA E1MEV /1.0d6/
      DATA ENEXT /0.0d0/
      DATA HALF  /5.0d-1/
      DATA EIHM1 /0.0d0/
C-----THERMAL ENERGY - ALWAYS KEEP
      DATA ETHERMAL/2.53d-2/
C-----01/16/04 - INITIALIZE TEMPERATURE DEPENDENT ENERGY SPACING
      ENEXT2 = 0.0d0
C-----------------------------------------------------------------------
C
C     TEST FOR CROSS SECTION EXTENSION
C
C-----------------------------------------------------------------------
C-----TEST LOWER LIMIT FOR ALL PAGES BEYOND SECOND.
      IF(HOT1.EQ.COLD1) GO TO 10
      DX=YCOLD(NP1P1)-YCOLD(1)
      IF(DX.GE.ATOP) GO TO 10
C-----DEFINE MAXIMUM ALLOWABLE TEMPERATURE CHANGE TO AVOID
C-----CROSS SECTION EXTENSION.
      DX=DX/ATOP
      DTMAX2=TEMPEF*DX*DX
      IF(DTMAX.LE.0.0d0.OR.DTMAX2.LT.DTMAX) DTMAX=DTMAX2
C-----SET FLAG TO PRINT OUT MESSAGE WITH SECTION
      MESS=2
C-----TEST UPPER LIMIT FOR ALL PAGES BUT LAST ONE.
   10 IF(HOT2.EQ.COLD2) GO TO 20
      DX=YCOLD(NPT3)-YCOLD(NPT2)
      IF(DX.GT.ATOP) GO TO 20
C-----DEFINE MAXIMUM ALLOWABLE TEMPERATURE CHANGE TO AVOID
C-----CROSS SECTION EXTENSION.
      DX=DX/ATOP
      DTMAX2=TEMPEF*DX*DX
      IF(DTMAX.LE.0.0d0.OR.DTMAX2.LT.DTMAX) DTMAX=DTMAX2
C-----SET FLAG TO PRINT OUT MESSAGE WITH SECTION
      MESS=2
C-----------------------------------------------------------------------
C
C     SET UP LOOP TO SELECT POINTS FROM WHICH TO BEGIN ITERATION.
C
C-----------------------------------------------------------------------
C-----TURN OFF BEGINNING OF ENERGY RANGE FLAG.
   20 HOTEND=0
      NLOW=HOT1
      IF(NLOW.GT.1) NLOW=NLOW-1
C-----INITIALIZE INDICES TO INTERIOR COLD POINTS IN ENERGY RANGE TO
C-----USE FOR INTEGRATION.
      LOHEAT=COLD1P+1
      HIHEAT=COLD2P-1
      DO 300 IHEAT=HOT1,HOT2
      IHEATM=IHEAT-1
C-----DEFINE COLD ENERGY AND CROSS SECTION IN SCALAR FORM.
      EIH=ECOLD(IHEAT)
      XCIH=XCCOLD(IHEAT)
C-----08/20/2013 - Copy High Energy Points (above 10 MeV).
      IF(EIH.GE.EHIGHEST) GO TO 30
C-----------------------------------------------------------------------
C
C     UNRESOLVED REGION WILL BE COPIED AND NOT BROADENED. WHEN THE
C     UPPER ENERGY LIMIT OF THE UNRESOLVED REGION IS REACHED RESET
C     INTEGRATION LIMITS TO EXTEND FROM UPPER ENERGY OF UNRESOLVED
C     REGION TO UPPER ENERGY OF DATA IN CORE.
C
C-----------------------------------------------------------------------
      IF(IHEAT.le.UNRES1) go to 50
      IF(IHEAT.eq.UNRES2) go to 40
      IF(IHEAT.gt.UNRES2) go to 50
C-----COPY POINTS WITHIN UNRESOLVED REGION.
   30 HOT3M1=HOT3
      HOT3=HOT3+1
      EHOT(HOT3)=EIH
      XCHOT(HOT3)=XCIH
C-----IF OVER 2 PAGES OF BROADENED DATA THIN IT.
      IF(HOT3.GT.NPT2) CALL THINIT
      GO TO 280
C-----UPPER LIMIT OF UNRESOLVED REGION REACHED. DEFINE RANGE OF
C-----OF INTEGRATION FROM UPPER LIMIT OF UNRESOLVED RANGE UP TO LAST
C-----POINT IN CORE.
   40 COLD1P=UNRES2
      COLD2P=COLD2
C-----RE-DEFINE INDICES TO INTERIOR COLD POINTS IN ENERGY RANGE TO
C-----USE FOR INTEGRATION.
      LOHEAT=COLD1P+1
      HIHEAT=COLD2P-1
C-----------------------------------------------------------------------
C
C     ALWAYS USE FIRST POINT AS NODE.
C
C-----------------------------------------------------------------------
C-----IS THIS FIRST POINT IN ENERGY RANGE.
   50 IF(IHEAT.NE.COLD1P) GO TO 60
C-----INITIALIZE SIGN OF SLOPE.
      DSIGNT=1.0d0
      IF(DCOLD(COLD1P).LT.0.0d0) DSIGNT=-1.0d0
C-----SET FLAG TO INDICATE BEGINNING OF ENERGY RANGE.
      HOTEND=1
      GO TO 100
C-----------------------------------------------------------------------
C
C     ALWAYS USE LAST POINT AS NODE.
C
C-----------------------------------------------------------------------
   60 IF(IHEAT.GE.HOT2.OR.IHEAT.GE.COLD2P) GO TO 100
C-----------------------------------------------------------------------
C
C     USE PRECEDING POINT IF IT WAS MAXIMUM OR MINIMUM AND ENERGY HAS
C     NOT YET BEEN USED.
C
C-----------------------------------------------------------------------
      IF(DSIGNT*DCOLD(IHEATM).GE.0.0d0) GO TO 70
      DSIGNT=-DSIGNT
C-----ONLY USE POINT IF SAME ENERGY HAS NOT YET BEEN USED.
      IF(EIHM1.le.EHOT(HOT3)) go to 290
      go to 90
C-----------------------------------------------------------------------
C
C     ONLY USE POINT IF SAME ENERGY HAS NOT YET BEEN USED (BROADENING
C     ELIMINATES ALL DISCONTINUITIES).
C
C-----------------------------------------------------------------------
   70 IF(EHOT(HOT3).GE.EIH) GO TO 290
C
C     USE ALL POINTS ABOVE 1 MEV.
C
      IF(EIH.GE.E1MEV) GO TO 100
C
C     USE ALL NON-POSITIVE CROSS SECTION POINTS.
C
      IF(XCIH.LE.0.0d0) GO TO 100
C
C     USE ALL POINTS WHERE COLD CROSS SECTION CHANGES BY MORE THAN A
C     FACTOR OF 1.5.
C
C-----01/16/04 - REDUCED FROM 2 TO 1.5
C-----           1.1 INCREASES RUNNING TIME WITHOUT IMPROVING RESULTS
      IF(XCIH.LE.1.5*SIGY.AND.SIGY.LE.1.5*XCIH) GO TO 80
C-----COLD CROSS SECTION HAS CHANGED BY FACTOR. USE EITHER CROSS
C-----SECTION OR ENERGY INTERVAL.
      IF(EIH.le.ENEXT) go to 100
      go to 110
C-----------------------------------------------------------------------
C
C     IF POINT IS NOT WITHIN ALLOWABLE ENERGY SPACING INTERPOLATE TO
C     INSERT ENERGY POINT.
C
C-----------------------------------------------------------------------
   80 IF(EIH.GT.ENEXT) GO TO 110
c-----------------------------------------------------------------------
C
C     USE AT LEAST EVERY TENTH POINT.
C
c-----------------------------------------------------------------------
C-----01/16/04 - TEMPERATURE DEEPENDENT ENERGY SPACING TEST.
      IF(EIH.GT.ENEXT2) GO TO 100
      IF((IHEAT-NLOW).GE.10) GO TO 100
c-----------------------------------------------------------------------
C
C     DO NOT USE POINT AS NODE.
C
c-----------------------------------------------------------------------
      GO TO 290
C-----------------------------------------------------------------------
C
C     DEFINE PARAMETERS AT ENERGY POINT TO BROADEN.
C
C-----------------------------------------------------------------------
C-----DEFINE BROADENED CROSS SECTION AT SAME ENERGY THAT COLD CROSS
C-----SECTION IS GIVEN (PRECEDING POINT).
   90 HOT3M1=HOT3
      HOT3=HOT3+1
      EHOT(HOT3)=EIHM1
      Y=YCOLD(IHEATM)
      SIGY=XCIHM1
      HEATM1=IHEATM
      HEATM2=IHEATM
      NHIGH=IHEATM
      GO TO 120
C-----DEFINE BROADENED CROSS SECTION AT SAME ENERGY THAT COLD CROSS
C-----SECTION IS GIVEN (CURRENT POINT).
  100 HOT3M1=HOT3
      HOT3=HOT3+1
      EHOT(HOT3)=EIH
      Y=YCOLD(IHEAT)
      SIGY=XCIH
      HEATM1=IHEAT
      HEATM2=IHEAT
      NHIGH=IHEAT
      GO TO 120
C-----DEFINE BROADENED CROSS SECTION AT ENERGY AT WHICH COLD CROSS
C-----SECTION NOT GIVEN (DEFINE CROSS SECTION BY ENERGY INTERPOLATIONS).
  110 HOT3M1=HOT3
      HOT3=HOT3+1
      EHOT(HOT3)=ENEXT
      ARG=ALPHA*EHOT(HOT3)
      Y=DSQRT(ARG)
      SIGY=((EIH-ENEXT)*XCIHM1+(ENEXT-EIHM1)*XCIH)/(EIH-EIHM1)
      HEATM1=IHEAT
      HEATM2=IHEATM
      NHIGH=IHEATM
C-----------------------------------------------------------------------
C
C     BROADEN DATA.
C
C-----------------------------------------------------------------------
C-----INITIALIZE COUNT OF SAVED DATA POINTS.
  120 ISAVE=0
C-----SELECT DOPPLER BROADENING METHOD.
      IF(Y.GT.HOTSY1) GO TO 130
      CALL BROADL(Y,SIGY,XCHOT(HOT3),HEATM1,HEATM2)
      GO TO 150
  130 IF(Y.GT.HOTSY2) GO TO 140
      CALL BROADH(Y,SIGY,XCHOT(HOT3),HEATM1,HEATM2)
      GO TO 150
  140 CALL BROADS(Y,SIGY,XCHOT(HOT3),HEATM1,HEATM2)
  150 CONTINUE
C-----CHECK FOR BEGINNING OF ENERGY RANGE (ONLY BROADEN ONE POINT AND
C-----THEN GO TO END OF LOOP TO SET UP FOR FIRST ENERGY INTERVAL).
      IF(HOTEND.GT.0) GO TO 280
c
C     DO NOT INTERPOLATE ZERO LENGTH INTERVALS.
c
  160 IF(EHOT(HOT3).LE.EHOT(HOT3M1)) GO TO 260
C-----------------------------------------------------------------------
C
C     CHECK FOR CONVERGENCE.
C
C-----------------------------------------------------------------------
C-----DO NOT INTERPOLATE IF CROSS SECTIONS AT BOTH ENDS OF INTERVAL
C-----ARE ABSOLUTELY LESS THAN MINIMUM CROSS SECTION OF INTEREST.
      IF(DABS(XCHOT(HOT3)).LT.XCLOW.AND.DABS(XCHOT(HOT3M1)).LT.XCLOW)
     1 GO TO 260
C-----------------------------------------------------------------------
C
C     PERFORM CALCULATION AT MIDPOINT.
C
C-----------------------------------------------------------------------
C-----DEFINE MID-POINT ENERGY AND SPEED-LIKE TERM.
      EMID=HALF*(EHOT(HOT3)+EHOT(HOT3M1))
C-----ROUND.
      CALL INCORE10(EMID)
c
C     DO NOT INTERPOLATE ZERO LENGTH INTERVALS.
c
      IF(EMID.LE.EHOT(HOT3M1).OR.EMID.GE.EHOT(HOT3)) GO TO 260
      ARG=ALPHA*EMID
      YMID=DSQRT(ARG)
C-----DEFINE INDICES TO ENERGY INTERVAL OR POINT.
      DO 170 NUSE=NLOW,IHEAT
      IF(YMID.lt.YCOLD(NUSE)) go to 190
      IF(YMID.eq.YCOLD(NUSE)) go to 180
  170 CONTINUE
      NUSE=IHEAT
C-----ENERGY POINT.
  180 SIGMID=XCCOLD(NUSE)
      HEATM1=NUSE
      HEATM2=NUSE
      GO TO 200
C-----ENERGY INTERVAL.
  190 HEATM1=NUSE
      HEATM2=NUSE-1
      WT1    = (ECOLD(NUSE)-EMID)/(ECOLD(NUSE)-ECOLD(HEATM2))
      WT2    = 1.0d0 - WT1
      SIGMID = WT1*XCCOLD(HEATM2) + WT2*XCCOLD(NUSE)
  200 CONTINUE
C-----SELECT BROADENING METHOD.
      IF(YMID.GT.HOTSY1) GO TO 210
      CALL BROADL(YMID,SIGMID,XCMID,HEATM1,HEATM2)
      GO TO 230
  210 IF(YMID.GT.HOTSY2) GO TO 220
      CALL BROADH(YMID,SIGMID,XCMID,HEATM1,HEATM2)
      GO TO 230
  220 CALL BROADS(YMID,SIGMID,XCMID,HEATM1,HEATM2)
C-----------------------------------------------------------------------
C
C     CHECK FOR CONVERGENCE.
C
C-----------------------------------------------------------------------
C-----DO NOT FURTHER SUB-DIVIDE ENERGY RANGES WITH NEGATIVE CROSS
C-----SECTIONS (SUCH DATA HAS NO PHYSICAL MEANING AND ADDITIONAL
C-----TIME SHOULD NOT BE SPEND ON IT).
  230 IF(XCMID.LT.0.0d0) GO TO 250
c-----Do not subdivide below low XC
      IF(DABS(XCMID).le.XCLOW) GO TO 250
C-----TO PREVENT INFINITE ITERATION TOWARD ZERO ONLY APPLY CHANGE TEST
C-----IF CROSS SECTION AT BOTH ENDS OF INTERVAL ARE POSITIVE.
      if(XCHOT(HOT3).gt.0.0d0.and.XCHOT(HOT3M1).gt.0.0d0) then
C-----NO CONVERGENCE IF CROSS SECTION CHANGES BY MORE THAN 10 PER-CENT.
C-----2001/04/16 - REDUCED FROM 1.4 TO 1.1
      IF(XCHOT(HOT3M1).GT.1.1d0*XCHOT(HOT3).OR.
     1   XCHOT(HOT3)  .GT.1.1d0*XCHOT(HOT3M1)) GO TO 240
      endif
c
c     Define linear approximation at midpoint
c
C-----DEFINE CROSS SECTION AT MID-POINT BY LINEAR INTERPOLATION.
      WT1   = (EHOT(HOT3)-EMID)/(EHOT(HOT3)-EHOT(HOT3M1))
      WT2   = 1.0d0 - WT1
      XCLIN = WT1*XCHOT(HOT3M1) + WT2*XCHOT(HOT3)
C-----IF REQUESTED, DEFINE ENERGY DEPENDENT CONVERGENCE CRITERIA.
      IF(KERR3C.NE.0) CALL ERROKC(EMID)
C-----------------------------------------------------------------------
C
C     USE MORE STRINGENT CONVERGENCE CRITERIA IF ITERATING
C     TOWARD MINIMUM OR MAXIMUM CROSS SECTION.
C
C-----------------------------------------------------------------------
c
c     Low XC Test
c
      if(DABS(XCMID).le.XCLOW) go to 250
c
c     Above XCLOW - Approaching Max or Min
c
C-----MINIMUM...XCMID < XCHOT(HOT3) and XCHOT(HOT3M1)
      IF(XCMID.lt.XCHOT(HOT3).and.XCMID.lt.XCHOT(HOT3M1)) then
      IF(DABS(XCMID-XCLIN).LE.DABS(ERMINMAX*XCMID)) GO TO 250
      go to 240
      endif
C-----MAXIMUM...XCMID > XCHOT(HOT3) and XCHOT(HOT3M1)
      IF(XCMID.gt.XCHOT(HOT3).and.XCMID.gt.XCHOT(HOT3M1)) then
      IF(DABS(XCMID-XCLIN).LE.DABS(ERMINMAX*XCMID)) GO TO 250
      go to 240
      endif
c
C     STANDARD LINEAR INTERPOLATION.
c
      IF(DABS(XCMID-XCLIN).LE.DABS(ERRXC3*XCMID)) GO TO 250
c
C     NO CONVERGENCE. SAVE POINT AND HALF INTERVAL.
c
  240 IF(ISAVE.LT.MAXSAVE) ISAVE=ISAVE+1
      ESAVE(ISAVE)=EHOT(HOT3)
      XCSAVE(ISAVE)=XCHOT(HOT3)
      EHOT(HOT3)=EMID
      XCHOT(HOT3)=XCMID
      GO TO 160
c
C     CONVERGENCE. IF THINNING WILL BE PERFORMED SAVE MIDPOINT AND
c     END POINT. IF NO THINNING ONLY SAVE END POINT.
c
  250 IF(NOTHIN.GT.0) GO TO 260
      EHOT(HOT3+1)=EHOT(HOT3)
      XCHOT(HOT3+1)=XCHOT(HOT3)
      EHOT(HOT3)=EMID
      XCHOT(HOT3)=XCMID
      HOT3M1=HOT3
      HOT3=HOT3+1
C-----CONVERGENCE. IF OVER 2 PAGES OF BROADENED DATA THIN IT.
  260 IF(HOT3.GT.NPT2) CALL THINIT
C-----IF END OF INTERVAL PROCEED TO NEXT INTERVAL. OTHERWISE USE LAST
C-----POINT GENERATED.
      IF(ISAVE.LE.0) GO TO 270
c-----2020/12/26 - Only increasing energies
      if(ESAVE(ISAVE).le.EHOT(HOT3)) then
      ISAVE=ISAVE-1
      GO TO 160
      endif
      HOT3M1=HOT3
      HOT3=HOT3+1
      EHOT(HOT3)=ESAVE(ISAVE)
      XCHOT(HOT3)=XCSAVE(ISAVE)
      ISAVE=ISAVE-1
      GO TO 160
C-----END OF INTERVAL. SET UP FOR NEXT INTERVAL BY PLACING END OF LAST
C-----INTERVAL AT BEGINNING OF NEXT INTERVAL.
  270 NLOW=HEATM1
      ENEXT=DEMAXH*EHOT(HOT3)
C-----01/16/04 - DEFINE SPACING FOR TEMPERATURE DEPENDENT TEST.
      ENEXT2 = DSQRT(ALPHA*EHOT(HOT3)) + ATOP
      ENEXT2 = ENEXT2**2/ALPHA
C-----RELAX ENERGY STEP ABOVE 1 EV.
      IF(EHOT(HOT3).GE.1.0d0) DEMAXH=DEMAXHI
C-----------------------------------------------------------------------
C
C     INSERT THERMAL POINT BY SETTING ENEXT = ETHERMAL
C     WHEN THERMAL ENERGY IS CROSSED.
C
C-----------------------------------------------------------------------
      IF(EHOT(HOT3).LT.ETHERMAL.AND.
     1   ENEXT     .GT.ETHERMAL) ENEXT=ETHERMAL
C-----CONTINUE IN LOOP IF PRECEDING (NOT CURRENT) POINT WAS USED OR
C-----IF STILL ITERATING IN ENERGY RANGE DUE TO ENERGY POINT SPACING.
      IF(NHIGH.NE.IHEAT) GO TO 70
C-----DEFINE BEGINNING OF NEXT TABULATED ENERGY INTERVAL.
  280 HOTEND=0
      NLOW=IHEAT
      SIGY=XCIH
      ENEXT=DEMAXH*EHOT(HOT3)
C-----RELAX ENERGY STEP ABOVE 1 EV.
      IF(EHOT(HOT3).GE.1.0d0) DEMAXH=DEMAXHI
C-----------------------------------------------------------------------
C
C     INSERT THERMAL POINT BY SETTING ENEXT = ETHERMAL
C     WHEN THERMAL ENERGY IS CROSSED.
C
C-----------------------------------------------------------------------
      IF(EHOT(HOT3).LT.ETHERMAL.AND.
     1   ENEXT     .GT.ETHERMAL) ENEXT=ETHERMAL
C-----SAVE LAST COLD ENERGY AND CROSS SECTION.
  290 EIHM1=EIH
      XCIHM1=XCIH
  300 CONTINUE
      RETURN
      END
      SUBROUTINE BROADL(Y,SIGY,XCY,HEATM1,HEATM2)
C=======================================================================
C
C     LOW ENERGY DOPPLER BROADENING ROUTINE. THIS ROUTINE WILL
C     BE USED TO DOPPLER BROADEN ALL CROSS SECTIONS AT ENERGIES
C     WHERE AE/KT IS LESS THAN OR EQUAL TO 16. ANY POINT WITH A
C     HIGHER ENERGY WILL BE PASSED ON TO ROUTINE BROADH.
C
C     FOR AE/KT LESS THAN OR EQUAL TO 16 BOTH EXPONENTIALS IN THE
C     DOPPLER BROADENING KERNEL MUST BE CONSIDERED. FOR HIGHER ENERGIES
C     THE SECOND EXPONENTIAL MAY BE IGNORED, WHICH SIMPLIFIES THE
C     DOPPLER BROADENING.
C
C     THE ROUTINE HAS BEEN DESIGNED WITH NO SUBROUTINE CALLS
C     IN ORDER TO MINIMIZE RUNNING TIME. THE ARITHMETIC
C     STATEMENT FUNCTIONS RATION(A) AND ERFC(R,EXPERF) WILL
C     BE COMPILED AS IN LINE CODING BY VIRTUALLY ANY FORTRAN
C     COMPILER, AND AS SUCH DO NOT REPRESENT FUNCTION CALLS.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INTEGER*4 COLD1,COLD2,COLD1P,COLD2P,HOT1,HOT2,HEATER,HIHEAT,
     1 HEATM1,HEATM2,HOT3,HOT3M1
      COMMON/INDEX/COLD1,COLD2,COLD1P,COLD2P,HOT1,HOT2,HOT3,HOT3M1,N2IN,
     1 N2TOT,N2SCR
      COMMON/CONTAC/OVPI,OVPI2,ATOP
      COMMON/INDICE/HEATER,LOHEAT,HIHEAT
      INCLUDE 'sigma1.h'
      DATA ZERO/0.0d0/
      DATA HALF/0.5d0/
      DATA ONE /1.0d0/
      DATA TWO /2.0d0/
      DATA FOUR/4.0d0/
C-----------------------------------------------------------------------
C
C     SET UP LOOP TO DOPPLER BROADEN CROSS SECTIONS.
C
C-----------------------------------------------------------------------
C-----DEFINE ALL REQUIRED CONSTANTS FOR POINT.
      Y2=Y+Y
      YY=Y*Y
      YYA=YY+HALF
C-----INITIALIZE INTEGRALS.
      DUMMY1=ZERO
      IF(Y2.LE.ATOP) GO TO 10
      EXPY2=ZERO
      ERFCY2=ZERO
      GO TO 20
   10 EXPY2=DEXP(-Y2*Y2)
      IX2 = 1.0d3*Y2
      Z = Y2 - ERFCX(IX2)
      ERFCY2 = EXPY2*(((F3(IX2)*Z+F2(IX2))*Z+F1(IX2))*Z+F0(IX2))
C-----------------------------------------------------------------------
C
C     INTEGRATE OVER ALL ENERGY INTERVALS ABOVE CURRENT ENERGY POINT.
C
C-----------------------------------------------------------------------
C-----INITIALIZE
   20 F2A=YYA*(ONE-ERFCY2)+OVPI2*Y
      SIGA=SIGY
C-----SET UP LOOP OVER INTERVALS ABOVE CURRENT ONE + 1 (FOR EXTENSION)
      DO 60 HEATER=HEATM2,HIHEAT+1
C-----EXTEND AS CONSTANT
      IF(HEATER.GT.HIHEAT) THEN
      B=Y+ATOP
      BMY=ATOP
      SIGB=SIGA
      ELSE
C-----USE TABULATED INTERVAL
      B=YCOLD(HEATER+1)
      SIGB=XCCOLD(HEATER+1)
C-----ONLY EXTEND RANGE OF INTEGRATION UP TO ATOP UNITS ABOVE Y.
      BMY=B-Y
      IF(BMY.LE.ATOP) GO TO 30
      XXA=YCOLD(HEATER)**2
      XXB=B*B
      BMY=ATOP
      B=Y+ATOP
      BS=B*B
      SIGB=((BS-XXB)*SIGA+(XXA-BS)*SIGB)/(XXA-XXB)
      ENDIF
C-----DEFINE CONTRIBUTION OF FIRST INTEGRAL.
   30 EXPBM=DEXP(-BMY*BMY)
      IX2 = 1.0d3*BMY
      Z = BMY - ERFCX(IX2)
      ERFCBM = EXPBM*(((F3(IX2)*Z+F2(IX2))*Z+F1(IX2))*Z+F0(IX2))
C-----DEFINE CONTRIBUTION OF SECOND INTEGRAL.
      BPY=B+Y
      IF(BPY.LE.ATOP) GO TO 40
      EXPBP=ZERO
      ERFCBP=ZERO
      F2B=YYA*ERFCBM+OVPI*BPY*EXPBM
      GO TO 50
   40 EXPBP=DEXP(-BPY*BPY)
      IX2 = 1.0d3*BPY
      Z = BPY - ERFCX(IX2)
      ERFCBP = EXPBP*(((F3(IX2)*Z+F2(IX2))*Z+F1(IX2))*Z+F0(IX2))
C-----ADD CONTRIBUTION FROM CURRENT INTERVAL.
      F2B=YYA*(ERFCBM-ERFCBP)+OVPI*(B*(EXPBM-EXPBP)+Y*(EXPBM+EXPBP))
   50 DUMMY1=DUMMY1+(SIGA+SIGB)*(F2A-F2B)
C-----TEST FOR END OF RANGE OF INTEGRATION.
      IF(BMY.GE.ATOP) GO TO 70
C-----SAVE VALUES FROM LAST INTEGRAL.
      F2A=F2B
      SIGA=SIGB
   60 CONTINUE
C-----------------------------------------------------------------------
C
C     INTEGRATE OVER ALL ENERGY INTERVALS BELOW CURRENT ENERGY POINT.
C
C-----------------------------------------------------------------------
C-----NO INTERVALS BELOW FIRST POINT.
   70 IF(HEATM1.LE.COLD1P) GO TO 120
C-----RE-INITIALIZE INTEGRALS TO ZERO DISTANCE VALUES
      F2B=YYA*(ONE+ERFCY2)-OVPI2*Y
      SIGB=SIGY
C-----SET UP LOOP OVER INTERVALS BELOW CURRENT POINT.
      HEATER=HEATM1
      DO 110 LL=LOHEAT,HEATM1
      HEATER=HEATER-1
      A=YCOLD(HEATER)
      SIGA=XCCOLD(HEATER)
C-----ONLY EXTEND RANGE OF INTEGRATION DOWN TO ATOP UNITS BELOW Y.
      YMA=Y-A
      IF(YMA.LE.ATOP) GO TO 80
      XXB=YCOLD(HEATER+1)**2
      XXA=A*A
      YMA=ATOP
      A=Y-ATOP
      AS=A*A
      SIGA=((AS-XXB)*SIGA+(XXA-AS)*SIGB)/(XXA-XXB)
C-----DEFINE CONTRIBUTION OF FIRST INTEGRAL.
   80 EXPAM=DEXP(-YMA*YMA)
      IX2 = 1.0d3*YMA
      Z = YMA - ERFCX(IX2)
      ERFCAM = EXPAM*(((F3(IX2)*Z+F2(IX2))*Z+F1(IX2))*Z+F0(IX2))
C-----DEFINE CONTRIBUTION OF SECOND INTEGRAL.
      YPA=Y+A
      IF(YPA.LE.ATOP) GO TO 90
      EXPAP=ZERO
      ERFCAP=ZERO
      F2A=YYA*ERFCAM-OVPI*YPA*EXPAM
      GO TO 100
   90 EXPAP=DEXP(-YPA*YPA)
      IX2 = 1.0d3*YPA
      Z = YPA - ERFCX(IX2)
      ERFCAP = EXPAP*(((F3(IX2)*Z+F2(IX2))*Z+F1(IX2))*Z+F0(IX2))
C-----ADD CONTRIBUTION FROM CURRENT INTERVAL.
      F2A=YYA*(ERFCAM+ERFCAP)-OVPI*(A*(EXPAM-EXPAP)+Y*(EXPAM+EXPAP))
  100 DUMMY1=DUMMY1+(SIGA+SIGB)*(F2B-F2A)
C-----TEST FOR END OF RANGE OF INTEGRATION.
      IF(YMA.GE.ATOP) GO TO 130
C-----SAVE VALUES FROM LAST INTEGRAL.
      F2B=F2A
      SIGB=SIGA
  110 CONTINUE
c-----------------------------------------------------------------------
C
C     CROSS SECTION EXTENSION AS 1/V BELOW TABULATED ENERGY RANGE.
C
c-----------------------------------------------------------------------
C-----CONTINUE CROSS SECTION AS 1/V FROM 0 TO GENERAL LOWER LIMIT
      ADDER =       XCCOLD(COLD1P)*YCOLD(COLD1P)*TWO*
     1 (Y*(ERFCAM-ERFCAP)-OVPI*(EXPAM-EXPAP))
      IF(ADDER.GT.0.0d0) DUMMY1 = DUMMY1 + ADDER
      GO TO 130
C-----Y IS AT LOWER END OF TABULATED RANGE. CONTINUE CROSS SECTION AS
C-----1/V FROM 0 TO LOWER LIMIT Y.
C-----CONTINUE CROSS SECTION AS 1/V TO YCOLD=0.0
  120 ADDER =       XCCOLD(COLD1P)*YCOLD(COLD1P)*TWO*
     1 (Y*(ONE-ERFCY2)-OVPI*(ONE-EXPY2))
      IF(ADDER.GT.0.0d0) DUMMY1 = DUMMY1 + ADDER
C-----------------------------------------------------------------------
C
C     DEFINE BROADENED CROSS SECTION.
C
C-----------------------------------------------------------------------
  130 XCY=DUMMY1/(FOUR*YY)
      RETURN
      END
      SUBROUTINE BROADH(Y,SIGY,XCY,HEATM1,HEATM2)
C=======================================================================
C
C     HIGH ENERGY DOPPLER BROADENING ROUTINE. THIS ROUTINE WILL
C     BE USED TO DOPPLER BROADEN ALL CROSS SECTIONS AT ENERGIES
C     WHERE AE/KT IS GREATER THAN 16. ANY POINT WITH A LOWER
C     ENERGY WILL ALREADY HAVE BEEN DOPPLER BROADENED BY
C     ROUTINE BROADL.
C
C     FOR AE/KT LESS THAN OR EQUAL TO 16 BOTH EXPONENTIALS IN THE
C     DOPPLER BROADENING KERNEL MUST BE CONSIDERED. FOR HIGHER ENERGIES
C     THE SECOND EXPONENTIAL MAY BE IGNORED, WHICH SIMPLIFIES THE
C     DOPPLER BROADENING.
C
C     THE ROUTINE HAS BEEN DESIGNED WITH NO SUBROUTINE CALLS
C     IN ORDER TO MINIMIZE RUNNING TIME. THE ARITHMETIC
C     STATEMENT FUNCTIONS RATION(A) AND ERFC(R,EXPERF) WILL
C     BE COMPILED AS IN LINE CODING BY VIRTUALLY ANY FORTRAN
C     COMPILER, AND AS SUCH DO NOT REPRESENT FUNCTION CALLS.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INTEGER*4 COLD1,COLD2,COLD1P,COLD2P,HOT1,HOT2,HEATER,HIHEAT,
     1 HEATM1,HEATM2,HOT3,HOT3M1
      COMMON/INDEX/COLD1,COLD2,COLD1P,COLD2P,HOT1,HOT2,HOT3,HOT3M1,N2IN,
     1 N2TOT,N2SCR
      COMMON/CONTAC/OVPI,OVPI2,ATOP
      COMMON/INDICE/HEATER,LOHEAT,HIHEAT
      INCLUDE 'sigma1.h'
      DATA ZERO  /0.0d0/
      DATA HALF  /0.5d0/
      DATA QUART3/0.75d0/
      DATA ONEP5 /1.5d0/
      DATA TWO   /2.0d0/
      DATA TWOP5 /2.5d0/
C-----------------------------------------------------------------------
C
C     SET UP LOOP TO DOPPLER BROADEN CROSS SECTIONS.
C
C-----------------------------------------------------------------------
C-----DEFINE ALL REQUIRED CONSTANTS FOR POINT.
      YY=Y*Y
      YYA=YY+HALF
      YYB=TWOP5*YY+QUART3
      YYC=OVPI2*Y
      YYD=YYC*(YY+TWO)
C-----INITIALIZE INTEGRALS.
      DUMMY1=ZERO
      DUMMY2=ZERO
C-----------------------------------------------------------------------
C
C     INTEGRATE OVER ALL ENERGY INTERVALS ABOVE CURRENT ENERGY POINT.
C
C-----------------------------------------------------------------------
C-----INITIALIZE INTEGRALS.
      A=Y
      SIGA=SIGY
      F2A=YYA+YYC
      F4A=YYB+YYD
C-----SET UP LOOP OVER INTERVALS ABOVE CURRENT ONE + 1 (FOR EXTENSION).
      DO 20 HEATER=HEATM2,HIHEAT+1
      IF(HEATER.GT.HIHEAT) THEN
      BMY=ATOP
      B=Y+ATOP
      ELSE
      B=YCOLD(HEATER+1)
      BMY=B-Y
C-----ONLY EXTEND RANGE OF INTEGRATION UP TO ATOP UNITS ABOVE Y.
      IF(BMY.LE.ATOP) GO TO 10
      BMY=ATOP
      B=Y+ATOP
      ENDIF
C-----DEFINE CONSTANTS FOR THIS POINT.
   10 BB1P5=B*B+ONEP5
      BPY=B+Y
      EXPBM=DEXP(-BMY*BMY)
      IX2 = 1.0d3*BMY
      Z = BMY - ERFCX(IX2)
      ERFCBM = EXPBM*(((F3(IX2)*Z+F2(IX2))*Z+F1(IX2))*Z+F0(IX2))
      F2B=YYA*ERFCBM+OVPI*BPY*EXPBM
      YYMAA=(Y-A)*(Y+A)
C-----ADD CONTRIBUTION FROM CURRENT INTERVAL.
      DUMMY1=DUMMY1+SIGA*(F2A-F2B)
      IF(HEATER.LE.HIHEAT) THEN
      F4B=(YYA*YYMAA+YYB)*ERFCBM+OVPI*(BPY*(BB1P5+YYMAA)+Y)*EXPBM
      DUMMY2=DUMMY2+DCOLD(HEATER)*(F4A-F4B)
      ENDIF
C-----TEST FOR END OF RANGE OF INTEGRATION.
      IF(BMY.GE.ATOP) GO TO 30
C-----SAVE VALUES FROM LAST INTERGAL.
      A=B
      SIGA=XCCOLD(HEATER+1)
      F2A=F2B
      YYMAA=(Y-A)*(Y+A)
      F4A=(YYA*YYMAA+YYB)*ERFCBM+OVPI*(BPY*(BB1P5+YYMAA)+Y)*EXPBM
   20 CONTINUE
C-----------------------------------------------------------------------
C
C     INTEGRATE OVER ALL ENERGY INTERVALS BELOW CURRENT ENERGY POINT.
C
C-----------------------------------------------------------------------
C-----NO INTERVALS BELOW CURRENT FIRST POINT.
   30 IF(HEATM1.LE.COLD1P) GO TO 60
C-----RE-INITIALIZE INTEGRALS TO ZERO DISTANCE VALUES
      B=Y
      SIGB=SIGY
      F2B=YYA-YYC
      F4B=YYB-YYD
C-----SET UP LOOP OVER INTERVALS BELOW CURRENT POINT.
      HEATER=HEATM1
      DO 50 LL=LOHEAT,HEATM1
      HEATER=HEATER-1
      A=YCOLD(HEATER)
      YMA=Y-A
C-----ONLY EXTEND RANGE OF INTEGRATION DOWN TO ATOP UNITS BELOW Y.
      IF(YMA.LE.ATOP) GO TO 40
      YMA=ATOP
      A=Y-ATOP
C-----DEFINE CONSTANTS FOR THIS POINT.
   40 AA1P5=A*A+ONEP5
      YPA=Y+A
      EXPAM=DEXP(-YMA*YMA)
      IX2 = 1.0d3*YMA
      Z = YMA - ERFCX(IX2)
      ERFCAM = EXPAM*(((F3(IX2)*Z+F2(IX2))*Z+F1(IX2))*Z+F0(IX2))
      F2A=YYA*ERFCAM-OVPI*YPA*EXPAM
      YYMBB=(Y-B)*(Y+B)
      F4A=(YYA*YYMBB+YYB)*ERFCAM-OVPI*(YPA*(AA1P5+YYMBB)+Y)*EXPAM
C-----ADD CONTRIBUTION FROM CURRENT INTERVAL.
      DUMMY1=DUMMY1+SIGB*(F2B-F2A)
      DUMMY2=DUMMY2+DCOLD(HEATER)*(F4B-F4A)
C-----TEST FOR END OF RANGE OF INTEGRATION.
      IF(YMA.GE.ATOP) GO TO 70
C-----SAVE VALUES FROM LAST INTEGRAL.
      B=A
      SIGB=XCCOLD(HEATER)
      F2B=F2A
      YYMBB=(Y-B)*(Y+B)
      F4B=(YYA*YYMBB+YYB)*ERFCAM-OVPI*(YPA*(AA1P5+YYMBB)+Y)*EXPAM
   50 CONTINUE
c-----------------------------------------------------------------------
C
C     EXTEND CROSS SECTION AS 1/V BELOW TABULATED ENERGY RANGE
C
c-----------------------------------------------------------------------
C-----CONTINUE CROSS SECTION AS 1/V FROM 0 TO GENERAL LOWER LIMIT
      ADDER =       XCCOLD(COLD1P)*YCOLD(COLD1P)*(Y*ERFCAM-OVPI*EXPAM)
      IF(ADDER.GT.0.0d0) DUMMY1 = DUMMY1 + ADDER
      GO TO 70
C-----Y IS AT LOWER END OF TABULATED RANGE. CONTINUE CROSS SECTION AS
C-----1/V FROM 0 TO LOWER LIMIT Y
   60 ADDER =       XCCOLD(COLD1P)*YCOLD(COLD1P)*(Y-OVPI)
      IF(ADDER.GT.0.0d0) DUMMY1 = DUMMY1 + ADDER
C-----------------------------------------------------------------------
C
C     DEFINE BROADENED CROSS SECTION.
C
C-----------------------------------------------------------------------
   70 XCY=HALF*(DUMMY1+DUMMY2)/YY
      RETURN
      END
      SUBROUTINE BROADS(Y,SIGY,XCY,HEATM1,HEATM2)
C=======================================================================
C
C     HIGH ENERGY DOPPLER BROADENING ROUTINE. THIS ROUTINE WILL
C     BE USED TO DOPPLER BROADEN ALL CROSS SECTIONS AT ENERGIES
C     WHERE AE/KT IS GREATER THAN ONE MILLION. ANY POINT WITH A LOWER
C     ENERGY WILL ALREADY HAVE BEEN DOPPLER BROADENED BY ROUTINE
C     BROADL OR BROADH.
C
C     FOR AE/KT LESS THAN OR EQUAL TO 16 BOTH EXPONENTIALS IN THE
C     DOPPLER BROADENING KERNEL MUST BE CONSIDERED. FOR HIGHER ENERGIES
C     THE SECOND EXPONENTIAL MAY BE IGNORED, WHICH SIMPLIFIES THE
C     DOPPLER BROADENING.
C
C     FOR AE/KT GREATER THAN 1,000,000 IT IS POSSIBLE TO ASSUME THE
C     TERM (X/Y)**2 IN THE DOPPLER INTEGRAL IS JUST UNITY (SINCE X ONLY
C     VARIES FROM Y-4 TO Y+4, FOR Y GREATER THAN 1000 THIS TERM IS
C     ESSENTIALLY CONSTANT SINCE IT VARIES FROM (996/1000)**2 TO
C     (1004/1000)**2.= 1.0 +/- 0.008.
C
C     THE ROUTINE HAS BEEN DESIGNED WITH NO SUBROUTINE CALLS
C     IN ORDER TO MINIMIZE RUNNING TIME. THE ARITHMETIC
C     STATEMENT FUNCTIONS RATION(A) AND ERFC(R,EXPERF) WILL
C     BE COMPILED AS IN LINE CODING BY VIRTUALLY ANY FORTRAN
C     COMPILER, AND AS SUCH DO NOT REPRESENT FUNCTION CALLS.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INTEGER*4 COLD1,COLD2,COLD1P,COLD2P,HOT1,HOT2,HEATER,HIHEAT,
     1 HEATM1,HEATM2,HOT3,HOT3M1
      COMMON/INDEX/COLD1,COLD2,COLD1P,COLD2P,HOT1,HOT2,HOT3,HOT3M1,N2IN,
     1 N2TOT,N2SCR
      COMMON/CONTAC/OVPI,OVPI2,ATOP
      COMMON/INDICE/HEATER,LOHEAT,HIHEAT
      INCLUDE 'sigma1.h'
      DATA ZERO /0.0d0/
      DATA HALF /0.5d0/
      DATA ONE  /1.0d0/
      DATA TWOP5/2.5d0/
C-----------------------------------------------------------------------
C
C     SET UP LOOP TO DOPPLER BROADEN CROSS SECTIONS.
C
C-----------------------------------------------------------------------
C-----DEFINE ALL REQUIRED CONSTANTS FOR POINT.
      YY = Y*Y
      YYA=OVPI2*Y
C-----INITIALIZE INTEGRALS.
      DUMMY1=ZERO
      DUMMY2=ZERO
C-----------------------------------------------------------------------
C
C     INTEGRATE OVER ALL ENERGY INTERVALS ABOVE CURRENT ENERGY POINT.
C
C-----------------------------------------------------------------------
C-----INITIALIZE INTEGRALS.
      A=Y
      SIGA=SIGY
      ERFCAM=ONE
      F4A=TWOP5+YYA
C-----SET UP LOOP OVER INTERVALS ABOVE CURRENT ONE + 1 (FOR EXTENSION)
      DO 20 HEATER=HEATM2,HIHEAT+1
      IF(HEATER.GT.HIHEAT) THEN
C-----EXTEND AS CONSATANT
      BMY=ATOP
      B=Y+ATOP
      ELSE
C-----USE TABULATED INTERVAL
      B=YCOLD(HEATER+1)
      BMY=B-Y
C-----ONLY EXTEND RANGE OF INTEGRATION UP TO ATOP UNITS ABOVE Y.
      IF(BMY.LE.ATOP) GO TO 10
      BMY=ATOP
      B=Y+ATOP
      ENDIF
C-----DEFINE CONSTANTS FOR THIS POINT.
   10 EXPBM=DEXP(-BMY*BMY)
      IX2 = 1.0d3*BMY
      Z = BMY - ERFCX(IX2)
      ERFCBM = EXPBM*(((F3(IX2)*Z+F2(IX2))*Z+F1(IX2))*Z+F0(IX2))
C-----ADD CONTRIBUTION FROM CURRENT INTERVAL.
      F2B=OVPI*(B+Y)*EXPBM
      DUMMY1=DUMMY1+SIGA*(ERFCAM-ERFCBM)
      IF(HEATER.LE.HIHEAT) THEN
      F4B=((Y-A)*(Y+A)+TWOP5)*ERFCBM+F2B
      DUMMY2=DUMMY2+DCOLD(HEATER)*(F4A-F4B)
      ENDIF
C-----TEST FOR END OF RANGE OF INTEGRATION.
      IF(BMY.GE.ATOP) GO TO 30
C-----SAVE VALUES FROM LAST INTERGAL.
      A=B
      SIGA=XCCOLD(HEATER+1)
      ERFCAM=ERFCBM
      F4A=((Y-A)*(Y+A)+TWOP5)*ERFCBM+F2B
   20 CONTINUE
C-----------------------------------------------------------------------
C
C     INTEGRATE OVER ALL ENERGY INTERVALS BELOW CURRENT ENERGY POINT.
C
C-----------------------------------------------------------------------
C-----NO INTERVALS BELOW CURRENT FIRST POINT.
   30 IF(HEATM1.LE.COLD1P) GO TO 60
C-----RE-INITIALIZE INTEGRALS TO ZERO DISTANCE VALUES
      B=Y
      SIGB=SIGY
      ERFCBM=ONE
      F4B=TWOP5-YYA
C-----SET UP LOOP OVER INTERVALS BELOW CURRENT POINT.
      HEATER=HEATM1
      DO 50 LL=LOHEAT,HEATM1
      HEATER=HEATER-1
      A=YCOLD(HEATER)
      YMA=Y-A
C-----ONLY EXTEND RANGE OF INTEGRATION DOWN TO ATOP UNITS BELOW Y.
      IF(YMA.LE.ATOP) GO TO 40
      YMA=ATOP
      A=Y-ATOP
C-----DEFINE CONSTANTS FOR THIS POINT.
   40 EXPAM=DEXP(-YMA*YMA)
      IX2 = 1.0d3*YMA
      Z = YMA - ERFCX(IX2)
      ERFCAM = EXPAM*(((F3(IX2)*Z+F2(IX2))*Z+F1(IX2))*Z+F0(IX2))
      F2A=OVPI*(Y+A)*EXPAM
      F4A=((Y-B)*(Y+B)+TWOP5)*ERFCAM-F2A
C-----ADD CONTRIBUTION FROM CURRENT INTERVAL.
      DUMMY1=DUMMY1+SIGB*(ERFCBM-ERFCAM)
      DUMMY2=DUMMY2+DCOLD(HEATER)*(F4B-F4A)
C-----TEST FOR END OF RANGE OF INTEGRATION.
      IF(YMA.GE.ATOP) GO TO 70
C-----SAVE VALUES FROM LAST INTEGRAL.
      B=A
      SIGB=XCCOLD(HEATER)
      ERFCBM=ERFCAM
      F4B=((Y-B)*(Y+B)+TWOP5)*ERFCAM-F2A
   50 CONTINUE
c-----------------------------------------------------------------------
C
C     CONTINUE CROSS SECTION AT 1/V BELOW TABULATED ENERGY RANGE.
C
c-----------------------------------------------------------------------
C-----CONTINUE CROSS SECTION AS 1/V FROM 0 TO GENERAL LOWER LIMIT
      ADDER = XCCOLD(COLD1P)*YCOLD(COLD1P)*(Y*ERFCAM-OVPI*EXPAM)/YY
      IF(ADDER.GT.0.0d0) DUMMY1 = DUMMY1 + ADDER
      GO TO 70
C-----Y IS AT LOWER END OF TABULATED RANGE. CONTINUE CROSS SECTION AS
C-----1/V FROM 0 TO LOWER LIMIT Y
   60 ADDER =       XCCOLD(COLD1P)*YCOLD(COLD1P)*(Y-OVPI)/YY
      IF(ADDER.GT.0.0d0) DUMMY1 = DUMMY1 + ADDER
C-----------------------------------------------------------------------
C
C     DEFINE BROADENED CROSS SECTION.
C
C-----------------------------------------------------------------------
   70 XCY=HALF*(DUMMY1+DUMMY2)
      RETURN
      END
      SUBROUTINE THINIT
C=======================================================================
C
C     GIVEN A FUNCTION REPRESENTED BY A TABLE OF ENERGIES EHOT AND
C     CROSS SECTIONS XCHOT AND LINEAR-LINEAR INTERPOLATION BETWEEN
C     TABULATED POINTS, THIS ROUTINE WILL REMOVE ALL EXTRANEOUS
C     POINTS THAT LIE WITHIN A GIVEN ACCURACY OF THE FUNCTION BASED
C     UPON INTERPOLATION FROM THE SURROUNDING POINTS.
C
C     DURING ONE PASS THIS ROUTINE WILL THIN ANY UNCONVERGED POINTS
C     FROM THE LAST BROADENED PAGE PLUS THE CURRENT BROADENED PAGE.
C     AT THE END OF THE CURRENT PAGE THE LAST CONVERGED POINT AND ALL
C     UNCONVERGED POINTS WILL BE LEFT IN THE CORE TO BE THINNED WITH
C     THE NEXT PAGE (UNLESS THE END OF THE TABLE IS REACHED IN WHICH
C     CASE THE LAST POINT IS CONVERGED). IF THERE IS MORE THAN A FULL
C     PAGE OF THINNED POINTS IT WILL BE COPIED TO SCRATCH AND ALL
C     REMAINING POINTS WILL BE SHIFTED FORWARD ONE PAGE IN THE DOPPLER
C     BROADENED DATA PAGES.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INTEGER*4 OUTP,OTAPE,SCR,COLD1,COLD2,COLD1P,COLD2P,HOT1,HOT2,HOT3,
     1 HOT3M1,UREVAL,UREACT,UNRES1,UNRES2,TOOHI
      CHARACTER*1 FIELD6
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/UNITS/SCR
      COMMON/INDEX/COLD1,COLD2,COLD1P,COLD2P,HOT1,HOT2,HOT3,HOT3M1,N2IN,
     1 N2TOT,N2SCR
      COMMON/PAGER/NPAGE,NPT2,NPT3,NP1P1,NP2P1
      COMMON/OKERRT/ENER3T(21),ER3T(21),KERR3T,MAXERT
      COMMON/ERRCOT/ERXC3T
      COMMON/SLIM/ISTART,NOTHIN,ITHIN1,ITHIN2,ITHIN3,MTEND
      COMMON/IWATCH/MONITR,MAKEPLUS,MYUNRES
      COMMON/RESOLV/EULOW,EUHIGH,UREVAL,UREACT,UNRES1,UNRES2,IL,IH
      COMMON/FILLER/N2LEFT,TOOHI,ITHRES,LOAD1,LOAD2
      COMMON/FIELDC/FIELD6(11,6)
      COMMON/HIGHESTE/EHIGHEST,EMILLION
      INCLUDE 'sigma1.h'
      DATA IMUSED/0/
C-----THERMAL ENERGY - ALWAYS KEEP
      DATA ETHERMAL/2.53D-02/
C-----------------------------------------------------------------------
C
C     IF MAXIMUM ALLOWABLE ERROR IS NOT POSITIVE NO THINNING CAN BE
C     PERFORMED ON THE TABLE. DO NOT THIN REACTIONS (MT) THAT WERE
C     NOT BROADENED.
C
C-----------------------------------------------------------------------
      IF(NOTHIN.LE.0.AND.TOOHI.LE.0) GO TO 10
C-----NO THINNING. SET THINNED POINT INDEX TO LAST BROADENED POINT.
      ITHIN1=HOT3
      GO TO 190
C-----------------------------------------------------------------------
C
C     THINNING WILL BE PERFORMED.
C
C-----------------------------------------------------------------------
C-----IF NO POINTS FOR THINNING SKIP TO END OF THINNING SECTION.
   10 IF(ITHIN2.GT.HOT3) GO TO 180
C-----------------------------------------------------------------------
C
C     INITIALIZE SIGN OF DERIVATIVE AT BEGINNING OF SECTION.
C
C-----------------------------------------------------------------------
      IF(ISTART.le.0) go to 20
      ISTART=0
      DSIGNT=1.0d0
      IF(XCHOT(1).GT.XCHOT(2)) DSIGNT=-1.0d0
C-----------------------------------------------------------------------
C
C     SET UP LOOP OVER BROADENED POINTS.
C
C-----------------------------------------------------------------------
   20 DO 170 M=ITHIN2,HOT3
      MM1=M-1
      DXC=XCHOT(M)-XCHOT(MM1)
C-----------------------------------------------------------------------
C
C     KEEP ALL MAXIMA AND MINIMA.
C
C-----------------------------------------------------------------------
C-----PRECEDING POINT WAS MAXIMUM OR MINIMUM IF SIGN OF CHANGE IN
C-----CROSS SECTION HAS REVERSED.
      IF(DXC*DSIGNT.ge.0.0d0) go to 30
      DSIGNT=-DSIGNT
C-----IF ENERGIES OF TWO POINTS ARE THE SAME TREAT AS DISCONTINUITY.
      IF(EHOT(M).LE.EHOT(MM1)) GO TO 50
C-----ENERGY NOT THE SAME. SAVE MAXIMUM OR MINIMUM IF IT HAS NOT
C-----ALREADY BEEN SAVED.
      IF(MM1.ge.ITHIN3) go to 130
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(XCHOT(M)*XCHOT(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 150
      go to 140
C-----------------------------------------------------------------------
C
C     KEEP DISCONTINUITY.
C
C-----------------------------------------------------------------------
C-----IS ENERGY OF TWO POINTS THE SAME.
   40 IF(EHOT(M).GT.EHOT(MM1)) GO TO 80
C-----YES. CHECK FOR SAME CROSS SECTION.
   50 DXC=DABS(XCHOT(M)-XCHOT(MM1))
C-----YES. 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 160
      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 140
   70 IF(M.le.ITHIN3) go to 150
      go to 140
C-----------------------------------------------------------------------
C
C     2013/9/18 - KEEP ALL POINTS ABOVE HIGH ENERGY CUTOFF.
C
C-----------------------------------------------------------------------
   80 IF(EHOT(M).LT.EHIGHEST) GO TO 90
      IF(M.le.ITHIN3) go to 150
      go to 140
C-----------------------------------------------------------------------
C
C     KEEP THERMAL POINT AND PRECEDING POINT, IF NOT ALREADY KEPT.
C
C-----------------------------------------------------------------------
   90 IF(EHOT(M).NE.ETHERMAL) GO TO 100
      IF(M.le.ITHIN3) go to 150
      go to 140
C-----------------------------------------------------------------------
C
C     KEEP ALL POINTS IN THE UNRESOLVED RESONANCE REGION.
C
C-----------------------------------------------------------------------
  100 IF(UREACT.LE.0) GO TO 110
      IF(EHOT(M).LT.EULOW.OR.EHOT(M).GT.EUHIGH) GO TO 110
      IF(M.le.ITHIN3) go to 150
      go to 140
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 PASASED THE TEST).
C
C-----------------------------------------------------------------------
C-----DEFINE ENERGY INTERVAL BETWEEN CURRENT POINT AND LAST CONVERGED
C-----POINT.
  110 DE=EHOT(M)-EHOT(ITHIN1)
      SLOPE=(XCHOT(M)-XCHOT(ITHIN1))/DE
C-----INITIALIZE MAXIMUM AND MINIMUM ALLOWABLE SLOPE AT FIRST POINT OF
C-----INTERVAL.
      IF(M.NE.ITHIN3) GO TO 120
      IF(KERR3T.NE.0) CALL ERROKT(EHOT(M))
      DSLOPE=ERXC3T*XCHOT(M)/DE
      SLPMAX=SLOPE+DSLOPE
      SLPMIN=SLOPE-DSLOPE
      GO TO 170
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.
  120 IF(SLOPE.GT.SLPMAX.OR.SLOPE.LT.SLPMIN) GO TO 130
C-----CAN ELIMINATE CURRENT POINT. UPDATE SLOPE LIMITS.
      IF(KERR3T.NE.0) CALL ERROKT(EHOT(M))
      DSLOPE=ERXC3T*XCHOT(M)/DE
      SLP1=SLOPE+DSLOPE
      IF(SLP1.LT.SLPMAX) SLPMAX=SLP1
      SLP2=SLOPE-DSLOPE
      IF(SLP2.GT.SLPMIN) SLPMIN=SLP2
      GO TO 170
C-----NEED TO KEEP LAST PRECEDING POINT (LAST ONE TO PASS TEST).
  130 ITHIN1=ITHIN1+1
      EHOT(ITHIN1)=EHOT(MM1)
      XCHOT(ITHIN1)=XCHOT(MM1)
C-----RE-DEFINE INDEX TO BEGINNING OF NEXT INTERVAL.
      ITHIN3=M
      GO TO 80
C-----NEED TO KEEP LAST PRECEDING AND CURRENT POINTS.
  140 ITHIN1=ITHIN1+1
      EHOT(ITHIN1)=EHOT(MM1)
      XCHOT(ITHIN1)=XCHOT(MM1)
C-----NEED TO KEEP CURRENT POINT.
  150 ITHIN1=ITHIN1+1
      EHOT(ITHIN1)=EHOT(M)
      XCHOT(ITHIN1)=XCHOT(M)
C-----RE-DEFINE INDEX TO BEGINNING OF NEXT INTERVAL.
  160 ITHIN3=M+1
C-----END OF THINNING LOOP.
  170 CONTINUE
C-----IF LAST POINT OF ARRAY WAS NOT SAVED SAVE IT NOW.
      IF(ITHIN3.GT.HOT3) GO TO 180
      ITHIN1=ITHIN1+1
      EHOT(ITHIN1)=EHOT(HOT3)
      XCHOT(ITHIN1)=XCHOT(HOT3)
C-----RE-DEFINE NUMBER OF BROADENED POINTS IN CORE.
  180 HOT3=ITHIN1
      HOT3M1=HOT3-1
  190 CONTINUE
C-----HAS LAST POINT OF CROSS SECTION BEEN DOPPLER BROADENED.
      IF(MTEND.GT.0) GO TO 230
C-----------------------------------------------------------------------
C
C     MORE POINTS REMAIN TO DOPPLER BROADEN. IF MORE THAN ONE PAGE
C     OF THINNED POINTS COPY ONE PAGE TO SCRATCH AND MOVE OTHER POINTS
C     ONE PAGE FORWARD IN CORE. OTHERWISE NOTHING MORE TO DO.
C
C-----------------------------------------------------------------------
C-----IF THERE IS A FULL PAGE OF THINNED POINTS UNLOAD THEM TO SCRATCH.
      IF(ITHIN1.LE.NPAGE) GO TO 220
C-----POSITION SCRATCH BEFORE FIRST WRITE.
      IF(N2SCR.EQ.0.AND.IMUSED.GT.0) REWIND SCR
      IMUSED=1
C-----COPY PAGE TO SCRATCH AND INCREMENT SCRATCH POINT COUNT.
      N2SCR=N2SCR+NPAGE
      WRITE(SCR) EHOT1,XCHOT1
      IF(MONITR.LE.0) GO TO 200
      CALL OUT9(EHOT1(1)    ,FIELD6(1,1))
      CALL OUT9(EHOT1(NPAGE),FIELD6(1,2))
      WRITE(OUTP,290) N2SCR,((FIELD6(M,KK),M=1,11),KK=1,2)
      WRITE(*   ,290) N2SCR,((FIELD6(M,KK),M=1,11),KK=1,2)
C-----MOVE REMAINING POINTS FORWARD IN CORE.
  200 K=0
      DO 210 J=NP1P1,ITHIN1
      K=K+1
      EHOT(K)=EHOT(J)
      XCHOT(K)=XCHOT(J)
  210 CONTINUE
C-----DEFINE INDEX TO LAST THINNED POINT.
      ITHIN1=K
      HOT3=K
      HOT3M1=HOT3-1
C-----DEFINE THINNING INDICES FOR NEXT TIME THAT THIS ROUTINE WILL BE
C-----CALLED.
  220 ITHIN2=HOT3+1
      ITHIN3=HOT3+1
      RETURN
C-----------------------------------------------------------------------
C
C     END OF REACTION. IF ALL DATA IS CORE RESIDENT LEAVE IT IN CORE.
C     OTHERWISE COPY ALL TO SCRATCH AND INDICATE NONE REMAINING IN
C     CORE (AT THIS POINT THERE MAY BE UP TO THREE PAGES OF CORE
C     RESIDENT DATA). IF SCRATCH FILE IS USED POSITION IT TO BE READ.
C
C     FIRST PAGE OUTPUT.
C
C-----------------------------------------------------------------------
  230 CONTINUE
C 220 IF(N2SCR.LE.0) GO TO 270
      IF(N2SCR.LE.0) GO TO 280
      IF(MONITR.LE.0) GO TO 240
      ITOP=ITHIN1
      IF(ITOP.GT.NPAGE) ITOP=NPAGE
      N2SCRP=N2SCR+ITOP
      CALL OUT9(EHOT(1)   ,FIELD6(1,1))
      CALL OUT9(EHOT(ITOP),FIELD6(1,2))
      WRITE(OUTP,290) N2SCRP,((FIELD6(M,KK),M=1,11),KK=1,2)
      WRITE(*   ,290) N2SCRP,((FIELD6(M,KK),M=1,11),KK=1,2)
  240 WRITE(SCR) EHOT1,XCHOT1
C-----------------------------------------------------------------------
C
C     SECOND PAGE OUTPUT.
C
C-----------------------------------------------------------------------
      IF(ITHIN1.LE.NPAGE) GO TO 270
      IF(MONITR.LE.0) GO TO 250
      ITOP=ITHIN1
      IF(ITOP.GT.NPT2) ITOP=NPT2
      N2SCRP=N2SCR+ITOP
      CALL OUT9(EHOT2(1)   ,FIELD6(1,1))
      CALL OUT9(EHOT (ITOP),FIELD6(1,2))
      WRITE(OUTP,290) N2SCRP,((FIELD6(M,KK),M=1,11),KK=1,2)
      WRITE(*   ,290) N2SCRP,((FIELD6(M,KK),M=1,11),KK=1,2)
  250 WRITE(SCR) EHOT2,XCHOT2
C-----------------------------------------------------------------------
C
C     THIRD PAGE OUTPUT.
C
C-----------------------------------------------------------------------
      IF(ITHIN1.LE.NPT2) GO TO 270
      IF(MONITR.LE.0) GO TO 260
      N2SCRP=N2SCR+ITHIN1
      CALL OUT9(EHOT3(1)     ,FIELD6(1,1))
      CALL OUT9(EHOT (ITHIN1),FIELD6(1,2))
      WRITE(OUTP,290) N2SCRP,((FIELD6(M,KK),M=1,11),KK=1,2)
      WRITE(*   ,290) N2SCRP,((FIELD6(M,KK),M=1,11),KK=1,2)
  260 WRITE(SCR) EHOT3,XCHOT3
C-----------------------------------------------------------------------
C
C     ALL POINTS ARE NOW ON SCRATCH.
C
C-----------------------------------------------------------------------
C-----INCREMENT SCRATCH POINT COUNT AND INDICATE NONE REMAIN IN CORE.
  270 N2SCR=N2SCR+ITHIN1
      ITHIN1=0
C-----END FILE AND POSITION SCRATCH TO BE READ.
      END FILE SCR
      REWIND SCR
C-----DEFINE FINAL NUMBER OF POINTS TO OUTPUT.
  280 N2TOT=ITHIN1+N2SCR
      RETURN
  290 FORMAT(33X,I9,11A1,' to',11A1,' eV Finished')
      END
      SUBROUTINE COPOUT
C=======================================================================
C
C     THIS ROUTINE IS DESIGNED TO COPY THE SECTION OF BROADENED AND/OR
C     THINNED DATA FROM THE CORE OR SCRATCH FILE TO THE RESULT FILE IN
C     THE ENDF/B FORMAT.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INTEGER*4 OTAPE,OUTP,SCR,COLD1,COLD2,COLD1P,COLD2P,HOT1,HOT2,HOT3,
     1 HOT3M1,TOOHI
      CHARACTER*1 ZABCD,FIELD6
      CHARACTER*4 MESSAG,FMTHOL,PROHOL
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/UNITS/SCR
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/LEADER/C1,Q,L1,L2,N1,N2,MAT,MF,MT
      COMMON/WHATZA/IZA
      COMMON/INDEX/COLD1,COLD2,COLD1P,COLD2P,HOT1,HOT2,HOT3,HOT3M1,N2IN,
     1 N2TOT,N2SCR
      COMMON/PAGER/NPAGE,NPT2,NPT3,NP1P1,NP2P1
      COMMON/FILLER/N2LEFT,TOOHI,ITHRES,LOAD1,LOAD2
      COMMON/THRESH/ETHRES,EMIN
      COMMON/FLAGS/MINUS3,IMPLUS
      COMMON/MATTOT/MATIN,MATOUT
      COMMON/TEMPO/TEMP3,IVERSE
      COMMON/EXTEND/DTMAX,MESS
      COMMON/HOLFMT/FMTHOL,PROHOL
      COMMON/POINT1/EIN1,EUSE1
      COMMON/FIELDC/FIELD6(11,6)
      COMMON/IWATCH/MONITR,MAKEPLUS,MYUNRES
      COMMON/LISOCOM/LISO
      INCLUDE 'sigma1.h'
c----- 2012 - deleted E3UT(3), XC3OUT(3)
      DIMENSION MESSAG(3,3),NBTO(1),INTO(1),ZABCD(12)
C-----DEFINE CROSS SECTION EXTENSION MESSAGE.
      DATA MESSAG/'    ','    ','    ',
     1            'Exte','nsio','n   ',
     2            'Copi','ed  ','    '/
C-----DEFINE LINEAR-LINEAR INTERPOLATION LAW.
      DATA INTO/2/
C-----------------------------------------------------------------------
C
C     DEFINE TABLE SIZE, OUTPUT BEGINNING OF TAB1 RECORD AND DEFINE
C     WHERE DATA IS (I.E. ON SCRATCH OR IN CORE).
C
C-----------------------------------------------------------------------
C-----2013/3/17 - Output 'Copied' IF NOT BRODENED.
      IF(TOOHI.GT.0) MESS = 3
C-----INITIALIZE NEGATIVE CROSS SECTION FLAG OFF.
      MINUS3=0
      IMPLUS=0
C-----OUTPUT TAB1 LEAD CARD (SECTION HEAD CARD ALREADY OUTPUT IN MAIN)
      CALL CARDO(C1,Q,L1,L2,N1,N2TOT)
C-----OUTPUT INTERPOLATION LAW.
      NBTO(1)=N2TOT
      CALL TERPO(NBTO,INTO,1)
C-----DEFINE NUMBER OF DATA POINTS IN CORE (ALL IF CORE RESIDENT, OR
C-----THREE PAGES IF DATA IS ON SCRATCH).
      IOUT=N2TOT
      IF(N2SCR.GT.0) IOUT=NPT3
C-----------------------------------------------------------------------
C
C     SET UP LOOP OVER PAGES OF DATA.
C
C-----------------------------------------------------------------------
      LOOP=1
C-----IF REQUIRED LOAD UP TO THREE THINNED PAGES INTO CORE.
   10 IF(N2SCR.LE.0) GO TO 30
      READ(SCR) EHOT1,XCHOT1
      IF(N2SCR.LE.NPAGE) GO TO 20
      READ(SCR) EHOT2,XCHOT2
      IF(N2SCR.LE.NPT2) GO TO 20
      READ(SCR) EHOT3,XCHOT3
C-----DEFINE NUMBER OF POINTS IN CORE AND DECREMENT COUNT OF POINTS
C-----ON SCRATCH.
   20 IF(N2SCR.LT.IOUT) IOUT=N2SCR
      N2SCR=N2SCR-NPT3
C-----IF THRESHOLD REPLACED DUE TO DOPPLER BROADENING INSURE THAT IF
C-----FIRST TABULATED ENERGY IS ABOVE MINIMUM ENERGY OF INTEREST THE
C-----CROSS SECTION IS ZERO AT THE NEW THRESHOLD.
   30 IF(ITHRES.le.0) go to 40
      ITHRES=0
      IF(EHOT(1).GT.1.1d0*EMIN) XCHOT(1)=0.0d0
C-----------------------------------------------------------------------
C
C     SELECT NORMAL OUTPUT OR OUTPUT WITH ADDITIONAL POINT AT LOWEST
C     ENERGY READ AS INPUT.
C
C-----------------------------------------------------------------------
   40 IF(EUSE1.LE.EIN1) GO TO 50
      XCHOT(1) = 0.0d0
C-----INSURE THIS CAN ONLY BE DONE ONCE.
      EUSE1=-10.0d0
      EIN1 = 10.0d0
C-----------------------------------------------------------------------
C
C     NORMAL OUTPUT ROUTE.
C
C-----------------------------------------------------------------------
C-----IF REQUESTED MAKE ALL NEGATIVE CROSS SECTIONS = 0
   50 IF(MAKEPLUS.EQ.1) THEN
      DO KP=1,IOUT
      IF(XCHOT(KP).LT.0.0d0) XCHOT(KP)=0.0d0
      ENDDO
      ENDIF
      CALL POINTO(EHOT,XCHOT,IOUT)
C-----------------------------------------------------------------------
C
C     END OF PAGE LOOP.
C
C-----------------------------------------------------------------------
      LOOP=LOOP+NPT3
      IF(LOOP.LE.N2TOT) GO TO 10
C-----------------------------------------------------------------------
C
C     OUTPUT SECTION REPORT AND INCREMENT POINT COUNTS FOR MATERIAL.
C     PRINT WARNING IF OUTPUT CONTAINS ANY NEGATIVE CROSS SECTIONS.
C
C-----------------------------------------------------------------------
c-----Added Target Isomer State
      CALL ZAHOLM(IZA,LISO,ZABCD)
      CALL OUT9(TEMP3,FIELD6(1,1))
      CALL OUT9(Q    ,FIELD6(1,2))
      WRITE(OUTP,60) PROHOL,ZABCD,MATH,MTH,FMTHOL,
     1 ((FIELD6(M,L),M=1,11),L=1,2),N2IN,N2TOT,
     2 (MESSAG(KK,MESS),KK=1,3)
      WRITE(*   ,60) PROHOL,ZABCD,MATH,MTH,FMTHOL,
     1 ((FIELD6(M,L),M=1,11),L=1,2),N2IN,N2TOT,
     2 (MESSAG(KK,MESS),KK=1,3)
      MATIN=MATIN+N2IN
      MATOUT=MATOUT+N2TOT
C-----PRINT WARNING MESSAGE IF THIS SECTION CONTAINS NEGATIVE CROSS
C-----SECTIONS.
      IF(MINUS3.GT.0) THEN
      WRITE(OUTP,70) MINUS3
      WRITE(*   ,70) MINUS3
c-----2018/2/9 - Added message if < 0 set = 0
      if(MAKEPLUS.eq.1) THEN
      WRITE(OUTP,90)
      WRITE(*   ,90)
      ENDIF
      ENDIF
C-----PRINT WARNING IF CROSS SECTION IS NOT POSITIVE AT ANY ENERGY.
      IF(IMPLUS.LE.0) WRITE(OUTP,80)
      IF(IMPLUS.LE.0) WRITE(*   ,80)
      RETURN
   60 FORMAT(1X,A4,12A1,I5,I4,2X,A2,2X,2(1X,11A1),2I9,1X,2A4,A1)
   70 FORMAT(19X,'WARNING - Above Cross Section Negative at',I9,
     1 ' Energies')
   80 FORMAT(19X,'WARNING - Above Cross Section NOT',
     1 ' Positive at ANY Energy')
   90 FORMAT(19X,'          As per INPUT Option, Negative set = 0.')
      END
      SUBROUTINE READIN
C=======================================================================
C
C     READ AND CHECK ALL INPUT PARAMETERS.
C
C=======================================================================
      INCLUDE 'implicit.h'
      CHARACTER*1 FIELD6
      CHARACTER*4 MESS1,MESS2
      CHARACTER*72 NAMEIN,NAMEOUT
      INTEGER*4 OUTP,OTAPE
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/IOSTATUS/ISTAT1,ISTAT2
      COMMON/MATZA/MODGET,NMATZA,MATMIN(101),MATMAX(101)
      COMMON/OKERRT/ENER3T(21),ER3T(21),KERR3T,MAXERT
      COMMON/OKERR3/ENER3C(21),ER3C(21),KERR3C,MAXERC
      COMMON/ERRCOM/ERRXC3,ERMINMAX,ERMT2,ERMT102,ERSOFT,XCLOW
      COMMON/ERRCOT/ERXC3T
      COMMON/HOTS/ALPHA,HOTSY1,HOTSY2,TEMPK,TEMPEF,N2TAPI,N2TAPO
      COMMON/SLIM/ISTART,NOTHIN,ITHIN1,ITHIN2,ITHIN3,MTEND
      COMMON/IWATCH/MONITR,MAKEPLUS,MYUNRES
      COMMON/NAMEX/NAMEIN,NAMEOUT
      COMMON/FIELDC/FIELD6(11,6)
      DIMENSION MESS1(2),MESS2(2)
      DATA MESS1/' MAT','  ZA'/
      DATA MESS2/' Off','  On'/
C-----DEFINE DEFAULT OPTION FOR MINIMUM CROSS SECTION.
c-----2019/6/30 - Changed to 1.0d-30 from 1.0d-10
c-----2020/12/26 - Changed from 1.0d-30 for RML Charged Particles
      DATA XCINP/1.0d-30/
C-----------------------------------------------------------------------
C
C     READ AND CHECK FIRST LINE OF INPUT PARAMETERS.
C
C-----------------------------------------------------------------------
      IF(ISTAT1.EQ.1) GO TO 20
c----- 2017 - Changed all floating point to character
      READ(INP,10,END=20,ERR=20) MODGET,MONITR,
     1 ((FIELD6(j,i),j=1,11),i=1,2),MAKEPLUS,MYUNRES
   10 FORMAT(2I11,22A1,2I11)
      CALL IN9(TEMPK,FIELD6(1,1))
      CALL IN9(XCLOW,FIELD6(1,2))
c-----2021/3/23 - No longer an input option
      XCLOW = XCINP
c----- 2017 - Changed all floating point to character
      GO TO 30
C-----DEFINE DEFAULT VALUES
   20 ISTAT1   = 1
      MODGET   = 0
      MONITR   = 0
C-----09/01/2013 - Changed from 300 to 293.6 K
      TEMPK    = 293.6d+0
c-----2020/12/26 - Changed from 0
      XCLOW    = XCINP
      MAKEPLUS = 1
      MYUNRES  = 0
c-----RETRIEVAL MODE
   30 IF(MODGET.NE.0) MODGET=1
c-----MONITOR MODE
      IF(MONITR.NE.0) MONITR=1
C-----TEMPERATURE
      CALL OUT9(TEMPK,FIELD6(1,1))
C-----MINIMUM CROSS SECTION (no longer an input option)
      CALL OUT9(XCLOW,FIELD6(1,2))
      WRITE(OUTP,260) MESS1(MODGET+1),MESS2(MONITR+1),
     1 ((FIELD6(M,KK),M=1,11),KK=1,2)
      WRITE(*   ,260) MESS1(MODGET+1),MESS2(MONITR+1),
     1 ((FIELD6(M,KK),M=1,11),KK=1,2)
C-----NEGATIVE CROSS SECTION TREATMENT
      IF(MAKEPLUS.NE.0) MAKEPLUS=1
      IF(MAKEPLUS.EQ.0) THEN
      WRITE(OUTP,270)
      WRITE(*   ,270)
      ELSE
      WRITE(OUTP,280)
      WRITE(*   ,280)
      ENDIF
C-----UNRESOLVED TREATMENT
      IF(MYUNRES.NE.0) MYUNRES = 1
      IF(MYUNRES.EQ.0) THEN
      WRITE(OUTP,290)
      WRITE(*   ,290)
      ELSE
      WRITE(OUTP,300)
      WRITE(*   ,300)
      ENDIF
C-----------------------------------------------------------------------
C
C     READ FILENAMES - IF BLANK USE STANDARD FILENAMES
C
C-----------------------------------------------------------------------
C-----INPUT DATA.
      IF(ISTAT1.EQ.1) GO TO 50
      READ(INP,40,END=50,ERR=50) NAMEIN
   40 FORMAT(A72)
      IF(NAMEIN.EQ.' ') NAMEIN = 'ENDFB.IN'
C-----OUTPUT DATA.
      READ(INP,40,END=60,ERR=60) NAMEOUT
      IF(NAMEOUT.EQ.' ') NAMEOUT = 'ENDFB.OUT'
      GO TO 70
C-----USE DEFAULT NAMES
   50 NAMEIN  = 'ENDFB.IN'
   60 NAMEOUT = 'ENDFB.OUT'
      ISTAT1 = 1
C-----PRINT FINAL FILENAME
   70 WRITE(OUTP,80) NAMEIN,NAMEOUT
      WRITE(*   ,80) NAMEIN,NAMEOUT
   80 FORMAT(1X,79('-')/
     1 ' ENDF/B Input and Output Data Filenames'/1X,79('-')/
     2 1X,A72/1X,A72)
C-----------------------------------------------------------------------
C
C     OPEN ENDF/B DATA FILES
C
C-----------------------------------------------------------------------
      CALL FILIO2
C-----------------------------------------------------------------------
C
C     TERMINATE IF ERROR OPENING FILE
C
C-----------------------------------------------------------------------
      IF(ISTAT2.EQ.1) THEN
      WRITE(OUTP,90) NAMEIN
      WRITE(   *,90) NAMEIN
   90 FORMAT(//' ERROR - Opening ENDF/B formatted file'/1X,A72//)
      CALL ENDERROR
      ENDIF
C-----------------------------------------------------------------------
C
C     READ SELECTION RANGES (EITHER MAT OR ZA). IF MAXIMUM IS LESS
C     THAN MINIMUM SET IT EQUAL TO MINIMUM. IF FIRST CARD IS BLANK
C     RETRIEVE ALL DATA.
C
C-----------------------------------------------------------------------
      IF(MODGET.EQ.0) WRITE(OUTP,310)
      IF(MODGET.EQ.1) WRITE(OUTP,320)
      IF(MODGET.EQ.0) WRITE(*   ,310)
      IF(MODGET.EQ.1) WRITE(*   ,320)
      IF(ISTAT1.EQ.1) GO TO 120
      READ(INP,100,END=110,ERR=110) MATMIN(1),MATMAX(1)
  100 FORMAT(2I11)
      IF(MATMIN(1).GT.0.OR.MATMAX(1).GT.0) GO TO 130
      GO TO 120
  110 ISTAT1    = 1
  120 MATMAX(1) = 9999
      MODGET=0
      NMATZA=2
      WRITE(OUTP,340) MATMIN(1),MATMAX(1)
      WRITE(*   ,340) MATMIN(1),MATMAX(1)
      GO TO 160
c-----Check input and define defaults.
  130 IF(MATMAX(1).LT.MATMIN(1)) MATMAX(1)=MATMIN(1)
      WRITE(OUTP,330) MATMIN(1),MATMAX(1)
      WRITE(*   ,330) MATMIN(1),MATMAX(1)
      DO 140 NMATZA=2,101
      READ(INP,100,END=150,ERR=150) MATMIN(NMATZA),MATMAX(NMATZA)
c-----Check input and define defaults.
      IF(MATMIN(NMATZA).LE.0.AND.MATMAX(NMATZA).LE.0) GO TO 160
      IF(MATMAX(NMATZA).LT.MATMIN(NMATZA)) MATMAX(NMATZA)=MATMIN(NMATZA)
      WRITE(OUTP,330) MATMIN(NMATZA),MATMAX(NMATZA)
      WRITE(*   ,330) MATMIN(NMATZA),MATMAX(NMATZA)
  140 CONTINUE
      WRITE(OUTP,350)
      WRITE(*   ,350)
      CALL ENDERROR
C-----------------------------------------------------------------------
C
C     READ AND LIST FILE 3 ERROR LAW. ENERGIES MUST BE IN ASCENDING
C     ORDER. IT IS O.K. IF ERROR IS ZERO (WHICH INDICATES THAT
C     THINNING SHOULD NOT BE PERFORMED). ERROR LAW IS TERMINATED BY
C     BLANK CARD. IF FIRST CARD IS BLANK, TERMINATE ERROR LAW AND
C     DEFINE ALLOWABLE ERROR TO BE 0.0 (I.E., NO THINNING).
C
C-----------------------------------------------------------------------
  150 ISTAT1 = 1
  160 NMATZA=NMATZA-1
      IF(ISTAT1.EQ.1) GO TO 180
c----- 2017 - Changed all floating point to character
      READ(INP,170,END=180,ERR=180) ((FIELD6(j,i),j=1,11),i=1,2)
  170 FORMAT(22A1)
      CALL IN9(ENER3T(1),FIELD6(1,1))
      CALL IN9(ER3T  (1),FIELD6(1,2))
c----- 2017 - Changed all floating point to character
      GO TO 190
  180 ISTAT1    = 1
      ENER3T(1) = 0.0d0
      ER3T(1)   = 0.0d0
  190 IF(ENER3T(1).LE.0.0d0) ENER3T(1)=0.0d0
      IF(ER3T  (1).LE.0.0d0) ER3T  (1)=0.0d0
      IF(ENER3T(1).GT.0.0d0.OR.ER3T(1).GT.0.0d0) GO TO 200
C-----USE DEFAULT VALUES.
      MAXERT=2
      ENER3T(1)=0.0d0
      ER3T  (1)=0.001d0  ! 2018/2/8 - CHANGED DEFAULT BACK TO 0.1%
      PERCNT=100.0d0*ER3T(1)
      ERRMAX=0.0d0
      CALL OUT9(ENER3T(1),FIELD6(1,1))
      CALL OUT9(ER3T(1)  ,FIELD6(1,2))
      WRITE(OUTP,390) ((FIELD6(M,I),M=1,11),I=1,2),PERCNT
      WRITE(*   ,390) ((FIELD6(M,I),M=1,11),I=1,2),PERCNT
      GO TO 230
C-----USE VALUES AS READ.
  200 IF(ER3T(1).LE.0.0d0) ER3T(1)=0.001d0 ! 2018/2/8 - CHANGED DEFAULT
      PERCNT=100.0d0*ER3T(1)
      ERRMAX=ER3T(1)
      CALL OUT9(ENER3T(1),FIELD6(1,1))
      CALL OUT9(ER3T(1)  ,FIELD6(1,2))
      WRITE(OUTP,380) ((FIELD6(M,I),M=1,11),I=1,2),PERCNT
      WRITE(*   ,380) ((FIELD6(M,I),M=1,11),I=1,2),PERCNT
      DO 210 MAXERT=2,21
c----- 2017 - Changed all floating point to character
      READ(INP,170,END=180,ERR=180) ((FIELD6(j,i),j=1,11),i=1,2)
      CALL IN9(ENER3T(MAXERT),FIELD6(1,1))
      CALL IN9(ER3T  (MAXERT),FIELD6(1,2))
c----- 2017 - Changed all floating point to character
      IF(ENER3T(MAXERT).LE.0.0d0.AND.ER3T(MAXERT).LE.0.0d0) GO TO 230
      IF(ER3T(MAXERT).LE.0.0d0) ER3T(MAXERT)=0.001d0
      PERCNT=100.0d0*ER3T(MAXERT)
      IF(ER3T(MAXERT).GT.ERRMAX) ERRMAX=ER3T(MAXERT)
      CALL OUT9(ENER3T(MAXERT),FIELD6(1,1))
      CALL OUT9(ER3T(MAXERT)  ,FIELD6(1,2))
      WRITE(OUTP,360) ((FIELD6(M,I),M=1,11),I=1,2),PERCNT
      WRITE(*   ,360) ((FIELD6(M,I),M=1,11),I=1,2),PERCNT
      IF(ENER3T(MAXERT).LT.ENER3T(MAXERT-1)) GO TO 250
  210 CONTINUE
      WRITE(OUTP,370)
      WRITE(*   ,370)
  220 CALL ENDERROR
  230 MAXERT=MAXERT-1
      KERR3T=0
      IF(MAXERT.GT.1) KERR3T=1
C-----SET C = T LAW
      MAXERC=MAXERT
      KERR3C=KERR3T
      DO 240 I=1,MAXERT
      ENER3C(I)=ENER3T(I)
      ER3C  (I)=ER3T  (I)
  240 CONTINUE
C-----INITIALIZE TO FIRST VALUES
      ERXC3T = ER3T(MAXERT)
      ERRXC3 = ER3C(MAXERT)
c-----2020/12/31 - ALL uncertainty parameters
      CALL SETERROR(3)   ! 3 = SIGMA1
C-----------------------------------------------------------------------
C
C     DATA WILL ALWAYS BE THINNED
C
C-----------------------------------------------------------------------
      NOTHIN=0
c-----------------------------------------------------------------------
C***** THINNING ON/OFF
C
C     TO TURN OFF THINNING ACTIVATE THE FOLLOWING
C
C     NOTHIN=1
C***** THINNING ON/OFF
c-----------------------------------------------------------------------
      RETURN
  250 WRITE(OUTP,400)
      WRITE(*   ,400)
      GO TO 220
  260 FORMAT(' Retrieval Criteria-----------',7X,A4/
     1 ' Monitor Mode-----------------',7X,A4/
     2 ' Temperature------------------',11A1,' KELVIN'/
     3 ' Mimimum Cross Section--------',11A1,
     4 ' (No Longer an Input Option)')
  270 FORMAT(' Negative Cross Section-------',
     1 ' No Change (Allow Negative Outout)')
  280 FORMAT(' Negative Cross Section-------',
     1 ' Make = 0 (No Negative Outout)')
  290 FORMAT(' Unresolved Resonances Region-',' Copy (No Broadening)')
  300 FORMAT(' Unresolved Resonances Region-',' Ignore (Broaden)')
  310 FORMAT(1X,79('-')/' Requested MAT Ranges'/1X,79('-')/
     1 5X,'Mimimum',4X,'Maximum'/1X,79('-'))
  320 FORMAT(1X,79('-')/' Requested ZA Ranges'/1X,79('-')/
     1 5X,'Minimum',4X,'Maximum'/1X,79('-'))
  330 FORMAT(1X,2I11)
  340 FORMAT(1X,2I11,' (Default Option)')
  350 FORMAT(1X,79('-')/' Over 100 Ranges----Execution Terminated')
  360 FORMAT(1X,11A1,1X,11A1,F11.4)
  370 FORMAT(1X,79('-')/' Over 20 Ranges----Execution Terminated')
  380 FORMAT(1X,79('-')/' Allowable Uncertainty'/1X,79('-')/
     1 6X,'Energy',1X,'Uncertainty',3X,'per-cent'/1X,79('-')/
     2 1X,11A1,1X,11A1,F11.4)
  390 FORMAT(1X,79('-')/' Allowable Uncertainty'/1X,79('-')/
     1 6X,'Energy',1X,'Uncertainty',3X,'per-cent'/1X,79('-')/
     2 1X,11A1,1X,11A1,F11.4,' (Default Option)')
  400 FORMAT(' Energies MUST be in Ascending Order----',
     1 'Execution Terminated')
      END
      REAL*8 FUNCTION ESPACE(ERROR)
C=======================================================================
C
C     DEFINE ENERGY SPACING TO APPROXIMATE 1/V TO WITHIN ERROR
C
C     THE BELOW TABLE HANDLES THE FRACTIONAL ERROR RANGE
C     1.0D-02 TO 1.0D-06 = 1.0 TO 0.0001 PER-CENT
C
C=======================================================================
      INCLUDE 'implicit.h'
      DIMENSION ERRTAB(5),DETAB(5)
      DATA ERRTAB/
     1 1.0d-2,
     2 1.0d-3,
     3 1.0d-4,
     4 1.0d-5,
     5 1.0d-6/
C-----04/23/08 - HALVED SPACING AGAIN
      DATA DETAB/
     1 1.04888250d0,
     2 1.01410820d0,
     3 1.00423800d0,
     4 1.00134370d0,
     5 1.00041050d0/
      IF(ERROR.LT.ERRTAB(1)) GO TO 10
      ESPACE=DETAB(1)
      RETURN
   10 DO 20 I=1,5
      IF(ERROR.ge.ERRTAB(I)) go to 30
   20 CONTINUE
      I=5
   30 ESPACE=DETAB(I)
      RETURN
      END
      SUBROUTINE NXTMAT
C=======================================================================
C
C     FIND NEXT REQUESTED MATERIAL BASED EITHER ON ZA OR MAT.
C
C=======================================================================
      INCLUDE 'implicit.h'
      CHARACTER*4 FMTHOL,PROHOL
      COMMON/MATZA/MODGET,NMATZA,MATMIN(101),MATMAX(101)
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/WHATZA/IZA
      COMMON/HOLFMT/FMTHOL,PROHOL
      COMMON/TEMPO/TEMP3,IVERSE
      DIMENSION IZAMIN(101),IZAMAX(101)
      EQUIVALENCE (MATMIN(1),IZAMIN(1)),(MATMAX(1),IZAMAX(1))
C-----READ NEXT CARD AND CHECK FOR END OF ENDF/B TAPE.
   10 CALL CONTI
      IF(MTH.gt.0) go to 20
      IF(MATH.lt.0) go to 60
      go to 10
C-----DEFINE FIXED POINT ZA.
   20 IZA=C1H
C-----COMPARE MAT OR ZA TO SELECTION CRITERIA.
      LOW=0
      DO 50 IMATZA=1,NMATZA
      IF(MODGET.NE.0) GO TO 30
      IF(MATH.lt.MATMIN(IMATZA)) go to 40
      IF(MATH.eq.MATMIN(IMATZA)) go to 70
      IF(MATH.le.MATMAX(IMATZA)) go to 70
      go to 50
   30 IF(IZA.lt.IZAMIN(IMATZA)) go to 40
      IF(IZA.eq.IZAMIN(IMATZA)) go to 70
      IF(IZA.le.IZAMAX(IMATZA)) go to 70
   40 LOW=1
   50 CONTINUE
C-----THIS MATERIAL HAS NOT BEEN REQUESTED. IF BEYOND RANGE OF ALL
C-----REQUESTS RUN IF COMPLETED. IF NOT SKIP TO NEXT MATERIAL.
      IF(LOW.LE.0) GO TO 60
C-----SKIP TO MATERIAL END (MEND) CARD.
      CALL SKIPM
      GO TO 10
C-----END OF RUN. RETURN NEGATIVE MATH AS INDICATOR.
   60 MATH=-1
      MFH=0
      MTH=0
C-----THIS MATERIAL REQUESTED. INITIALIZE OUTPUT SEQUENCE NUMBER,
C-----ENDF/B FORMAT VERSION TO BLANK, ENDF/B FORMAT TO VERSION 5 AND 6
C-----INITIAL TEMPERATURE TO ZERO.
   70 NOSEQ=1
      FMTHOL='6   '
      IVERSE=6
      TEMP3=0.0d0
      RETURN
      END
      SUBROUTINE ERROKT(E)
C=======================================================================
C
C     DEFINE ALLOWABLE ERROR FOR FILE 3 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/OKERRT/ENER3T(21),ER3T(21),KERR3T,MAXERT
      COMMON/ERRCOT/ERXC3T
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.ENER3T(1)) go to 80
      DO 10 NOWER3=MINER3,MAXERT
      IF(E.lt.ENER3T(NOWER3)) go to 20
      IF(E.eq.ENER3T(NOWER3)) go to 70
   10 CONTINUE
C-----EXTEND AS CONSTANT TO HIGHER ENERGIES.
      GO TO 90
   20 NM1=NOWER3-1
      IF(E.eq.ENER3T(NM1)) go to 60
      IF(E.gt.ENER3T(NM1)) go to 50
      DO 30 NOWER3=2,MAXERT
      IF(E.lt.ENER3T(NOWER3)) go to 40
      IF(E.eq.ENER3T(NOWER3)) go to 70
   30 CONTINUE
      GO TO 90
C-----INTERPOLATE BETWEEN ENERGIES.
   40 NM1=NOWER3-1
   50 MINER3=NOWER3
      ERXC3T=((ENER3T(NOWER3)-E)*ER3T(NM1)+(E-ENER3T(NM1))*ER3T(NOWER3))
     1 /(ENER3T(NOWER3)-ENER3T(NM1))
      RETURN
C-----EXACT ENERGY MATCH.
   60 MINER3=NM1
      IF(MINER3.LE.1) MINER3=2
      ERXC3T=ER3T(NM1)
      RETURN
C-----EXACT ENERGY MATCH.
   70 MINER3=NOWER3
      ERXC3T=ER3T(NOWER3)
      RETURN
C-----EXTEND AS CONSTANT TO LOWER ENERGIES.
   80 MINER3=2
      ERXC3T=ER3T(1)
      RETURN
C-----EXTEND AS CONSTANT TO HIGHER ENERGIES.
   90 MINER3=MAXERT
      ERXC3T=ER3T(MAXERT)
      RETURN
      END
      SUBROUTINE ERROKC(E)
C=======================================================================
C
C     DEFINE ALLOWABLE ERROR FOR FILE 3 RECONSTRUCTED 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/ENER3C(21),ER3C(21),KERR3C,MAXERC
      COMMON/ERRCOM/ERRXC3,ERMINMAX,ERMT2,ERMT102,ERSOFT,XCLOW
C-----INITIALIZE INDEX TO INTERPOLATION TABLE.
      DATA MINERD/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.ENER3C(1)) go to 80
      DO 10 NOWERD=MINERD,MAXERC
      IF(E.lt.ENER3C(NOWERD)) go to 20
      IF(E.eq.ENER3C(NOWERD)) go to 70
   10 CONTINUE
C-----EXTEND TO HIGHER ENERGIES AS CONSTANT.
      GO TO 90
   20 NM1=NOWERD-1
      IF(E.eq.ENER3C(NM1)) go to 60
      IF(E.gt.ENER3C(NM1)) go to 50
      DO 30 NOWERD=2,MAXERC
      IF(E.lt.ENER3C(NOWERD)) go to 40
      IF(E.eq.ENER3C(NOWERD)) go to 70
   30 CONTINUE
      GO TO 90
C-----INTERPOLATE BETWEEN ENERGIES.
   40 NM1=NOWERD-1
   50 MINERD=NOWERD
      ERRXC3=((ENER3C(NOWERD)-E)*ER3C(NM1)+(E-ENER3C(NM1))*ER3C(NOWERD))
     1 /(ENER3C(NOWERD)-ENER3C(NM1))
      RETURN
C-----EXACT ENERGY MATCH.
   60 MINERD=NM1
      IF(MINERD.LE.1) MINERD=2
      ERRXC3=ER3C(NM1)
      RETURN
C-----EXACT ENERGY MATCH.
   70 MINERD=NOWERD
      ERRXC3=ER3C(NOWERD)
      RETURN
C-----EXTEND TO LOWER ENERGIES AS CONSTANT.
   80 MINERD=2
      ERRXC3=ER3C(1)
      RETURN
C-----EXTEND TO HIGHER ENERGIES AS CONSTANT.
   90 MINERD=MAXERC
      ERRXC3=ER3C(MAXERC)
      RETURN
      END
      SUBROUTINE FILEIO
C=======================================================================
C
C     DEFINE ALL I/O UNITS.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INTEGER*4 OUTP,OTAPE,SCR
      CHARACTER*72 NAMEIN,NAMEOUT
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/IOSTATUS/ISTAT1,ISTAT2
      COMMON/UNITS/SCR
      COMMON/NAMEX/NAMEIN,NAMEOUT
C-----DEFINE ALL I/O UNIT NUMBERS.
      INP=2
      OUTP=3
      ITAPE=10
      OTAPE=11
      SCR=12
C-----DEFINE ALL FILE NAMES.
      OPEN(OUTP,FILE='SIGMA1.LST',STATUS='UNKNOWN')
      CALL SCRATCH1(SCR,'SIGMA1.001  ')
      OPEN(INP,FILE='SIGMA1.INP',STATUS='OLD',ERR=10)
      ISTAT1 = 0
      RETURN
   10 ISTAT1 = 1
      RETURN
      ENTRY FILIO2
C=======================================================================
C
C     DEFINE ENDF/B DATA I/O UNITS AND OPTIONAL DEFINE 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
      REAL*8 FUNCTION TERFC(x)
C=======================================================================
C
c     compute the complementary error function.
c     from the slatec library fnlib ERFC.
C
C=======================================================================
      INCLUDE 'implicit.h'
      DIMENSION erfcs(21),erfccs(59),erc2cs(49)
      data erfcs/
     1  -.4904612123 4691808039 9845440333 76 d-1      ,
     2  -.1422612051 0371364237 8247418996 31 d+0      ,
     3  +.1003558218 7599795575 7546767129 33 d-1      ,
     4  -.5768764699 7674847650 8270255091 67 d-3      ,
     5  +.2741993125 2196061034 4221607914 71 d-4      ,
     6  -.1104317550 7344507604 1353812959 05 d-5      ,
     7  +.3848875542 0345036949 9613114981 74 d-7      ,
     8  -.1180858253 3875466969 6317518015 81 d-8      ,
     9  +.3233421582 6050909646 4029309533 54 d-10     ,
     A  -.7991015947 0045487581 6073747085 95 d-12     ,
     1  +.1799072511 3961455611 9672454866 34 d-13     ,
     2  -.3718635487 8186926382 3168282094 93 d-15     ,
     3  +.7103599003 7142529711 6899083946 66 d-17     ,
     4  -.1261245511 9155225832 4954248533 33 d-18     ,
     5  +.2091640694 1769294369 1705002666 66 d-20     ,
     6  -.3253973102 9314072982 3641600000 00 d-22     ,
     7  +.4766867209 7976748332 3733333333 33 d-24     ,
     8  -.6598012078 2851343155 1999999999 99 d-26     ,
     9  +.8655011469 9637626197 3333333333 33 d-28     ,
     B  -.1078892517 7498064213 3333333333 33 d-29     ,
     1  +.1281188399 3017002666 6666666666 66 d-31     /
c
      data erc2cs/
     1  -.6960134660 2309501127 3915082619 7 d-1      ,
     2  -.4110133936 2620893489 8221208466 6 d-1      ,
     3  +.3914495866 6896268815 6114370524 4 d-2      ,
     4  -.4906395650 5489791612 8093545077 4 d-3      ,
     5  +.7157479001 3770363807 6089414182 5 d-4      ,
     6  -.1153071634 1312328338 0823284791 2 d-4      ,
     7  +.1994670590 2019976350 5231486770 9 d-5      ,
     8  -.3642666471 5992228739 3611843071 1 d-6      ,
     9  +.6944372610 0050125899 3127721463 3 d-7      ,
     A  -.1371220902 1043660195 3460514121 0 d-7      ,
     1  +.2788389661 0071371319 6386034808 7 d-8      ,
     2  -.5814164724 3311615518 6479105031 6 d-9      ,
     3  +.1238920491 7527531811 8016881795 0 d-9      ,
     4  -.2690639145 3067434323 9042493788 9 d-10     ,
     5  +.5942614350 8479109824 4470968384 0 d-11     ,
     6  -.1332386735 7581195792 8775442057 0 d-11     ,
     7  +.3028046806 1771320171 7369724330 4 d-12     ,
     8  -.6966648814 9410325887 9586758895 4 d-13     ,
     9  +.1620854541 0539229698 1289322762 8 d-13     ,
     B  -.3809934465 2504919998 7691305772 9 d-14     ,
     1  +.9040487815 9788311493 6897101297 5 d-15     ,
     2  -.2164006195 0896073478 0981204700 3 d-15     ,
     3  +.5222102233 9958549846 0798024417 2 d-16     ,
     4  -.1269729602 3645553363 7241552778 0 d-16     ,
     5  +.3109145504 2761975838 3622741295 1 d-17     ,
     6  -.7663762920 3203855240 0956671481 1 d-18     ,
     7  +.1900819251 3627452025 3692973329 0 d-18     ,
     8  -.4742207279 0690395452 2565599996 5 d-19     ,
     9  +.1189649200 0765283828 8068307845 1 d-19     ,
     C  -.3000035590 3257802568 4527131306 6 d-20     ,
     1  +.7602993453 0432461730 1938527709 8 d-21     ,
     2  -.1935909447 6068728815 6981104913 0 d-21     ,
     3  +.4951399124 7733378810 0004238677 3 d-22     ,
     4  -.1271807481 3363718796 0862198988 8 d-22     ,
     5  +.3280049600 4695130433 1584165205 3 d-23     ,
     6  -.8492320176 8228965689 2479242239 9 d-24     ,
     7  +.2206917892 8075602235 1987998719 9 d-24     ,
     8  -.5755617245 6965284983 1281950719 9 d-25     ,
     9  +.1506191533 6392342503 5414405119 9 d-25     ,
     D  -.3954502959 0187969531 0428569599 9 d-26     ,
     1  +.1041529704 1515009799 8464505173 3 d-26     ,
     2  -.2751487795 2787650794 5017890133 3 d-27     ,
     3  +.7290058205 4975574089 9770368000 0 d-28     ,
     4  -.1936939645 9159478040 7750109866 6 d-28     ,
     5  +.5160357112 0514872983 7005482666 6 d-29     ,
     6  -.1378419322 1930940993 8964480000 0 d-29     ,
     7  +.3691326793 1070690422 5109333333 3 d-30     ,
     8  -.9909389590 6243654206 5322666666 6 d-31     ,
     9  +.2666491705 1953884133 2394666666 6 d-31     /
c
      data erfccs/
     1  +.7151793102 0292477450 3697709496 d-1        ,
     2  -.2653243433 7606715755 8893386681 d-1        ,
     3  +.1711153977 9208558833 2699194606 d-2        ,
     4  -.1637516634 5851788416 3746404749 d-3        ,
     5  +.1987129350 0552036499 5974806758 d-4        ,
     6  -.2843712412 7665550875 0175183152 d-5        ,
     7  +.4606161308 9631303696 9379968464 d-6        ,
     8  -.8227753025 8792084205 7766536366 d-7        ,
     9  +.1592141872 7709011298 9358340826 d-7        ,
     A  -.3295071362 2528432148 6631665072 d-8        ,
     1  +.7223439760 4005554658 1261153890 d-9        ,
     2  -.1664855813 3987295934 4695966886 d-9        ,
     3  +.4010392588 2376648207 7671768814 d-10       ,
     4  -.1004816214 4257311327 2170176283 d-10       ,
     5  +.2608275913 3003338085 9341009439 d-11       ,
     6  -.6991110560 4040248655 7697812476 d-12       ,
     7  +.1929492333 2617070862 4205749803 d-12       ,
     8  -.5470131188 7543310649 0125085271 d-13       ,
     9  +.1589663309 7626974483 9084032762 d-13       ,
     B  -.4726893980 1975548392 0369584290 d-14       ,
     1  +.1435873376 7849847867 2873997840 d-14       ,
     2  -.4449510561 8173583941 7250062829 d-15       ,
     3  +.1404810884 7682334373 7305537466 d-15       ,
     4  -.4513818387 7642108962 5963281623 d-16       ,
     5  +.1474521541 0451330778 7018713262 d-16       ,
     6  -.4892621406 9457761543 6841552532 d-17       ,
     7  +.1647612141 4106467389 5301522827 d-17       ,
     8  -.5626817176 3294080929 9928521323 d-18       ,
     9  +.1947443382 2320785142 9197867821 d-18       ,
     C  -.6826305642 9484207295 6664144723 d-19       ,
     1  +.2421988887 2986492401 8301125438 d-19       ,
     2  -.8693414133 5030704256 3800861857 d-20       ,
     3  +.3155180346 2280855712 2363401262 d-20       ,
     4  -.1157372324 0496087426 1239486742 d-20       ,
     5  +.4288947161 6056539462 3737097442 d-21       ,
     6  -.1605030742 0576168500 5737770964 d-21       ,
     7  +.6063298757 4538026449 5069923027 d-22       ,
     8  -.2311404251 6979584909 8840801367 d-22       ,
     9  +.8888778540 6618855255 4702955697 d-23       ,
     D  -.3447260576 6513765223 0718495566 d-23       ,
     1  +.1347865460 2069650682 7582774181 d-23       ,
     2  -.5311794071 1250217364 5873201807 d-24       ,
     3  +.2109341058 6197831682 8954734537 d-24       ,
     4  -.8438365587 9237891159 8133256738 d-25       ,
     5  +.3399982524 9452089062 7359576337 d-25       ,
     6  -.1379452388 0732420900 2238377110 d-25       ,
     7  +.5634490311 8332526151 3392634811 d-26       ,
     8  -.2316490434 4770654482 3427752700 d-26       ,
     9  +.9584462844 6018101526 3158381226 d-27       ,
     E  -.3990722880 3301097262 4224850193 d-27       ,
     1  +.1672129225 9444773601 7228709669 d-27       ,
     2  -.7045991522 7660138563 8803782587 d-28       ,
     3  +.2979768402 8642063541 2357989444 d-28       ,
     4  -.1262522466 4606192972 2422632994 d-28       ,
     5  +.5395438704 5424879398 5299653154 d-29       ,
     6  -.2380992882 5314591867 5346190062 d-29       ,
     7  +.1099052830 1027615735 9726683750 d-29       ,
     8  -.4867713741 6449657273 2518677435 d-30       ,
     9  +.1525877264 1103575676 3200828211 d-30       /
c
      data sqrtpi / 1.772453850 9055160272 9816748334 115d0 /
c-----------------------------------------------------------------------
c
c     Initialize on first call
c
c-----------------------------------------------------------------------
      DATA IFIRST/1/
      if (IFIRST.ne.0) then
      eta=0.1d0*D1MACH(3)
      nterf =INITDS(erfcs ,21,eta)
      nterfc=INITDS(erfccs,59,eta)
      nterc2=INITDS(erc2cs,49,eta)
      xsml=-DSQRT(-DLOG(sqrtpi*D1MACH(3)))
      txmax=DSQRT(-DLOG(sqrtpi*D1MACH(1)))
      xmax=txmax-0.5d0*DLOG(txmax)/txmax-0.01d0
      sqeps=DSQRT(2.0d0*D1MACH(3))
      IFIRST = 0
      endif
c
      if (x.le.xsml) then
      TERFC=2.0d0
      else if (x.le.xmax) then
      y=abs(x)
      if (y.le.1.0d0) then
      if (y.lt.sqeps) TERFC=1.0d0-2.0d0*x/sqrtpi
      if (y.ge.sqeps) TERFC=1.0d0-x*(1.0d0
     &        +DCSEVL(2.d0*x*x-1.d0,erfcs,nterf))
      else
      y=y*y
      if (y.le.4.d0) TERFC=exp(-y)/abs(x)*(0.5d0
     &        +DCSEVL((8.d0/y-5.d0)/3.d0,erc2cs,nterc2))
      if (y.gt.4.d0) TERFC=exp(-y)/abs(x)*(0.5d0
     &        +DCSEVL(8.d0/y-1.d0,erfccs,nterfc))
      if (x.lt.0.d0) TERFC=2.0d0-TERFC
      endif
      else
c        call mess('derfc','x so big erfc underflows',' ')
      TERFC=0.d0
      endif
      return
      END
      REAL*8 FUNCTION D1MACH(i)
C=======================================================================
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     assume double precision numbers are represented in the t-digit,
c     base-b form
c
c              sign (b**e)*( (x(1)/b) + ... + (x(t)/b**t) )
c
c     where 0 .le. x(i) .lt. b for i=1,...,t, 0 .lt. x(1), and
c     emin .le. e .le. emax.
c
c     the values of b, t, emin and emax are provided in i1mach as
c     follows:
c
c      i1mach(10) = b, the base.
c      i1mach(14) = t, the number of base-b digits.
c      i1mach(15) = emin, the smallest exponent e.
c      i1mach(16) = emax, the largest exponent e.
c
c     to alter this function for a particular environment, the desired
c     set of data statements should be activated by removing the c from
c     column 1.  also, the values of D1MACH(1) - D1MACH(4) should be
c     checked for consistency with the local operating system.
C
C=======================================================================
      INCLUDE 'implicit.h'
      DIMENSION dmach(5)
      dmach(1)=2.22507385d-100
      dmach(2)=1.79769313d+100
      dmach(3)=1.11022302d-16
      dmach(4)=2.22044605d-16
      dmach(5)=0.30103001d+0
      D1MACH=dmach(i)
      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(*)
      err=0.0D+0
      do i=nos,1,-1
      err=err+DABS(    os(i) )
      if(err.le.eta) go to 10
      enddo
      i = 1
   10 INITDS=i
      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
      SUBROUTINE TABERFC
C=======================================================================
C
C     TABULATE ERFC AND CUBIC SPLINE COEFFICIENTS
C
C=======================================================================
      INCLUDE 'implicit.h'
      INCLUDE 'sigma1.h'
      DO 10 IX=-1,10002
      X = IX
      X = 1.0D-03*X
      ERFCX  (IX) = X
      ERFCTAB(IX) = TERFC(X)*DEXP(X*X)
   10 CONTINUE
c-----------------------------------------------------------------------
C
C     FIRST DEFINE COMPLICATED CUBIC SPLINE COEFFICIENTS
C
C     F(X) = (X-X2)(X-X3)(X-X4)F1/[(X1-X2)(X1-X3)(X1-X4)] +
C            (X-X1)(X-X3)(X-X4)F2/[(X2-X1)(X2-X3)(X2-X4)] +
C            (X-X1)(X-X2)(X-X4)F3/[(X3-X1)(X3-X2)(X3-X4)] +
C            (X-X1)(X-X2)(X-X3)F4/[(X4-X1)(X4-X2)(X4-X3)]
C     DEFINE THE 4 COEFFICIENTS
C     ERFC1 = F1/[(X1-X2)(X1-X3)(X1-X4)]
C     ERFC2 = F2/[(X2-X1)(X2-X3)(X2-X4)]
C     ERFC3 = F3/[(X3-X1)(X3-X2)(X3-X4)]
C     ERFC4 = F4/[(X4-X1)(X4-X2)(X4-X3)]
C     X1-X2 = -D
C     X1-X3 = -D*2
C     X1-X4 = -D*3
c     X2-X1 = +D
C     X2-X3 = -D
C     X2-X4 = -D*2
C     X3-X1 = +D*2
C     X3-X2 = +D
C     X3-X4 = -D
C     X4-X1 = +D*3
C     X4-X2 = +D*2
C     X4-X3 = +D
C     ERFC1 = F1/[(-D   )(-D*2 )(-D*3 )] = -F1/[6*D^3]
C     ERFC2 = F2/[(+D   )(-D   )(-D*2 )] = +F2/[2*D^3]
C     ERFC3 = F3/[(+D*2 )(+D   )(-D   )] = -F3/[2*D^3]
C     ERFC4 = F4/[(+D*3 )(+D*2 )(+D   )] = +F4/[6*D^3]
C
c-----------------------------------------------------------------------
      D   = 1.0D-03
      DDD = D**3
      DO 20 IX=0,10000
      ERFC1(IX) = -ERFCTAB(IX-1)/(6.0d0*DDD)
      ERFC2(IX) =  ERFCTAB(IX  )/(2.0d0*DDD)
      ERFC3(IX) = -ERFCTAB(IX+1)/(2.0d0*DDD)
      ERFC4(IX) =  ERFCTAB(IX+2)/(6.0d0*DDD)
   20 CONTINUE
c-----------------------------------------------------------------------
C
C     NOW CONVERT TO SIMPLE CUBIC SPLINE COEFFICIENTS
C
C     F3 = [ERFC1+ERFC2+ERFC3+ERC4]
C     F2 =-D*[3*ERFC1+2*ERFC2+ERFC3]
C     F1 = D^2*[2*ERFC1-ERFC2-2*ERFC3-ERFC4]
C     F0 = 2*D^3*ERFC2
C     Z = X-X2
C     ERFC = (((F3*Z+F2)*Z+F1)*Z+F0)
C
c-----------------------------------------------------------------------
      D = 1.0d-03
      DO 30 IX2=0,10000
      F3(IX2) = ERFC1(IX2)+ERFC2(IX2)+ERFC3(IX2)+ERFC4(IX2)
      F2(IX2) =-D*(3.0d0*ERFC1(IX2)+
     1             2.0d0*ERFC2(IX2)+
     1                   ERFC3(IX2))
      F1(IX2) =(D*D)*(2.0d0*ERFC1(IX2) -
     1                      ERFC2(IX2) -
     2                2.0d0*ERFC3(IX2) -
     3                      ERFC4(IX2))
      F0(IX2) =2.0d0*D*D*D*ERFC2(IX2)
   30 CONTINUE
      RETURN
      END