!               ********************************
!               * ALEV AND SUPPORTING ROUTINES *
!               ********************************
!
!                  VERSION 1.0    30/04/1989
!
!     THESE SUBROUTINES SUPPORT THE "EV" COMMAND IN ALADDIN.  "ALEV"
!     MUST BE MODIFIED BY THE USER IF THIS COMMAND IS TO RECOGNIZE NEW
!     EVALUATION LABELS (FITTED DATA FORMS).
!
!     ORIGINAL VERSION DESIGNED AND WRITTEN BY R. A. HULSE, OF THE
!     PRINCETON UNIVERSITY, PLASMA PHYSICS LABORATORY.
!     (PAPER TO BE SUBMITTED TO THE JOURNAL OF COMPUTATIONAL PHYSICS
!      COMMUNICATIONS)
!
!-------------------------------------------------------------------------------
!
!      REV: 21/4/88 BY R. A. HULSE.
!           RE-ORGANIZE TABULAR OUTPUT AND ALLOW OUTPUT TO FILE
!
!      REV: 15/4/88 BY R. A. HULSE.
!            BREAKOUT CODE FOR EACH DATA TYPE TO SUBROUTINES;
!            GENERATE MULTI-POINT TABULAR OUTPUT;
!            ADD ORNL CHEBYSHEV POLYNOMIAL DATA TYPE
!
!      REV: 7/4/88 BY R. A. HULSE.
!            BASIC VERSION WITH #MEWE AND #TAB1D TYPES
!
!      REV: 1/03/89 BY J.J.SMITH IAEA ATOMIC AND MOLECULAR DATA UNIT
!            SUBROUTINE ALREVD INTRODUCED TO CONTROL THE READING AND
!            PASSING OF INPUT PARAMETERS TO BE USED IN GENERATING
!            TABLES FROM ALEV. SUBROUTINE ALTB1D ADDED TO GENERATE
!            LINEARLY INTERPOLABLE TABLES FOR FITTED DATA FORMS TO
!            REPRODUCE THE FUNCTION TO A INPUT SPECIFIED PERCENTAGE
!            ACCURACY. FUNCTION ALRND6 ADDED TO ROUND REAL NUMBERS TO
!            SIX DECIMAL PLACES FOR OUTPUT FROM THE SUBROUTINE ALTB1D.
!
!#######################################################################
!
SUBROUTINE ALEV
!
!-------------------------------------------------------------------
!
!          EV = EVALUATE DATA VALUE FOR CURRENT ENTRY
!
!-------------------------------------------------------------------
!
!          IN ORDER TO ADD A NEW DATA TYPE TO THE "EV" COMMAND, ADD AN
!          ADDITIONAL "ELSE IF(...)" STATEMENT TO THE MAIN IF...THEN...
!          ELSE CHAIN THAT CHECKS THE "#..." EVALUATION LABEL. THE
!          SUBROUTINE CALLS AND OTHER CODING EXECUTED ON THIS BRANCH ARES
!          USED TO INTERACTIVELY EVALUATE THIS DATA ENTRY TYPE FOR
!          DISPLAY TO THE TERMINAL OR A FILE. FOR EACH DATA TYPE A
!          CALL MUST BE INCLUDED TO READ THE REQUIRED PERCENTAGE
!          ACCURACY AND LIMITS FOR GENERATION OF THE LINEAR DATA POINT
!          SERIES. THE SUBROUTINE ALTB1D REQUIRES THE NUMBER OF
!          INTERVALS AND THE EXTENTS OF EACH INTERVAL. FOR FITTED DATA
!          FORMS SPECIFIED OVER ONE INTERVAL THE EXTENTS CAN BE PASSED
!          DIRECTLY FROM THE VALUES FROM THE CALL TO ALREVD. FOR FITTED
!          DATA FORMS WHICH ARE DEFINED OVER MULTIPLE INTERVALS,
!          ADDITIONAL STATEMENTS HAVE TO BE ADDED TO CONSTRUCT THE
!          ARRAY OF INTERVALS FOR THE SUBROUTINE ALTB1D. A MAXIMUM OF
!          TEN INTERVALS FOR FITTED DATA FORMS HAS BEEN DEFINED.
!          (SEE RELEVANT CODING AND FURTHER COMMENTS BELOW).
!
!          SPECIAL NOTE: IF THE 1-DIMENSIONAL DATA EVALUATION LOOP
!          ROUTINE ALTB1D(AL----) IS TO BE USED, THE NEW EVALUATION
!          SUBROUTINE NAME **MUST** BE ADDED TO THE EXTERNAL STATEMENT
!          AT THE BEGINNING OF ALEV, AND THIS EVALUATION ROUTINE
!          **MUST** BE IN STANDARD FORM !!!
!          (AGAIN, SEE RELEVANT CODING BELOW FOR MORE DETAIL AND
!          EXAMPLE)
!
!-------------------------------------------------------------------
!
  use iso_c_binding, only: fp => c_double
  use alpcom_mod
  use alcom_mod
  implicit none
  EXTERNAL ALMEWE_Z, ALCHEB_Z, ALKING_Z, ALPHACX_Z
  EXTERNAL ALJAN1_Z , ALBELI_Z, RTABSQ_Z, ETABSQ_Z
  real(fp) PERUNC, ZX1, ZX2
  real(fp) ETH
  integer nrange, inpts, ios
!
!-----  GAMMA, CLINE, CTARGT, CION ARE VARIABLES
!-----         FOR FUNCTION TABSPY
!
  real(fp) GAMMA
  CHARACTER*2  CTARGT, CION
!
!-----  Q, ELOW AND EHIGH ARE VARAIABLES FOR FUNCTION ALPHACX
!
  real(fp) Q, ELOW, EHIGH
