/* -*-C-*- tdlog1p.c */

#define DP_T	double

#include "elefunt.h"

extern double dlog1p(double);
extern double dl1p10(double);

#define DLOG1P10(x)	((dl1p10)(x))
#define DLOG1P(x)	((dlog1p)(x))
#define PRINTF		(void)printf

static const double HALF = 0.5e+00;
static const double EIGHT = 8.0e+00;
static const double TENTH = 0.1e+00;

/*
 *     Program to test DLOG1P/DLOG1P10
 *
 *     Data required
 *
 *        none
 *
 *     Subprograms required from this package
 *
 *        machar - An environmental inquiry program providing
 *                 information on the floating-point arithmetic
 *                 system.  Note that the call to machar can
 *                 be deleted provided the following four
 *                 parameters are assigned the values indicated
 *
 *                 ibeta - the radix of the floating-point system
 *                 it    - the number of base-ibeta digits in the
 *                         significand of a floating-point number
 *                 xmin  - the smallest non-vanishing floating-point
 *                         power of the radix
 *                 xmax  - the largest finite floating-point no.
 *
 *        ran(k) - a function subprogram returning random real
 *                 numbers uniformly distributed over (0,1)
 *
 *
 *     Standard Fortran subprograms required
 *
 *         ABS, DLOG1P, DLOG1P10, amax1, exp, dfloat, sign, sqrt
 *
 *
 *     Latest revision - June 19, 2002
 *
 *     Author - Nelson H. F. Beebe
 *              Mathematics Department, University of Utah
 *
 *     Based on talog:
 *
 *     Latest revision - December 6, 1979
 *
 *     Author - W. J. Cody
 *              Argonne National Laboratory
 *
 **/

