/* -*-C-*- texpm1.c */

#define SP_T	float

#include "elefunt.h"

extern float expm1f(float);

#define EXPM1(x)	((expm1f)(x))
#define PRINTF		(void)printf

static const sp_t C16 = 16.0e+00F;
static const sp_t C45 = 45.0e+00F;
static const sp_t EIGHT = 8.0e+00F;
static const sp_t FIVE = 5.0e+00F;
static const sp_t HALF = 0.5e+00F;
static const sp_t ONEP5 = 1.5e+00F;
static const sp_t TENTH = 0.1e+00F;

/*
 *     Program to test expm1
 *
 *     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, aint, alog, AMAX1, EXPM1, float, sqrt
 *
 *     Latest revision - June 26, 2002
 *
 *     Author - Nelson H. F. Beebe
 *              Mathematics Department, University of Utah
 *
 *     Based on texp:
 *
 *     Latest revision - December 6, 1979
 *
 *     Author - W. J. Cody
 *              Argonne National Laboratory
 *
 */

void
texpm1(VOID_ARG)
{
    int i,
        ibeta,
        iexp,
        iout,
        irnd,
        it,
        i1,
        j,
        k1,
        k2,
        k3,
        machep,
        maxexp,
        minexp,
        n,
        negep,
        ngrd;

    sp_t a,
        ait,
        albeta,
        b,
        beta,
        del,
        eps,
        epsneg,
        r6,
        r7,
        temp,
        v,
        w,
        x,
        xl,
        xmax,
        xmin,
        xn,
        x1,
        y,
        z,
        zz,
        zzz;

    (void)sranset(initseed());
    macharf(&ibeta, &it, &irnd, &ngrd, &machep, &negep, &iexp, &minexp,
	    &maxexp, &eps, &epsneg, &xmin, &xmax);
    beta = TO_FP_T(ibeta);
    albeta = ALOG(beta);
    ait = TO_FP_T(it);

    n = maxtest();
    xn = TO_FP_T(n);
    i1 = 0;

    /*
     *-----------------------------------------------------------------------
     *     random argument accuracy tests
     *-----------------------------------------------------------------------
     */
    for (j = 0; j < 6; ++j)
    {
	k1 = 0;
	k3 = 0;
	x1 = ZERO;
	r6 = ZERO;
	r7 = ZERO;

	switch (j)
	{
	case 0:
	    a = -ALOG(0.9e+00F * xmax);
	    b = ALOG(HALF * epsneg);
	    v = ONE / C16;
	    break;

	case 1:
	    a = ALOG(HALF * epsneg);
	    b = -FIVE * ALOG(TWO);
	    v = ONE / C16;
	    break;

	case 2:
	    a = -FIVE * ALOG(TWO);
	    b = ALOG(HALF);
	    v = C45 / C16;
	    break;

	case 3:
	    a = ALOG(HALF);
	    b = -xmin;
	    v = ONE / C16;
	    break;

	case 4:
	    a = xmin;
	    b = ALOG(ONEP5);
	    v = C45 / C16;
	    break;

	case 5:
	    a = ALOG(ONEP5);
	    b = ALOG(0.9e+00F * xmax);
	    v = ONE / C16;
	    break;

	default:
	    break;
	}

	del = (b - a) / xn;
	xl = a;

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

	    /*
	     *-----------------------------------------------------------------------
	     *     purify arguments
	     *-----------------------------------------------------------------------
	     */

	    temp = x - v;
	    y = STORE(&temp);
	    temp = y + v;
	    x = STORE(&temp);

	    /*
	     *-----------------------------------------------------------------------
	     *           we have an additive formula, suitable for use with
	     *           uniformly-distributed pseudo-random arguments:
	     *
	     *           expm1(x - v) = expm1(-v)*(1 + expm1(x)) + expm1(x)
	     *                        = expm1(x)*(1 + expm1(-v)) + expm1(-v)
	     *
	     *           and we represent expm1(v) as c1 + c2, where c1 is exactly
	     *           representable, and c2 is a small correction term.
	     *-----------------------------------------------------------------------
	     */

	    z = EXPM1(x);
	    zz = EXPM1(y);
	    switch (j)
	    {
	    case 0:		/* * j .eq. 0, v .eq. 1/16, expm1(-v) = -1/16 + 0.00191306... */
		zzz = (z * 0.9375e+00F) +
		    (z *
		     1.9130628134757861197108246223050845246808905494418220e-03F)
		    + (-0.0625e+00F +
		       1.9130628134757861197108246223050845246808905494418220e-03F);
		break;

	    case 1:		/* j .eq. 1, v .eq. 1/16, expm1(-v) = -1/16 + 0.00191306... */
		zzz = (z * 0.9375e+00F) +
		    ((z *
		      1.9130628134757861197108246223050845246808905494418220e-03F)
		     + (-0.0625e+00F +
			1.9130628134757861197108246223050845246808905494418220e-03F));
		break;

	    case 2:		/* j .eq. 2, v .eq. 45/16, expm1(-v) = -(15/16 + 0.0024453...) */
		zzz = (z * 0.0625e+00F) -
		    (z *
		     2.4453321046920570389443866922096486559947441807771923e-03F)
		    - (0.9375e+00F +
		       2.4453321046920570389443866922096486559947441807771923e-03F);
		break;

	    case 3:		/* j .eq. 3, v .eq. 1/16, expm1(-v) = -1/16 + 0.00191306... */
		zzz = (z * 0.9375e+00F) +
		    ((z *
		      1.9130628134757861197108246223050845246808905494418220e-03F)
		     + (-0.0625e+00F +
			1.9130628134757861197108246223050845246808905494418220e-03F));
		break;

	    case 4:		/* j .eq. 4, v .eq. 45/16, expm1(-v) = -(15/16 + 0.0024453...) */
		zzz = (z * 0.0625e+00F) -
		    (z *
		     2.4453321046920570389443866922096486559947441807771923e-03F)
		    - (0.9375e+00F +
		       2.4453321046920570389443866922096486559947441807771923e-03F);
		break;

	    case 5:		/* j .eq. 5, v .eq. 1/16, expm1(-v) = -1/16 + 0.00191306... */
		zzz = (z * 0.9375e+00F) +
		    ((z *
		      1.9130628134757861197108246223050845246808905494418220e-03F)
		     + (-0.0625e+00F +
			1.9130628134757861197108246223050845246808905494418220e-03F));
		break;

	    default:
		break;
	    }

	    w = ONE;
	    if (zzz != ZERO)
		w = (zz - zzz) / zzz;
	    if (w < ZERO)
		k1 = k1 + 1;
	    if (w > 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) */
	}

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

	PRINTF("1TEST OF EXPM1(X-%7.4f) VS EXPM1(%7.4f)*(1 + EXPM1(X)) + EXPM1(X)\n\n\n",
	     (double)v, -(double)v);

	PRINTF(" %6d RANDOM ARGUMENTS WERE TESTED FROM THE INTERVAL\n", n);
	PRINTF("      (%15.4E,%15.4E)\n\n\n", (double)a, (double)b);

	PRINTF(" EXPM1(X+V) WAS LARGER %5d TIMES,\n", k1);
	PRINTF("                AGREED %5d TIMES, AND\n", k2);
	PRINTF("           WAS SMALLER %5d TIMES.\n\n\n", k3);
	PRINTF("\n");

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

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

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

	w = AMAX1(ait + w, ZERO);
	PRINTF(" THE ESTIMATED LOSS OF BASE %3d SIGNIFICANT DIGITS IS %6.2f\n\n\n",
	     ibeta, (double)w);

	w = -999.0e+00F;
	if (r7 != ZERO)
	    w = ALOG(ABS(r7)) / albeta;

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

	w = AMAX1(ait + w, ZERO);
	PRINTF("\n");
	PRINTF(" THE ESTIMATED LOSS OF BASE %3d SIGNIFICANT DIGITS IS %6.2f\n\n\n",
	     ibeta, (double)w);
    }

    /*
     *-----------------------------------------------------------------------
     *     special tests
     *-----------------------------------------------------------------------
     */


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

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

    for (i = 1; i <= 5; ++i)
    {
	x = RAN() * beta;
	z = ONE + EXPM1(x) + EXPM1(x) / EXPM1(-x);

	PRINTF(" %14.7E %14.7E\n\n", (double)x, (double)z);
    }

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

    x = ZERO;
    y = EXPM1(x) - ONE;
    PRINTF(" EXPM1(0.0) - 1.0 = %15.7E\n", (double)y);

    x = aint(ALOG(xmin));
    y = EXPM1(x);
    PRINTF(" EXPM1(%13.6E) = %13.6E\n", (double)x, (double)y);

    x = aint(ALOG(xmax));
    y = EXPM1(x);
    PRINTF(" EXPM1(%13.6E) = %13.6E\n", (double)x, (double)y);

    x = x / TWO;
    v = x / TWO;
    y = EXPM1(x);
    z = EXPM1(v);
    z = z * z;

    PRINTF("\n");
    PRINTF(" IF EXPM1(%13.6E) = %13.6E IS NOT ABOUT\n", (double)x, (double)y);
    PRINTF(" EXPM1(%13.6E)**2 = %13.6E THERE IS AN ARG RED ERROR\n",
	   (double)v, (double)z);

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

    if (xmin * HALF != ZERO)
    {
	PRINTF("\n\n\n");
	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 expm1() that lose
	 * low-order bits. 
	 */
	while (z != ZERO)
	{
	    x = z * (ONE - w);
	    y = EXPM1(x);
	    if (y != x)
		k1 = k1 + 1;

	    if (y != x)
		PRINTF(" ERROR: EXPM1(%13.6E) RETURNED %13.6E INSTEAD OF CORRECT %13.6E\n",
		       (double)x, (double)y, (double)x);

	    y = EXPM1(-x);
	    if (y != (-x))
		k1 = k1 + 1;

	    if (y != (-x))
		PRINTF(" ERROR: EXPM1(%13.6E) RETURNED %13.6E INSTEAD OF CORRECT %13.6E\n",
		       -(double)x, (double)y, -(double)x);

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

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

    /*
     *-----------------------------------------------------------------------
     *     test of error returns
     *-----------------------------------------------------------------------
     */

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

    x = -ONE / sqrt(xmin);
    PRINTF(" EXMP1 WILL BE CALLED WITH THE ARGUMENT %14.4E\n", (double)x);
    PRINTF(" THIS SHOULD TRIGGER AN ERROR MESSAGE\n\n\n");
    y = EXPM1(x);
    PRINTF(" EXPM1 RETURNED THE VALUE %15.4E\n\n\n\n", (double)y);

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

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