!
  real(fp) XRANGE(10)
!
!-------------------------------------------------------------------
!
  IF(LESEQN .EQ. 0) THEN
     WRITE(LUTOUT, '(/'' NO ENTRY CURRENTLY READ IN'')' )
     RETURN
  ENDIF
!
!-------------------------------------------------------------------
!
!      BEGIN SUBROUTINE SWITCH TO SELECT CORRECT SUBROUTINE TO CALL
!      IN ORDER TO EVALUATE THIS ENTRY, BASED ON THE EVALUATION
!      FUNCTION LABEL FROM THE ENTRY.  THIS LABEL IS STORED AS THE
!      LAST BOOLEAN LABEL.
!
!-------------------------------------------------------------------
!
  IF(BL(NBL) .EQ. '#MEWE') THEN
     WRITE(LUTOUT,&
     '(/'' MEWE SPECTRAL LINE EXCITATION RATE COEFFICIENT (cm3/s),'',/'' AS FUNCTION OF ELECTRON TEMPERATURE (keV)'')')
!
!--------------  RETREIVE NUMERIC COEFFICIENTS
!
     CALL ALRECF_Z(CF, NCF, NCFMX, ERRMSG)
     IF(NCF .NE. 8 .AND. ERRMSG .EQ. ' ')&
          ERRMSG = 'INCORRECT NUMBER OF COEFFICIENTS'
     IF (ERRMSG .NE.  ' ') THEN
        WRITE(LUTOUT, '(/1X,A)') ERRMSG
        RETURN
     ENDIF
!
!--------------  READ PERCENTAGE UNCERTAINTY AND RANGE FOR EVALUATION
!
     CALL ALREVD_Z(PERUNC,XRANGE(1),XRANGE(2))
     IF (PERUNC .EQ. 0.0_fp) RETURN
!
     NRANGE=1
!
!--------------  GENERATE TABLE OF VALUES OF FUNCTION
!
     CALL ALTB1D_Z(PERUNC,ALMEWE_Z,NRANGE,XRANGE)
!
!------
!
  ELSE IF(BL(NBL) .EQ. '#BELI') THEN
     WRITE(LUTOUT,&
          '(/'' ELECTRON IMPACT IONIZATION CROSS SECTION cm[2], '',&
          /'' AS FUNCTION OF ELECTRON ENERGY (eV)'')')
!
!--------------  RETREIVE NUMERIC COEFFICIENTS
!
     CALL ALRECF_Z(CF, NCF, NCFMX, ERRMSG)
     IF(NCF.EQ.0) THEN
        WRITE(LUTOUT,'(/'' NO FITTING PARAMETERS   EV FUNCTION TERMINATED'')' )
        RETURN
     ENDIF
     IF(ERRMSG .EQ. ' ') THEN
        WRITE(LUTOUT, '(/'' (INPUT VALID RANGE FROM THRESHOLD OF'',&
             1PE12.4, '' (eV) )'')') CF(1)
     ELSE
        WRITE(LUTOUT, '(/1X,A)') ERRMSG
        RETURN
     ENDIF
!
!--------------  READ PERCENTAGE UNCERTAINTY AND RANGE FOR EVALUATION
!
     CALL ALREVD_Z(PERUNC,ZX1,ZX2)
     IF (PERUNC .EQ. 0.0_fp) RETURN
!
!------      DEFINE EXTENT AND NUMBER OF INTERVALS FOR TABLE
!------ (SEE ROUTINE ALBELI FOR DETAILS OF INTERPRETATION OF PARAMETERS)
!
     XRANGE(1) = ZX1
     IF (NCF .GT. 7 ) THEN
        IF (ZX2 .LT. CF(8) .OR. ZX1 .GT. CF(8)) THEN
!
!------      RANGE ZX1 YTO ZX2 OUTSIDE OF AUTOIONIZATION THRESHOLD
!
           XRANGE(2) = ZX2
           NRANGE=1
        ELSE
!
!------      RANGE ZX1 YTO ZX2 BOUNDS THE AUTOIONIZATION THRESHOLD
!
           XRANGE(2) = CF(8)
           XRANGE(3) = ZX2
           NRANGE=2
        ENDIF
     ELSE
!
!------      NO AUTOIONIZATION STRUCTURE
!
        XRANGE(2) = ZX2
        NRANGE = 1
     ENDIF
!
!--------------  GENERATE TABLE OF VALUES OF FUNCTION
!
     CALL ALTB1D_Z(PERUNC,ALBELI_Z,NRANGE,XRANGE)
!
!------
!
  ELSE IF(BL(NBL) .EQ. '#CHEB') THEN
     WRITE(LUTOUT,'(/'' ORNL:CFADC CHEBYSHEV POLYNOMIAL FIT'')' )
!
     CALL ALRECF_Z(CF, NCF, NCFMX, ERRMSG)
!
     IF(NCF .NE. 11 .AND. ERRMSG .EQ. ' ')&
          ERRMSG = 'INCORRECT NUMBER OF COEFFICIENTS'
     IF(ERRMSG .EQ. ' ') THEN
        WRITE(LUTOUT, '(/'' (INPUT VALID RANGE FROM'',&
             1PE10.2, '' TO'', 1PE10.2, '')'')' ) CF(10), CF(11)
     ELSE
        WRITE(LUTOUT, '(/1X,A)') ERRMSG
        RETURN
     ENDIF
!
     CALL ALREVD_Z(PERUNC,XRANGE(1),XRANGE(2))
     IF (PERUNC .EQ. 0.0_fp) RETURN
     NRANGE=1
!
     CALL ALTB1D_Z(PERUNC,ALCHEB_Z,NRANGE,XRANGE)