void
tdlog1p(VOID_ARG)
{
    int i,
	ibeta,
	iexp,
	iout,
	irnd,
	it,
	j,
	k1,
	k2,
	k3,
	machep,
	maxexp,
	minexp,
	n,
	negep,
	ngrd;
    volatile dp_t a,
	ait,
	albeta,
	b,
	beta,
	c,
	d56,
	d78,
	del,
	r6,
	r7,
	s,
	w,
	x,
	xl,
	xn,
	x1,
	y,
	z,
	zz;
    dp_t eps,
	epsneg,
	temp,
	xmax,
	xmin;

    (void)ranset(initseed());
    machar(&ibeta, &it, &irnd, &ngrd, &machep, &negep, &iexp, &minexp,
	    &maxexp, &eps, &epsneg, &xmin, &xmax);

    beta = TO_FP_T(ibeta);
    albeta = LOG(beta);
    ait = TO_FP_T(it);
    j = it / 3;

    /*
     * For regions 5 and 6, where the scale factor in the identity test
     * is 17/16, find d56 = (smallest 1/beta**k such that the relative
     * error in subtracting ln(s) from ln(s*(1 + 1/beta**k)) is larger
     * than 1/beta), guaranteeing no leading bit loss.
     */
    s = 17.0e+00 / 16.0e+00;
    d56 = (ONE + eps) * (EXP(beta * LOG(s) / (beta - ONE))) / s - ONE;

    /*
     * Do the same for regions 7 and 8.
     */
    s = 11.0e+00 / 10.0e+00;
    d78 = (ONE + eps) * (EXP(beta * LOG(s) / (beta - ONE))) / s - ONE;

    c = ONE;

    for (i = 1; i <= j; i++)
	c = c / beta;

    a = -c;
    b = +c;
    n = maxtest();
    xn = TO_FP_T(n);

    /*
     *-----------------------------------------------------------------------
     *     Random argument accuracy tests
     *-----------------------------------------------------------------------
     */
    for (j = 1; j <= 8; ++j)
    {
	k1 = 0;
	k3 = 0;
	x1 = ZERO;
	r6 = ZERO;
	r7 = ZERO;
	del = (b - a) / xn;
	xl = a;

	for (i = 1; i <= n; ++i)
	{
	    x = del * RAN() + xl;

	    switch (j)
	    {
	    case 1:
		y = x;
		zz = DLOG1P(x);
		z = ONE / 3.0e+00;
		z = y * (z - y / 4.0e+00);
		z = (z - HALF) * y * y + y;
		break;

	    case 2:
		temp = x + EIGHT;
		temp = STORE(&temp) - EIGHT;
		x = STORE(&temp);
		y = x + x / 16.0e+00;
		z = DLOG1P(x - ONE);

		/*
		 *# zz = DLOG1P(y - ONE) - (log(17/16) = 31/512 + delta);
		 *
		 * Original summation order:
		 *
		 * zz = DLOG1P(y - ONE) -
		 *      7.774681643484258060613204042026328620247514472377081452e-05;
		 * zz = zz - 31.0e+00 / 512.0e+00;
		 *
		 * Revised summation order (smallest to largest):
		 */

		zz = DLOG1P(y - ONE) - (31.0e+00 / 512.0e+00 +
					7.77468164348425806061320404202632862024751447237708145e-05);
		break;

	    case 3:
		temp = x + EIGHT;
		temp = STORE(&temp) - EIGHT;
		x = STORE(&temp);
		y = x + x * TENTH;
		z = DLOG1P10(x - ONE);

		/*
		 *# zz = DLOG1P10(y - one) - (log10(1.1) = 21/512 + delta)
		 */

		zz = DLOG1P10(y - ONE) -
		    3.770601582250407501999712430242417067021904664530945965e-04;
		zz = zz - 21.0e+00 / 512.0e+00;
		break;

	    case 4:
		z = DLOG1P(x * x - ONE);
		zz = DLOG1P(x - ONE);
		zz = zz + zz;
		break;

	    case 5:		/* FALLTHRU */
	    case 6:
		/*
		 * With x in (0.5,1.5), adding and subtracting 16 clears 4
		 * low-order bits, so that 17x/16 is exactly computable.
		 */

		temp = x + 16.0e+00;
		temp = STORE(&temp) - 16.0e+00;
		x = STORE(&temp);
		y = x + x / 16.0e+00;
		z = DLOG1P(x - ONE);

		/*
		 * zz = DLOG1P(y - ONE) - (log(17/16) = 31/512 + delta)
		 *
		 * Original summation order:
		 *
		 * zz = DLOG1P(y - ONE) -
		 *      7.774681643484258060613204042026328620247514472377081452e-05;
		 * zz = zz - 31.0E+00 / 512.0E+00;
		 *
		 * Revised summation order (smallest to largest):
		 */

		zz = DLOG1P(y - ONE) - (31.0e+00 / 512.0e+00 +
					7.77468164348425806061320404202632862024751447237708145e-05);
		break;

	    case 7:		/* FALLTHRU */
	    case 8:
		temp = x + 16.0e+00;
		temp = STORE(&temp) - 16.0e+00;
		x = STORE(&temp);
		y = x + x * TENTH;
		z = DLOG1P10(x - ONE);

		/*
		 *# zz = DLOG1P10(y - one) - (log10(11/10) = 21/512 + delta)
		 */

		zz = DLOG1P10(y - ONE) -
		    3.770601582250407501999712430242417067021904664530945965e-04;
		zz = zz - 21.0e+00 / 512.0e+00;
		break;

	    default:
		break;
	    }

	    w = ONE;
	    if (z != ZERO)
		w = (z - zz) / z;
	    z = SIGN(w, z);
	    if (z > ZERO)
		k1 = k1 + 1;
	    if (z < ZERO)
		k3 = k3 + 1;

	    w = ABS(w);
	    if (w > r6)
	    {
		r6 = w;
		x1 = x;
	    }
	    r7 = r7 + w * w;
	    xl = a + TO_FP_T(i) * del;	/* OLD: xl = xl + del (bad for large n) */
	} /* end for (i = 1; i <= n; ++i) */

	k2 = n - k3 - k1;
	r7 = SQRT(r7 / xn);

	switch (j)
	{
	case 1:
	    PRINTF("1TEST OF DLOG1P(X) VS T.S. EXPANSION OF DLOG1P(X)\n\n\n");
	    break;

	case 2:
	    PRINTF("1TEST OF DLOG1P(X-1) VS DLOG1P(17(X-1)/16)-DLOG1P(17/16)\n\n");
	    PRINTF(" IF BASE (= %d) IS NOT A POWER OF 2, EXPECT BIT LOSSES 1 OR 2 BITS LARGER THAN NORMAL.\n\n\n", ibeta);
	    break;

	case 3:
	    PRINTF("1TEST OF DL1P10(X-1) VS DL1P10(11(X-1)/10)-DL1P10(11/10)\n\n");
	    PRINTF(" IF BASE (= %d) IS NOT 10, EXPECT BIT LOSSES 1 OR 2 BITS LARGER THAN NORMAL.\n\n\n", ibeta);
	    break;

	case 4:
	    PRINTF("1TEST OF DLOG1P((X-1)*(X-1)) VS 2 * DLOG1P(X-1)\n\n\n");
	    break;

	case 5:
	    PRINTF("1TEST OF DLOG1P(X-1) VS DLOG1P(17(X-1)/16)-DLOG1P(17/16)\n\n");
	    PRINTF(" IF BASE (= %d) IS NOT A POWER OF 2, EXPECT BIT LOSSES 1 OR 2 BITS LARGER THAN NORMAL.\n\n\n", ibeta);
	    break;

	case 6:
	    PRINTF("1TEST OF DLOG1P(X-1) VS DLOG1P(17(X-1)/16)-DLOG1P(17/16)\n\n");
	    PRINTF(" IF BASE (= %d) IS NOT A POWER OF 2, EXPECT BIT LOSSES 1 OR 2 BITS LARGER THAN NORMAL.\n\n\n", ibeta);
	    break;

	case 7:
	    PRINTF("1TEST OF DL1P10(X-1) VS DL1P10(11(X-1)/10)-DL1P10(11/10)\n\n");
	    PRINTF(" IF BASE (= %d) IS NOT 10, EXPECT BIT LOSSES 1 OR 2 BITS LARGER THAN NORMAL.\n\n\n", ibeta);
	    break;

	case 8:
	    PRINTF("1TEST OF DL1P10(X-1) VS DL1P10(11(X-1)/10)-DL1P10(11/10)\n\n");
	    PRINTF(" IF BASE (= %d) IS NOT 10, EXPECT BIT LOSSES 1 OR 2 BITS LARGER THAN NORMAL.\n\n\n", ibeta);
	    break;
	default:
	    break;
	}

	PRINTF(" %6d RANDOM ARGUMENTS WERE TESTED FROM THE INTERVAL\n", n);
	if (j == 1)
	    PRINTF("      (-EPS,+EPS), WHERE EPS = %14.4E\n\n\n", c);
	else
	    PRINTF("      (%15.4E,%15.4E)\n\n\n", a, b);

	if ((j == 3) || (j == 7) || (j == 8))
	    PRINTF(" DL1P10(X) WAS LARGER %5d TIMES,\n", k1);
	else
	    PRINTF(" DLOG1P(X) WAS LARGER %5d TIMES,\n", k1);

	PRINTF("               AGREED %5d TIMES, AND\n", k2);
	PRINTF("          WAS SMALLER %5d TIMES.\n\n\n", k3);

	PRINTF(" THERE ARE %3d BASE %3d SIGNIFICANT DIGITS IN A FLOATING-POINT NUMBER\n\n\n",
	       it, ibeta);

	w = -999.0e+00;
	if (r6 != ZERO)
	    w = LOG(ABS(r6)) / albeta;

	PRINTF(" THE MAXIMUM RELATIVE ERROR OF %14.4E = %4d ** %6.2f\n",
	       r6, ibeta, w);
	PRINTF("    OCCURRED FOR X = %16.6E\n", x1);
	w = AMAX1(ait + w, ZERO);

	PRINTF(" THE ESTIMATED LOSS OF BASE %3d SIGNIFICANT DIGITS IS %6.2f\n\n\n",
	       ibeta, w);
	w = -999.0e+00;
	if (r7 != ZERO)
	    w = LOG(ABS(r7)) / albeta;

	PRINTF(" THE ROOT MEAN SQUARE RELATIVE ERROR WAS %14.4E = %4d ** %6.2f\n",
	       r7, ibeta, w);
	w = AMAX1(ait + w, ZERO);

	PRINTF(" THE ESTIMATED LOSS OF BASE %3d SIGNIFICANT DIGITS IS %6.2f\n\n\n",
	       ibeta, w);

	switch (j)
	{
	case 1:
	    a = SQRT(HALF);
	    b = 15.0e+00 / 16.0e+00;
	    break;

	case 2:
	    a = SQRT(TENTH);
	    b = 0.9e+00;
	    break;

	case 3:
	    a = 16.0e+00;
	    b = 240.0e+00;
	    break;

	case 4:
	    a = ONE - ONE / beta;
	    b = ONE - d56;
	    break;

	case 5:
	    a = ONE + d56;
	    b = ONE + ONE / beta;
	    break;

	case 6:
	    a = ONE - ONE / beta;
	    b = ONE - d78;
	    break;

	case 7:
	    a = ONE + d78;
	    b = ONE + ONE / beta;
	    break;

	default:
	    break;

	}
    } /* for (j = 1; j <= 8; ++j) */

    /*
     *-----------------------------------------------------------------------
     *     SPECIAL TESTS
     *-----------------------------------------------------------------------
     */

    PRINTF("1SPECIAL TESTS\n\n\n");

    PRINTF(" THE IDENTITY  DLOG1P(X-1) = -DLOG1P((1/X)-1)  WILL BE TESTED.\n\n");
    PRINTF("        X         F(X-1) + F((1/X)-1)\n\n");

    for (i = 1; i <= 5; ++i)
    {
	x = RAN();
	x = x + x + 15.0e+00;
	y = ONE / x;
	z = DLOG1P(x - ONE) + DLOG1P(y - ONE);
	zz = z / eps;
	PRINTF(" %14.7f %16.7E %14.2f ULPS\n\n", x, z, zz);
    }

    PRINTF("\n");
    PRINTF(" THE IDENTITY  DLOG1P(X) = X - X**2/2  FOR ABS(X) .LE. SQRT(3*EPS)/BETA WILL BE TESTED.\n");
    PRINTF(" NONZERO RESULTS SUGGEST THAT DLOG1P(X) HAS BEEN SLOPPILY IMPLEMENTED AS DLOG(1+X)\n\n");
    PRINTF("        X         F(X) - F(X - X**2/2)\n\n");

    x = SQRT(eps + eps + eps) / beta;
    for (i = 1; i <= 5; ++i)
    {
	y = DLOG1P(x);
	z = y - (x - HALF * x * x);
	zz = z / eps;
	PRINTF(" %16.7E %16.7E %15.2f ULPS\n\n", x, z, zz);

	x = -x;
	y = DLOG1P(x);
	z = y - (x - HALF * x * x);
	zz = z / eps;
	PRINTF(" %16.7E %16.7E %15.2f ULPS\n\n", x, z, zz);

	x = -x * HALF;
    }

    PRINTF("\n\n");
    PRINTF(" TEST OF SPECIAL ARGUMENTS\n\n\n");

    x = -ZERO;
    y = DLOG1P(x);
    PRINTF(" DLOG1P(%16.7E) = %16.7E\n\n\n", x, y);

    x = ZERO;
    y = DLOG1P(x);
    PRINTF(" DLOG1P(%16.7E) = %16.7E\n\n\n", x, y);

    x = -(ONE - epsneg);
    y = DLOG1P(x);
    PRINTF(" DLOG1P(%16.7E) = %16.7E\n\n\n", x, y);

    x = -eps;
    y = DLOG1P(x);
    PRINTF(" DLOG1P(%16.7E) = %16.7E\n\n\n", x, y);

    x = eps;
    y = DLOG1P(x);
    PRINTF(" DLOG1P(%16.7E) = %16.7E\n\n\n", x, y);

    x = -(eps + eps / (beta * beta * beta * beta));
    y = DLOG1P(x);
    PRINTF(" DLOG1P(%16.7E) = %16.7E\n\n\n", x, y);

    x = eps + eps / (beta * beta * beta * beta);
    y = DLOG1P(x);
    PRINTF(" DLOG1P(%16.7E) = %16.7E\n\n\n", x, y);

    x = xmin;
    y = DLOG1P(x);
    PRINTF(" DLOG1P(XMIN) = DLOG1P(%16.7E) = %16.7E\n\n\n", x, y);

    x = xmax;
    y = DLOG1P(x);
    PRINTF(" DLOG1P(XMAX) = DLOG1P(%16.7E) = %16.7E\n\n\n", x, y);

    /*
     *-----------------------------------------------------------------------
     *     Tests of IEEE 754 subnormals (if available and enabled)
     *-----------------------------------------------------------------------
     */

    if (xmin * HALF != ZERO)
    {
	PRINTF(" TEST OF IEEE 754 SUBNORMAL ARGUMENTS\n\n");

	k1 = 0;
	k2 = 0;
	w = eps;
	z = xmin;
	/*
	 * The choice of x here ensures that all significant bits are one, so
	 * that we can detect deficient implementations of dlog1p() that lose
	 * low-order bits. 
	 */
	while (z != ZERO)
	{
	    x = z * (ONE - w);
	    y = DLOG1P(x);
	    if (y != x)
	    {
		k1 = k1 + 1;
		PRINTF(" ERROR: DLOG1P(%13.6E) RETURNED %13.6E INSTEAD OF CORRECT %13.6E\n",
		       x, y, x);
	    }

	    y = DLOG1P(-x);
	    if (y != (-x))
	    {
		k1 = k1 + 1;
		PRINTF(" ERROR: DLOG1P(%13.6E) RETURNED %13.6E INSTEAD OF CORRECT %13.6E\n",
		       -x, y, -x);
	    }

	    k2 = k2 + 2;
	    z = z * HALF;
	    w += w;
	}

	if (k1 == 0)
	    PRINTF(" ALL %3d SUBNORMALS TESTED CORRECTLY SATISFY DLOG1P(X) = X\n\n\n", k2);
	else
	    PRINTF(" %2d OF %3d SUBNORMALS TESTED FAIL TO SATISFY DLOG1P(X) = X\n\n\n", k1, k2);
    }

    /*
     *-----------------------------------------------------------------------
     *     TEST OF ERROR RETURNS
     *-----------------------------------------------------------------------
     */

    PRINTF("1TEST OF ERROR RETURNS\n\n\n");

    x = -TWO;
    PRINTF(" DLOG1P WILL BE CALLED WITH THE ARGUMENT %14.4E\n", x);
    PRINTF(" THIS SHOULD TRIGGER AN ERROR MESSAGE\n\n\n");
    y = DLOG1P(x);
    PRINTF(" DLOG1P RETURNED THE VALUE %15.4E\n\n\n\n", y);

    x = -ONE;
    PRINTF(" DLOG1P WILL BE CALLED WITH THE ARGUMENT %15.4E\n", x);
    PRINTF(" THIS SHOULD TRIGGER AN ERROR MESSAGE\n\n\n");
    y = DLOG1P(x);
    PRINTF(" DLOG1P RETURNED THE VALUE %15.4E\n\n\n\n", y);

    PRINTF(" THIS CONCLUDES THE TESTS\n");
}
