/* Translated from machar.f (Cody's 1988 TOMS version, with extensions
   by NHFB to force storage of intermediate results) by f2c (version
   20020314), with manual conversion of goto-style loops for better
   readability */

#include "elefunt.h"

#if STDC
void
macharl(int *ibeta, int *it, int *irnd, int *ngrd, int *machep, int
       *negep, int *iexp, int *minexp, int *maxexp,
       qp_t *eps, qp_t *epsneg, qp_t *xmin, qp_t *xmax)
#else /* NOT STDC */
void
macharl(ibeta, it, irnd, ngrd, machep, negep, iexp, minexp, maxexp,
	eps, epsneg, xmin, xmax)
int *ibeta,
    *iexp,
    *irnd,
    *it,
    *machep,
    *maxexp,
    *minexp,
    *negep,
    *ngrd;
qp_t *eps,
    *epsneg,
    *xmax,
    *xmin;
#endif /* STDC */
/***********************************************************************
*      ALGORITHM 665, COLLECTED ALGORITHMS FROM ACM.
*      THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
*      VOL. 14, NO. 4, PP. 303-311.
*-----------------------------------------------------------------------
*  This Fortran 77 subroutine is intended to determine the parameters
*   of the floating-point arithmetic system specified below.  The
*   determination of the first three uses an extension of an algorithm
*   due to M. Malcolm, CACM 15 (1972), pp. 949-951, incorporating some,
*   but not all, of the improvements suggested by M. Gentleman and S.
*   Marovich, CACM 17 (1974), pp. 276-277.  An earlier version of this
*   program was published in the book Software Manual for the
*   Elementary Functions by W. J. Cody and W. Waite, Prentice-Hall,
*   Englewood Cliffs, NJ, 1980.
*
*  The program as given here must be modified before compiling.  If
*   a single (double) precision version is desired, change all
*   occurrences of CS (CD) in columns 1 and 2 to blanks.
*
*  Parameter values reported are as follows:
*
*       IBETA   - the radix for the floating-point representation
*       IT      - the number of base IBETA digits in the floating-point
*                 significand
*       IRND    - 0 if floating-point addition chops
*                 1 if floating-point addition rounds, but not in the
*                   IEEE style
*                 2 if floating-point addition rounds in the IEEE style
*                 3 if floating-point addition chops, and there is
*                   partial underflow
*                 4 if floating-point addition rounds, but not in the
*                   IEEE style, and there is partial underflow
*                 5 if floating-point addition rounds in the IEEE style,
*                   and there is partial underflow
*       NGRD    - the number of guard digits for multiplication with
*                 truncating arithmetic.  It is
*                 0 if floating-point arithmetic rounds, or if it
*                   truncates and only  IT  base  IBETA digits
*                   participate in the post-normalization shift of the
*                   floating-point significand in multiplication;
*                 1 if floating-point arithmetic truncates and more
*                   than  IT  base  IBETA  digits participate in the
*                   post-normalization shift of the floating-point
*                   significand in multiplication.
*       MACHEP  - the largest negative integer such that
*                 1.0+FLOAT(IBETA)**MACHEP .NE. 1.0, except that
*                 MACHEP is bounded below by  -(IT+3)
*       NEGEPS  - the largest negative integer such that
*                 1.0-FLOAT(IBETA)**NEGEPS .NE. 1.0, except that
*                 NEGEPS is bounded below by  -(IT+3)
*       IEXP    - the number of bits (decimal places if IBETA = 10)
*                 reserved for the representation of the exponent
*                 (including the bias or sign) of a floating-point
*                 number
*       MINEXP  - the largest in magnitude negative integer such that
*                 FLOAT(IBETA)**MINEXP is positive and normalized
*       MAXEXP  - the smallest positive power of  BETA  that overflows
*       EPS     - the smallest positive floating-point number such
*                 that  1.0+EPS .NE. 1.0. In particular, if either
*                 IBETA = 2  or  IRND = 0, EPS = FLOAT(IBETA)**MACHEP.
*                 Otherwise,  EPS = (FLOAT(IBETA)**MACHEP)/2
*       EPSNEG  - A small positive floating-point number such that
*                 1.0-EPSNEG .NE. 1.0. In particular, if IBETA = 2
*                 or  IRND = 0, EPSNEG = FLOAT(IBETA)**NEGEPS.
*                 Otherwise,  EPSNEG = (IBETA**NEGEPS)/2.  Because
*                 NEGEPS is bounded below by -(IT+3), EPSNEG may not
*                 be the smallest number that can alter 1.0 by
*                 subtraction.
*       XMIN    - the smallest non-vanishing normalized floating-point
*                 power of the radix, i.e.,  XMIN = FLOAT(IBETA)**MINEXP
*       XMAX    - the largest finite floating-point number.  In
*                 particular  XMAX = (1.0-EPSNEG)*FLOAT(IBETA)**MAXEXP
*                 Note - on some machines  XMAX  will be only the
*                 second, or perhaps third, largest number, being
*                 too small by 1 or 2 units in the last digit of
*                 the significand.
*
*     Latest revision - April 20, 1987
*
*     Author - W. J. Cody
*              Argonne National Laboratory
*
***********************************************************************/
{
    /* System generated locals */
    qp_t d_1, d_2;

    /* Local variables */
    static qp_t beta, temp, temp1, a, b;
    static int i, j, k;
    static qp_t betah, t, y, z, tempa;
    static int itemp;
    static int nxres;
    static qp_t betain;
    static int iz, mx;

/* ----------------------------------------------------------------------- */
/* S    REAL A,B,BETA,BETAIN,BETAH,CONV,EPS,EPSNEG,ONE,T,TEMP,TEMPA, */
/* S   1     TEMP1,TWO,XMAX,XMIN,Y,Z,ZERO */
/* S    REAL STORE */
/* ----------------------------------------------------------------------- */
/* S    CONV(I) = REAL(I) */
/* ----------------------------------------------------------------------- */
/*  Determine IBETA, BETA ala Malcolm. */
/* ----------------------------------------------------------------------- */
    a = ONE;
    do
    {
	a += a;
	d_1 = a + ONE;
	temp = STORE(&d_1);
	d_1 = temp - a;
	temp1 = STORE(&d_1);
	d_1 = temp1 - ONE;
    }
    while (STORE(&d_1) == ZERO);

    b = ONE;
    do
    {
	b += b;
	d_1 = a + b;
	temp = STORE(&d_1);
	d_1 = temp - a;
	itemp = (int) STORE(&d_1);
    }
    while (itemp == 0);

    *ibeta = itemp;
    beta = TO_FP_T(*ibeta);
/* ----------------------------------------------------------------------- */
/*  Determine IT, IRND. */
/* ----------------------------------------------------------------------- */
    *it = 0;
    b = ONE;
    do
    {
	++(*it);
	b *= beta;
	d_1 = b + ONE;
	temp = STORE(&d_1);
	d_1 = temp - b;
	temp1 = STORE(&d_1);
	d_1 = temp1 - ONE;
    }
    while (STORE(&d_1) == ZERO);

    *irnd = 0;
    betah = beta / TWO;
    d_1 = a + betah;
    temp = STORE(&d_1);
    d_1 = temp - a;
    if (STORE(&d_1) != ZERO)
	*irnd = 1;
    d_1 = a + beta;
    tempa = STORE(&d_1);
    d_1 = tempa + betah;
    temp = STORE(&d_1);
    d_1 = temp - tempa;
    if (*irnd == 0 && STORE(&d_1) != ZERO)
	*irnd = 2;
/* ----------------------------------------------------------------------- */
/*  Determine NEGEP, EPSNEG. */
/* ----------------------------------------------------------------------- */
    *negep = *it + 3;
    betain = ONE / beta;
    a = ONE;
    for (i = 1; i <= *negep; ++i)
	a *= betain;
    b = a;
    for (;;)
    {
	d_1 = ONE - a;
	temp = STORE(&d_1);
	d_1 = temp - ONE;
	if (STORE(&d_1) != ZERO)
	    break;
	a *= beta;
	--(*negep);
    }

    *negep = -(*negep);
    *epsneg = a;
    if (*ibeta == 2 || *irnd == 0)
	/* NO-OP */;
    else
    {
	d_1 = ONE + a;
	a = a * STORE(&d_1) / TWO;
	d_1 = ONE - a;
	temp = STORE(&d_1);
	d_1 = temp - ONE;
	if (STORE(&d_1) != ZERO)
	    *epsneg = a;
    }
/* ----------------------------------------------------------------------- */
/*  Determine MACHEP, EPS. */
/* ----------------------------------------------------------------------- */
    *machep = -(*it) - 3;
    a = b;
    for (;;)
    {
	d_1 = ONE + a;
	temp = STORE(&d_1);
	d_1 = temp - ONE;
	if (STORE(&d_1) != ZERO)
	    break;
	a *= beta;
	++(*machep);
    }

    *eps = a;
    d_1 = tempa + beta * (ONE + *eps);
    temp = STORE(&d_1);
    if (*ibeta == 2 || *irnd == 0)
	/* NO-OP */;
    else
    {
	d_2 = ONE + a;
	d_1 = a * STORE(&d_2) / TWO;
	a = STORE(&d_1);
	d_1 = ONE + a;
	temp = STORE(&d_1);
	d_1 = temp - ONE;
	if (STORE(&d_1) != ZERO)
	    *eps = a;
    }
/* ----------------------------------------------------------------------- */
/*  Determine NGRD. */
/* ----------------------------------------------------------------------- */
    *ngrd = 0;
    d_1 = ONE + *eps;
    temp = STORE(&d_1);
    d_1 = temp * ONE - ONE;
    if (*irnd == 0 && STORE(&d_1) != ZERO)
	*ngrd = 1;
/* ----------------------------------------------------------------------- */
/*  Determine IEXP, MINEXP, XMIN. */

/*  Loop to determine largest I and K = 2**I such that */
/*         (1/BETA) ** (2**(I)) */
/*  does not underflow. */
/*  Exit from loop is signaled by an underflow. */
/* ----------------------------------------------------------------------- */
    i = 0;
    k = 1;
    z = betain;
    t = ONE + *eps;
    nxres = 0;
    for (;;)
    {
	y = z;
	z = y * y;
    /* ----------------------------------------------------------------------- */
    /*  Check for underflow here. */
    /* ----------------------------------------------------------------------- */
	a = z * ONE;
	temp = z * t;
	d_1 = a + a;
	if (STORE(&d_1) == ZERO || ABS(z) >= y)
	    break;
	temp1 = temp * betain;
	d_1 = temp1 * beta;
	if (STORE(&d_1) == z)
	    break;
	++i;
	k += k;
    }

    if (*ibeta == 10)
    {
	/* ----------------------------------------------------------------------- */
	/*  This segment is for decimal machines only. */
	/* ----------------------------------------------------------------------- */
	*iexp = 2;
	iz = *ibeta;
	while (k >= iz)
	{
	    iz *= *ibeta;
	    ++(*iexp);
	}
	mx = iz + iz - 1;
    }
    else
    {
	*iexp = i + 1;
	mx = k + k;
    }
/* ----------------------------------------------------------------------- */
/*  Loop to determine MINEXP, XMIN. */
/*  Exit from loop is signaled by an underflow. */
/* ----------------------------------------------------------------------- */
    do
    {
	*xmin = y;
	y *= betain;
    /* ----------------------------------------------------------------------- */
    /*  Check for underflow here. */
    /* ----------------------------------------------------------------------- */
	d_1 = y * ONE;
	a = STORE(&d_1);
	d_1 = y * t;
	temp = STORE(&d_1);
	d_1 = a + a;
	if (STORE(&d_1) == ZERO || ABS(y) >= *xmin)
	    goto L460;
	++k;
	d_1 = temp * betain;
	temp1 = STORE(&d_1);
	d_1 = temp1 * beta;
    } while (STORE(&d_1) != y);
    nxres = 3;
    *xmin = y;
L460:
    *minexp = -k;
/* ----------------------------------------------------------------------- */
/*  Determine MAXEXP, XMAX. */
/* ----------------------------------------------------------------------- */
    if ((mx > (k + k - 3)) || (*ibeta == 10))
	/* NO-OP */;
    else
    {
	mx += mx;
	++(*iexp);
    }
    *maxexp = mx + *minexp;
/* ----------------------------------------------------------------- */
/*  Adjust IRND to reflect partial underflow. */
/* ----------------------------------------------------------------- */
    *irnd += nxres;
/* ----------------------------------------------------------------- */
/*  Adjust for IEEE-style machines. */
/* ----------------------------------------------------------------- */
    if ((*irnd == 2) || (*irnd == 5))
	*maxexp += -2;
/* ----------------------------------------------------------------- */
/*  Adjust for non-IEEE machines with partial underflow. */
/* ----------------------------------------------------------------- */
    if ((*irnd == 3) || (*irnd == 4))
	*maxexp -= *it;
/* ----------------------------------------------------------------- */
/*  Adjust for machines with implicit leading bit in binary */
/*  significand, and machines with radix point at extreme */
/*  right of significand. */
/* ----------------------------------------------------------------- */
    i = *maxexp + *minexp;
    if ((*ibeta == 2) && (i == 0))
	--(*maxexp);
    if (i > 20)
	--(*maxexp);
    if (a != y)
	*maxexp += -2;
    *xmax = ONE - *epsneg;
    d_1 = *xmax * ONE;
    if (STORE(&d_1) != *xmax)
	*xmax = ONE - beta * *epsneg;
    *xmax /= beta * beta * beta * *xmin;
    i = *maxexp + *minexp + 3;
    for (j = 1; j <= i; ++j)
    {
	if (*ibeta == 2)
	    *xmax += *xmax;
	if (*ibeta != 2)
	    *xmax *= beta;
    }
/* ---------- LAST CARD OF MACHAR ---------- */
} /* machar_ */