!
!------
!
  ELSE IF(BL(NBL) .EQ. '#KINGEX') THEN
     WRITE(LUTOUT,&
          '(/'' POLYNOMIAL FIT OF EXCITATION RATE COEFFICIENT (cm3/s),'',&
          /'' AS FUNCTION OF ELECTRON TEMPERATURE (eV)'')')
!
     CALL ALRECF_Z(CF, NCF, NCFMX, ERRMSG)
     IF(ERRMSG .EQ. ' ') THEN
        WRITE(LUTOUT, '(/'' (INPUT VALID RANGE FROM'',&
             1PE12.4, '' TO'', 1PE12.4, '')'')' ) CF(2), CF(3)
     ELSE
        WRITE(LUTOUT, '(/1X,A)') ERRMSG
        RETURN
     ENDIF
!
     CALL ALREVD_Z(PERUNC,XRANGE(1),XRANGE(2))
     IF (PERUNC .EQ. 0.0_fp) RETURN
     NRANGE=1
!
     CALL ALTB1D_Z(PERUNC,ALKING_Z,NRANGE,XRANGE)
!
!------
!
  ELSE IF(BL(NBL) .EQ. '#PHACX') THEN
     WRITE(LUTOUT,&
          '(/'' CHARGE EXCHANGE CROSS SECTION (cm[2]),'',&
          /'' AS FUNCTION OF PROJECTILE ENERGY (eV/amu)'')')
!
     CALL ALRECF_Z(CF, NCF, NCFMX, ERRMSG)
     IF(ERRMSG .NE. ' ') THEN
        WRITE(LUTOUT, '(/1X,A)') ERRMSG
        RETURN
     ENDIF
!
!-------   READ THE CHARGE STATE OF THE ION AND THEN DETERMINE THE
!-------   ENERGY RANGE OF VALIDITY FROM THE SCALED ENERGY
!
10   WRITE(LUTOUT, '(/'' INPUT THE CHARGE STATE OF THE ION,'',&
          '' (TO EXIT INPUT ,) ? '')' )
!
     INPTS = 0
     READ(LUTIN, *, IOSTAT=IOS) Q
     IF (Q .EQ. 0.0_fp ) RETURN
     IF (IOS .NE. 0) THEN
        WRITE(LUTOUT, '('' INVALID INPUT'')')
        GO TO 10
     ENDIF
!
!-------   THE SCALED CROSS SECTION APPLIES TO CHARGE STATES FROM
!-------   5 TO 26.
!
     IF(Q.LT.5.OR.Q.GT.26) THEN
        WRITE(LUTOUT,&
             '(/'' INVALID INPUT, THE CHARGE STATE (Q) MUST '',&
             ''BE A VALUE IN THE RANGE 5 <= Q <= 26 '')')
        GO TO 10
     ENDIF
!
!-------   PASS Q IN THE COEFFICIENT ARRAY TO EVALUATION FUNCTION
!-------   ALPHACX. THERE ARE SIX COEFFICIENTS FOR THESE ENTRIES
!
     CF(7) = Q
!
     ELOW = CF(1)*DSQRT(Q)
     EHIGH = CF(2)*DSQRT(Q)
     WRITE(LUTOUT, '(/'' (INPUT VALID RANGE FROM'',&
          1PE11.3, '' TO'', 1PE11.3, '' (eV/amu))'')' ) ELOW, EHIGH
!
     CALL ALREVD_Z(PERUNC,XRANGE(1),XRANGE(2))
     IF (PERUNC .EQ. 0.0_fp) RETURN
     NRANGE=1
!
     CALL ALTB1D_Z(PERUNC,ALPHACX_Z,NRANGE,XRANGE)
!
!------
!
  ELSE IF(BL(NBL) .EQ. '#JAN1') THEN
     WRITE(LUTOUT,&
          '(/'' LOG(N) POLYNOMIAL FIT '')' )
!
     CALL ALRECF_Z(CF, NCF, NCFMX, ERRMSG)
     IF(NCF .NE. 11 .AND. ERRMSG .EQ. ' ')&
          ERRMSG = 'INCORRECT NUMBER OF COEFFICIENTS'
     IF(ERRMSG .EQ. ' ') THEN
        WRITE(LUTOUT, '(/'' (INPUT VALID RANGE FROM'',&
             1PE10.2, '' TO'', 1PE10.2, '')'')' ) CF(1), CF(2)
     ELSE
        WRITE(LUTOUT, '(/1X,A)') ERRMSG
        RETURN
     ENDIF
!
     CALL ALREVD_Z(PERUNC,XRANGE(1),XRANGE(2))
     IF (PERUNC .EQ. 0.0_fp) RETURN
     NRANGE=1
!
     CALL ALTB1D_Z(PERUNC,ALJAN1_Z,NRANGE,XRANGE)
!
!------
!
  ELSE IF(BL(NBL) .EQ. '#'.AND. BL(1) .EQ. '$TABSPY') THEN
     WRITE(LUTOUT,&
          '(/'' SPUTTERING YIELDS (ATOMS/ION) OF MONATOMIC SOLIDS),'',&
          /'' AS FUNCTION OF INCIDENT ION ENERGY (eV)'')')
!
!------  THE INCIDENT ION AND TARGET PAIR MUST BE SPECIFIED
!
100  WRITE(LUTOUT,&
          '(/'' ENTER THE INCIDENT ION, TARGET PAIR '',&
          ''(WITH 2 CHARACTERS FOR EACH REACTANT)'',&
          /'' EXAMPLE H ,Cu  . (TO EXIT INPUT ,,) ? '')' )
!
     READ(LUTIN, '(A2,1X,A2)', IOSTAT=IOS) CION,CTARGT
     INPTS = 0
