/* -*-C-*- tqexpm1.c */

#define QP_T	long double

#include "elefunt.h"

extern long double expm1l(long double);

#define DINT(x)		(AINT(x))
#define DLOG(x)		(LOG(x))
#define QEXPM1(x)	((expm1l)(x))
#define PRINTF		(void)printf

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

/*
 *     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, DINT, alog, AMAX1, QEXPM1, 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
tqexpm1(VOID_ARG)
{
    int i,
	ibeta,
	iexp,
	iout,
	irnd,
	it,
	i1,
	j,
	k1,
	k2,
	k3,
	machep,
	maxexp,
	minexp,
	n,
	negep,
	ngrd;

    qp_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)qranset(initseed());
    macharl(&ibeta, &it, &irnd, &ngrd, &machep, &negep, &iexp, &minexp,
	    &maxexp, &eps, &epsneg, &xmin, &xmax);
    beta = TO_FP_T(ibeta);
    albeta = DLOG(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 = -DLOG(0.9e+00L * xmax);
	    b = DLOG(HALF * epsneg);
	    v = ONE / C16;
	    break;

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

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

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

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

	case 5:
	    a = DLOG(ONEP5);
	    b = DLOG(0.9e+00L * 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 = QEXPM1(x);
	    zz = QEXPM1(y);
	    switch (j)
	    {
	    case 0:		/* * j .eq. 0, v .eq. 1/16, expm1(-v) = -1/16 + 0.00191306... */
		zzz = (z * 0.9375e+00L) +
		    (z *
		     1.9130628134757861197108246223050845246808905494418220e-03L)
		    + (-0.0625e+00L +
		       1.9130628134757861197108246223050845246808905494418220e-03L);
		break;

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

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

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

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

	    case 5:		/* j .eq. 5, v .eq. 1/16, expm1(-v) = -1/16 + 0.00191306... */
		zzz = (z * 0.9375e+00L) +
		    ((z *
		      1.9130628134757861197108246223050845246808905494418220e-03L)
		     + (-0.0625e+00L +
			1.9130628134757861197108246223050845246808905494418220e-03L));
		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 QEXPM1(X-%7.4Lf) VS QEXPM1(%7.4Lf)*(1 + QEXPM1(X)) + QEXPM1(X)\n\n\n",
	     v, -v);

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

	PRINTF(" QEXPM1(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+00L;
	if (r6 != ZERO)
	    w = DLOG(ABS(r6)) / albeta;

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

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

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

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

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

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


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

    PRINTF(" THE IDENTITY  1 + QEXPM1(X) = -QEXPM1(X)/QEXPM1(-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 + QEXPM1(x) + QEXPM1(x) / QEXPM1(-x);

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

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

    x = ZERO;
    y = QEXPM1(x) - ONE;
    PRINTF(" QEXPM1(0.0) - 1.0 = %15.7LE\n", y);

    x = DINT(DLOG(xmin));
    y = QEXPM1(x);
    PRINTF(" QEXPM1(%13.6LE) = %13.6LE\n", x, y);

    x = DINT(DLOG(xmax));
    y = QEXPM1(x);
    PRINTF(" QEXPM1(%13.6LE) = %13.6LE\n", x, y);

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

    PRINTF("\n");
    PRINTF(" IF QEXPM1(%13.6LE) = %13.6LE IS NOT ABOUT\n", x, y);
    PRINTF(" QEXPM1(%13.6LE)**2 = %13.6LE THERE IS AN ARG RED ERROR\n",
	   v, 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 qexpm1() that lose
	 * low-order bits. 
	 */
	while (z != ZERO)
	{
	    x = z * (ONE - w);
	    y = QEXPM1(x);
	    if (y != x)
		k1 = k1 + 1;

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

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

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

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

	if (k1 == 0)
	    PRINTF(" ALL %3d SUBNORMALS TESTED CORRECTLY SATISFY QEXPM1(X) = X\n\n\n",
		 k2);
	else
	    PRINTF(" %2d OF %3d SUBNORMALS TESTED FAIL TO SATISFY QEXPM1(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.4LE\n", x);
    PRINTF(" THIS SHOULD TRIGGER AN ERROR MESSAGE\n\n\n");
    y = QEXPM1(x);
    PRINTF(" QEXPM1 RETURNED THE VALUE %15.4LE\n\n\n\n", y);

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

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