!
!------  CHECK RETURNED VALUES FOR THE INCIDENT ION AND TARGET
!
     IF (CION .EQ. ',,') RETURN
     IF (CION .EQ. ' ' .AND. CTARGT .EQ. ' ') RETURN
     IF(IOS .NE. 0 .OR. CION .EQ. ' ' .OR. CTARGT .EQ. ' ')  THEN
        WRITE(LUTOUT, '('' INVALID INPUT'')')
        GO TO 100
     ENDIF
!
!--  CALL RTABSQ TO READ DATA FOR CALCULATION OF SPUTTERING YIELDS
!--  CHECK THE TARGET, ION COMBINATION AND PASS BACK ARRAY CF FOR
!--  ROUTINE ETABSQ TO PRODUCE THE SPUTTERING YIELD.
!
     CALL RTABSQ_Z(CION,CTARGT,CF,ERRMSG)
     IF(ERRMSG .NE. ' ') THEN
        WRITE(LUTOUT, '(/1X,A)') ERRMSG
        RETURN
     ENDIF
!-----
!-----  DETERMINE AND PRINT THE THRESHOLD ENERGY FOR THE REACTION
!-----  (ROUNDED UP TO THE NEXT .1 EV).
!-----  CF(2) = ATOMIC MASS OF ION   CF(4) = ATOMIC MASS OF TARGET
!-----  CF(5) = SUBLIMATION ENERGY.
!
     GAMMA= 4.0_fp * CF(2)* CF(4) / (CF(2) + CF(4))**2.0_fp
     IF (CF(2) .GE. CF(4))    THEN
        ETH = (4.0_fp / 3.0_fp)**6.0_fp * CF(5) / GAMMA
     ELSE
        ETH = (CF(5) / GAMMA) *&
             ((2.0_fp * (CF(2) + CF(4))) / (CF(2) + 2.0_fp * CF(4)))**6.0_fp
     ENDIF
     ETH = ETH + 0.0999_fp 
     WRITE(LUTOUT, '(/'' (INPUT VALID RANGE FROM THRESHOLD OF'',&
          1PE10.2, '' (eV) )'')') ETH
!
     CALL ALREVD_Z(PERUNC,XRANGE(1),XRANGE(2))
     IF (PERUNC .EQ. 0.0_fp) RETURN
     NRANGE=1
!
     CALL ALTB1D_Z(PERUNC,ETABSQ_Z,NRANGE,XRANGE)
!
!------
!
!      OTHER EVALUATION LABELS GO HERE IN STRUCTURE OF THE FORM:
!
!      ELSE IF(BL(NBL) .EQ. '#{EVALUATION LABEL}') THEN
!             CALL {APPROPRIATE SUBROUTINE TO DO INTERACTIVE
!                    EVALUATION}
!
!      FOR 1-D DATA TYPES WITH SUBROUTINES IN PROPER FORM, ALTB1D CAN
!      BE USED TO CALL THE EVALUATION SUBROUTINE DIRECTLY BY NAME, WITH NO
!      NO SEPARATE ROUTINE NEEDED FOR ALEV TO INTERACT WITH THE
!      TERMINAL ETC.
!
!      IF ALTB1D CANNOT BE USED, THE TYPICAL STRUCTURE OF SUBROUTINE
!      CALLED BY ALEV FOR INTERACTIVE EVALUATION OF A DATA ENTRY CON
!      CONTAINS:
!
!          {CODING TO CONVERT COEFFICIENT FIELD AS REQUIRED}
!          {CODING TO OBTAIN REQUIRED INDEPENDENT VARIABLE(S) FOR THIS
!           DATA TYPE}
!          {CODING TO CALL EVALUATION FUNCTION SUBROUTINE}
!          {CODING TO OUTPUT RESULTING DATA POINT VALUE(S)}
!          {LOOP BACK FOR MORE EVALUATIONS OR RETURN}
!
!------
!
!          CATCH-ALL FOR ENTRIES WITH EVALUATION LABELS NOT CURRENTLY IN
!          THIS VERSION OF ALADDIN
!
  ELSE
     WRITE(LUTOUT,&
          '(/'' THIS EVALUATION LABEL CURRENTLY UNAVAILABLE'')')
!
!------
!
  ENDIF
!
  RETURN
END SUBROUTINE ALEV
!
SUBROUTINE ALTB1D_Z(PERUNC,EVSUB,NRANGE,XRANGE)
  use iso_c_binding, only: fp => c_double
  use alcom_mod
  implicit none
  EXTERNAL EVSUB
!
!     CONSTRUCT A LINEARLY INTERPOLABLE TABLE OF VALUES OF A FUNCTION
!     OF A SINGLE CONTINUOUS VARIABLE.
!
!     THE ROUTINE WILL CONSTRUCT A TABLE OF VALUES (X,Y) WHERE THE
!     TABULATED (X,Y) PAIRS WILL BE EXACTLY REPRODUCE THE FUNCTION
!     AND LINEAR INTERPOLATION BETWEEN THE TABULATED PAIRS WILL BE
!     WITHIN THE FRACTIONAL UNCERTAINTY (PERUNC).  THE FUNCTION CAN
!     BE DEFINED OVER A NUMBER OF X INTERVALS.
!
!     THE PASSED VARIABLE "EVSUB" IS THE NAME OF THE SUBROUTINE TO
!     TO EVALUATE THE DATA POINT.  THIS SUBROUTINE MUST HAVE AN
!     ARGUMENT LIST IN STANDARD FORM, AND USE TYPE REAL DOUBLE PRECISION
!     COEFFICIENTS, FOR ALTB1D TO BE USED.
!     OTHERWISE, A SEPARATE ROUTINE FOR THAT DATA TYPE WILL HAVE TO BE
!     TO BE WRITTEN.
!
!     THE PARAMETERS REQUIRED BY SUBROUTINE ALTB1D ARE:
!
!       PERCUNC = FRACTIONAL PERCENTAGE UNCERTAINTY FOR GENERATION OF
!                 THE TABLE.
!       EVSUB = NAME OF EVALUATION SUBROUTINE
!              THE REQUIRED FORM FOR AN EVALUATION SUBROUTINE CALLABLE
!              USING ALTB1D IS:
!
!           SUBROUTINE {EVSUB} (PX, PCF, KNCF, PY, KERMSG)
!
!             WHERE PX = INDEPENDENT VARIABLE
!             PCF = ARRAY OF REAL DOUBLE PRECISION COEFFICIENTS
!                   (E.G., ALEVID USES ALRECF)
!             KNCF = NUMBER OF COEFFICIENTS IN PCF
!             PY = RETURNED DOUBLE PRECISION VALUE CORRESPONDING TO PX
!             KERMSG = CHARACTER ARRAY RETURNING ERROR MESSAGE (BLANK =
!                      NO ERROR)
!       NRANGE  = NUMBER OF RANGES/INTERVALS USED IN REPRESENTING THE
!                 FUNCBTION
!       XRANGE  = ARRAY OF RANGES USED FOR FUNCTION WHERE THE RANGES ARE
!                 DEFINED AS
!
!                         XRANGE(1) TO XRANGE(2)   WITH NRANGE = 1
!                     AND XRANGE(2) TO XRANGE(3)   WITH NRANGE = 2 ETC
!
!      ON SUCCESFUL COMPLETION OF THE GENERATION OF THE LINEARLY
!      INTERPOLABLE TABLE THE NUMBER OF (X,Y) PAIRS REPRESENTING THE
!      FUNCTION IS OUTPUT. OTHERWISE EITHER CONVERGENCE HAS FAILED DUE
!      TO THE FUNCTIONAL  FORM OF THE EXPRESSION OR BECAUSE MORE THAN
!      THE MAXIMUM NUMBER OF POINTS IN A TABLE HAS BEEN EXCEDDED.
!
  CHARACTER*4, dimension(6) ::  KSIGN
  real(fp) XNOW,YNOW,XLAST,YLAST,XEND,&
       YEND,XMID,YMID,YLIN,XFINAL,YFINAL,PERUNC,&
       DX,DXSTEP,RATLST,RATNOW,XNOWL,DYMID,XNOW1,XNOW2,ALRND6
!
  real(fp) ZERO,HUNDRD,HALF,TEN,SMALLR,SMALLX
!
  real(fp) XRANGE(*)
  real(fp) XTAB(5000),YTAB(5000),XNORM(6),KEXP(6),&
       MARKER(5000)
  integer nrange, iptmax, maxlp1, maxlp2, kpt, irange, myway, ipt
  integer loop, npt, inow, jmin, jmax, itop, j, i
!
!------DEFINE DIMENSION OF TABLES (TO PREVENT MEMORY OVERFLOW)
!
  DATA IPTMAX/5000/
  DATA MAXLP1/20/
  DATA MAXLP2/40/
  DATA ZERO/0.0_fp/
  DATA HALF/5.0e-01_fp/
  DATA TEN/1.0e+01_fp/
  DATA HUNDRD/1.0e+02_fp/
  DATA SMALLR/9.99e-01_fp/
  DATA SMALLX/1.0e-07_fp/
!
!------INITIALIZE TOTAL POINT COUNT (ALL X REGIONS COMBINED).
!
  KPT=0
!
!          TREAT EACH X RANGE OF FUNCTION SEPARATELY.
!
  DO IRANGE=1,NRANGE
!
!------- DETERMINE FUNCTION AT START AN END OF INTERVAL
!
     XNOW=XRANGE(IRANGE)
     IF (IRANGE .NE. 1) XNOW = XNOW + (SMALLX * XNOW)
     CALL EVSUB (XNOW, CF, NCF, YNOW, ERRMSG)
     IF (ERRMSG .NE. ' ')       GO TO 370
     XEND=XRANGE(IRANGE+1)
     CALL EVSUB (XEND, CF, NCF, YEND, ERRMSG)
     IF (ERRMSG .NE. ' ')       GO TO 370
!
!          SELECT LINEAR OR LOG INTERVALS.
!
     IF(XNOW.LE.ZERO) GO TO 10
     IF(XEND.LT.TEN*XNOW) GO TO 10
!
!------LOG INTERVALS.
!
     MYWAY=2
     DXSTEP=DLOG(XEND/XNOW)/HUNDRD
     DXSTEP=DEXP(DXSTEP)
     XNOW1=ALRND6(XNOW*DXSTEP)
     GO TO 20
!
!------LINEAR INTERVALS.
!
10   MYWAY=1
     DXSTEP=(XEND-XNOW)/HUNDRD
     XNOW1=ALRND6(XNOW+DXSTEP)
!
!         START CONSTRUCTING TABLE.
!
!------INITIALIZE TABLE TO CONTAIN START OF INTERVAL.
!
20   IPT=1
     XTAB(IPT)=XNOW
     YTAB(IPT)=YNOW
     MARKER(IPT)=0
!
!------NO LINEARIZING IF ALLOWABLE ERROR IS NOT POSITIVE OR CURRENT
!------INTERVAL IS OF ZERO LENGTH.
!
     IF(PERUNC.GT.ZERO.AND.XEND.GT.XNOW) GO TO 30
     IPT=2
     XTAB(IPT)=XEND
     YTAB(IPT)=YEND
     MARKER(IPT)=1
     GO TO 240
!
!          START NEXT X INTERVAL.
!
!------DEFINE BEGINNING OF SUB-INTERVAL.
!
30   XLAST=XNOW
     YLAST=YNOW
!
!------INITIALIZE TABLE TO CONTAIN START OF INTERVAL.
!
     IF(XNOW.LT.XNOW1) GO TO 80
!
!------SAVE UNROUNDED VALUE TO SKIP VERY SHORT INTERVALS.
!
40   XNOWL=XNOW1
!
!------DEFINE END OF SUB-INTERVAL.
!
     IF(MYWAY.EQ.2) GO TO 50
!
!------LINEAR INTERVALS.
!
     XNOW1=ALRND6(XNOW1+DXSTEP)
     XNOW2=XNOW1+DXSTEP
!
!------SPECIAL TREATMENT FOR 0.0.
!
     IF(XLAST.LT.ZERO.AND.XNOW1.GT.ZERO) XNOW1=ZERO
     GO TO 60
!
!------LOG INTERVALS.
!
50   XNOW1=ALRND6(XNOW1*DXSTEP)
     XNOW2=XNOW1*DXSTEP
!
!------AVOID ROUNDOFF NEAR END OF INTERVAL.
!
60   IF(XNOW2.GE.XEND) GO TO 90
!
!------STOP AT END OF INTERVAL.
!
     IF(XNOW1.GE.XEND) GO TO 90
!
!------IGNORE INTERVALS THAT CANNOT BE SUB-DIVIDED AT LEAST ONCE.
!
     XMID=HALF*(XNOW1+XNOW)
     XMID=ALRND6(XMID)
     IF(XMID.LE.XNOW.OR.XMID.GE.XNOW1) GO TO 70
     GO TO 80
70   XNOW1=XNOWL+DXSTEP
     GO TO 40
80   XNOW=XNOW1
!
!------INITIALIZE COUNT OF NUMBER OF TIMES INTERVAL HAS BEEN SUB-DIVIDED
!
     LOOP=0
     IF(XNOW.LT.XEND) GO TO 100
90   XNOW=XEND
     YNOW=YEND
     XNOW1=XEND
     GO TO 110
100  CALL EVSUB (XNOW, CF, NCF, YNOW, ERRMSG)
     IF (ERRMSG .NE. ' ')       GO TO 370
!
!          SUB-DIVIDE INTERVAL AND CHECK FOR CONVERGENCE.
!
!------INCREMENT COUNT OF NUMBER OF TIMES INTERVAL HAS BEEN SUB-DIVIDED
!------AND CHECK FOR MAXIMUM NUMBER OF SUB-DIVISIONS.
!
110  LOOP=LOOP+1
     IF(LOOP.GT.MAXLP2) GO TO 150
!
!------COMPARE EXACT FUNCTION TO LINEAR INTERPOLATION OVER CURRENT
!------SUBINTERVAL.
!
     XMID=HALF*(XLAST+XNOW)
     XMID = ALRND6(XMID)
!
!------CHECK FOR MINIMUM X INTERVAL.
!
     IF(XMID.LE.XLAST.OR.XMID.GE.XNOW) GO TO 150
     CALL EVSUB (XMID, CF, NCF, YMID, ERRMSG)
     IF (ERRMSG .NE. ' ')  GO TO 370
     YLIN=((XMID-XLAST)*YNOW+(XNOW-XMID)*YLAST)/(XNOW-XLAST)
!
!------CHECK FOR CONVERGENCE.
!
     DYMID=YMID-YLIN
     IF(DABS(DYMID).LE.DABS(PERUNC*YMID)) GO TO 140
!
!------IF POSSIBLE SAVE CURRENT AND LAST RATIO AND CHECK TO SEE IF
!------METHOD IS CONVERGING.
!
     IF(YMID.EQ.ZERO) GO TO 130
     RATNOW=DABS((YMID-YLIN)/(PERUNC*YMID))
     IF(LOOP.LT.MAXLP1) GO TO 120
!
!------STOP SUB-DIVIDING IF METHOD IS NOT CONVERGING.
!
     IF(RATNOW.GE.SMALLR*RATLST) GO TO 150
120  RATLST=RATNOW
!
!------NO CONVERERENCE...HALF SUBINTERVAL AND CONTINUE.
!
130  XNOW=XMID
     YNOW=YMID
     GO TO 110
!
!------CONVERGENCE...SAVE MIDPOINT AND ENDPOINT FOR LATER THINNING.
!
140  IF(IPT.GE.IPTMAX) GO TO 170
     IPT=IPT+1
     XTAB(IPT)=XMID
     YTAB(IPT)=YMID
     MARKER(IPT)=0
     IF(IPT.GE.IPTMAX) GO TO 170
     IPT=IPT+1
     XTAB(IPT)=XNOW
     YTAB(IPT)=YNOW
     MARKER(IPT)=0
     GO TO 160
!
!------MINIMUM X INTERVAL OR MAXIMUM NUMBER OF SUB-DIVISIONS...SAVE
!------ENDPOINT AND MARK AS UNCONVERGED.
!
150  IF(IPT.GE.IPTMAX) GO TO 170
     IPT=IPT+1
     XTAB(IPT)=XNOW
     YTAB(IPT)=YNOW
     MARKER(IPT)=1
!
!------CONTINUE UNTIL END OF X INTERVAL.
!
160  IF(XNOW.LT.XEND) GO TO 30
     GO TO 180
!
!          OVER 5000 POINTS REQUIRED. SAVE END OF X RANGE AND INDICATE N
!          CONVERGENCE...TOO MANY POINTS REQUIRED.
!
170  XTAB(IPT)=XEND
     YTAB(IPT)=YEND
     MARKER(IPT)=2
!
!          THIN RESULTS.
!
!------INITIALIZE ORIGINAL POINT COUNT, FINAL POINT COUNT AND POINTE
!------BEGINNING OF THINNING INTERVAL.
!
180  NPT=IPT
     IPT=1
     INOW=1
!
!------DEFINE X AND Y AT BEGINNING OF THINNING INTERVAL.
!
190  XLAST=XTAB(INOW)
     YLAST=YTAB(INOW)
!
!------INITIALIZE THINNING INDICES TO TRY TO THIN 1 POINT ABOVE INOW
!
     JMIN=INOW+1
     JMAX=INOW+1
!
!------FINISHED IF NO MORE POINTS TO THIN.
!
200  IF(JMAX.GE.NPT) GO TO 230
!
!------SAVE POINT IF NO CONVERGENCE OR X = 0.0.
!
     IF(MARKER(JMAX).NE.0.OR.XTAB(JMAX).EQ.ZERO) GO TO 220
!
!------DEFINE INDEX TO END OF THINNING INTERVAL.
!
     ITOP=JMAX+1
!
!------DEFINE X AND Y AT END OF THINNING INTERVAL AND X INTERVAL.
!
     XNOW=XTAB(ITOP)
     YNOW=YTAB(ITOP)
     DX=XNOW-XLAST
!
!------SEE IF POINTS JMIN TO JMAX CAN BE APPROXIMATED BY LINEAR
!------INTERPOLATION BETWEEN ENDS OF THINNING INTERVAL.
!
     DO J=JMIN,JMAX
        XMID=XTAB(J)
        YMID=YTAB(J)
        YLIN=((XMID-XLAST)*YNOW+(XNOW-XMID)*YLAST)/DX
        IF(DABS(YMID-YLIN).GE.DABS(PERUNC*YMID)) GO TO 220
     enddo
!
!------CAN ELIMINATE ALL POINTS JMIN TO JMAX. INCREMENT JMAX AND TRY
!------ELIMINATE MORE POINTS.
!
     JMAX=JMAX+1
     GO TO 200
!
!------MUST KEEP POINT JMAX.
!
220  IPT=IPT+1
     XTAB(IPT)=XTAB(JMAX)
     YTAB(IPT)=YTAB(JMAX)
     MARKER(IPT)=MARKER(JMAX)
!
!------RESET INDEX TO RESTART THINNING AT JMAX
!
     INOW=JMAX
     GO TO 190
!
!------END OF THINNING SAVE LAST POINT.
!
230  IPT=IPT+1
     XTAB(IPT)=XTAB(NPT)
     YTAB(IPT)=YTAB(NPT)
     MARKER(IPT)=MARKER(NPT)
!
!          PRINT RESULTS AFTER THINNING
!
!------IGNORE FIRST POINT IF AT BOUNDARY BETWEEN X RANGES AND FUNCTION
!------IS CONTINUOUS.
!
240  NPT=1
     IF(IRANGE.EQ.1) GO TO 250
     IF(XTAB(1).EQ.XFINAL.AND.YTAB(1).EQ.YFINAL) NPT=2
!
!------OUTPUT TABULATED VALUES
!
250  DO I=NPT,IPT
!
!------INCREMENT TOTAL POINT COUNT AND CONVERT TO OUTPUT FORM.
!
        KPT=KPT+1
!
!     IF MARKER FOR THE INTERVAL LINEARISATION HAS FAILED A MESSAGE
!     IS DISPLAYED AMD LINEARISATION TERMINATED
!
        IF(MARKER(I).NE.0) GO TO 350
!
!------CONVERGENCE - WRITE DATA TO LUEF OR LUTOUT
!
        IF(EFNAME .NE. '**NONE**') THEN
           WRITE(LUEF,'(2(1PE12.5))') XTAB(I),YTAB(I)
        ELSE
           WRITE(LUTOUT,'(2(1PE12.5))') XTAB(I),YTAB(I)
        ENDIF
     enddo
!
!------SAVE VALUE FROM END OF X REGION (TO CHECK FOR DISCONTINUITY).
!
     XFINAL=XEND
     YFINAL=YEND
!
!------END OF RANGE.
!
  enddo !end DO IRANGE=1,NRANGE
!
!------LINEARIZING IS COMPLETED.
!
  WRITE(LUTOUT, '('' LINEAR DATA POINT SERIES  '', I4,&
       '' VALUES IN TABLE'')') KPT
  IF(EFNAME .NE. '**NONE**')&
       WRITE(LUEF, '(25X,'' LINEAR DATA POINT SERIES  '', I4,&
       '' VALUES IN TABLE'')') KPT
  RETURN
!
350 IF(MARKER(I).EQ.2) GO TO 360
!
!------NO CONVERGENCE.
!
  WRITE(LUTOUT,'(I6,(2(1PE12.5)),'' NO CONVERGENCE OF ALTB1D'')')&
       KPT,XTAB(J),YTAB(J)
!
  IF(EFNAME .NE. '**NONE**')&
       WRITE(LUEF,'(I6,(2(1PE12.5)),'' NO CONVERGENCE OF ALTB1D'')')&
       KPT,XTAB(J),YTAB(J)
  GO TO 380
!
!------TOO MANY POINTS.
!
360 WRITE(LUTOUT,'(I6,2(1PE12.5),&
         '' CONVERGENCE FAILED TOO MANY POINTS'')') KPT,XTAB(J),YTAB(J)
!
  IF(EFNAME .NE. '**NONE**')&
       WRITE(LUEF,'(I6,2(1PE12.5),&
       '' CONVERGENCE FAILED TOO MANY POINTS'')') KPT,XTAB(J),YTAB(J)
  GO TO 380
!
!------ PRINT FINAL ERROR MESSAGE ON LUTOUT
!
370 WRITE(LUTOUT,'('' LINEARISING TERMINATED : '',A)' ) ERRMSG
380 RETURN
END SUBROUTINE ALTB1D_Z
!
!####################################################################
!
SUBROUTINE ALREVD_Z(PERUNC,ZX1,ZX2)
!
  use iso_c_binding, only: fp => c_double
  use alcom_mod
  implicit none
!
  integer ios
  real(fp) PERUNC, ZX1, ZX2
!
  PERUNC=0.0_fp
!
!      READ DATA FOR FUNCTION EVALUATION
!
100 WRITE(LUTOUT,&
         '(/'' EV OUTPUT DATA CURRENTLY DIRECTED TO FILE: '', A,&
         /'' (TO CHANGE OUTPUT FILE, USE EF COMMAND AFTER'',&
         '' EXITING AT NEXT PROMPT)'')') EFNAME
!
!      DETERMINE VALUES OF INDEPENDENT VARIABLE TO BE EVALUATED
!
  WRITE(LUTOUT,&
       '(/''$LINEAR DATA POINT SERIES, INPUT  '')' )
!
  WRITE(LUTOUT,&
       '(/''$% UNCERTAINTY, FIRST, LAST VALUE (,,, TO EXIT) ? '')' )
  READ(LUTIN, *, IOSTAT=IOS) PERUNC, ZX1, ZX2
  IF (PERUNC .EQ. 0.0_fp) RETURN
  IF(IOS .NE. 0 .OR. PERUNC .LT. 0.0_fp&
       .OR. (PERUNC .GT. 0.0_fp .AND. ZX2 .LE. ZX1) ) THEN
     WRITE(LUTOUT, '('' INVALID INPUT'')')
     GO TO 100
  ENDIF
  PERUNC = PERUNC*0.01_fp
!
!          BEFORE DATA OUTPUT, WRITE APPROPRIATE HEADER LINE
!
  IF(EFNAME .NE. '**NONE**') THEN
     WRITE(LUTOUT, '('' ENTER HEADER LINE FOR THIS DATA ?'')')
     READ(LUTIN, '(A)') CMND
     WRITE(LUTOUT, '(1X,''DATA IS BEING WRITTEN TO   '',A)') EFNAME
     WRITE(LUEF, '(A)') CMND
  ENDIF
  RETURN
END SUBROUTINE ALREVD_Z
!
!####################################################################
!
real(fp) FUNCTION ALRND6(X)
!
!          ROUND NUMBER TO 6 DIGITS ACCURACY.
!
  use iso_c_binding, only: fp => c_double
  real(fp) X,ABSX,XR,OFFSET,ZERO,HALF,ONE,TEN
  DATA ZERO/0.0_fp/
  DATA HALF/5.0e-01_fp/
  DATA ONE/1.0e+00_fp/
  DATA TEN/1.0e+01_fp/
  DATA NMAX/1000000_fp/
!
!------AVOID TRYING TO TAKE THE LOG OF 0.0 OR NEGATIVE NUMBERS.
!
  ABSX=DABS(X)
  IF(ABSX.GT.ZERO) GO TO 10
  ALRND6=ZERO
  RETURN
!
!------DEFINE EXPONENT TO ROUND TO NORMAL FORM (1.00.. TO 9.99....).
!
10 I=DLOG10(ABSX)
  IF(ABSX.LT.ONE) I=I-1
!
!------ROUND TO 6 DIGIT INTEGER (TREAT -, 0 AND + EXPONENTS SEPARATE
!------TO AVOID ROUNDOFF WITH NEGATIVE POWERS OF 10..E.G., 10E-1 IS
!------A BINARY MULTIPLE).
!
  I=I-5
  IF(I) 20,40,60
!
!          NEGATIVE EXPONENT.
!
!------ROUND TO 6 DIGIT INTEGER.
!
20 OFFSET=TEN**(-I)
  N=ABSX*OFFSET+HALF
!
!------CHECK FOR CHANGE IN EXPONENT DUE TO ROUNDING.
!
  IF(N.LT.NMAX) GO TO 30
  OFFSET=OFFSET/TEN
  N=ABSX*OFFSET+HALF
!
!------CONVERT TO 6 DIGIT ACCURACY FLOATING POINT NUMBER AND RE-NORM
!
30 XR=N
  XR=XR/OFFSET
  GO TO 80
!
!          ZERO EXPONENT.
!
!------ROUND TO 6 DIGIT INTEGER.
!
40 OFFSET=ONE
  N=ABSX+HALF
!
!------CHECK FOR CHANGE IN EXPONENT DUE TO ROUNDING.
!
  IF(N.LT.NMAX) GO TO 50
  I=-1
  OFFSET=TEN
  N=ABSX/OFFSET+HALF
!
!------CONVERT TO 6 DIGIT ACCURACY FLOATING POINT NUMBER AND RE-NORM
!
50 XR=N
  XR=XR*OFFSET
  GO TO 80
!
!          POSITIVE EXPONENT.
!
!------ROUND TO 6 DIGIT INTEGER.
!
60 OFFSET=TEN**I
  N=ABSX/OFFSET+HALF
!
!------CHECK FOR CHANGE IN EXPONENT DUE TO ROUNDING.
!
  IF(N.LT.NMAX) GO TO 70
  OFFSET=TEN*OFFSET
  N=ABSX/OFFSET+HALF
!
!------CONVERT TO 6 DIGIT ACCURACY FLOATING POINT NUMBER AND RE-NORM
!
70 XR=N
  XR=XR*OFFSET
!
!------DEFINE SIGN OF RESULT.
!
80 IF(X.LT.ZERO) XR=-XR
  ALRND6=XR
  RETURN
END FUNCTION ALRND6
