diff options
| author | Eric Andersen <andersen@codepoet.org> | 2001-11-22 14:04:29 +0000 |
|---|---|---|
| committer | Eric Andersen <andersen@codepoet.org> | 2001-11-22 14:04:29 +0000 |
| commit | 7ce331c01ce6eb7b3f5c715a38a24359da9c6ee2 (patch) | |
| tree | 3a7e8476e868ae15f4da1b7ce26b2db6f434468c /libm/ldouble | |
| parent | c117dd5fb183afb1a4790a6f6110d88704be6bf8 (diff) | |
Totally rework the math library, this time based on the MacOs X
math library (which is itself based on the math lib from FreeBSD).
-Erik
Diffstat (limited to 'libm/ldouble')
69 files changed, 0 insertions, 27633 deletions
diff --git a/libm/ldouble/Makefile b/libm/ldouble/Makefile deleted file mode 100644 index dad448840..000000000 --- a/libm/ldouble/Makefile +++ /dev/null @@ -1,122 +0,0 @@ -# Makefile for uClibc's math library -# Copyright (C) 2001 by Lineo, inc. -# -# This math library is derived primarily from the Cephes Math Library, -# copyright by Stephen L. Moshier <moshier@world.std.com> -# -# This program is free software; you can redistribute it and/or modify it under -# the terms of the GNU Library General Public License as published by the Free -# Software Foundation; either version 2 of the License, or (at your option) any -# later version. -# -# This program is distributed in the hope that it will be useful, but WITHOUT -# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -# FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more -# details. -# -# You should have received a copy of the GNU Library General Public License -# along with this program; if not, write to the Free Software Foundation, Inc., -# 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -# - -TOPDIR=../../ -include $(TOPDIR)Rules.mak - -LIBM=../libm.a -TARGET_CC= $(TOPDIR)/extra/gcc-uClibc/$(TARGET_ARCH)-uclibc-gcc - -CSRC=acoshl.c asinhl.c asinl.c atanhl.c atanl.c bdtrl.c btdtrl.c cbrtl.c \ - chdtrl.c coshl.c ellpel.c ellpkl.c elliel.c ellikl.c ellpjl.c \ - exp10l.c exp2l.c expl.c fdtrl.c gammal.c gdtrl.c igamil.c igaml.c \ - incbetl.c incbil.c isnanl.c j0l.c j1l.c jnl.c ldrand.c log10l.c log2l.c \ - logl.c nbdtrl.c ndtril.c ndtrl.c pdtrl.c powl.c powil.c sinhl.c sinl.c \ - sqrtl.c stdtrl.c tanhl.c tanl.c unityl.c ynl.c \ - floorl.c polevll.c mtherr.c #cmplxl.c clogl.c -COBJS=$(patsubst %.c,%.o, $(CSRC)) - - -OBJS=$(COBJS) - -all: $(OBJS) $(LIBM) - -$(LIBM): ar-target - -ar-target: $(OBJS) - $(AR) $(ARFLAGS) $(LIBM) $(OBJS) - -$(COBJS): %.o : %.c - $(TARGET_CC) $(TARGET_CFLAGS) -c $< -o $@ - $(STRIPTOOL) -x -R .note -R .comment $*.o - -$(OBJ): Makefile - -clean: - rm -f *.[oa] *~ core - - - -#----------------------------------------- - - -#all: mtstl lparanoi lcalc fltestl nantst testvect monotl libml.a - -mtstl: libml.a mtstl.o $(OBJS) - $(TARGET_CC) $(TARGET_CFLAGS) -o mtstl mtstl.o libml.a $(LIBS) - -mtstl.o: mtstl.c - -lparanoi: libml.a lparanoi.o setprec.o ieee.o econst.o $(OBJS) - $(TARGET_CC) $(TARGET_CFLAGS) -o lparanoi lparanoi.o setprec.o ieee.o econst.o libml.a $(LIBS) - -lparanoi.o: lparanoi.c - $(TARGET_CC) $(TARGET_CFLAGS) -Wno-implicit -c lparanoi.c - -econst.o: econst.c ehead.h - -lcalc: libml.a lcalc.o ieee.o econst.o $(OBJS) - $(TARGET_CC) $(TARGET_CFLAGS) -o lcalc lcalc.o ieee.o econst.o libml.a $(LIBS) - -lcalc.o: lcalc.c lcalc.h ehead.h - -ieee.o: ieee.c ehead.h - -# Use $(OBJS) in ar command for libml.a if possible; else *.o -libml.a: $(OBJS) mconf.h - ar -rv libml.a $(OBJS) - ranlib libml.a - - -fltestl: fltestl.c libml.a - $(TARGET_CC) $(TARGET_CFLAGS) -o fltestl fltestl.c libml.a - -fltestl.o: fltestl.c - -flrtstl: flrtstl.c libml.a - $(TARGET_CC) $(TARGET_CFLAGS) -o flrtstl flrtstl.c libml.a - -flrtstl.o: flrtstl.c - -nantst: nantst.c libml.a - $(TARGET_CC) $(TARGET_CFLAGS) -o nantst nantst.c libml.a - -nantst.o: nantst.c - -testvect: testvect.o libml.a - $(TARGET_CC) $(TARGET_CFLAGS) -o testvect testvect.o libml.a - -testvect.o: testvect.c - $(TARGET_CC) -g -c -o testvect.o testvect.c - -monotl: monotl.o libml.a - $(TARGET_CC) $(TARGET_CFLAGS) -o monotl monotl.o libml.a - -monotl.o: monotl.c - $(TARGET_CC) -g -c -o monotl.o monotl.c - -# Run test programs -check: mtstl fltestl testvect monotl libml.a - -mtstl - -fltestl - -testvect - -monotl - diff --git a/libm/ldouble/README.txt b/libm/ldouble/README.txt deleted file mode 100644 index 30fcaad36..000000000 --- a/libm/ldouble/README.txt +++ /dev/null @@ -1,3502 +0,0 @@ -/* acoshl.c - * - * Inverse hyperbolic cosine, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, acoshl(); - * - * y = acoshl( x ); - * - * - * - * DESCRIPTION: - * - * Returns inverse hyperbolic cosine of argument. - * - * If 1 <= x < 1.5, a rational approximation - * - * sqrt(2z) * P(z)/Q(z) - * - * where z = x-1, is used. Otherwise, - * - * acosh(x) = log( x + sqrt( (x-1)(x+1) ). - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 1,3 30000 2.0e-19 3.9e-20 - * - * - * ERROR MESSAGES: - * - * message condition value returned - * acoshl domain |x| < 1 0.0 - * - */ - -/* asinhl.c - * - * Inverse hyperbolic sine, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, asinhl(); - * - * y = asinhl( x ); - * - * - * - * DESCRIPTION: - * - * Returns inverse hyperbolic sine of argument. - * - * If |x| < 0.5, the function is approximated by a rational - * form x + x**3 P(x)/Q(x). Otherwise, - * - * asinh(x) = log( x + sqrt(1 + x*x) ). - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -3,3 30000 1.7e-19 3.5e-20 - * - */ - -/* asinl.c - * - * Inverse circular sine, long double precision - * - * - * - * SYNOPSIS: - * - * double x, y, asinl(); - * - * y = asinl( x ); - * - * - * - * DESCRIPTION: - * - * Returns radian angle between -pi/2 and +pi/2 whose sine is x. - * - * A rational function of the form x + x**3 P(x**2)/Q(x**2) - * is used for |x| in the interval [0, 0.5]. If |x| > 0.5 it is - * transformed by the identity - * - * asin(x) = pi/2 - 2 asin( sqrt( (1-x)/2 ) ). - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -1, 1 30000 2.7e-19 4.8e-20 - * - * - * ERROR MESSAGES: - * - * message condition value returned - * asin domain |x| > 1 0.0 - * - */ - /* acosl() - * - * Inverse circular cosine, long double precision - * - * - * - * SYNOPSIS: - * - * double x, y, acosl(); - * - * y = acosl( x ); - * - * - * - * DESCRIPTION: - * - * Returns radian angle between -pi/2 and +pi/2 whose cosine - * is x. - * - * Analytically, acos(x) = pi/2 - asin(x). However if |x| is - * near 1, there is cancellation error in subtracting asin(x) - * from pi/2. Hence if x < -0.5, - * - * acos(x) = pi - 2.0 * asin( sqrt((1+x)/2) ); - * - * or if x > +0.5, - * - * acos(x) = 2.0 * asin( sqrt((1-x)/2) ). - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -1, 1 30000 1.4e-19 3.5e-20 - * - * - * ERROR MESSAGES: - * - * message condition value returned - * asin domain |x| > 1 0.0 - */ - -/* atanhl.c - * - * Inverse hyperbolic tangent, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, atanhl(); - * - * y = atanhl( x ); - * - * - * - * DESCRIPTION: - * - * Returns inverse hyperbolic tangent of argument in the range - * MINLOGL to MAXLOGL. - * - * If |x| < 0.5, the rational form x + x**3 P(x)/Q(x) is - * employed. Otherwise, - * atanh(x) = 0.5 * log( (1+x)/(1-x) ). - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -1,1 30000 1.1e-19 3.3e-20 - * - */ - -/* atanl.c - * - * Inverse circular tangent, long double precision - * (arctangent) - * - * - * - * SYNOPSIS: - * - * long double x, y, atanl(); - * - * y = atanl( x ); - * - * - * - * DESCRIPTION: - * - * Returns radian angle between -pi/2 and +pi/2 whose tangent - * is x. - * - * Range reduction is from four intervals into the interval - * from zero to tan( pi/8 ). The approximant uses a rational - * function of degree 3/4 of the form x + x**3 P(x)/Q(x). - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -10, 10 150000 1.3e-19 3.0e-20 - * - */ - /* atan2l() - * - * Quadrant correct inverse circular tangent, - * long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, z, atan2l(); - * - * z = atan2l( y, x ); - * - * - * - * DESCRIPTION: - * - * Returns radian angle whose tangent is y/x. - * Define compile time symbol ANSIC = 1 for ANSI standard, - * range -PI < z <= +PI, args (y,x); else ANSIC = 0 for range - * 0 to 2PI, args (x,y). - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -10, 10 60000 1.7e-19 3.2e-20 - * See atan.c. - * - */ - -/* bdtrl.c - * - * Binomial distribution - * - * - * - * SYNOPSIS: - * - * int k, n; - * long double p, y, bdtrl(); - * - * y = bdtrl( k, n, p ); - * - * - * - * DESCRIPTION: - * - * Returns the sum of the terms 0 through k of the Binomial - * probability density: - * - * k - * -- ( n ) j n-j - * > ( ) p (1-p) - * -- ( j ) - * j=0 - * - * The terms are not summed directly; instead the incomplete - * beta integral is employed, according to the formula - * - * y = bdtr( k, n, p ) = incbet( n-k, k+1, 1-p ). - * - * The arguments must be positive, with p ranging from 0 to 1. - * - * - * - * ACCURACY: - * - * Tested at random points (k,n,p) with a and b between 0 - * and 10000 and p between 0 and 1. - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 0,10000 3000 1.6e-14 2.2e-15 - * - * ERROR MESSAGES: - * - * message condition value returned - * bdtrl domain k < 0 0.0 - * n < k - * x < 0, x > 1 - * - */ - /* bdtrcl() - * - * Complemented binomial distribution - * - * - * - * SYNOPSIS: - * - * int k, n; - * long double p, y, bdtrcl(); - * - * y = bdtrcl( k, n, p ); - * - * - * - * DESCRIPTION: - * - * Returns the sum of the terms k+1 through n of the Binomial - * probability density: - * - * n - * -- ( n ) j n-j - * > ( ) p (1-p) - * -- ( j ) - * j=k+1 - * - * The terms are not summed directly; instead the incomplete - * beta integral is employed, according to the formula - * - * y = bdtrc( k, n, p ) = incbet( k+1, n-k, p ). - * - * The arguments must be positive, with p ranging from 0 to 1. - * - * - * - * ACCURACY: - * - * See incbet.c. - * - * ERROR MESSAGES: - * - * message condition value returned - * bdtrcl domain x<0, x>1, n<k 0.0 - */ - /* bdtril() - * - * Inverse binomial distribution - * - * - * - * SYNOPSIS: - * - * int k, n; - * long double p, y, bdtril(); - * - * p = bdtril( k, n, y ); - * - * - * - * DESCRIPTION: - * - * Finds the event probability p such that the sum of the - * terms 0 through k of the Binomial probability density - * is equal to the given cumulative probability y. - * - * This is accomplished using the inverse beta integral - * function and the relation - * - * 1 - p = incbi( n-k, k+1, y ). - * - * ACCURACY: - * - * See incbi.c. - * Tested at random k, n between 1 and 10000. The "domain" refers to p: - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 0,1 3500 2.0e-15 8.2e-17 - * - * ERROR MESSAGES: - * - * message condition value returned - * bdtril domain k < 0, n <= k 0.0 - * x < 0, x > 1 - */ - - -/* btdtrl.c - * - * Beta distribution - * - * - * - * SYNOPSIS: - * - * long double a, b, x, y, btdtrl(); - * - * y = btdtrl( a, b, x ); - * - * - * - * DESCRIPTION: - * - * Returns the area from zero to x under the beta density - * function: - * - * - * x - * - - - * | (a+b) | | a-1 b-1 - * P(x) = ---------- | t (1-t) dt - * - - | | - * | (a) | (b) - - * 0 - * - * - * The mean value of this distribution is a/(a+b). The variance - * is ab/[(a+b)^2 (a+b+1)]. - * - * This function is identical to the incomplete beta integral - * function, incbetl(a, b, x). - * - * The complemented function is - * - * 1 - P(1-x) = incbetl( b, a, x ); - * - * - * ACCURACY: - * - * See incbetl.c. - * - */ - -/* cbrtl.c - * - * Cube root, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, cbrtl(); - * - * y = cbrtl( x ); - * - * - * - * DESCRIPTION: - * - * Returns the cube root of the argument, which may be negative. - * - * Range reduction involves determining the power of 2 of - * the argument. A polynomial of degree 2 applied to the - * mantissa, and multiplication by the cube root of 1, 2, or 4 - * approximates the root to within about 0.1%. Then Newton's - * iteration is used three times to converge to an accurate - * result. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE .125,8 80000 7.0e-20 2.2e-20 - * IEEE exp(+-707) 100000 7.0e-20 2.4e-20 - * - */ - -/* chdtrl.c - * - * Chi-square distribution - * - * - * - * SYNOPSIS: - * - * long double df, x, y, chdtrl(); - * - * y = chdtrl( df, x ); - * - * - * - * DESCRIPTION: - * - * Returns the area under the left hand tail (from 0 to x) - * of the Chi square probability density function with - * v degrees of freedom. - * - * - * inf. - * - - * 1 | | v/2-1 -t/2 - * P( x | v ) = ----------- | t e dt - * v/2 - | | - * 2 | (v/2) - - * x - * - * where x is the Chi-square variable. - * - * The incomplete gamma integral is used, according to the - * formula - * - * y = chdtr( v, x ) = igam( v/2.0, x/2.0 ). - * - * - * The arguments must both be positive. - * - * - * - * ACCURACY: - * - * See igam(). - * - * ERROR MESSAGES: - * - * message condition value returned - * chdtr domain x < 0 or v < 1 0.0 - */ - /* chdtrcl() - * - * Complemented Chi-square distribution - * - * - * - * SYNOPSIS: - * - * long double v, x, y, chdtrcl(); - * - * y = chdtrcl( v, x ); - * - * - * - * DESCRIPTION: - * - * Returns the area under the right hand tail (from x to - * infinity) of the Chi square probability density function - * with v degrees of freedom: - * - * - * inf. - * - - * 1 | | v/2-1 -t/2 - * P( x | v ) = ----------- | t e dt - * v/2 - | | - * 2 | (v/2) - - * x - * - * where x is the Chi-square variable. - * - * The incomplete gamma integral is used, according to the - * formula - * - * y = chdtr( v, x ) = igamc( v/2.0, x/2.0 ). - * - * - * The arguments must both be positive. - * - * - * - * ACCURACY: - * - * See igamc(). - * - * ERROR MESSAGES: - * - * message condition value returned - * chdtrc domain x < 0 or v < 1 0.0 - */ - /* chdtril() - * - * Inverse of complemented Chi-square distribution - * - * - * - * SYNOPSIS: - * - * long double df, x, y, chdtril(); - * - * x = chdtril( df, y ); - * - * - * - * - * DESCRIPTION: - * - * Finds the Chi-square argument x such that the integral - * from x to infinity of the Chi-square density is equal - * to the given cumulative probability y. - * - * This is accomplished using the inverse gamma integral - * function and the relation - * - * x/2 = igami( df/2, y ); - * - * - * - * - * ACCURACY: - * - * See igami.c. - * - * ERROR MESSAGES: - * - * message condition value returned - * chdtri domain y < 0 or y > 1 0.0 - * v < 1 - * - */ - -/* clogl.c - * - * Complex natural logarithm - * - * - * - * SYNOPSIS: - * - * void clogl(); - * cmplxl z, w; - * - * clogl( &z, &w ); - * - * - * - * DESCRIPTION: - * - * Returns complex logarithm to the base e (2.718...) of - * the complex argument x. - * - * If z = x + iy, r = sqrt( x**2 + y**2 ), - * then - * w = log(r) + i arctan(y/x). - * - * The arctangent ranges from -PI to +PI. - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -10,+10 7000 8.5e-17 1.9e-17 - * IEEE -10,+10 30000 5.0e-15 1.1e-16 - * - * Larger relative error can be observed for z near 1 +i0. - * In IEEE arithmetic the peak absolute error is 5.2e-16, rms - * absolute error 1.0e-16. - */ - - /* cexpl() - * - * Complex exponential function - * - * - * - * SYNOPSIS: - * - * void cexpl(); - * cmplxl z, w; - * - * cexpl( &z, &w ); - * - * - * - * DESCRIPTION: - * - * Returns the exponential of the complex argument z - * into the complex result w. - * - * If - * z = x + iy, - * r = exp(x), - * - * then - * - * w = r cos y + i r sin y. - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -10,+10 8700 3.7e-17 1.1e-17 - * IEEE -10,+10 30000 3.0e-16 8.7e-17 - * - */ - /* csinl() - * - * Complex circular sine - * - * - * - * SYNOPSIS: - * - * void csinl(); - * cmplxl z, w; - * - * csinl( &z, &w ); - * - * - * - * DESCRIPTION: - * - * If - * z = x + iy, - * - * then - * - * w = sin x cosh y + i cos x sinh y. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -10,+10 8400 5.3e-17 1.3e-17 - * IEEE -10,+10 30000 3.8e-16 1.0e-16 - * Also tested by csin(casin(z)) = z. - * - */ - /* ccosl() - * - * Complex circular cosine - * - * - * - * SYNOPSIS: - * - * void ccosl(); - * cmplxl z, w; - * - * ccosl( &z, &w ); - * - * - * - * DESCRIPTION: - * - * If - * z = x + iy, - * - * then - * - * w = cos x cosh y - i sin x sinh y. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -10,+10 8400 4.5e-17 1.3e-17 - * IEEE -10,+10 30000 3.8e-16 1.0e-16 - */ - /* ctanl() - * - * Complex circular tangent - * - * - * - * SYNOPSIS: - * - * void ctanl(); - * cmplxl z, w; - * - * ctanl( &z, &w ); - * - * - * - * DESCRIPTION: - * - * If - * z = x + iy, - * - * then - * - * sin 2x + i sinh 2y - * w = --------------------. - * cos 2x + cosh 2y - * - * On the real axis the denominator is zero at odd multiples - * of PI/2. The denominator is evaluated by its Taylor - * series near these points. - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -10,+10 5200 7.1e-17 1.6e-17 - * IEEE -10,+10 30000 7.2e-16 1.2e-16 - * Also tested by ctan * ccot = 1 and catan(ctan(z)) = z. - */ - /* ccotl() - * - * Complex circular cotangent - * - * - * - * SYNOPSIS: - * - * void ccotl(); - * cmplxl z, w; - * - * ccotl( &z, &w ); - * - * - * - * DESCRIPTION: - * - * If - * z = x + iy, - * - * then - * - * sin 2x - i sinh 2y - * w = --------------------. - * cosh 2y - cos 2x - * - * On the real axis, the denominator has zeros at even - * multiples of PI/2. Near these points it is evaluated - * by a Taylor series. - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -10,+10 3000 6.5e-17 1.6e-17 - * IEEE -10,+10 30000 9.2e-16 1.2e-16 - * Also tested by ctan * ccot = 1 + i0. - */ - - /* casinl() - * - * Complex circular arc sine - * - * - * - * SYNOPSIS: - * - * void casinl(); - * cmplxl z, w; - * - * casinl( &z, &w ); - * - * - * - * DESCRIPTION: - * - * Inverse complex sine: - * - * 2 - * w = -i clog( iz + csqrt( 1 - z ) ). - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -10,+10 10100 2.1e-15 3.4e-16 - * IEEE -10,+10 30000 2.2e-14 2.7e-15 - * Larger relative error can be observed for z near zero. - * Also tested by csin(casin(z)) = z. - */ - /* cacosl() - * - * Complex circular arc cosine - * - * - * - * SYNOPSIS: - * - * void cacosl(); - * cmplxl z, w; - * - * cacosl( &z, &w ); - * - * - * - * DESCRIPTION: - * - * - * w = arccos z = PI/2 - arcsin z. - * - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -10,+10 5200 1.6e-15 2.8e-16 - * IEEE -10,+10 30000 1.8e-14 2.2e-15 - */ - - /* catanl() - * - * Complex circular arc tangent - * - * - * - * SYNOPSIS: - * - * void catanl(); - * cmplxl z, w; - * - * catanl( &z, &w ); - * - * - * - * DESCRIPTION: - * - * If - * z = x + iy, - * - * then - * 1 ( 2x ) - * Re w = - arctan(-----------) + k PI - * 2 ( 2 2) - * (1 - x - y ) - * - * ( 2 2) - * 1 (x + (y+1) ) - * Im w = - log(------------) - * 4 ( 2 2) - * (x + (y-1) ) - * - * Where k is an arbitrary integer. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -10,+10 5900 1.3e-16 7.8e-18 - * IEEE -10,+10 30000 2.3e-15 8.5e-17 - * The check catan( ctan(z) ) = z, with |x| and |y| < PI/2, - * had peak relative error 1.5e-16, rms relative error - * 2.9e-17. See also clog(). - */ - -/* cmplxl.c - * - * Complex number arithmetic - * - * - * - * SYNOPSIS: - * - * typedef struct { - * long double r; real part - * long double i; imaginary part - * }cmplxl; - * - * cmplxl *a, *b, *c; - * - * caddl( a, b, c ); c = b + a - * csubl( a, b, c ); c = b - a - * cmull( a, b, c ); c = b * a - * cdivl( a, b, c ); c = b / a - * cnegl( c ); c = -c - * cmovl( b, c ); c = b - * - * - * - * DESCRIPTION: - * - * Addition: - * c.r = b.r + a.r - * c.i = b.i + a.i - * - * Subtraction: - * c.r = b.r - a.r - * c.i = b.i - a.i - * - * Multiplication: - * c.r = b.r * a.r - b.i * a.i - * c.i = b.r * a.i + b.i * a.r - * - * Division: - * d = a.r * a.r + a.i * a.i - * c.r = (b.r * a.r + b.i * a.i)/d - * c.i = (b.i * a.r - b.r * a.i)/d - * ACCURACY: - * - * In DEC arithmetic, the test (1/z) * z = 1 had peak relative - * error 3.1e-17, rms 1.2e-17. The test (y/z) * (z/y) = 1 had - * peak relative error 8.3e-17, rms 2.1e-17. - * - * Tests in the rectangle {-10,+10}: - * Relative error: - * arithmetic function # trials peak rms - * DEC cadd 10000 1.4e-17 3.4e-18 - * IEEE cadd 100000 1.1e-16 2.7e-17 - * DEC csub 10000 1.4e-17 4.5e-18 - * IEEE csub 100000 1.1e-16 3.4e-17 - * DEC cmul 3000 2.3e-17 8.7e-18 - * IEEE cmul 100000 2.1e-16 6.9e-17 - * DEC cdiv 18000 4.9e-17 1.3e-17 - * IEEE cdiv 100000 3.7e-16 1.1e-16 - */ - -/* cabsl() - * - * Complex absolute value - * - * - * - * SYNOPSIS: - * - * long double cabsl(); - * cmplxl z; - * long double a; - * - * a = cabs( &z ); - * - * - * - * DESCRIPTION: - * - * - * If z = x + iy - * - * then - * - * a = sqrt( x**2 + y**2 ). - * - * Overflow and underflow are avoided by testing the magnitudes - * of x and y before squaring. If either is outside half of - * the floating point full scale range, both are rescaled. - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -30,+30 30000 3.2e-17 9.2e-18 - * IEEE -10,+10 100000 2.7e-16 6.9e-17 - */ - /* csqrtl() - * - * Complex square root - * - * - * - * SYNOPSIS: - * - * void csqrtl(); - * cmplxl z, w; - * - * csqrtl( &z, &w ); - * - * - * - * DESCRIPTION: - * - * - * If z = x + iy, r = |z|, then - * - * 1/2 - * Im w = [ (r - x)/2 ] , - * - * Re w = y / 2 Im w. - * - * - * Note that -w is also a square root of z. The root chosen - * is always in the upper half plane. - * - * Because of the potential for cancellation error in r - x, - * the result is sharpened by doing a Heron iteration - * (see sqrt.c) in complex arithmetic. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -10,+10 25000 3.2e-17 9.6e-18 - * IEEE -10,+10 100000 3.2e-16 7.7e-17 - * - * 2 - * Also tested by csqrt( z ) = z, and tested by arguments - * close to the real axis. - */ - -/* coshl.c - * - * Hyperbolic cosine, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, coshl(); - * - * y = coshl( x ); - * - * - * - * DESCRIPTION: - * - * Returns hyperbolic cosine of argument in the range MINLOGL to - * MAXLOGL. - * - * cosh(x) = ( exp(x) + exp(-x) )/2. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE +-10000 30000 1.1e-19 2.8e-20 - * - * - * ERROR MESSAGES: - * - * message condition value returned - * cosh overflow |x| > MAXLOGL MAXNUML - * - * - */ - -/* elliel.c - * - * Incomplete elliptic integral of the second kind - * - * - * - * SYNOPSIS: - * - * long double phi, m, y, elliel(); - * - * y = elliel( phi, m ); - * - * - * - * DESCRIPTION: - * - * Approximates the integral - * - * - * phi - * - - * | | - * | 2 - * E(phi_\m) = | sqrt( 1 - m sin t ) dt - * | - * | | - * - - * 0 - * - * of amplitude phi and modulus m, using the arithmetic - - * geometric mean algorithm. - * - * - * - * ACCURACY: - * - * Tested at random arguments with phi in [-10, 10] and m in - * [0, 1]. - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -10,10 50000 2.7e-18 2.3e-19 - * - * - */ - -/* ellikl.c - * - * Incomplete elliptic integral of the first kind - * - * - * - * SYNOPSIS: - * - * long double phi, m, y, ellikl(); - * - * y = ellikl( phi, m ); - * - * - * - * DESCRIPTION: - * - * Approximates the integral - * - * - * - * phi - * - - * | | - * | dt - * F(phi_\m) = | ------------------ - * | 2 - * | | sqrt( 1 - m sin t ) - * - - * 0 - * - * of amplitude phi and modulus m, using the arithmetic - - * geometric mean algorithm. - * - * - * - * - * ACCURACY: - * - * Tested at random points with m in [0, 1] and phi as indicated. - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -10,10 30000 3.6e-18 4.1e-19 - * - * - */ - -/* ellpel.c - * - * Complete elliptic integral of the second kind - * - * - * - * SYNOPSIS: - * - * long double m1, y, ellpel(); - * - * y = ellpel( m1 ); - * - * - * - * DESCRIPTION: - * - * Approximates the integral - * - * - * pi/2 - * - - * | | 2 - * E(m) = | sqrt( 1 - m sin t ) dt - * | | - * - - * 0 - * - * Where m = 1 - m1, using the approximation - * - * P(x) - x log x Q(x). - * - * Though there are no singularities, the argument m1 is used - * rather than m for compatibility with ellpk(). - * - * E(1) = 1; E(0) = pi/2. - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 0, 1 10000 1.1e-19 3.5e-20 - * - * - * ERROR MESSAGES: - * - * message condition value returned - * ellpel domain x<0, x>1 0.0 - * - */ - -/* ellpjl.c - * - * Jacobian Elliptic Functions - * - * - * - * SYNOPSIS: - * - * long double u, m, sn, cn, dn, phi; - * int ellpjl(); - * - * ellpjl( u, m, _&sn, _&cn, _&dn, _&phi ); - * - * - * - * DESCRIPTION: - * - * - * Evaluates the Jacobian elliptic functions sn(u|m), cn(u|m), - * and dn(u|m) of parameter m between 0 and 1, and real - * argument u. - * - * These functions are periodic, with quarter-period on the - * real axis equal to the complete elliptic integral - * ellpk(1.0-m). - * - * Relation to incomplete elliptic integral: - * If u = ellik(phi,m), then sn(u|m) = sin(phi), - * and cn(u|m) = cos(phi). Phi is called the amplitude of u. - * - * Computation is by means of the arithmetic-geometric mean - * algorithm, except when m is within 1e-12 of 0 or 1. In the - * latter case with m close to 1, the approximation applies - * only for phi < pi/2. - * - * ACCURACY: - * - * Tested at random points with u between 0 and 10, m between - * 0 and 1. - * - * Absolute error (* = relative error): - * arithmetic function # trials peak rms - * IEEE sn 10000 1.7e-18 2.3e-19 - * IEEE cn 20000 1.6e-18 2.2e-19 - * IEEE dn 10000 4.7e-15 2.7e-17 - * IEEE phi 10000 4.0e-19* 6.6e-20* - * - * Accuracy deteriorates when u is large. - * - */ - -/* ellpkl.c - * - * Complete elliptic integral of the first kind - * - * - * - * SYNOPSIS: - * - * long double m1, y, ellpkl(); - * - * y = ellpkl( m1 ); - * - * - * - * DESCRIPTION: - * - * Approximates the integral - * - * - * - * pi/2 - * - - * | | - * | dt - * K(m) = | ------------------ - * | 2 - * | | sqrt( 1 - m sin t ) - * - - * 0 - * - * where m = 1 - m1, using the approximation - * - * P(x) - log x Q(x). - * - * The argument m1 is used rather than m so that the logarithmic - * singularity at m = 1 will be shifted to the origin; this - * preserves maximum accuracy. - * - * K(0) = pi/2. - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 0,1 10000 1.1e-19 3.3e-20 - * - * ERROR MESSAGES: - * - * message condition value returned - * ellpkl domain x<0, x>1 0.0 - * - */ - -/* exp10l.c - * - * Base 10 exponential function, long double precision - * (Common antilogarithm) - * - * - * - * SYNOPSIS: - * - * long double x, y, exp10l() - * - * y = exp10l( x ); - * - * - * - * DESCRIPTION: - * - * Returns 10 raised to the x power. - * - * Range reduction is accomplished by expressing the argument - * as 10**x = 2**n 10**f, with |f| < 0.5 log10(2). - * The Pade' form - * - * 1 + 2x P(x**2)/( Q(x**2) - P(x**2) ) - * - * is used to approximate 10**f. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE +-4900 30000 1.0e-19 2.7e-20 - * - * ERROR MESSAGES: - * - * message condition value returned - * exp10l underflow x < -MAXL10 0.0 - * exp10l overflow x > MAXL10 MAXNUM - * - * IEEE arithmetic: MAXL10 = 4932.0754489586679023819 - * - */ - -/* exp2l.c - * - * Base 2 exponential function, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, exp2l(); - * - * y = exp2l( x ); - * - * - * - * DESCRIPTION: - * - * Returns 2 raised to the x power. - * - * Range reduction is accomplished by separating the argument - * into an integer k and fraction f such that - * x k f - * 2 = 2 2. - * - * A Pade' form - * - * 1 + 2x P(x**2) / (Q(x**2) - x P(x**2) ) - * - * approximates 2**x in the basic range [-0.5, 0.5]. - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE +-16300 300000 9.1e-20 2.6e-20 - * - * - * See exp.c for comments on error amplification. - * - * - * ERROR MESSAGES: - * - * message condition value returned - * exp2l underflow x < -16382 0.0 - * exp2l overflow x >= 16384 MAXNUM - * - */ - -/* expl.c - * - * Exponential function, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, expl(); - * - * y = expl( x ); - * - * - * - * DESCRIPTION: - * - * Returns e (2.71828...) raised to the x power. - * - * Range reduction is accomplished by separating the argument - * into an integer k and fraction f such that - * - * x k f - * e = 2 e. - * - * A Pade' form of degree 2/3 is used to approximate exp(f) - 1 - * in the basic range [-0.5 ln 2, 0.5 ln 2]. - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE +-10000 50000 1.12e-19 2.81e-20 - * - * - * Error amplification in the exponential function can be - * a serious matter. The error propagation involves - * exp( X(1+delta) ) = exp(X) ( 1 + X*delta + ... ), - * which shows that a 1 lsb error in representing X produces - * a relative error of X times 1 lsb in the function. - * While the routine gives an accurate result for arguments - * that are exactly represented by a long double precision - * computer number, the result contains amplified roundoff - * error for large arguments not exactly represented. - * - * - * ERROR MESSAGES: - * - * message condition value returned - * exp underflow x < MINLOG 0.0 - * exp overflow x > MAXLOG MAXNUM - * - */ - -/* fabsl.c - * - * Absolute value - * - * - * - * SYNOPSIS: - * - * long double x, y; - * - * y = fabsl( x ); - * - * - * - * DESCRIPTION: - * - * Returns the absolute value of the argument. - * - */ - -/* fdtrl.c - * - * F distribution, long double precision - * - * - * - * SYNOPSIS: - * - * int df1, df2; - * long double x, y, fdtrl(); - * - * y = fdtrl( df1, df2, x ); - * - * - * - * DESCRIPTION: - * - * Returns the area from zero to x under the F density - * function (also known as Snedcor's density or the - * variance ratio density). This is the density - * of x = (u1/df1)/(u2/df2), where u1 and u2 are random - * variables having Chi square distributions with df1 - * and df2 degrees of freedom, respectively. - * - * The incomplete beta integral is used, according to the - * formula - * - * P(x) = incbetl( df1/2, df2/2, (df1*x/(df2 + df1*x) ). - * - * - * The arguments a and b are greater than zero, and x - * x is nonnegative. - * - * ACCURACY: - * - * Tested at random points (a,b,x) in the indicated intervals. - * x a,b Relative error: - * arithmetic domain domain # trials peak rms - * IEEE 0,1 1,100 10000 9.3e-18 2.9e-19 - * IEEE 0,1 1,10000 10000 1.9e-14 2.9e-15 - * IEEE 1,5 1,10000 10000 5.8e-15 1.4e-16 - * - * ERROR MESSAGES: - * - * message condition value returned - * fdtrl domain a<0, b<0, x<0 0.0 - * - */ - /* fdtrcl() - * - * Complemented F distribution - * - * - * - * SYNOPSIS: - * - * int df1, df2; - * long double x, y, fdtrcl(); - * - * y = fdtrcl( df1, df2, x ); - * - * - * - * DESCRIPTION: - * - * Returns the area from x to infinity under the F density - * function (also known as Snedcor's density or the - * variance ratio density). - * - * - * inf. - * - - * 1 | | a-1 b-1 - * 1-P(x) = ------ | t (1-t) dt - * B(a,b) | | - * - - * x - * - * (See fdtr.c.) - * - * The incomplete beta integral is used, according to the - * formula - * - * P(x) = incbet( df2/2, df1/2, (df2/(df2 + df1*x) ). - * - * - * ACCURACY: - * - * See incbet.c. - * Tested at random points (a,b,x). - * - * x a,b Relative error: - * arithmetic domain domain # trials peak rms - * IEEE 0,1 0,100 10000 4.2e-18 3.3e-19 - * IEEE 0,1 1,10000 10000 7.2e-15 2.6e-16 - * IEEE 1,5 1,10000 10000 1.7e-14 3.0e-15 - * - * ERROR MESSAGES: - * - * message condition value returned - * fdtrcl domain a<0, b<0, x<0 0.0 - * - */ - /* fdtril() - * - * Inverse of complemented F distribution - * - * - * - * SYNOPSIS: - * - * int df1, df2; - * long double x, p, fdtril(); - * - * x = fdtril( df1, df2, p ); - * - * DESCRIPTION: - * - * Finds the F density argument x such that the integral - * from x to infinity of the F density is equal to the - * given probability p. - * - * This is accomplished using the inverse beta integral - * function and the relations - * - * z = incbi( df2/2, df1/2, p ) - * x = df2 (1-z) / (df1 z). - * - * Note: the following relations hold for the inverse of - * the uncomplemented F distribution: - * - * z = incbi( df1/2, df2/2, p ) - * x = df2 z / (df1 (1-z)). - * - * ACCURACY: - * - * See incbi.c. - * Tested at random points (a,b,p). - * - * a,b Relative error: - * arithmetic domain # trials peak rms - * For p between .001 and 1: - * IEEE 1,100 40000 4.6e-18 2.7e-19 - * IEEE 1,10000 30000 1.7e-14 1.4e-16 - * For p between 10^-6 and .001: - * IEEE 1,100 20000 1.9e-15 3.9e-17 - * IEEE 1,10000 30000 2.7e-15 4.0e-17 - * - * ERROR MESSAGES: - * - * message condition value returned - * fdtril domain p <= 0 or p > 1 0.0 - * v < 1 - */ - -/* ceill() - * floorl() - * frexpl() - * ldexpl() - * fabsl() - * - * Floating point numeric utilities - * - * - * - * SYNOPSIS: - * - * long double x, y; - * long double ceill(), floorl(), frexpl(), ldexpl(), fabsl(); - * int expnt, n; - * - * y = floorl(x); - * y = ceill(x); - * y = frexpl( x, &expnt ); - * y = ldexpl( x, n ); - * y = fabsl( x ); - * - * - * - * DESCRIPTION: - * - * All four routines return a long double precision floating point - * result. - * - * floorl() returns the largest integer less than or equal to x. - * It truncates toward minus infinity. - * - * ceill() returns the smallest integer greater than or equal - * to x. It truncates toward plus infinity. - * - * frexpl() extracts the exponent from x. It returns an integer - * power of two to expnt and the significand between 0.5 and 1 - * to y. Thus x = y * 2**expn. - * - * ldexpl() multiplies x by 2**n. - * - * fabsl() returns the absolute value of its argument. - * - * These functions are part of the standard C run time library - * for some but not all C compilers. The ones supplied are - * written in C for IEEE arithmetic. They should - * be used only if your compiler library does not already have - * them. - * - * The IEEE versions assume that denormal numbers are implemented - * in the arithmetic. Some modifications will be required if - * the arithmetic has abrupt rather than gradual underflow. - */ - -/* gammal.c - * - * Gamma function - * - * - * - * SYNOPSIS: - * - * long double x, y, gammal(); - * extern int sgngam; - * - * y = gammal( x ); - * - * - * - * DESCRIPTION: - * - * Returns gamma function of the argument. The result is - * correctly signed, and the sign (+1 or -1) is also - * returned in a global (extern) variable named sgngam. - * This variable is also filled in by the logarithmic gamma - * function lgam(). - * - * Arguments |x| <= 13 are reduced by recurrence and the function - * approximated by a rational function of degree 7/8 in the - * interval (2,3). Large arguments are handled by Stirling's - * formula. Large negative arguments are made positive using - * a reflection formula. - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -40,+40 10000 3.6e-19 7.9e-20 - * IEEE -1755,+1755 10000 4.8e-18 6.5e-19 - * - * Accuracy for large arguments is dominated by error in powl(). - * - */ -/* lgaml() - * - * Natural logarithm of gamma function - * - * - * - * SYNOPSIS: - * - * long double x, y, lgaml(); - * extern int sgngam; - * - * y = lgaml( x ); - * - * - * - * DESCRIPTION: - * - * Returns the base e (2.718...) logarithm of the absolute - * value of the gamma function of the argument. - * The sign (+1 or -1) of the gamma function is returned in a - * global (extern) variable named sgngam. - * - * For arguments greater than 33, the logarithm of the gamma - * function is approximated by the logarithmic version of - * Stirling's formula using a polynomial approximation of - * degree 4. Arguments between -33 and +33 are reduced by - * recurrence to the interval [2,3] of a rational approximation. - * The cosecant reflection formula is employed for arguments - * less than -33. - * - * Arguments greater than MAXLGML (10^4928) return MAXNUML. - * - * - * - * ACCURACY: - * - * - * arithmetic domain # trials peak rms - * IEEE -40, 40 100000 2.2e-19 4.6e-20 - * IEEE 10^-2000,10^+2000 20000 1.6e-19 3.3e-20 - * The error criterion was relative when the function magnitude - * was greater than one but absolute when it was less than one. - * - */ - -/* gdtrl.c - * - * Gamma distribution function - * - * - * - * SYNOPSIS: - * - * long double a, b, x, y, gdtrl(); - * - * y = gdtrl( a, b, x ); - * - * - * - * DESCRIPTION: - * - * Returns the integral from zero to x of the gamma probability - * density function: - * - * - * x - * b - - * a | | b-1 -at - * y = ----- | t e dt - * - | | - * | (b) - - * 0 - * - * The incomplete gamma integral is used, according to the - * relation - * - * y = igam( b, ax ). - * - * - * ACCURACY: - * - * See igam(). - * - * ERROR MESSAGES: - * - * message condition value returned - * gdtrl domain x < 0 0.0 - * - */ - /* gdtrcl.c - * - * Complemented gamma distribution function - * - * - * - * SYNOPSIS: - * - * long double a, b, x, y, gdtrcl(); - * - * y = gdtrcl( a, b, x ); - * - * - * - * DESCRIPTION: - * - * Returns the integral from x to infinity of the gamma - * probability density function: - * - * - * inf. - * b - - * a | | b-1 -at - * y = ----- | t e dt - * - | | - * | (b) - - * x - * - * The incomplete gamma integral is used, according to the - * relation - * - * y = igamc( b, ax ). - * - * - * ACCURACY: - * - * See igamc(). - * - * ERROR MESSAGES: - * - * message condition value returned - * gdtrcl domain x < 0 0.0 - * - */ - -/* -C -C .................................................................. -C -C SUBROUTINE GELS -C -C PURPOSE -C TO SOLVE A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH -C SYMMETRIC COEFFICIENT MATRIX UPPER TRIANGULAR PART OF WHICH -C IS ASSUMED TO BE STORED COLUMNWISE. -C -C USAGE -C CALL GELS(R,A,M,N,EPS,IER,AUX) -C -C DESCRIPTION OF PARAMETERS -C R - M BY N RIGHT HAND SIDE MATRIX. (DESTROYED) -C ON RETURN R CONTAINS THE SOLUTION OF THE EQUATIONS. -C A - UPPER TRIANGULAR PART OF THE SYMMETRIC -C M BY M COEFFICIENT MATRIX. (DESTROYED) -C M - THE NUMBER OF EQUATIONS IN THE SYSTEM. -C N - THE NUMBER OF RIGHT HAND SIDE VECTORS. -C EPS - AN INPUT CONSTANT WHICH IS USED AS RELATIVE -C TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE. -C IER - RESULTING ERROR PARAMETER CODED AS FOLLOWS -C IER=0 - NO ERROR, -C IER=-1 - NO RESULT BECAUSE OF M LESS THAN 1 OR -C PIVOT ELEMENT AT ANY ELIMINATION STEP -C EQUAL TO 0, -C IER=K - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI- -C CANCE INDICATED AT ELIMINATION STEP K+1, -C WHERE PIVOT ELEMENT WAS LESS THAN OR -C EQUAL TO THE INTERNAL TOLERANCE EPS TIMES -C ABSOLUTELY GREATEST MAIN DIAGONAL -C ELEMENT OF MATRIX A. -C AUX - AN AUXILIARY STORAGE ARRAY WITH DIMENSION M-1. -C -C REMARKS -C UPPER TRIANGULAR PART OF MATRIX A IS ASSUMED TO BE STORED -C COLUMNWISE IN M*(M+1)/2 SUCCESSIVE STORAGE LOCATIONS, RIGHT -C HAND SIDE MATRIX R COLUMNWISE IN N*M SUCCESSIVE STORAGE -C LOCATIONS. ON RETURN SOLUTION MATRIX R IS STORED COLUMNWISE -C TOO. -C THE PROCEDURE GIVES RESULTS IF THE NUMBER OF EQUATIONS M IS -C GREATER THAN 0 AND PIVOT ELEMENTS AT ALL ELIMINATION STEPS -C ARE DIFFERENT FROM 0. HOWEVER WARNING IER=K - IF GIVEN - -C INDICATES POSSIBLE LOSS OF SIGNIFICANCE. IN CASE OF A WELL -C SCALED MATRIX A AND APPROPRIATE TOLERANCE EPS, IER=K MAY BE -C INTERPRETED THAT MATRIX A HAS THE RANK K. NO WARNING IS -C GIVEN IN CASE M=1. -C ERROR PARAMETER IER=-1 DOES NOT NECESSARILY MEAN THAT -C MATRIX A IS SINGULAR, AS ONLY MAIN DIAGONAL ELEMENTS -C ARE USED AS PIVOT ELEMENTS. POSSIBLY SUBROUTINE GELG (WHICH -C WORKS WITH TOTAL PIVOTING) WOULD BE ABLE TO FIND A SOLUTION. -C -C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED -C NONE -C -C METHOD -C SOLUTION IS DONE BY MEANS OF GAUSS-ELIMINATION WITH -C PIVOTING IN MAIN DIAGONAL, IN ORDER TO PRESERVE -C SYMMETRY IN REMAINING COEFFICIENT MATRICES. -C -C .................................................................. -C -*/ - -/* igamil() - * - * Inverse of complemented imcomplete gamma integral - * - * - * - * SYNOPSIS: - * - * long double a, x, y, igamil(); - * - * x = igamil( a, y ); - * - * - * - * DESCRIPTION: - * - * Given y, the function finds x such that - * - * igamc( a, x ) = y. - * - * Starting with the approximate value - * - * 3 - * x = a t - * - * where - * - * t = 1 - d - ndtri(y) sqrt(d) - * - * and - * - * d = 1/9a, - * - * the routine performs up to 10 Newton iterations to find the - * root of igamc(a,x) - y = 0. - * - * - * ACCURACY: - * - * Tested for a ranging from 0.5 to 30 and x from 0 to 0.5. - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC 0,0.5 3400 8.8e-16 1.3e-16 - * IEEE 0,0.5 10000 1.1e-14 1.0e-15 - * - */ - -/* igaml.c - * - * Incomplete gamma integral - * - * - * - * SYNOPSIS: - * - * long double a, x, y, igaml(); - * - * y = igaml( a, x ); - * - * - * - * DESCRIPTION: - * - * The function is defined by - * - * x - * - - * 1 | | -t a-1 - * igam(a,x) = ----- | e t dt. - * - | | - * | (a) - - * 0 - * - * - * In this implementation both arguments must be positive. - * The integral is evaluated by either a power series or - * continued fraction expansion, depending on the relative - * values of a and x. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC 0,30 4000 4.4e-15 6.3e-16 - * IEEE 0,30 10000 3.6e-14 5.1e-15 - * - */ - /* igamcl() - * - * Complemented incomplete gamma integral - * - * - * - * SYNOPSIS: - * - * long double a, x, y, igamcl(); - * - * y = igamcl( a, x ); - * - * - * - * DESCRIPTION: - * - * The function is defined by - * - * - * igamc(a,x) = 1 - igam(a,x) - * - * inf. - * - - * 1 | | -t a-1 - * = ----- | e t dt. - * - | | - * | (a) - - * x - * - * - * In this implementation both arguments must be positive. - * The integral is evaluated by either a power series or - * continued fraction expansion, depending on the relative - * values of a and x. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC 0,30 2000 2.7e-15 4.0e-16 - * IEEE 0,30 60000 1.4e-12 6.3e-15 - * - */ - -/* incbetl.c - * - * Incomplete beta integral - * - * - * SYNOPSIS: - * - * long double a, b, x, y, incbetl(); - * - * y = incbetl( a, b, x ); - * - * - * DESCRIPTION: - * - * Returns incomplete beta integral of the arguments, evaluated - * from zero to x. The function is defined as - * - * x - * - - - * | (a+b) | | a-1 b-1 - * ----------- | t (1-t) dt. - * - - | | - * | (a) | (b) - - * 0 - * - * The domain of definition is 0 <= x <= 1. In this - * implementation a and b are restricted to positive values. - * The integral from x to 1 may be obtained by the symmetry - * relation - * - * 1 - incbet( a, b, x ) = incbet( b, a, 1-x ). - * - * The integral is evaluated by a continued fraction expansion - * or, when b*x is small, by a power series. - * - * ACCURACY: - * - * Tested at random points (a,b,x) with x between 0 and 1. - * arithmetic domain # trials peak rms - * IEEE 0,5 20000 4.5e-18 2.4e-19 - * IEEE 0,100 100000 3.9e-17 1.0e-17 - * Half-integer a, b: - * IEEE .5,10000 100000 3.9e-14 4.4e-15 - * Outputs smaller than the IEEE gradual underflow threshold - * were excluded from these statistics. - * - * ERROR MESSAGES: - * - * message condition value returned - * incbetl domain x<0, x>1 0.0 - */ - -/* incbil() - * - * Inverse of imcomplete beta integral - * - * - * - * SYNOPSIS: - * - * long double a, b, x, y, incbil(); - * - * x = incbil( a, b, y ); - * - * - * - * DESCRIPTION: - * - * Given y, the function finds x such that - * - * incbet( a, b, x ) = y. - * - * the routine performs up to 10 Newton iterations to find the - * root of incbet(a,b,x) - y = 0. - * - * - * ACCURACY: - * - * Relative error: - * x a,b - * arithmetic domain domain # trials peak rms - * IEEE 0,1 .5,10000 10000 1.1e-14 1.4e-16 - */ - -/* j0l.c - * - * Bessel function of order zero - * - * - * - * SYNOPSIS: - * - * long double x, y, j0l(); - * - * y = j0l( x ); - * - * - * - * DESCRIPTION: - * - * Returns Bessel function of first kind, order zero of the argument. - * - * The domain is divided into the intervals [0, 9] and - * (9, infinity). In the first interval the rational approximation - * is (x^2 - r^2) (x^2 - s^2) (x^2 - t^2) P7(x^2) / Q8(x^2), - * where r, s, t are the first three zeros of the function. - * In the second interval the expansion is in terms of the - * modulus M0(x) = sqrt(J0(x)^2 + Y0(x)^2) and phase P0(x) - * = atan(Y0(x)/J0(x)). M0 is approximated by sqrt(1/x)P7(1/x)/Q7(1/x). - * The approximation to J0 is M0 * cos(x - pi/4 + 1/x P5(1/x^2)/Q6(1/x^2)). - * - * - * ACCURACY: - * - * Absolute error: - * arithmetic domain # trials peak rms - * IEEE 0, 30 100000 2.8e-19 7.4e-20 - * - * - */ - /* y0l.c - * - * Bessel function of the second kind, order zero - * - * - * - * SYNOPSIS: - * - * double x, y, y0l(); - * - * y = y0l( x ); - * - * - * - * DESCRIPTION: - * - * Returns Bessel function of the second kind, of order - * zero, of the argument. - * - * The domain is divided into the intervals [0, 5>, [5,9> and - * [9, infinity). In the first interval a rational approximation - * R(x) is employed to compute y0(x) = R(x) + 2/pi * log(x) * j0(x). - * - * In the second interval, the approximation is - * (x - p)(x - q)(x - r)(x - s)P7(x)/Q7(x) - * where p, q, r, s are zeros of y0(x). - * - * The third interval uses the same approximations to modulus - * and phase as j0(x), whence y0(x) = modulus * sin(phase). - * - * ACCURACY: - * - * Absolute error, when y0(x) < 1; else relative error: - * - * arithmetic domain # trials peak rms - * IEEE 0, 30 100000 3.4e-19 7.6e-20 - * - */ - -/* j1l.c - * - * Bessel function of order one - * - * - * - * SYNOPSIS: - * - * long double x, y, j1l(); - * - * y = j1l( x ); - * - * - * - * DESCRIPTION: - * - * Returns Bessel function of order one of the argument. - * - * The domain is divided into the intervals [0, 9] and - * (9, infinity). In the first interval the rational approximation - * is (x^2 - r^2) (x^2 - s^2) (x^2 - t^2) x P8(x^2) / Q8(x^2), - * where r, s, t are the first three zeros of the function. - * In the second interval the expansion is in terms of the - * modulus M1(x) = sqrt(J1(x)^2 + Y1(x)^2) and phase P1(x) - * = atan(Y1(x)/J1(x)). M1 is approximated by sqrt(1/x)P7(1/x)/Q8(1/x). - * The approximation to j1 is M1 * cos(x - 3 pi/4 + 1/x P5(1/x^2)/Q6(1/x^2)). - * - * - * ACCURACY: - * - * Absolute error: - * arithmetic domain # trials peak rms - * IEEE 0, 30 40000 1.8e-19 5.0e-20 - * - * - */ - /* y1l.c - * - * Bessel function of the second kind, order zero - * - * - * - * SYNOPSIS: - * - * double x, y, y1l(); - * - * y = y1l( x ); - * - * - * - * DESCRIPTION: - * - * Returns Bessel function of the second kind, of order - * zero, of the argument. - * - * The domain is divided into the intervals [0, 4.5>, [4.5,9> and - * [9, infinity). In the first interval a rational approximation - * R(x) is employed to compute y0(x) = R(x) + 2/pi * log(x) * j0(x). - * - * In the second interval, the approximation is - * (x - p)(x - q)(x - r)(x - s)P9(x)/Q10(x) - * where p, q, r, s are zeros of y1(x). - * - * The third interval uses the same approximations to modulus - * and phase as j1(x), whence y1(x) = modulus * sin(phase). - * - * ACCURACY: - * - * Absolute error, when y0(x) < 1; else relative error: - * - * arithmetic domain # trials peak rms - * IEEE 0, 30 36000 2.7e-19 5.3e-20 - * - */ - -/* jnl.c - * - * Bessel function of integer order - * - * - * - * SYNOPSIS: - * - * int n; - * long double x, y, jnl(); - * - * y = jnl( n, x ); - * - * - * - * DESCRIPTION: - * - * Returns Bessel function of order n, where n is a - * (possibly negative) integer. - * - * The ratio of jn(x) to j0(x) is computed by backward - * recurrence. First the ratio jn/jn-1 is found by a - * continued fraction expansion. Then the recurrence - * relating successive orders is applied until j0 or j1 is - * reached. - * - * If n = 0 or 1 the routine for j0 or j1 is called - * directly. - * - * - * - * ACCURACY: - * - * Absolute error: - * arithmetic domain # trials peak rms - * IEEE -30, 30 5000 3.3e-19 4.7e-20 - * - * - * Not suitable for large n or x. - * - */ - -/* ldrand.c - * - * Pseudorandom number generator - * - * - * - * SYNOPSIS: - * - * double y; - * int ldrand(); - * - * ldrand( &y ); - * - * - * - * DESCRIPTION: - * - * Yields a random number 1.0 <= y < 2.0. - * - * The three-generator congruential algorithm by Brian - * Wichmann and David Hill (BYTE magazine, March, 1987, - * pp 127-8) is used. - * - * Versions invoked by the different arithmetic compile - * time options IBMPC, and MIEEE, produce the same sequences. - * - */ - -/* log10l.c - * - * Common logarithm, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, log10l(); - * - * y = log10l( x ); - * - * - * - * DESCRIPTION: - * - * Returns the base 10 logarithm of x. - * - * The argument is separated into its exponent and fractional - * parts. If the exponent is between -1 and +1, the logarithm - * of the fraction is approximated by - * - * log(1+x) = x - 0.5 x**2 + x**3 P(x)/Q(x). - * - * Otherwise, setting z = 2(x-1)/x+1), - * - * log(x) = z + z**3 P(z)/Q(z). - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 0.5, 2.0 30000 9.0e-20 2.6e-20 - * IEEE exp(+-10000) 30000 6.0e-20 2.3e-20 - * - * In the tests over the interval exp(+-10000), the logarithms - * of the random arguments were uniformly distributed over - * [-10000, +10000]. - * - * ERROR MESSAGES: - * - * log singularity: x = 0; returns MINLOG - * log domain: x < 0; returns MINLOG - */ - -/* log2l.c - * - * Base 2 logarithm, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, log2l(); - * - * y = log2l( x ); - * - * - * - * DESCRIPTION: - * - * Returns the base 2 logarithm of x. - * - * The argument is separated into its exponent and fractional - * parts. If the exponent is between -1 and +1, the (natural) - * logarithm of the fraction is approximated by - * - * log(1+x) = x - 0.5 x**2 + x**3 P(x)/Q(x). - * - * Otherwise, setting z = 2(x-1)/x+1), - * - * log(x) = z + z**3 P(z)/Q(z). - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 0.5, 2.0 30000 9.8e-20 2.7e-20 - * IEEE exp(+-10000) 70000 5.4e-20 2.3e-20 - * - * In the tests over the interval exp(+-10000), the logarithms - * of the random arguments were uniformly distributed over - * [-10000, +10000]. - * - * ERROR MESSAGES: - * - * log singularity: x = 0; returns MINLOG - * log domain: x < 0; returns MINLOG - */ - -/* logl.c - * - * Natural logarithm, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, logl(); - * - * y = logl( x ); - * - * - * - * DESCRIPTION: - * - * Returns the base e (2.718...) logarithm of x. - * - * The argument is separated into its exponent and fractional - * parts. If the exponent is between -1 and +1, the logarithm - * of the fraction is approximated by - * - * log(1+x) = x - 0.5 x**2 + x**3 P(x)/Q(x). - * - * Otherwise, setting z = 2(x-1)/x+1), - * - * log(x) = z + z**3 P(z)/Q(z). - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 0.5, 2.0 150000 8.71e-20 2.75e-20 - * IEEE exp(+-10000) 100000 5.39e-20 2.34e-20 - * - * In the tests over the interval exp(+-10000), the logarithms - * of the random arguments were uniformly distributed over - * [-10000, +10000]. - * - * ERROR MESSAGES: - * - * log singularity: x = 0; returns MINLOG - * log domain: x < 0; returns MINLOG - */ - -/* mtherr.c - * - * Library common error handling routine - * - * - * - * SYNOPSIS: - * - * char *fctnam; - * int code; - * int mtherr(); - * - * mtherr( fctnam, code ); - * - * - * - * DESCRIPTION: - * - * This routine may be called to report one of the following - * error conditions (in the include file mconf.h). - * - * Mnemonic Value Significance - * - * DOMAIN 1 argument domain error - * SING 2 function singularity - * OVERFLOW 3 overflow range error - * UNDERFLOW 4 underflow range error - * TLOSS 5 total loss of precision - * PLOSS 6 partial loss of precision - * EDOM 33 Unix domain error code - * ERANGE 34 Unix range error code - * - * The default version of the file prints the function name, - * passed to it by the pointer fctnam, followed by the - * error condition. The display is directed to the standard - * output device. The routine then returns to the calling - * program. Users may wish to modify the program to abort by - * calling exit() under severe error conditions such as domain - * errors. - * - * Since all error conditions pass control to this function, - * the display may be easily changed, eliminated, or directed - * to an error logging device. - * - * SEE ALSO: - * - * mconf.h - * - */ - -/* nbdtrl.c - * - * Negative binomial distribution - * - * - * - * SYNOPSIS: - * - * int k, n; - * long double p, y, nbdtrl(); - * - * y = nbdtrl( k, n, p ); - * - * - * - * DESCRIPTION: - * - * Returns the sum of the terms 0 through k of the negative - * binomial distribution: - * - * k - * -- ( n+j-1 ) n j - * > ( ) p (1-p) - * -- ( j ) - * j=0 - * - * In a sequence of Bernoulli trials, this is the probability - * that k or fewer failures precede the nth success. - * - * The terms are not computed individually; instead the incomplete - * beta integral is employed, according to the formula - * - * y = nbdtr( k, n, p ) = incbet( n, k+1, p ). - * - * The arguments must be positive, with p ranging from 0 to 1. - * - * - * - * ACCURACY: - * - * Tested at random points (k,n,p) with k and n between 1 and 10,000 - * and p between 0 and 1. - * - * arithmetic domain # trials peak rms - * Absolute error: - * IEEE 0,10000 10000 9.8e-15 2.1e-16 - * - */ - /* nbdtrcl.c - * - * Complemented negative binomial distribution - * - * - * - * SYNOPSIS: - * - * int k, n; - * long double p, y, nbdtrcl(); - * - * y = nbdtrcl( k, n, p ); - * - * - * - * DESCRIPTION: - * - * Returns the sum of the terms k+1 to infinity of the negative - * binomial distribution: - * - * inf - * -- ( n+j-1 ) n j - * > ( ) p (1-p) - * -- ( j ) - * j=k+1 - * - * The terms are not computed individually; instead the incomplete - * beta integral is employed, according to the formula - * - * y = nbdtrc( k, n, p ) = incbet( k+1, n, 1-p ). - * - * The arguments must be positive, with p ranging from 0 to 1. - * - * - * - * ACCURACY: - * - * See incbetl.c. - * - */ - /* nbdtril - * - * Functional inverse of negative binomial distribution - * - * - * - * SYNOPSIS: - * - * int k, n; - * long double p, y, nbdtril(); - * - * p = nbdtril( k, n, y ); - * - * - * - * DESCRIPTION: - * - * Finds the argument p such that nbdtr(k,n,p) is equal to y. - * - * ACCURACY: - * - * Tested at random points (a,b,y), with y between 0 and 1. - * - * a,b Relative error: - * arithmetic domain # trials peak rms - * IEEE 0,100 - * See also incbil.c. - */ - -/* ndtril.c - * - * Inverse of Normal distribution function - * - * - * - * SYNOPSIS: - * - * long double x, y, ndtril(); - * - * x = ndtril( y ); - * - * - * - * DESCRIPTION: - * - * Returns the argument, x, for which the area under the - * Gaussian probability density function (integrated from - * minus infinity to x) is equal to y. - * - * - * For small arguments 0 < y < exp(-2), the program computes - * z = sqrt( -2 log(y) ); then the approximation is - * x = z - log(z)/z - (1/z) P(1/z) / Q(1/z) . - * For larger arguments, x/sqrt(2 pi) = w + w^3 R(w^2)/S(w^2)) , - * where w = y - 0.5 . - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * Arguments uniformly distributed: - * IEEE 0, 1 5000 7.8e-19 9.9e-20 - * Arguments exponentially distributed: - * IEEE exp(-11355),-1 30000 1.7e-19 4.3e-20 - * - * - * ERROR MESSAGES: - * - * message condition value returned - * ndtril domain x <= 0 -MAXNUML - * ndtril domain x >= 1 MAXNUML - * - */ - -/* ndtril.c - * - * Inverse of Normal distribution function - * - * - * - * SYNOPSIS: - * - * long double x, y, ndtril(); - * - * x = ndtril( y ); - * - * - * - * DESCRIPTION: - * - * Returns the argument, x, for which the area under the - * Gaussian probability density function (integrated from - * minus infinity to x) is equal to y. - * - * - * For small arguments 0 < y < exp(-2), the program computes - * z = sqrt( -2 log(y) ); then the approximation is - * x = z - log(z)/z - (1/z) P(1/z) / Q(1/z) . - * For larger arguments, x/sqrt(2 pi) = w + w^3 R(w^2)/S(w^2)) , - * where w = y - 0.5 . - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * Arguments uniformly distributed: - * IEEE 0, 1 5000 7.8e-19 9.9e-20 - * Arguments exponentially distributed: - * IEEE exp(-11355),-1 30000 1.7e-19 4.3e-20 - * - * - * ERROR MESSAGES: - * - * message condition value returned - * ndtril domain x <= 0 -MAXNUML - * ndtril domain x >= 1 MAXNUML - * - */ - -/* pdtrl.c - * - * Poisson distribution - * - * - * - * SYNOPSIS: - * - * int k; - * long double m, y, pdtrl(); - * - * y = pdtrl( k, m ); - * - * - * - * DESCRIPTION: - * - * Returns the sum of the first k terms of the Poisson - * distribution: - * - * k j - * -- -m m - * > e -- - * -- j! - * j=0 - * - * The terms are not summed directly; instead the incomplete - * gamma integral is employed, according to the relation - * - * y = pdtr( k, m ) = igamc( k+1, m ). - * - * The arguments must both be positive. - * - * - * - * ACCURACY: - * - * See igamc(). - * - */ - /* pdtrcl() - * - * Complemented poisson distribution - * - * - * - * SYNOPSIS: - * - * int k; - * long double m, y, pdtrcl(); - * - * y = pdtrcl( k, m ); - * - * - * - * DESCRIPTION: - * - * Returns the sum of the terms k+1 to infinity of the Poisson - * distribution: - * - * inf. j - * -- -m m - * > e -- - * -- j! - * j=k+1 - * - * The terms are not summed directly; instead the incomplete - * gamma integral is employed, according to the formula - * - * y = pdtrc( k, m ) = igam( k+1, m ). - * - * The arguments must both be positive. - * - * - * - * ACCURACY: - * - * See igam.c. - * - */ - /* pdtril() - * - * Inverse Poisson distribution - * - * - * - * SYNOPSIS: - * - * int k; - * long double m, y, pdtrl(); - * - * m = pdtril( k, y ); - * - * - * - * - * DESCRIPTION: - * - * Finds the Poisson variable x such that the integral - * from 0 to x of the Poisson density is equal to the - * given probability y. - * - * This is accomplished using the inverse gamma integral - * function and the relation - * - * m = igami( k+1, y ). - * - * - * - * - * ACCURACY: - * - * See igami.c. - * - * ERROR MESSAGES: - * - * message condition value returned - * pdtri domain y < 0 or y >= 1 0.0 - * k < 0 - * - */ - -/* polevll.c - * p1evll.c - * - * Evaluate polynomial - * - * - * - * SYNOPSIS: - * - * int N; - * long double x, y, coef[N+1], polevl[]; - * - * y = polevll( x, coef, N ); - * - * - * - * DESCRIPTION: - * - * Evaluates polynomial of degree N: - * - * 2 N - * y = C + C x + C x +...+ C x - * 0 1 2 N - * - * Coefficients are stored in reverse order: - * - * coef[0] = C , ..., coef[N] = C . - * N 0 - * - * The function p1evll() assumes that coef[N] = 1.0 and is - * omitted from the array. Its calling arguments are - * otherwise the same as polevll(). - * - * This module also contains the following globally declared constants: - * MAXNUML = 1.189731495357231765021263853E4932L; - * MACHEPL = 5.42101086242752217003726400434970855712890625E-20L; - * MAXLOGL = 1.1356523406294143949492E4L; - * MINLOGL = -1.1355137111933024058873E4L; - * LOGE2L = 6.9314718055994530941723E-1L; - * LOG2EL = 1.4426950408889634073599E0L; - * PIL = 3.1415926535897932384626L; - * PIO2L = 1.5707963267948966192313L; - * PIO4L = 7.8539816339744830961566E-1L; - * - * SPEED: - * - * In the interest of speed, there are no checks for out - * of bounds arithmetic. This routine is used by most of - * the functions in the library. Depending on available - * equipment features, the user may wish to rewrite the - * program in microcode or assembly language. - * - */ - -/* powil.c - * - * Real raised to integer power, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, powil(); - * int n; - * - * y = powil( x, n ); - * - * - * - * DESCRIPTION: - * - * Returns argument x raised to the nth power. - * The routine efficiently decomposes n as a sum of powers of - * two. The desired power is a product of two-to-the-kth - * powers of x. Thus to compute the 32767 power of x requires - * 28 multiplications instead of 32767 multiplications. - * - * - * - * ACCURACY: - * - * - * Relative error: - * arithmetic x domain n domain # trials peak rms - * IEEE .001,1000 -1022,1023 50000 4.3e-17 7.8e-18 - * IEEE 1,2 -1022,1023 20000 3.9e-17 7.6e-18 - * IEEE .99,1.01 0,8700 10000 3.6e-16 7.2e-17 - * - * Returns MAXNUM on overflow, zero on underflow. - * - */ - -/* powl.c - * - * Power function, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, z, powl(); - * - * z = powl( x, y ); - * - * - * - * DESCRIPTION: - * - * Computes x raised to the yth power. Analytically, - * - * x**y = exp( y log(x) ). - * - * Following Cody and Waite, this program uses a lookup table - * of 2**-i/32 and pseudo extended precision arithmetic to - * obtain several extra bits of accuracy in both the logarithm - * and the exponential. - * - * - * - * ACCURACY: - * - * The relative error of pow(x,y) can be estimated - * by y dl ln(2), where dl is the absolute error of - * the internally computed base 2 logarithm. At the ends - * of the approximation interval the logarithm equal 1/32 - * and its relative error is about 1 lsb = 1.1e-19. Hence - * the predicted relative error in the result is 2.3e-21 y . - * - * Relative error: - * arithmetic domain # trials peak rms - * - * IEEE +-1000 40000 2.8e-18 3.7e-19 - * .001 < x < 1000, with log(x) uniformly distributed. - * -1000 < y < 1000, y uniformly distributed. - * - * IEEE 0,8700 60000 6.5e-18 1.0e-18 - * 0.99 < x < 1.01, 0 < y < 8700, uniformly distributed. - * - * - * ERROR MESSAGES: - * - * message condition value returned - * pow overflow x**y > MAXNUM MAXNUM - * pow underflow x**y < 1/MAXNUM 0.0 - * pow domain x<0 and y noninteger 0.0 - * - */ - -/* sinhl.c - * - * Hyperbolic sine, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, sinhl(); - * - * y = sinhl( x ); - * - * - * - * DESCRIPTION: - * - * Returns hyperbolic sine of argument in the range MINLOGL to - * MAXLOGL. - * - * The range is partitioned into two segments. If |x| <= 1, a - * rational function of the form x + x**3 P(x)/Q(x) is employed. - * Otherwise the calculation is sinh(x) = ( exp(x) - exp(-x) )/2. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -2,2 10000 1.5e-19 3.9e-20 - * IEEE +-10000 30000 1.1e-19 2.8e-20 - * - */ - -/* sinl.c - * - * Circular sine, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, sinl(); - * - * y = sinl( x ); - * - * - * - * DESCRIPTION: - * - * Range reduction is into intervals of pi/4. The reduction - * error is nearly eliminated by contriving an extended precision - * modular arithmetic. - * - * Two polynomial approximating functions are employed. - * Between 0 and pi/4 the sine is approximated by the Cody - * and Waite polynomial form - * x + x**3 P(x**2) . - * Between pi/4 and pi/2 the cosine is represented as - * 1 - .5 x**2 + x**4 Q(x**2) . - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE +-5.5e11 200,000 1.2e-19 2.9e-20 - * - * ERROR MESSAGES: - * - * message condition value returned - * sin total loss x > 2**39 0.0 - * - * Loss of precision occurs for x > 2**39 = 5.49755813888e11. - * The routine as implemented flags a TLOSS error for - * x > 2**39 and returns 0.0. - */ - /* cosl.c - * - * Circular cosine, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, cosl(); - * - * y = cosl( x ); - * - * - * - * DESCRIPTION: - * - * Range reduction is into intervals of pi/4. The reduction - * error is nearly eliminated by contriving an extended precision - * modular arithmetic. - * - * Two polynomial approximating functions are employed. - * Between 0 and pi/4 the cosine is approximated by - * 1 - .5 x**2 + x**4 Q(x**2) . - * Between pi/4 and pi/2 the sine is represented by the Cody - * and Waite polynomial form - * x + x**3 P(x**2) . - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE +-5.5e11 50000 1.2e-19 2.9e-20 - */ - -/* sqrtl.c - * - * Square root, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, sqrtl(); - * - * y = sqrtl( x ); - * - * - * - * DESCRIPTION: - * - * Returns the square root of x. - * - * Range reduction involves isolating the power of two of the - * argument and using a polynomial approximation to obtain - * a rough value for the square root. Then Heron's iteration - * is used three times to converge to an accurate value. - * - * Note, some arithmetic coprocessors such as the 8087 and - * 68881 produce correctly rounded square roots, which this - * routine will not. - * - * ACCURACY: - * - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 0,10 30000 8.1e-20 3.1e-20 - * - * - * ERROR MESSAGES: - * - * message condition value returned - * sqrt domain x < 0 0.0 - * - */ - -/* stdtrl.c - * - * Student's t distribution - * - * - * - * SYNOPSIS: - * - * long double p, t, stdtrl(); - * int k; - * - * p = stdtrl( k, t ); - * - * - * DESCRIPTION: - * - * Computes the integral from minus infinity to t of the Student - * t distribution with integer k > 0 degrees of freedom: - * - * t - * - - * | | - * - | 2 -(k+1)/2 - * | ( (k+1)/2 ) | ( x ) - * ---------------------- | ( 1 + --- ) dx - * - | ( k ) - * sqrt( k pi ) | ( k/2 ) | - * | | - * - - * -inf. - * - * Relation to incomplete beta integral: - * - * 1 - stdtr(k,t) = 0.5 * incbet( k/2, 1/2, z ) - * where - * z = k/(k + t**2). - * - * For t < -1.6, this is the method of computation. For higher t, - * a direct method is derived from integration by parts. - * Since the function is symmetric about t=0, the area under the - * right tail of the density is found by calling the function - * with -t instead of t. - * - * ACCURACY: - * - * Tested at random 1 <= k <= 100. The "domain" refers to t. - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -100,-1.6 10000 5.7e-18 9.8e-19 - * IEEE -1.6,100 10000 3.8e-18 1.0e-19 - */ - -/* stdtril.c - * - * Functional inverse of Student's t distribution - * - * - * - * SYNOPSIS: - * - * long double p, t, stdtril(); - * int k; - * - * t = stdtril( k, p ); - * - * - * DESCRIPTION: - * - * Given probability p, finds the argument t such that stdtrl(k,t) - * is equal to p. - * - * ACCURACY: - * - * Tested at random 1 <= k <= 100. The "domain" refers to p: - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 0,1 3500 4.2e-17 4.1e-18 - */ - -/* tanhl.c - * - * Hyperbolic tangent, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, tanhl(); - * - * y = tanhl( x ); - * - * - * - * DESCRIPTION: - * - * Returns hyperbolic tangent of argument in the range MINLOGL to - * MAXLOGL. - * - * A rational function is used for |x| < 0.625. The form - * x + x**3 P(x)/Q(x) of Cody _& Waite is employed. - * Otherwise, - * tanh(x) = sinh(x)/cosh(x) = 1 - 2/(exp(2x) + 1). - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -2,2 30000 1.3e-19 2.4e-20 - * - */ - -/* tanl.c - * - * Circular tangent, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, tanl(); - * - * y = tanl( x ); - * - * - * - * DESCRIPTION: - * - * Returns the circular tangent of the radian argument x. - * - * Range reduction is modulo pi/4. A rational function - * x + x**3 P(x**2)/Q(x**2) - * is employed in the basic interval [0, pi/4]. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE +-1.07e9 30000 1.9e-19 4.8e-20 - * - * ERROR MESSAGES: - * - * message condition value returned - * tan total loss x > 2^39 0.0 - * - */ - /* cotl.c - * - * Circular cotangent, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, cotl(); - * - * y = cotl( x ); - * - * - * - * DESCRIPTION: - * - * Returns the circular cotangent of the radian argument x. - * - * Range reduction is modulo pi/4. A rational function - * x + x**3 P(x**2)/Q(x**2) - * is employed in the basic interval [0, pi/4]. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE +-1.07e9 30000 1.9e-19 5.1e-20 - * - * - * ERROR MESSAGES: - * - * message condition value returned - * cot total loss x > 2^39 0.0 - * cot singularity x = 0 MAXNUM - * - */ - -/* unityl.c - * - * Relative error approximations for function arguments near - * unity. - * - * log1p(x) = log(1+x) - * expm1(x) = exp(x) - 1 - * cos1m(x) = cos(x) - 1 - * - */ - -/* ynl.c - * - * Bessel function of second kind of integer order - * - * - * - * SYNOPSIS: - * - * long double x, y, ynl(); - * int n; - * - * y = ynl( n, x ); - * - * - * - * DESCRIPTION: - * - * Returns Bessel function of order n, where n is a - * (possibly negative) integer. - * - * The function is evaluated by forward recurrence on - * n, starting with values computed by the routines - * y0l() and y1l(). - * - * If n = 0 or 1 the routine for y0l or y1l is called - * directly. - * - * - * - * ACCURACY: - * - * - * Absolute error, except relative error when y > 1. - * x >= 0, -30 <= n <= +30. - * arithmetic domain # trials peak rms - * IEEE -30, 30 10000 1.3e-18 1.8e-19 - * - * - * ERROR MESSAGES: - * - * message condition value returned - * ynl singularity x = 0 MAXNUML - * ynl overflow MAXNUML - * - * Spot checked against tables for x, n between 0 and 100. - * - */ diff --git a/libm/ldouble/acoshl.c b/libm/ldouble/acoshl.c deleted file mode 100644 index 96c46bf22..000000000 --- a/libm/ldouble/acoshl.c +++ /dev/null @@ -1,167 +0,0 @@ -/* acoshl.c - * - * Inverse hyperbolic cosine, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, acoshl(); - * - * y = acoshl( x ); - * - * - * - * DESCRIPTION: - * - * Returns inverse hyperbolic cosine of argument. - * - * If 1 <= x < 1.5, a rational approximation - * - * sqrt(2z) * P(z)/Q(z) - * - * where z = x-1, is used. Otherwise, - * - * acosh(x) = log( x + sqrt( (x-1)(x+1) ). - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 1,3 30000 2.0e-19 3.9e-20 - * - * - * ERROR MESSAGES: - * - * message condition value returned - * acoshl domain |x| < 1 0.0 - * - */ - -/* acosh.c */ - -/* -Cephes Math Library Release 2.7: May, 1998 -Copyright 1984, 1991, 1998 by Stephen L. Moshier -*/ - - -/* acosh(1+x) = sqrt(2x) * R(x), interval 0 < x < 0.5 */ - -#include <math.h> - -#ifdef UNK -static long double P[] = { - 2.9071989653343333587238E-5L, - 3.2906030801088967279449E-3L, - 6.3034445964862182128388E-2L, - 4.1587081802731351459504E-1L, - 1.0989714347599256302467E0L, - 9.9999999999999999999715E-1L, -}; -static long double Q[] = { - 1.0443462486787584738322E-4L, - 6.0085845375571145826908E-3L, - 8.7750439986662958343370E-2L, - 4.9564621536841869854584E-1L, - 1.1823047680932589605190E0L, - 1.0000000000000000000028E0L, -}; -#endif - - -#ifdef IBMPC -static unsigned short P[] = { -0x4536,0x4dba,0x9f55,0xf3df,0x3fef, XPD -0x23a5,0xf9aa,0x289c,0xd7a7,0x3ff6, XPD -0x7e8b,0x8645,0x341f,0x8118,0x3ffb, XPD -0x0fd5,0x937f,0x0515,0xd4ed,0x3ffd, XPD -0x2364,0xc41b,0x1891,0x8cab,0x3fff, XPD -0x0000,0x0000,0x0000,0x8000,0x3fff, XPD -}; -static short Q[] = { -0x1e7c,0x4f16,0xe98c,0xdb03,0x3ff1, XPD -0xc319,0xc272,0xa90a,0xc4e3,0x3ff7, XPD -0x2f83,0x9e5e,0x80af,0xb3b6,0x3ffb, XPD -0xe1e0,0xc97c,0x573a,0xfdc5,0x3ffd, XPD -0xcdf2,0x6ec5,0xc33c,0x9755,0x3fff, XPD -0x0000,0x0000,0x0000,0x8000,0x3fff, XPD -}; -#endif - -#ifdef MIEEE -static long P[] = { -0x3fef0000,0xf3df9f55,0x4dba4536, -0x3ff60000,0xd7a7289c,0xf9aa23a5, -0x3ffb0000,0x8118341f,0x86457e8b, -0x3ffd0000,0xd4ed0515,0x937f0fd5, -0x3fff0000,0x8cab1891,0xc41b2364, -0x3fff0000,0x80000000,0x00000000, -}; -static long Q[] = { -0x3ff10000,0xdb03e98c,0x4f161e7c, -0x3ff70000,0xc4e3a90a,0xc272c319, -0x3ffb0000,0xb3b680af,0x9e5e2f83, -0x3ffd0000,0xfdc5573a,0xc97ce1e0, -0x3fff0000,0x9755c33c,0x6ec5cdf2, -0x3fff0000,0x80000000,0x00000000, -}; -#endif - -extern long double LOGE2L; -#ifdef INFINITIES -extern long double INFINITYL; -#endif -#ifdef NANS -extern long double NANL; -#endif -#ifdef ANSIPROT -extern long double logl ( long double ); -extern long double sqrtl ( long double ); -extern long double polevll ( long double, void *, int ); -extern int isnanl ( long double ); -#else -long double logl(), sqrtl(), polevll(), isnanl(); -#endif - -long double acoshl(x) -long double x; -{ -long double a, z; - -#ifdef NANS -if( isnanl(x) ) - return(x); -#endif -if( x < 1.0L ) - { - mtherr( "acoshl", DOMAIN ); -#ifdef NANS - return(NANL); -#else - return(0.0L); -#endif - } - -if( x > 1.0e10 ) - { -#ifdef INFINITIES - if( x == INFINITYL ) - return( INFINITYL ); -#endif - return( logl(x) + LOGE2L ); - } - -z = x - 1.0L; - -if( z < 0.5L ) - { - a = sqrtl(2.0L*z) * (polevll(z, P, 5) / polevll(z, Q, 5) ); - return( a ); - } - -a = sqrtl( z*(x+1.0L) ); -return( logl(x + a) ); -} diff --git a/libm/ldouble/arcdotl.c b/libm/ldouble/arcdotl.c deleted file mode 100644 index 952f027c6..000000000 --- a/libm/ldouble/arcdotl.c +++ /dev/null @@ -1,108 +0,0 @@ -/* arcdot.c - * - * Angle between two vectors - * - * - * - * - * SYNOPSIS: - * - * long double p[3], q[3], arcdotl(); - * - * y = arcdotl( p, q ); - * - * - * - * DESCRIPTION: - * - * For two vectors p, q, the angle A between them is given by - * - * p.q / (|p| |q|) = cos A . - * - * where "." represents inner product, "|x|" the length of vector x. - * If the angle is small, an expression in sin A is preferred. - * Set r = q - p. Then - * - * p.q = p.p + p.r , - * - * |p|^2 = p.p , - * - * |q|^2 = p.p + 2 p.r + r.r , - * - * p.p^2 + 2 p.p p.r + p.r^2 - * cos^2 A = ---------------------------- - * p.p (p.p + 2 p.r + r.r) - * - * p.p + 2 p.r + p.r^2 / p.p - * = --------------------------- , - * p.p + 2 p.r + r.r - * - * sin^2 A = 1 - cos^2 A - * - * r.r - p.r^2 / p.p - * = -------------------- - * p.p + 2 p.r + r.r - * - * = (r.r - p.r^2 / p.p) / q.q . - * - * ACCURACY: - * - * About 1 ULP. See arcdot.c. - * - */ - -/* -Cephes Math Library Release 2.3: November, 1995 -Copyright 1995 by Stephen L. Moshier -*/ - -#include <math.h> -#ifdef ANSIPROT -extern long double sqrtl ( long double ); -extern long double acosl ( long double ); -extern long double asinl ( long double ); -extern long double atanl ( long double ); -#else -long double sqrtl(), acosl(), asinl(), atanl(); -#endif -extern long double PIL; - -long double arcdotl(p,q) -long double p[], q[]; -{ -long double pp, pr, qq, rr, rt, pt, qt, pq; -int i; - -pq = 0.0L; -qq = 0.0L; -pp = 0.0L; -pr = 0.0L; -rr = 0.0L; -for (i=0; i<3; i++) - { - pt = p[i]; - qt = q[i]; - pq += pt * qt; - qq += qt * qt; - pp += pt * pt; - rt = qt - pt; - pr += pt * rt; - rr += rt * rt; - } -if (rr == 0.0L || pp == 0.0L || qq == 0.0L) - return 0.0L; -rt = (rr - (pr * pr) / pp) / qq; -if (rt <= 0.75L) - { - rt = sqrtl(rt); - qt = asinl(rt); - if (pq < 0.0L) - qt = PIL - qt; - } -else - { - pt = pq / sqrtl(pp*qq); - qt = acosl(pt); - } -return qt; -} diff --git a/libm/ldouble/asinhl.c b/libm/ldouble/asinhl.c deleted file mode 100644 index 025dfc29d..000000000 --- a/libm/ldouble/asinhl.c +++ /dev/null @@ -1,156 +0,0 @@ -/* asinhl.c - * - * Inverse hyperbolic sine, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, asinhl(); - * - * y = asinhl( x ); - * - * - * - * DESCRIPTION: - * - * Returns inverse hyperbolic sine of argument. - * - * If |x| < 0.5, the function is approximated by a rational - * form x + x**3 P(x)/Q(x). Otherwise, - * - * asinh(x) = log( x + sqrt(1 + x*x) ). - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -3,3 30000 1.7e-19 3.5e-20 - * - */ - - -/* -Cephes Math Library Release 2.7: May, 1998 -Copyright 1984, 1991, 1998 by Stephen L. Moshier -*/ - - -#include <math.h> - -#ifdef UNK -static long double P[] = { --7.2157234864927687427374E-1L, --1.3005588097490352458918E1L, --5.9112383795679709212744E1L, --9.5372702442289028811361E1L, --4.9802880260861844539014E1L, -}; -static long double Q[] = { -/* 1.0000000000000000000000E0L,*/ - 2.8754968540389640419671E1L, - 2.0990255691901160529390E2L, - 5.9265075560893800052658E2L, - 7.0670399135805956780660E2L, - 2.9881728156517107462943E2L, -}; -#endif - - -#ifdef IBMPC -static short P[] = { -0x8f42,0x2584,0xf727,0xb8b8,0xbffe, XPD -0x9d56,0x7f7c,0xe38b,0xd016,0xc002, XPD -0xc518,0xdc2d,0x14bc,0xec73,0xc004, XPD -0x99fe,0xc18a,0xd2da,0xbebe,0xc005, XPD -0xb46c,0x3c05,0x263e,0xc736,0xc004, XPD -}; -static short Q[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ -0xdfed,0x33db,0x2cf2,0xe60a,0x4003, XPD -0xf109,0x61ee,0x0df8,0xd1e7,0x4006, XPD -0xf21e,0xda84,0xa5fa,0x9429,0x4008, XPD -0x13fc,0xc4e2,0x0e31,0xb0ad,0x4008, XPD -0x485c,0xad04,0x9cae,0x9568,0x4007, XPD -}; -#endif - -#ifdef MIEEE -static long P[] = { -0xbffe0000,0xb8b8f727,0x25848f42, -0xc0020000,0xd016e38b,0x7f7c9d56, -0xc0040000,0xec7314bc,0xdc2dc518, -0xc0050000,0xbebed2da,0xc18a99fe, -0xc0040000,0xc736263e,0x3c05b46c, -}; -static long Q[] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0x40030000,0xe60a2cf2,0x33dbdfed, -0x40060000,0xd1e70df8,0x61eef109, -0x40080000,0x9429a5fa,0xda84f21e, -0x40080000,0xb0ad0e31,0xc4e213fc, -0x40070000,0x95689cae,0xad04485c, -}; -#endif - -extern long double LOGE2L; -#ifdef INFINITIES -extern long double INFINITYL; -#endif -#ifdef ANSIPROT -extern long double logl ( long double ); -extern long double sqrtl ( long double ); -extern long double polevll ( long double, void *, int ); -extern long double p1evll ( long double, void *, int ); -extern int isnanl ( long double ); -extern int isfinitel ( long double ); -#else -long double logl(), sqrtl(), polevll(), p1evll(), isnanl(), isfinitel(); -#endif - -long double asinhl(x) -long double x; -{ -long double a, z; -int sign; - -#ifdef NANS -if( isnanl(x) ) - return(x); -#endif -#ifdef MINUSZERO -if( x == 0.0L ) - return(x); -#endif -#ifdef INFINITIES - if( !isfinitel(x) ) - return(x); -#endif -if( x < 0.0L ) - { - sign = -1; - x = -x; - } -else - sign = 1; - -if( x > 1.0e10L ) - { - return( sign * (logl(x) + LOGE2L) ); - } - -z = x * x; -if( x < 0.5L ) - { - a = ( polevll(z, P, 4)/p1evll(z, Q, 5) ) * z; - a = a * x + x; - if( sign < 0 ) - a = -a; - return(a); - } - -a = sqrtl( z + 1.0L ); -return( sign * logl(x + a) ); -} diff --git a/libm/ldouble/asinl.c b/libm/ldouble/asinl.c deleted file mode 100644 index 163f01055..000000000 --- a/libm/ldouble/asinl.c +++ /dev/null @@ -1,249 +0,0 @@ -/* asinl.c - * - * Inverse circular sine, long double precision - * - * - * - * SYNOPSIS: - * - * double x, y, asinl(); - * - * y = asinl( x ); - * - * - * - * DESCRIPTION: - * - * Returns radian angle between -pi/2 and +pi/2 whose sine is x. - * - * A rational function of the form x + x**3 P(x**2)/Q(x**2) - * is used for |x| in the interval [0, 0.5]. If |x| > 0.5 it is - * transformed by the identity - * - * asin(x) = pi/2 - 2 asin( sqrt( (1-x)/2 ) ). - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -1, 1 30000 2.7e-19 4.8e-20 - * - * - * ERROR MESSAGES: - * - * message condition value returned - * asinl domain |x| > 1 NANL - * - */ - /* acosl() - * - * Inverse circular cosine, long double precision - * - * - * - * SYNOPSIS: - * - * double x, y, acosl(); - * - * y = acosl( x ); - * - * - * - * DESCRIPTION: - * - * Returns radian angle between -pi/2 and +pi/2 whose cosine - * is x. - * - * Analytically, acos(x) = pi/2 - asin(x). However if |x| is - * near 1, there is cancellation error in subtracting asin(x) - * from pi/2. Hence if x < -0.5, - * - * acos(x) = pi - 2.0 * asin( sqrt((1+x)/2) ); - * - * or if x > +0.5, - * - * acos(x) = 2.0 * asin( sqrt((1-x)/2) ). - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -1, 1 30000 1.4e-19 3.5e-20 - * - * - * ERROR MESSAGES: - * - * message condition value returned - * acosl domain |x| > 1 NANL - */ - -/* asin.c */ - -/* -Cephes Math Library Release 2.7: May, 1998 -Copyright 1984, 1990, 1998 by Stephen L. Moshier -*/ - -#include <math.h> - -#ifdef UNK -static long double P[] = { - 3.7769340062433674871612E-3L, --6.1212919176969202969441E-1L, - 5.9303993515791417710775E0L, --1.8631697621590161441592E1L, - 2.3314603132141795720634E1L, --1.0087146579384916260197E1L, -}; -static long double Q[] = { -/* 1.0000000000000000000000E0L,*/ --1.5684335624873146511217E1L, - 7.8702951549021104258866E1L, --1.7078401170625864261444E2L, - 1.6712291455718995937376E2L, --6.0522879476309497128868E1L, -}; -#endif - -#ifdef IBMPC -static short P[] = { -0x59d1,0x3509,0x7009,0xf786,0x3ff6, XPD -0xbe97,0x93e6,0x7fab,0x9cb4,0xbffe, XPD -0x8bf5,0x6810,0xd4dc,0xbdc5,0x4001, XPD -0x9bd4,0x8d86,0xb77b,0x950d,0xc003, XPD -0x3b0f,0x9e25,0x4ea5,0xba84,0x4003, XPD -0xea38,0xc6a9,0xf3cf,0xa164,0xc002, XPD -}; -static short Q[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ -0x1229,0x8516,0x09e9,0xfaf3,0xc002, XPD -0xb5c3,0xf36f,0xe943,0x9d67,0x4005, XPD -0xe11a,0xbe0f,0xb4fd,0xaac8,0xc006, XPD -0x4c69,0x1355,0x7754,0xa71f,0x4006, XPD -0xded7,0xa9fe,0x6db7,0xf217,0xc004, XPD -}; -#endif - -#ifdef MIEEE -static long P[] = { -0x3ff60000,0xf7867009,0x350959d1, -0xbffe0000,0x9cb47fab,0x93e6be97, -0x40010000,0xbdc5d4dc,0x68108bf5, -0xc0030000,0x950db77b,0x8d869bd4, -0x40030000,0xba844ea5,0x9e253b0f, -0xc0020000,0xa164f3cf,0xc6a9ea38, -}; -static long Q[] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0xc0020000,0xfaf309e9,0x85161229, -0x40050000,0x9d67e943,0xf36fb5c3, -0xc0060000,0xaac8b4fd,0xbe0fe11a, -0x40060000,0xa71f7754,0x13554c69, -0xc0040000,0xf2176db7,0xa9feded7, -}; -#endif -#ifdef NANS -extern long double NANL; -#endif -#ifdef ANSIPROT -extern long double ldexpl ( long double, int ); -extern long double sqrtl ( long double ); -extern long double polevll ( long double, void *, int ); -extern long double p1evll ( long double, void *, int ); -long double asinl ( long double ); -#else -long double ldexpl(), sqrtl(), polevll(), p1evll(); -long double asinl(); -#endif - -long double asinl(x) -long double x; -{ -long double a, p, z, zz; -short sign, flag; -extern long double PIO2L; - -if( x > 0 ) - { - sign = 1; - a = x; - } -else - { - sign = -1; - a = -x; - } - -if( a > 1.0L ) - { - mtherr( "asinl", DOMAIN ); -#ifdef NANS - return( NANL ); -#else - return( 0.0L ); -#endif - } - -if( a < 1.0e-8L ) - { - z = a; - goto done; - } - -if( a > 0.5L ) - { - zz = 0.5L -a; - zz = ldexpl( zz + 0.5L, -1 ); - z = sqrtl( zz ); - flag = 1; - } -else - { - z = a; - zz = z * z; - flag = 0; - } - -p = zz * polevll( zz, P, 5)/p1evll( zz, Q, 5); -z = z * p + z; -if( flag != 0 ) - { - z = z + z; - z = PIO2L - z; - } -done: -if( sign < 0 ) - z = -z; -return(z); -} - - -extern long double PIO2L, PIL; - -long double acosl(x) -long double x; -{ - -if( x < -1.0L ) - goto domerr; - -if( x < -0.5L) - return( PIL - 2.0L * asinl( sqrtl(0.5L*(1.0L+x)) ) ); - -if( x > 1.0L ) - { -domerr: mtherr( "acosl", DOMAIN ); -#ifdef NANS - return( NANL ); -#else - return( 0.0L ); -#endif - } - -if( x > 0.5L ) - return( 2.0L * asinl( sqrtl(0.5L*(1.0L-x) ) ) ); - -return( PIO2L - asinl(x) ); -} diff --git a/libm/ldouble/atanhl.c b/libm/ldouble/atanhl.c deleted file mode 100644 index 3dc7bd2eb..000000000 --- a/libm/ldouble/atanhl.c +++ /dev/null @@ -1,163 +0,0 @@ -/* atanhl.c - * - * Inverse hyperbolic tangent, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, atanhl(); - * - * y = atanhl( x ); - * - * - * - * DESCRIPTION: - * - * Returns inverse hyperbolic tangent of argument in the range - * MINLOGL to MAXLOGL. - * - * If |x| < 0.5, the rational form x + x**3 P(x)/Q(x) is - * employed. Otherwise, - * atanh(x) = 0.5 * log( (1+x)/(1-x) ). - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -1,1 30000 1.1e-19 3.3e-20 - * - */ - - - -/* -Cephes Math Library Release 2.7: May, 1998 -Copyright (C) 1987, 1991, 1998 by Stephen L. Moshier -*/ - -#include <math.h> - -#ifdef UNK -static long double P[] = { - 2.9647757819596835680719E-3L, --8.0026596513099094380633E-1L, - 7.7920941408493040219831E0L, --2.4330686602187898836837E1L, - 3.0204265014595622991082E1L, --1.2961142942114056581210E1L, -}; -static long double Q[] = { -/* 1.0000000000000000000000E0L,*/ --1.3729634163247557081869E1L, - 6.2320841104088512332185E1L, --1.2469344457045341444078E2L, - 1.1394285233959210574352E2L, --3.8883428826342169425890E1L, -}; -#endif - -#ifdef IBMPC -static short P[] = { -0x3aa2,0x036b,0xaf06,0xc24c,0x3ff6, XPD -0x528e,0x56e8,0x3af4,0xccde,0xbffe, XPD -0x9d89,0xc9a1,0xd5cf,0xf958,0x4001, XPD -0xa653,0x6cfa,0x3f04,0xc2a5,0xc003, XPD -0xc651,0x2b3d,0x55b2,0xf1a2,0x4003, XPD -0xd76d,0xf293,0xd76b,0xcf60,0xc002, XPD -}; -static short Q[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ -0xd1b9,0x5314,0x94df,0xdbac,0xc002, XPD -0x3caa,0x0517,0x8a92,0xf948,0x4004, XPD -0x535e,0xaf5f,0x0b2a,0xf963,0xc005, XPD -0xa6f9,0xb702,0xbd8a,0xe3e2,0x4005, XPD -0xe136,0xf5ee,0xa190,0x9b88,0xc004, XPD -}; -#endif - -#ifdef MIEEE -static long P[] = { -0x3ff60000,0xc24caf06,0x036b3aa2, -0xbffe0000,0xccde3af4,0x56e8528e, -0x40010000,0xf958d5cf,0xc9a19d89, -0xc0030000,0xc2a53f04,0x6cfaa653, -0x40030000,0xf1a255b2,0x2b3dc651, -0xc0020000,0xcf60d76b,0xf293d76d, -}; -static long Q[] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0xc0020000,0xdbac94df,0x5314d1b9, -0x40040000,0xf9488a92,0x05173caa, -0xc0050000,0xf9630b2a,0xaf5f535e, -0x40050000,0xe3e2bd8a,0xb702a6f9, -0xc0040000,0x9b88a190,0xf5eee136, -}; -#endif - -extern long double MAXNUML; -#ifdef ANSIPROT -extern long double fabsl ( long double ); -extern long double logl ( long double ); -extern long double polevll ( long double, void *, int ); -extern long double p1evll ( long double, void *, int ); -#else -long double fabsl(), logl(), polevll(), p1evll(); -#endif -#ifdef INFINITIES -extern long double INFINITYL; -#endif -#ifdef NANS -extern long double NANL; -#endif - -long double atanhl(x) -long double x; -{ -long double s, z; - -#ifdef MINUSZERO -if( x == 0.0L ) - return(x); -#endif -z = fabsl(x); -if( z >= 1.0L ) - { - if( x == 1.0L ) - { -#ifdef INFINITIES - return( INFINITYL ); -#else - return( MAXNUML ); -#endif - } - if( x == -1.0L ) - { -#ifdef INFINITIES - return( -INFINITYL ); -#else - return( -MAXNUML ); -#endif - } - mtherr( "atanhl", DOMAIN ); -#ifdef NANS - return( NANL ); -#else - return( MAXNUML ); -#endif - } - -if( z < 1.0e-8L ) - return(x); - -if( z < 0.5L ) - { - z = x * x; - s = x + x * z * (polevll(z, P, 5) / p1evll(z, Q, 5)); - return(s); - } - -return( 0.5L * logl((1.0L+x)/(1.0L-x)) ); -} diff --git a/libm/ldouble/atanl.c b/libm/ldouble/atanl.c deleted file mode 100644 index 9e6d9af3c..000000000 --- a/libm/ldouble/atanl.c +++ /dev/null @@ -1,376 +0,0 @@ -/* atanl.c - * - * Inverse circular tangent, long double precision - * (arctangent) - * - * - * - * SYNOPSIS: - * - * long double x, y, atanl(); - * - * y = atanl( x ); - * - * - * - * DESCRIPTION: - * - * Returns radian angle between -pi/2 and +pi/2 whose tangent - * is x. - * - * Range reduction is from four intervals into the interval - * from zero to tan( pi/8 ). The approximant uses a rational - * function of degree 3/4 of the form x + x**3 P(x)/Q(x). - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -10, 10 150000 1.3e-19 3.0e-20 - * - */ - /* atan2l() - * - * Quadrant correct inverse circular tangent, - * long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, z, atan2l(); - * - * z = atan2l( y, x ); - * - * - * - * DESCRIPTION: - * - * Returns radian angle whose tangent is y/x. - * Define compile time symbol ANSIC = 1 for ANSI standard, - * range -PI < z <= +PI, args (y,x); else ANSIC = 0 for range - * 0 to 2PI, args (x,y). - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -10, 10 60000 1.7e-19 3.2e-20 - * See atan.c. - * - */ - -/* atan.c */ - - -/* -Cephes Math Library Release 2.7: May, 1998 -Copyright 1984, 1990, 1998 by Stephen L. Moshier -*/ - - -#include <math.h> - -#ifdef UNK -static long double P[] = { --8.6863818178092187535440E-1L, --1.4683508633175792446076E1L, --6.3976888655834347413154E1L, --9.9988763777265819915721E1L, --5.0894116899623603312185E1L, -}; -static long double Q[] = { -/* 1.00000000000000000000E0L,*/ - 2.2981886733594175366172E1L, - 1.4399096122250781605352E2L, - 3.6144079386152023162701E2L, - 3.9157570175111990631099E2L, - 1.5268235069887081006606E2L, -}; - -/* tan( 3*pi/8 ) */ -static long double T3P8 = 2.41421356237309504880169L; - -/* tan( pi/8 ) */ -static long double TP8 = 4.1421356237309504880169e-1L; -#endif - - -#ifdef IBMPC -static unsigned short P[] = { -0x8ece,0xce53,0x1266,0xde5f,0xbffe, XPD -0x07e6,0xa061,0xa6bf,0xeaef,0xc002, XPD -0x53ee,0xf291,0x557f,0xffe8,0xc004, XPD -0xf9d6,0xeda6,0x3f3e,0xc7fa,0xc005, XPD -0xb6c3,0x6abc,0x9361,0xcb93,0xc004, XPD -}; -static unsigned short Q[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ -0x54d4,0x894e,0xe76e,0xb7da,0x4003, XPD -0x76b9,0x7a46,0xafa2,0x8ffd,0x4006, XPD -0xe3a9,0xe9c0,0x6bee,0xb4b8,0x4007, XPD -0xabc1,0x50a7,0xb098,0xc3c9,0x4007, XPD -0x891c,0x100d,0xae89,0x98ae,0x4006, XPD -}; - -/* tan( 3*pi/8 ) = 2.41421356237309504880 */ -static unsigned short T3P8A[] = {0x3242,0xfcef,0x7999,0x9a82,0x4000, XPD}; -#define T3P8 *(long double *)T3P8A - -/* tan( pi/8 ) = 0.41421356237309504880 */ -static unsigned short TP8A[] = {0x9211,0xe779,0xcccf,0xd413,0x3ffd, XPD}; -#define TP8 *(long double *)TP8A -#endif - -#ifdef MIEEE -static unsigned long P[] = { -0xbffe0000,0xde5f1266,0xce538ece, -0xc0020000,0xeaefa6bf,0xa06107e6, -0xc0040000,0xffe8557f,0xf29153ee, -0xc0050000,0xc7fa3f3e,0xeda6f9d6, -0xc0040000,0xcb939361,0x6abcb6c3, -}; -static unsigned long Q[] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0x40030000,0xb7dae76e,0x894e54d4, -0x40060000,0x8ffdafa2,0x7a4676b9, -0x40070000,0xb4b86bee,0xe9c0e3a9, -0x40070000,0xc3c9b098,0x50a7abc1, -0x40060000,0x98aeae89,0x100d891c, -}; - -/* tan( 3*pi/8 ) = 2.41421356237309504880 */ -static long T3P8A[] = {0x40000000,0x9a827999,0xfcef3242}; -#define T3P8 *(long double *)T3P8A - -/* tan( pi/8 ) = 0.41421356237309504880 */ -static long TP8A[] = {0x3ffd0000,0xd413cccf,0xe7799211}; -#define TP8 *(long double *)TP8A -#endif - -#ifdef ANSIPROT -extern long double polevll ( long double, void *, int ); -extern long double p1evll ( long double, void *, int ); -extern long double fabsl ( long double ); -extern int signbitl ( long double ); -extern int isnanl ( long double ); -long double atanl ( long double ); -#else -long double polevll(), p1evll(), fabsl(), signbitl(), isnanl(); -long double atanl(); -#endif -#ifdef INFINITIES -extern long double INFINITYL; -#endif -#ifdef NANS -extern long double NANL; -#endif -#ifdef MINUSZERO -extern long double NEGZEROL; -#endif - -long double atanl(x) -long double x; -{ -extern long double PIO2L, PIO4L; -long double y, z; -short sign; - -#ifdef MINUSZERO -if( x == 0.0L ) - return(x); -#endif -#ifdef INFINITIES -if( x == INFINITYL ) - return( PIO2L ); -if( x == -INFINITYL ) - return( -PIO2L ); -#endif -/* make argument positive and save the sign */ -sign = 1; -if( x < 0.0L ) - { - sign = -1; - x = -x; - } - -/* range reduction */ -if( x > T3P8 ) - { - y = PIO2L; - x = -( 1.0L/x ); - } - -else if( x > TP8 ) - { - y = PIO4L; - x = (x-1.0L)/(x+1.0L); - } -else - y = 0.0L; - -/* rational form in x**2 */ -z = x * x; -y = y + ( polevll( z, P, 4 ) / p1evll( z, Q, 5 ) ) * z * x + x; - -if( sign < 0 ) - y = -y; - -return(y); -} - -/* atan2 */ - - -extern long double PIL, PIO2L, MAXNUML; - -#if ANSIC -long double atan2l( y, x ) -#else -long double atan2l( x, y ) -#endif -long double x, y; -{ -long double z, w; -short code; - -code = 0; - -if( x < 0.0L ) - code = 2; -if( y < 0.0L ) - code |= 1; - -#ifdef NANS -if( isnanl(x) ) - return(x); -if( isnanl(y) ) - return(y); -#endif -#ifdef MINUSZERO -if( y == 0.0L ) - { - if( signbitl(y) ) - { - if( x > 0.0L ) - z = y; - else if( x < 0.0L ) - z = -PIL; - else - { - if( signbitl(x) ) - z = -PIL; - else - z = y; - } - } - else /* y is +0 */ - { - if( x == 0.0L ) - { - if( signbitl(x) ) - z = PIL; - else - z = 0.0L; - } - else if( x > 0.0L ) - z = 0.0L; - else - z = PIL; - } - return z; - } -if( x == 0.0L ) - { - if( y > 0.0L ) - z = PIO2L; - else - z = -PIO2L; - return z; - } -#endif /* MINUSZERO */ -#ifdef INFINITIES -if( x == INFINITYL ) - { - if( y == INFINITYL ) - z = 0.25L * PIL; - else if( y == -INFINITYL ) - z = -0.25L * PIL; - else if( y < 0.0L ) - z = NEGZEROL; - else - z = 0.0L; - return z; - } -if( x == -INFINITYL ) - { - if( y == INFINITYL ) - z = 0.75L * PIL; - else if( y == -INFINITYL ) - z = -0.75L * PIL; - else if( y >= 0.0L ) - z = PIL; - else - z = -PIL; - return z; - } -if( y == INFINITYL ) - return( PIO2L ); -if( y == -INFINITYL ) - return( -PIO2L ); -#endif /* INFINITIES */ - -#ifdef INFINITIES -if( x == 0.0L ) -#else -if( fabsl(x) <= (fabsl(y) / MAXNUML) ) -#endif - { - if( code & 1 ) - { -#if ANSIC - return( -PIO2L ); -#else - return( 3.0L*PIO2L ); -#endif - } - if( y == 0.0L ) - return( 0.0L ); - return( PIO2L ); - } - -if( y == 0.0L ) - { - if( code & 2 ) - return( PIL ); - return( 0.0L ); - } - - -switch( code ) - { - default: -#if ANSIC - case 0: - case 1: w = 0.0L; break; - case 2: w = PIL; break; - case 3: w = -PIL; break; -#else - case 0: w = 0.0L; break; - case 1: w = 2.0L * PIL; break; - case 2: - case 3: w = PIL; break; -#endif - } - -z = w + atanl( y/x ); -#ifdef MINUSZERO -if( z == 0.0L && y < 0.0L ) - z = NEGZEROL; -#endif -return( z ); -} diff --git a/libm/ldouble/bdtrl.c b/libm/ldouble/bdtrl.c deleted file mode 100644 index aca9577d1..000000000 --- a/libm/ldouble/bdtrl.c +++ /dev/null @@ -1,260 +0,0 @@ -/* bdtrl.c - * - * Binomial distribution - * - * - * - * SYNOPSIS: - * - * int k, n; - * long double p, y, bdtrl(); - * - * y = bdtrl( k, n, p ); - * - * - * - * DESCRIPTION: - * - * Returns the sum of the terms 0 through k of the Binomial - * probability density: - * - * k - * -- ( n ) j n-j - * > ( ) p (1-p) - * -- ( j ) - * j=0 - * - * The terms are not summed directly; instead the incomplete - * beta integral is employed, according to the formula - * - * y = bdtr( k, n, p ) = incbet( n-k, k+1, 1-p ). - * - * The arguments must be positive, with p ranging from 0 to 1. - * - * - * - * ACCURACY: - * - * Tested at random points (k,n,p) with a and b between 0 - * and 10000 and p between 0 and 1. - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 0,10000 3000 1.6e-14 2.2e-15 - * - * ERROR MESSAGES: - * - * message condition value returned - * bdtrl domain k < 0 0.0 - * n < k - * x < 0, x > 1 - * - */ - /* bdtrcl() - * - * Complemented binomial distribution - * - * - * - * SYNOPSIS: - * - * int k, n; - * long double p, y, bdtrcl(); - * - * y = bdtrcl( k, n, p ); - * - * - * - * DESCRIPTION: - * - * Returns the sum of the terms k+1 through n of the Binomial - * probability density: - * - * n - * -- ( n ) j n-j - * > ( ) p (1-p) - * -- ( j ) - * j=k+1 - * - * The terms are not summed directly; instead the incomplete - * beta integral is employed, according to the formula - * - * y = bdtrc( k, n, p ) = incbet( k+1, n-k, p ). - * - * The arguments must be positive, with p ranging from 0 to 1. - * - * - * - * ACCURACY: - * - * See incbet.c. - * - * ERROR MESSAGES: - * - * message condition value returned - * bdtrcl domain x<0, x>1, n<k 0.0 - */ - /* bdtril() - * - * Inverse binomial distribution - * - * - * - * SYNOPSIS: - * - * int k, n; - * long double p, y, bdtril(); - * - * p = bdtril( k, n, y ); - * - * - * - * DESCRIPTION: - * - * Finds the event probability p such that the sum of the - * terms 0 through k of the Binomial probability density - * is equal to the given cumulative probability y. - * - * This is accomplished using the inverse beta integral - * function and the relation - * - * 1 - p = incbi( n-k, k+1, y ). - * - * ACCURACY: - * - * See incbi.c. - * Tested at random k, n between 1 and 10000. The "domain" refers to p: - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 0,1 3500 2.0e-15 8.2e-17 - * - * ERROR MESSAGES: - * - * message condition value returned - * bdtril domain k < 0, n <= k 0.0 - * x < 0, x > 1 - */ - -/* bdtr() */ - - -/* -Cephes Math Library Release 2.3: March, 1995 -Copyright 1984, 1995 by Stephen L. Moshier -*/ - -#include <math.h> -#ifdef ANSIPROT -extern long double incbetl ( long double, long double, long double ); -extern long double incbil ( long double, long double, long double ); -extern long double powl ( long double, long double ); -extern long double expm1l ( long double ); -extern long double log1pl ( long double ); -#else -long double incbetl(), incbil(), powl(), expm1l(), log1pl(); -#endif - -long double bdtrcl( k, n, p ) -int k, n; -long double p; -{ -long double dk, dn; - -if( (p < 0.0L) || (p > 1.0L) ) - goto domerr; -if( k < 0 ) - return( 1.0L ); - -if( n < k ) - { -domerr: - mtherr( "bdtrcl", DOMAIN ); - return( 0.0L ); - } - -if( k == n ) - return( 0.0L ); -dn = n - k; -if( k == 0 ) - { - if( p < .01L ) - dk = -expm1l( dn * log1pl(-p) ); - else - dk = 1.0L - powl( 1.0L-p, dn ); - } -else - { - dk = k + 1; - dk = incbetl( dk, dn, p ); - } -return( dk ); -} - - - -long double bdtrl( k, n, p ) -int k, n; -long double p; -{ -long double dk, dn, q; - -if( (p < 0.0L) || (p > 1.0L) ) - goto domerr; -if( (k < 0) || (n < k) ) - { -domerr: - mtherr( "bdtrl", DOMAIN ); - return( 0.0L ); - } - -if( k == n ) - return( 1.0L ); - -q = 1.0L - p; -dn = n - k; -if( k == 0 ) - { - dk = powl( q, dn ); - } -else - { - dk = k + 1; - dk = incbetl( dn, dk, q ); - } -return( dk ); -} - - -long double bdtril( k, n, y ) -int k, n; -long double y; -{ -long double dk, dn, p; - -if( (y < 0.0L) || (y > 1.0L) ) - goto domerr; -if( (k < 0) || (n <= k) ) - { -domerr: - mtherr( "bdtril", DOMAIN ); - return( 0.0L ); - } - -dn = n - k; -if( k == 0 ) - { - if( y > 0.8L ) - p = -expm1l( log1pl(y-1.0L) / dn ); - else - p = 1.0L - powl( y, 1.0L/dn ); - } -else - { - dk = k + 1; - p = incbetl( dn, dk, y ); - if( p > 0.5 ) - p = incbil( dk, dn, 1.0L-y ); - else - p = 1.0 - incbil( dn, dk, y ); - } -return( p ); -} diff --git a/libm/ldouble/btdtrl.c b/libm/ldouble/btdtrl.c deleted file mode 100644 index cbc4515da..000000000 --- a/libm/ldouble/btdtrl.c +++ /dev/null @@ -1,68 +0,0 @@ - -/* btdtrl.c - * - * Beta distribution - * - * - * - * SYNOPSIS: - * - * long double a, b, x, y, btdtrl(); - * - * y = btdtrl( a, b, x ); - * - * - * - * DESCRIPTION: - * - * Returns the area from zero to x under the beta density - * function: - * - * - * x - * - - - * | (a+b) | | a-1 b-1 - * P(x) = ---------- | t (1-t) dt - * - - | | - * | (a) | (b) - - * 0 - * - * - * The mean value of this distribution is a/(a+b). The variance - * is ab/[(a+b)^2 (a+b+1)]. - * - * This function is identical to the incomplete beta integral - * function, incbetl(a, b, x). - * - * The complemented function is - * - * 1 - P(1-x) = incbetl( b, a, x ); - * - * - * ACCURACY: - * - * See incbetl.c. - * - */ - -/* btdtrl() */ - - -/* -Cephes Math Library Release 2.0: April, 1987 -Copyright 1984, 1995 by Stephen L. Moshier -Direct inquiries to 30 Frost Street, Cambridge, MA 02140 -*/ -#include <math.h> -#ifdef ANSIPROT -extern long double incbetl ( long double, long double, long double ); -#else -long double incbetl(); -#endif - -long double btdtrl( a, b, x ) -long double a, b, x; -{ - -return( incbetl( a, b, x ) ); -} diff --git a/libm/ldouble/cbrtl.c b/libm/ldouble/cbrtl.c deleted file mode 100644 index 89ed11a06..000000000 --- a/libm/ldouble/cbrtl.c +++ /dev/null @@ -1,143 +0,0 @@ -/* cbrtl.c - * - * Cube root, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, cbrtl(); - * - * y = cbrtl( x ); - * - * - * - * DESCRIPTION: - * - * Returns the cube root of the argument, which may be negative. - * - * Range reduction involves determining the power of 2 of - * the argument. A polynomial of degree 2 applied to the - * mantissa, and multiplication by the cube root of 1, 2, or 4 - * approximates the root to within about 0.1%. Then Newton's - * iteration is used three times to converge to an accurate - * result. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE .125,8 80000 7.0e-20 2.2e-20 - * IEEE exp(+-707) 100000 7.0e-20 2.4e-20 - * - */ - - -/* -Cephes Math Library Release 2.2: January, 1991 -Copyright 1984, 1991 by Stephen L. Moshier -Direct inquiries to 30 Frost Street, Cambridge, MA 02140 -*/ - - -#include <math.h> - -static long double CBRT2 = 1.2599210498948731647672L; -static long double CBRT4 = 1.5874010519681994747517L; -static long double CBRT2I = 0.79370052598409973737585L; -static long double CBRT4I = 0.62996052494743658238361L; - -#ifdef ANSIPROT -extern long double frexpl ( long double, int * ); -extern long double ldexpl ( long double, int ); -extern int isnanl ( long double ); -#else -long double frexpl(), ldexpl(); -extern int isnanl(); -#endif - -#ifdef INFINITIES -extern long double INFINITYL; -#endif - -long double cbrtl(x) -long double x; -{ -int e, rem, sign; -long double z; - - -#ifdef NANS -if(isnanl(x)) - return(x); -#endif -#ifdef INFINITIES -if( x == INFINITYL) - return(x); -if( x == -INFINITYL) - return(x); -#endif -if( x == 0 ) - return( x ); -if( x > 0 ) - sign = 1; -else - { - sign = -1; - x = -x; - } - -z = x; -/* extract power of 2, leaving - * mantissa between 0.5 and 1 - */ -x = frexpl( x, &e ); - -/* Approximate cube root of number between .5 and 1, - * peak relative error = 1.2e-6 - */ -x = (((( 1.3584464340920900529734e-1L * x - - 6.3986917220457538402318e-1L) * x - + 1.2875551670318751538055e0L) * x - - 1.4897083391357284957891e0L) * x - + 1.3304961236013647092521e0L) * x - + 3.7568280825958912391243e-1L; - -/* exponent divided by 3 */ -if( e >= 0 ) - { - rem = e; - e /= 3; - rem -= 3*e; - if( rem == 1 ) - x *= CBRT2; - else if( rem == 2 ) - x *= CBRT4; - } -else - { /* argument less than 1 */ - e = -e; - rem = e; - e /= 3; - rem -= 3*e; - if( rem == 1 ) - x *= CBRT2I; - else if( rem == 2 ) - x *= CBRT4I; - e = -e; - } - -/* multiply by power of 2 */ -x = ldexpl( x, e ); - -/* Newton iteration */ - -x -= ( x - (z/(x*x)) )*0.3333333333333333333333L; -x -= ( x - (z/(x*x)) )*0.3333333333333333333333L; - -if( sign < 0 ) - x = -x; -return(x); -} diff --git a/libm/ldouble/chdtrl.c b/libm/ldouble/chdtrl.c deleted file mode 100644 index e55361e1f..000000000 --- a/libm/ldouble/chdtrl.c +++ /dev/null @@ -1,200 +0,0 @@ -/* chdtrl.c - * - * Chi-square distribution - * - * - * - * SYNOPSIS: - * - * long double df, x, y, chdtrl(); - * - * y = chdtrl( df, x ); - * - * - * - * DESCRIPTION: - * - * Returns the area under the left hand tail (from 0 to x) - * of the Chi square probability density function with - * v degrees of freedom. - * - * - * inf. - * - - * 1 | | v/2-1 -t/2 - * P( x | v ) = ----------- | t e dt - * v/2 - | | - * 2 | (v/2) - - * x - * - * where x is the Chi-square variable. - * - * The incomplete gamma integral is used, according to the - * formula - * - * y = chdtr( v, x ) = igam( v/2.0, x/2.0 ). - * - * - * The arguments must both be positive. - * - * - * - * ACCURACY: - * - * See igam(). - * - * ERROR MESSAGES: - * - * message condition value returned - * chdtr domain x < 0 or v < 1 0.0 - */ - /* chdtrcl() - * - * Complemented Chi-square distribution - * - * - * - * SYNOPSIS: - * - * long double v, x, y, chdtrcl(); - * - * y = chdtrcl( v, x ); - * - * - * - * DESCRIPTION: - * - * Returns the area under the right hand tail (from x to - * infinity) of the Chi square probability density function - * with v degrees of freedom: - * - * - * inf. - * - - * 1 | | v/2-1 -t/2 - * P( x | v ) = ----------- | t e dt - * v/2 - | | - * 2 | (v/2) - - * x - * - * where x is the Chi-square variable. - * - * The incomplete gamma integral is used, according to the - * formula - * - * y = chdtr( v, x ) = igamc( v/2.0, x/2.0 ). - * - * - * The arguments must both be positive. - * - * - * - * ACCURACY: - * - * See igamc(). - * - * ERROR MESSAGES: - * - * message condition value returned - * chdtrc domain x < 0 or v < 1 0.0 - */ - /* chdtril() - * - * Inverse of complemented Chi-square distribution - * - * - * - * SYNOPSIS: - * - * long double df, x, y, chdtril(); - * - * x = chdtril( df, y ); - * - * - * - * - * DESCRIPTION: - * - * Finds the Chi-square argument x such that the integral - * from x to infinity of the Chi-square density is equal - * to the given cumulative probability y. - * - * This is accomplished using the inverse gamma integral - * function and the relation - * - * x/2 = igami( df/2, y ); - * - * - * - * - * ACCURACY: - * - * See igami.c. - * - * ERROR MESSAGES: - * - * message condition value returned - * chdtri domain y < 0 or y > 1 0.0 - * v < 1 - * - */ - -/* chdtr() */ - - -/* -Cephes Math Library Release 2.3: March, 1995 -Copyright 1984, 1995 by Stephen L. Moshier -*/ - -#include <math.h> -#ifdef ANSIPROT -extern long double igamcl ( long double, long double ); -extern long double igaml ( long double, long double ); -extern long double igamil ( long double, long double ); -#else -long double igamcl(), igaml(), igamil(); -#endif - -long double chdtrcl(df,x) -long double df, x; -{ - -if( (x < 0.0L) || (df < 1.0L) ) - { - mtherr( "chdtrcl", DOMAIN ); - return(0.0L); - } -return( igamcl( 0.5L*df, 0.5L*x ) ); -} - - - -long double chdtrl(df,x) -long double df, x; -{ - -if( (x < 0.0L) || (df < 1.0L) ) - { - mtherr( "chdtrl", DOMAIN ); - return(0.0L); - } -return( igaml( 0.5L*df, 0.5L*x ) ); -} - - - -long double chdtril( df, y ) -long double df, y; -{ -long double x; - -if( (y < 0.0L) || (y > 1.0L) || (df < 1.0L) ) - { - mtherr( "chdtril", DOMAIN ); - return(0.0L); - } - -x = igamil( 0.5L * df, y ); -return( 2.0L * x ); -} diff --git a/libm/ldouble/clogl.c b/libm/ldouble/clogl.c deleted file mode 100644 index b3e6b25fb..000000000 --- a/libm/ldouble/clogl.c +++ /dev/null @@ -1,720 +0,0 @@ -/* clogl.c - * - * Complex natural logarithm - * - * - * - * SYNOPSIS: - * - * void clogl(); - * cmplxl z, w; - * - * clogl( &z, &w ); - * - * - * - * DESCRIPTION: - * - * Returns complex logarithm to the base e (2.718...) of - * the complex argument x. - * - * If z = x + iy, r = sqrt( x**2 + y**2 ), - * then - * w = log(r) + i arctan(y/x). - * - * The arctangent ranges from -PI to +PI. - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -10,+10 7000 8.5e-17 1.9e-17 - * IEEE -10,+10 30000 5.0e-15 1.1e-16 - * - * Larger relative error can be observed for z near 1 +i0. - * In IEEE arithmetic the peak absolute error is 5.2e-16, rms - * absolute error 1.0e-16. - */ - -#include <math.h> -#ifdef ANSIPROT -static void cchshl ( long double x, long double *c, long double *s ); -static long double redupil ( long double x ); -static long double ctansl ( cmplxl *z ); -long double cabsl ( cmplxl *x ); -void csqrtl ( cmplxl *x, cmplxl *y ); -void caddl ( cmplxl *x, cmplxl *y, cmplxl *z ); -extern long double fabsl ( long double ); -extern long double sqrtl ( long double ); -extern long double logl ( long double ); -extern long double expl ( long double ); -extern long double atan2l ( long double, long double ); -extern long double coshl ( long double ); -extern long double sinhl ( long double ); -extern long double asinl ( long double ); -extern long double sinl ( long double ); -extern long double cosl ( long double ); -void clogl ( cmplxl *, cmplxl *); -void casinl ( cmplxl *, cmplxl *); -#else -static void cchshl(); -static long double redupil(); -static long double ctansl(); -long double cabsl(), fabsl(), sqrtl(); -lnog double logl(), expl(), atan2l(), coshl(), sinhl(); -long double asinl(), sinl(), cosl(); -void caddl(), csqrtl(), clogl(), casinl(); -#endif - -extern long double MAXNUML, MACHEPL, PIL, PIO2L; - -void clogl( z, w ) -register cmplxl *z, *w; -{ -long double p, rr; - -/*rr = sqrt( z->r * z->r + z->i * z->i );*/ -rr = cabsl(z); -p = logl(rr); -#if ANSIC -rr = atan2l( z->i, z->r ); -#else -rr = atan2l( z->r, z->i ); -if( rr > PIL ) - rr -= PIL + PIL; -#endif -w->i = rr; -w->r = p; -} - /* cexpl() - * - * Complex exponential function - * - * - * - * SYNOPSIS: - * - * void cexpl(); - * cmplxl z, w; - * - * cexpl( &z, &w ); - * - * - * - * DESCRIPTION: - * - * Returns the exponential of the complex argument z - * into the complex result w. - * - * If - * z = x + iy, - * r = exp(x), - * - * then - * - * w = r cos y + i r sin y. - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -10,+10 8700 3.7e-17 1.1e-17 - * IEEE -10,+10 30000 3.0e-16 8.7e-17 - * - */ - -void cexpl( z, w ) -register cmplxl *z, *w; -{ -long double r; - -r = expl( z->r ); -w->r = r * cosl( z->i ); -w->i = r * sinl( z->i ); -} - /* csinl() - * - * Complex circular sine - * - * - * - * SYNOPSIS: - * - * void csinl(); - * cmplxl z, w; - * - * csinl( &z, &w ); - * - * - * - * DESCRIPTION: - * - * If - * z = x + iy, - * - * then - * - * w = sin x cosh y + i cos x sinh y. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -10,+10 8400 5.3e-17 1.3e-17 - * IEEE -10,+10 30000 3.8e-16 1.0e-16 - * Also tested by csin(casin(z)) = z. - * - */ - -void csinl( z, w ) -register cmplxl *z, *w; -{ -long double ch, sh; - -cchshl( z->i, &ch, &sh ); -w->r = sinl( z->r ) * ch; -w->i = cosl( z->r ) * sh; -} - - - -/* calculate cosh and sinh */ - -static void cchshl( x, c, s ) -long double x, *c, *s; -{ -long double e, ei; - -if( fabsl(x) <= 0.5L ) - { - *c = coshl(x); - *s = sinhl(x); - } -else - { - e = expl(x); - ei = 0.5L/e; - e = 0.5L * e; - *s = e - ei; - *c = e + ei; - } -} - - /* ccosl() - * - * Complex circular cosine - * - * - * - * SYNOPSIS: - * - * void ccosl(); - * cmplxl z, w; - * - * ccosl( &z, &w ); - * - * - * - * DESCRIPTION: - * - * If - * z = x + iy, - * - * then - * - * w = cos x cosh y - i sin x sinh y. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -10,+10 8400 4.5e-17 1.3e-17 - * IEEE -10,+10 30000 3.8e-16 1.0e-16 - */ - -void ccosl( z, w ) -register cmplxl *z, *w; -{ -long double ch, sh; - -cchshl( z->i, &ch, &sh ); -w->r = cosl( z->r ) * ch; -w->i = -sinl( z->r ) * sh; -} - /* ctanl() - * - * Complex circular tangent - * - * - * - * SYNOPSIS: - * - * void ctanl(); - * cmplxl z, w; - * - * ctanl( &z, &w ); - * - * - * - * DESCRIPTION: - * - * If - * z = x + iy, - * - * then - * - * sin 2x + i sinh 2y - * w = --------------------. - * cos 2x + cosh 2y - * - * On the real axis the denominator is zero at odd multiples - * of PI/2. The denominator is evaluated by its Taylor - * series near these points. - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -10,+10 5200 7.1e-17 1.6e-17 - * IEEE -10,+10 30000 7.2e-16 1.2e-16 - * Also tested by ctan * ccot = 1 and catan(ctan(z)) = z. - */ - -void ctanl( z, w ) -register cmplxl *z, *w; -{ -long double d; - -d = cosl( 2.0L * z->r ) + coshl( 2.0L * z->i ); - -if( fabsl(d) < 0.25L ) - d = ctansl(z); - -if( d == 0.0L ) - { - mtherr( "ctan", OVERFLOW ); - w->r = MAXNUML; - w->i = MAXNUML; - return; - } - -w->r = sinl( 2.0L * z->r ) / d; -w->i = sinhl( 2.0L * z->i ) / d; -} - /* ccotl() - * - * Complex circular cotangent - * - * - * - * SYNOPSIS: - * - * void ccotl(); - * cmplxl z, w; - * - * ccotl( &z, &w ); - * - * - * - * DESCRIPTION: - * - * If - * z = x + iy, - * - * then - * - * sin 2x - i sinh 2y - * w = --------------------. - * cosh 2y - cos 2x - * - * On the real axis, the denominator has zeros at even - * multiples of PI/2. Near these points it is evaluated - * by a Taylor series. - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -10,+10 3000 6.5e-17 1.6e-17 - * IEEE -10,+10 30000 9.2e-16 1.2e-16 - * Also tested by ctan * ccot = 1 + i0. - */ - -void ccotl( z, w ) -register cmplxl *z, *w; -{ -long double d; - -d = coshl(2.0L * z->i) - cosl(2.0L * z->r); - -if( fabsl(d) < 0.25L ) - d = ctansl(z); - -if( d == 0.0L ) - { - mtherr( "ccot", OVERFLOW ); - w->r = MAXNUML; - w->i = MAXNUML; - return; - } - -w->r = sinl( 2.0L * z->r ) / d; -w->i = -sinhl( 2.0L * z->i ) / d; -} - -/* Program to subtract nearest integer multiple of PI */ -/* extended precision value of PI: */ -#ifdef UNK -static double DP1 = 3.14159265160560607910E0; -static double DP2 = 1.98418714791870343106E-9; -static double DP3 = 1.14423774522196636802E-17; -#endif - -#ifdef DEC -static unsigned short P1[] = {0040511,0007732,0120000,0000000,}; -static unsigned short P2[] = {0031010,0055060,0100000,0000000,}; -static unsigned short P3[] = {0022123,0011431,0105056,0001560,}; -#define DP1 *(double *)P1 -#define DP2 *(double *)P2 -#define DP3 *(double *)P3 -#endif - -#ifdef IBMPC -static unsigned short P1[] = {0x0000,0x5400,0x21fb,0x4009}; -static unsigned short P2[] = {0x0000,0x1000,0x0b46,0x3e21}; -static unsigned short P3[] = {0xc06e,0x3145,0x6263,0x3c6a}; -#define DP1 *(double *)P1 -#define DP2 *(double *)P2 -#define DP3 *(double *)P3 -#endif - -#ifdef MIEEE -static unsigned short P1[] = { -0x4009,0x21fb,0x5400,0x0000 -}; -static unsigned short P2[] = { -0x3e21,0x0b46,0x1000,0x0000 -}; -static unsigned short P3[] = { -0x3c6a,0x6263,0x3145,0xc06e -}; -#define DP1 *(double *)P1 -#define DP2 *(double *)P2 -#define DP3 *(double *)P3 -#endif - -static long double redupil(x) -long double x; -{ -long double t; -long i; - -t = x/PIL; -if( t >= 0.0L ) - t += 0.5L; -else - t -= 0.5L; - -i = t; /* the multiple */ -t = i; -t = ((x - t * DP1) - t * DP2) - t * DP3; -return(t); -} - -/* Taylor series expansion for cosh(2y) - cos(2x) */ - -static long double ctansl(z) -cmplxl *z; -{ -long double f, x, x2, y, y2, rn, t; -long double d; - -x = fabsl( 2.0L * z->r ); -y = fabsl( 2.0L * z->i ); - -x = redupil(x); - -x = x * x; -y = y * y; -x2 = 1.0L; -y2 = 1.0L; -f = 1.0L; -rn = 0.0; -d = 0.0; -do - { - rn += 1.0L; - f *= rn; - rn += 1.0L; - f *= rn; - x2 *= x; - y2 *= y; - t = y2 + x2; - t /= f; - d += t; - - rn += 1.0L; - f *= rn; - rn += 1.0L; - f *= rn; - x2 *= x; - y2 *= y; - t = y2 - x2; - t /= f; - d += t; - } -while( fabsl(t/d) > MACHEPL ); -return(d); -} - /* casinl() - * - * Complex circular arc sine - * - * - * - * SYNOPSIS: - * - * void casinl(); - * cmplxl z, w; - * - * casinl( &z, &w ); - * - * - * - * DESCRIPTION: - * - * Inverse complex sine: - * - * 2 - * w = -i clog( iz + csqrt( 1 - z ) ). - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -10,+10 10100 2.1e-15 3.4e-16 - * IEEE -10,+10 30000 2.2e-14 2.7e-15 - * Larger relative error can be observed for z near zero. - * Also tested by csin(casin(z)) = z. - */ - -void casinl( z, w ) -cmplxl *z, *w; -{ -static cmplxl ca, ct, zz, z2; -long double x, y; - -x = z->r; -y = z->i; - -if( y == 0.0L ) - { - if( fabsl(x) > 1.0L ) - { - w->r = PIO2L; - w->i = 0.0L; - mtherr( "casinl", DOMAIN ); - } - else - { - w->r = asinl(x); - w->i = 0.0L; - } - return; - } - -/* Power series expansion */ -/* -b = cabsl(z); -if( b < 0.125L ) -{ -z2.r = (x - y) * (x + y); -z2.i = 2.0L * x * y; - -cn = 1.0L; -n = 1.0L; -ca.r = x; -ca.i = y; -sum.r = x; -sum.i = y; -do - { - ct.r = z2.r * ca.r - z2.i * ca.i; - ct.i = z2.r * ca.i + z2.i * ca.r; - ca.r = ct.r; - ca.i = ct.i; - - cn *= n; - n += 1.0L; - cn /= n; - n += 1.0L; - b = cn/n; - - ct.r *= b; - ct.i *= b; - sum.r += ct.r; - sum.i += ct.i; - b = fabsl(ct.r) + fabs(ct.i); - } -while( b > MACHEPL ); -w->r = sum.r; -w->i = sum.i; -return; -} -*/ - - -ca.r = x; -ca.i = y; - -ct.r = -ca.i; /* iz */ -ct.i = ca.r; - - /* sqrt( 1 - z*z) */ -/* cmul( &ca, &ca, &zz ) */ -zz.r = (ca.r - ca.i) * (ca.r + ca.i); /*x * x - y * y */ -zz.i = 2.0L * ca.r * ca.i; - -zz.r = 1.0L - zz.r; -zz.i = -zz.i; -csqrtl( &zz, &z2 ); - -caddl( &z2, &ct, &zz ); -clogl( &zz, &zz ); -w->r = zz.i; /* mult by 1/i = -i */ -w->i = -zz.r; -return; -} - /* cacosl() - * - * Complex circular arc cosine - * - * - * - * SYNOPSIS: - * - * void cacosl(); - * cmplxl z, w; - * - * cacosl( &z, &w ); - * - * - * - * DESCRIPTION: - * - * - * w = arccos z = PI/2 - arcsin z. - * - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -10,+10 5200 1.6e-15 2.8e-16 - * IEEE -10,+10 30000 1.8e-14 2.2e-15 - */ - -void cacosl( z, w ) -cmplxl *z, *w; -{ - -casinl( z, w ); -w->r = PIO2L - w->r; -w->i = -w->i; -} - /* catanl() - * - * Complex circular arc tangent - * - * - * - * SYNOPSIS: - * - * void catanl(); - * cmplxl z, w; - * - * catanl( &z, &w ); - * - * - * - * DESCRIPTION: - * - * If - * z = x + iy, - * - * then - * 1 ( 2x ) - * Re w = - arctan(-----------) + k PI - * 2 ( 2 2) - * (1 - x - y ) - * - * ( 2 2) - * 1 (x + (y+1) ) - * Im w = - log(------------) - * 4 ( 2 2) - * (x + (y-1) ) - * - * Where k is an arbitrary integer. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -10,+10 5900 1.3e-16 7.8e-18 - * IEEE -10,+10 30000 2.3e-15 8.5e-17 - * The check catan( ctan(z) ) = z, with |x| and |y| < PI/2, - * had peak relative error 1.5e-16, rms relative error - * 2.9e-17. See also clog(). - */ - -void catanl( z, w ) -cmplxl *z, *w; -{ -long double a, t, x, x2, y; - -x = z->r; -y = z->i; - -if( (x == 0.0L) && (y > 1.0L) ) - goto ovrf; - -x2 = x * x; -a = 1.0L - x2 - (y * y); -if( a == 0.0L ) - goto ovrf; - -#if ANSIC -t = atan2l( 2.0L * x, a ) * 0.5L; -#else -t = atan2l( a, 2.0 * x ) * 0.5L; -#endif -w->r = redupil( t ); - -t = y - 1.0L; -a = x2 + (t * t); -if( a == 0.0L ) - goto ovrf; - -t = y + 1.0L; -a = (x2 + (t * t))/a; -w->i = logl(a)/4.0; -return; - -ovrf: -mtherr( "catanl", OVERFLOW ); -w->r = MAXNUML; -w->i = MAXNUML; -} diff --git a/libm/ldouble/cmplxl.c b/libm/ldouble/cmplxl.c deleted file mode 100644 index ef130618d..000000000 --- a/libm/ldouble/cmplxl.c +++ /dev/null @@ -1,461 +0,0 @@ -/* cmplxl.c - * - * Complex number arithmetic - * - * - * - * SYNOPSIS: - * - * typedef struct { - * long double r; real part - * long double i; imaginary part - * }cmplxl; - * - * cmplxl *a, *b, *c; - * - * caddl( a, b, c ); c = b + a - * csubl( a, b, c ); c = b - a - * cmull( a, b, c ); c = b * a - * cdivl( a, b, c ); c = b / a - * cnegl( c ); c = -c - * cmovl( b, c ); c = b - * - * - * - * DESCRIPTION: - * - * Addition: - * c.r = b.r + a.r - * c.i = b.i + a.i - * - * Subtraction: - * c.r = b.r - a.r - * c.i = b.i - a.i - * - * Multiplication: - * c.r = b.r * a.r - b.i * a.i - * c.i = b.r * a.i + b.i * a.r - * - * Division: - * d = a.r * a.r + a.i * a.i - * c.r = (b.r * a.r + b.i * a.i)/d - * c.i = (b.i * a.r - b.r * a.i)/d - * ACCURACY: - * - * In DEC arithmetic, the test (1/z) * z = 1 had peak relative - * error 3.1e-17, rms 1.2e-17. The test (y/z) * (z/y) = 1 had - * peak relative error 8.3e-17, rms 2.1e-17. - * - * Tests in the rectangle {-10,+10}: - * Relative error: - * arithmetic function # trials peak rms - * DEC cadd 10000 1.4e-17 3.4e-18 - * IEEE cadd 100000 1.1e-16 2.7e-17 - * DEC csub 10000 1.4e-17 4.5e-18 - * IEEE csub 100000 1.1e-16 3.4e-17 - * DEC cmul 3000 2.3e-17 8.7e-18 - * IEEE cmul 100000 2.1e-16 6.9e-17 - * DEC cdiv 18000 4.9e-17 1.3e-17 - * IEEE cdiv 100000 3.7e-16 1.1e-16 - */ - /* cmplx.c - * complex number arithmetic - */ - - -/* -Cephes Math Library Release 2.3: March, 1995 -Copyright 1984, 1995 by Stephen L. Moshier -*/ - - -#include <math.h> - -/* -typedef struct - { - long double r; - long double i; - }cmplxl; -*/ - -#ifdef ANSIPROT -extern long double fabsl ( long double ); -extern long double cabsl ( cmplxl * ); -extern long double sqrtl ( long double ); -extern long double atan2l ( long double, long double ); -extern long double cosl ( long double ); -extern long double sinl ( long double ); -extern long double frexpl ( long double, int * ); -extern long double ldexpl ( long double, int ); -extern int isnanl ( long double ); -void cdivl ( cmplxl *, cmplxl *, cmplxl * ); -void caddl ( cmplxl *, cmplxl *, cmplxl * ); -#else -long double fabsl(), cabsl(), sqrtl(), atan2l(), cosl(), sinl(); -long double frexpl(), ldexpl(); -int isnanl(); -void cdivl(), caddl(); -#endif - - -extern double MAXNUML, MACHEPL, PIL, PIO2L, INFINITYL, NANL; -cmplx czerol = {0.0L, 0.0L}; -cmplx conel = {1.0L, 0.0L}; - - -/* c = b + a */ - -void caddl( a, b, c ) -register cmplxl *a, *b; -cmplxl *c; -{ - -c->r = b->r + a->r; -c->i = b->i + a->i; -} - - -/* c = b - a */ - -void csubl( a, b, c ) -register cmplxl *a, *b; -cmplxl *c; -{ - -c->r = b->r - a->r; -c->i = b->i - a->i; -} - -/* c = b * a */ - -void cmull( a, b, c ) -register cmplxl *a, *b; -cmplxl *c; -{ -long double y; - -y = b->r * a->r - b->i * a->i; -c->i = b->r * a->i + b->i * a->r; -c->r = y; -} - - - -/* c = b / a */ - -void cdivl( a, b, c ) -register cmplxl *a, *b; -cmplxl *c; -{ -long double y, p, q, w; - - -y = a->r * a->r + a->i * a->i; -p = b->r * a->r + b->i * a->i; -q = b->i * a->r - b->r * a->i; - -if( y < 1.0L ) - { - w = MAXNUML * y; - if( (fabsl(p) > w) || (fabsl(q) > w) || (y == 0.0L) ) - { - c->r = INFINITYL; - c->i = INFINITYL; - mtherr( "cdivl", OVERFLOW ); - return; - } - } -c->r = p/y; -c->i = q/y; -} - - -/* b = a - Caution, a `short' is assumed to be 16 bits wide. */ - -void cmovl( a, b ) -void *a, *b; -{ -register short *pa, *pb; -int i; - -pa = (short *) a; -pb = (short *) b; -i = 16; -do - *pb++ = *pa++; -while( --i ); -} - - -void cnegl( a ) -register cmplxl *a; -{ - -a->r = -a->r; -a->i = -a->i; -} - -/* cabsl() - * - * Complex absolute value - * - * - * - * SYNOPSIS: - * - * long double cabsl(); - * cmplxl z; - * long double a; - * - * a = cabs( &z ); - * - * - * - * DESCRIPTION: - * - * - * If z = x + iy - * - * then - * - * a = sqrt( x**2 + y**2 ). - * - * Overflow and underflow are avoided by testing the magnitudes - * of x and y before squaring. If either is outside half of - * the floating point full scale range, both are rescaled. - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -30,+30 30000 3.2e-17 9.2e-18 - * IEEE -10,+10 100000 2.7e-16 6.9e-17 - */ - - -/* -Cephes Math Library Release 2.1: January, 1989 -Copyright 1984, 1987, 1989 by Stephen L. Moshier -Direct inquiries to 30 Frost Street, Cambridge, MA 02140 -*/ - - -/* -typedef struct - { - long double r; - long double i; - }cmplxl; -*/ - -#ifdef UNK -#define PRECL 32 -#define MAXEXPL 16384 -#define MINEXPL -16384 -#endif -#ifdef IBMPC -#define PRECL 32 -#define MAXEXPL 16384 -#define MINEXPL -16384 -#endif -#ifdef MIEEE -#define PRECL 32 -#define MAXEXPL 16384 -#define MINEXPL -16384 -#endif - - -long double cabsl( z ) -register cmplxl *z; -{ -long double x, y, b, re, im; -int ex, ey, e; - -#ifdef INFINITIES -/* Note, cabs(INFINITY,NAN) = INFINITY. */ -if( z->r == INFINITYL || z->i == INFINITYL - || z->r == -INFINITYL || z->i == -INFINITYL ) - return( INFINITYL ); -#endif - -#ifdef NANS -if( isnanl(z->r) ) - return(z->r); -if( isnanl(z->i) ) - return(z->i); -#endif - -re = fabsl( z->r ); -im = fabsl( z->i ); - -if( re == 0.0 ) - return( im ); -if( im == 0.0 ) - return( re ); - -/* Get the exponents of the numbers */ -x = frexpl( re, &ex ); -y = frexpl( im, &ey ); - -/* Check if one number is tiny compared to the other */ -e = ex - ey; -if( e > PRECL ) - return( re ); -if( e < -PRECL ) - return( im ); - -/* Find approximate exponent e of the geometric mean. */ -e = (ex + ey) >> 1; - -/* Rescale so mean is about 1 */ -x = ldexpl( re, -e ); -y = ldexpl( im, -e ); - -/* Hypotenuse of the right triangle */ -b = sqrtl( x * x + y * y ); - -/* Compute the exponent of the answer. */ -y = frexpl( b, &ey ); -ey = e + ey; - -/* Check it for overflow and underflow. */ -if( ey > MAXEXPL ) - { - mtherr( "cabsl", OVERFLOW ); - return( INFINITYL ); - } -if( ey < MINEXPL ) - return(0.0L); - -/* Undo the scaling */ -b = ldexpl( b, e ); -return( b ); -} - /* csqrtl() - * - * Complex square root - * - * - * - * SYNOPSIS: - * - * void csqrtl(); - * cmplxl z, w; - * - * csqrtl( &z, &w ); - * - * - * - * DESCRIPTION: - * - * - * If z = x + iy, r = |z|, then - * - * 1/2 - * Im w = [ (r - x)/2 ] , - * - * Re w = y / 2 Im w. - * - * - * Note that -w is also a square root of z. The root chosen - * is always in the upper half plane. - * - * Because of the potential for cancellation error in r - x, - * the result is sharpened by doing a Heron iteration - * (see sqrt.c) in complex arithmetic. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC -10,+10 25000 3.2e-17 9.6e-18 - * IEEE -10,+10 100000 3.2e-16 7.7e-17 - * - * 2 - * Also tested by csqrt( z ) = z, and tested by arguments - * close to the real axis. - */ - - -void csqrtl( z, w ) -cmplxl *z, *w; -{ -cmplxl q, s; -long double x, y, r, t; - -x = z->r; -y = z->i; - -if( y == 0.0L ) - { - if( x < 0.0L ) - { - w->r = 0.0L; - w->i = sqrtl(-x); - return; - } - else - { - w->r = sqrtl(x); - w->i = 0.0L; - return; - } - } - - -if( x == 0.0L ) - { - r = fabsl(y); - r = sqrtl(0.5L*r); - if( y > 0.0L ) - w->r = r; - else - w->r = -r; - w->i = r; - return; - } - -/* Approximate sqrt(x^2+y^2) - x = y^2/2x - y^4/24x^3 + ... . - * The relative error in the first term is approximately y^2/12x^2 . - */ -if( (fabsl(y) < 2.e-4L * fabsl(x)) - && (x > 0) ) - { - t = 0.25L*y*(y/x); - } -else - { - r = cabsl(z); - t = 0.5L*(r - x); - } - -r = sqrtl(t); -q.i = r; -q.r = y/(2.0L*r); -/* Heron iteration in complex arithmetic */ -cdivl( &q, z, &s ); -caddl( &q, &s, w ); -w->r *= 0.5L; -w->i *= 0.5L; - -cdivl( &q, z, &s ); -caddl( &q, &s, w ); -w->r *= 0.5L; -w->i *= 0.5L; -} - - -long double hypotl( x, y ) -long double x, y; -{ -cmplxl z; - -z.r = x; -z.i = y; -return( cabsl(&z) ); -} diff --git a/libm/ldouble/coshl.c b/libm/ldouble/coshl.c deleted file mode 100644 index 46212ae44..000000000 --- a/libm/ldouble/coshl.c +++ /dev/null @@ -1,89 +0,0 @@ -/* coshl.c - * - * Hyperbolic cosine, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, coshl(); - * - * y = coshl( x ); - * - * - * - * DESCRIPTION: - * - * Returns hyperbolic cosine of argument in the range MINLOGL to - * MAXLOGL. - * - * cosh(x) = ( exp(x) + exp(-x) )/2. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE +-10000 30000 1.1e-19 2.8e-20 - * - * - * ERROR MESSAGES: - * - * message condition value returned - * cosh overflow |x| > MAXLOGL+LOGE2L INFINITYL - * - * - */ - - -/* -Cephes Math Library Release 2.7: May, 1998 -Copyright 1985, 1991, 1998 by Stephen L. Moshier -*/ - -#include <math.h> -extern long double MAXLOGL, MAXNUML, LOGE2L; -#ifdef ANSIPROT -extern long double expl ( long double ); -extern int isnanl ( long double ); -#else -long double expl(), isnanl(); -#endif -#ifdef INFINITIES -extern long double INFINITYL; -#endif -#ifdef NANS -extern long double NANL; -#endif - -long double coshl(x) -long double x; -{ -long double y; - -#ifdef NANS -if( isnanl(x) ) - return(x); -#endif -if( x < 0 ) - x = -x; -if( x > (MAXLOGL + LOGE2L) ) - { - mtherr( "coshl", OVERFLOW ); -#ifdef INFINITIES - return( INFINITYL ); -#else - return( MAXNUML ); -#endif - } -if( x >= (MAXLOGL - LOGE2L) ) - { - y = expl(0.5L * x); - y = (0.5L * y) * y; - return(y); - } -y = expl(x); -y = 0.5L * (y + 1.0L / y); -return( y ); -} diff --git a/libm/ldouble/econst.c b/libm/ldouble/econst.c deleted file mode 100644 index cfddbe3e2..000000000 --- a/libm/ldouble/econst.c +++ /dev/null @@ -1,96 +0,0 @@ -/* econst.c */ -/* e type constants used by high precision check routines */ - -#include "ehead.h" - - -#if NE == 10 -/* 0.0 */ -unsigned short ezero[NE] = - {0x0000, 0x0000, 0x0000, 0x0000, - 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,}; - -/* 5.0E-1 */ -unsigned short ehalf[NE] = - {0x0000, 0x0000, 0x0000, 0x0000, - 0x0000, 0x0000, 0x0000, 0x0000, 0x8000, 0x3ffe,}; - -/* 1.0E0 */ -unsigned short eone[NE] = - {0x0000, 0x0000, 0x0000, 0x0000, - 0x0000, 0x0000, 0x0000, 0x0000, 0x8000, 0x3fff,}; - -/* 2.0E0 */ -unsigned short etwo[NE] = - {0x0000, 0x0000, 0x0000, 0x0000, - 0x0000, 0x0000, 0x0000, 0x0000, 0x8000, 0x4000,}; - -/* 3.2E1 */ -unsigned short e32[NE] = - {0x0000, 0x0000, 0x0000, 0x0000, - 0x0000, 0x0000, 0x0000, 0x0000, 0x8000, 0x4004,}; - -/* 6.93147180559945309417232121458176568075500134360255E-1 */ -unsigned short elog2[NE] = - {0x40f3, 0xf6af, 0x03f2, 0xb398, - 0xc9e3, 0x79ab, 0150717, 0013767, 0130562, 0x3ffe,}; - -/* 1.41421356237309504880168872420969807856967187537695E0 */ -unsigned short esqrt2[NE] = - {0x1d6f, 0xbe9f, 0x754a, 0x89b3, - 0x597d, 0x6484, 0174736, 0171463, 0132404, 0x3fff,}; - -/* 3.14159265358979323846264338327950288419716939937511E0 */ -unsigned short epi[NE] = - {0x2902, 0x1cd1, 0x80dc, 0x628b, - 0xc4c6, 0xc234, 0020550, 0155242, 0144417, 0040000,}; - -/* 5.7721566490153286060651209008240243104215933593992E-1 */ -unsigned short eeul[NE] = { -0xd1be,0xc7a4,0076660,0063743,0111704,0x3ffe,}; - -#else - -/* 0.0 */ -unsigned short ezero[NE] = { -0, 0000000,0000000,0000000,0000000,0000000,}; -/* 5.0E-1 */ -unsigned short ehalf[NE] = { -0, 0000000,0000000,0000000,0100000,0x3ffe,}; -/* 1.0E0 */ -unsigned short eone[NE] = { -0, 0000000,0000000,0000000,0100000,0x3fff,}; -/* 2.0E0 */ -unsigned short etwo[NE] = { -0, 0000000,0000000,0000000,0100000,0040000,}; -/* 3.2E1 */ -unsigned short e32[NE] = { -0, 0000000,0000000,0000000,0100000,0040004,}; -/* 6.93147180559945309417232121458176568075500134360255E-1 */ -unsigned short elog2[NE] = { -0xc9e4,0x79ab,0150717,0013767,0130562,0x3ffe,}; -/* 1.41421356237309504880168872420969807856967187537695E0 */ -unsigned short esqrt2[NE] = { -0x597e,0x6484,0174736,0171463,0132404,0x3fff,}; -/* 2/sqrt(PI) = - * 1.12837916709551257389615890312154517168810125865800E0 */ -unsigned short eoneopi[NE] = { -0x71d5,0x688d,0012333,0135202,0110156,0x3fff,}; -/* 3.14159265358979323846264338327950288419716939937511E0 */ -unsigned short epi[NE] = { -0xc4c6,0xc234,0020550,0155242,0144417,0040000,}; -/* 5.7721566490153286060651209008240243104215933593992E-1 */ -unsigned short eeul[NE] = { -0xd1be,0xc7a4,0076660,0063743,0111704,0x3ffe,}; -#endif -extern unsigned short ezero[]; -extern unsigned short ehalf[]; -extern unsigned short eone[]; -extern unsigned short etwo[]; -extern unsigned short e32[]; -extern unsigned short elog2[]; -extern unsigned short esqrt2[]; -extern unsigned short eoneopi[]; -extern unsigned short epi[]; -extern unsigned short eeul[]; - diff --git a/libm/ldouble/ehead.h b/libm/ldouble/ehead.h deleted file mode 100644 index 785396dce..000000000 --- a/libm/ldouble/ehead.h +++ /dev/null @@ -1,45 +0,0 @@ - -/* Include file for extended precision arithmetic programs. - */ - -/* Number of 16 bit words in external x type format */ -#define NE 6 -/* #define NE 10 */ - -/* Number of 16 bit words in internal format */ -#define NI (NE+3) - -/* Array offset to exponent */ -#define E 1 - -/* Array offset to high guard word */ -#define M 2 - -/* Number of bits of precision */ -#define NBITS ((NI-4)*16) - -/* Maximum number of decimal digits in ASCII conversion - * = NBITS*log10(2) - */ -#define NDEC (NBITS*8/27) - -/* The exponent of 1.0 */ -#define EXONE (0x3fff) - - -void eadd(), esub(), emul(), ediv(); -int ecmp(), enormlz(), eshift(); -void eshup1(), eshup8(), eshup6(), eshdn1(), eshdn8(), eshdn6(); -void eabs(), eneg(), emov(), eclear(), einfin(), efloor(); -void eldexp(), efrexp(), eifrac(), ltoe(); -void esqrt(), elog(), eexp(), etanh(), epow(); -void asctoe(), asctoe24(), asctoe53(), asctoe64(); -void etoasc(), e24toasc(), e53toasc(), e64toasc(); -void etoe64(), etoe53(), etoe24(), e64toe(), e53toe(), e24toe(); -int mtherr(); - -extern unsigned short ezero[], ehalf[], eone[], etwo[]; -extern unsigned short elog2[], esqrt2[]; - - -/* by Stephen L. Moshier. */ diff --git a/libm/ldouble/elliel.c b/libm/ldouble/elliel.c deleted file mode 100644 index 851914454..000000000 --- a/libm/ldouble/elliel.c +++ /dev/null @@ -1,146 +0,0 @@ -/* elliel.c - * - * Incomplete elliptic integral of the second kind - * - * - * - * SYNOPSIS: - * - * long double phi, m, y, elliel(); - * - * y = elliel( phi, m ); - * - * - * - * DESCRIPTION: - * - * Approximates the integral - * - * - * phi - * - - * | | - * | 2 - * E(phi_\m) = | sqrt( 1 - m sin t ) dt - * | - * | | - * - - * 0 - * - * of amplitude phi and modulus m, using the arithmetic - - * geometric mean algorithm. - * - * - * - * ACCURACY: - * - * Tested at random arguments with phi in [-10, 10] and m in - * [0, 1]. - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -10,10 50000 2.7e-18 2.3e-19 - * - * - */ - - -/* -Cephes Math Library Release 2.3: November, 1995 -Copyright 1984, 1987, 1993, 1995 by Stephen L. Moshier -*/ - -/* Incomplete elliptic integral of second kind */ - -#include <math.h> -#ifdef ANSIPROT -extern long double sqrtl ( long double ); -extern long double fabsl ( long double ); -extern long double logl ( long double ); -extern long double sinl ( long double ); -extern long double tanl ( long double ); -extern long double atanl ( long double ); -extern long double floorl ( long double ); -extern long double ellpel ( long double ); -extern long double ellpkl ( long double ); -long double elliel ( long double, long double ); -#else -long double sqrtl(), fabsl(), logl(), sinl(), tanl(), atanl(), floorl(); -long double ellpel(), ellpkl(), elliel(); -#endif -extern long double PIL, PIO2L, MACHEPL; - - -long double elliel( phi, m ) -long double phi, m; -{ -long double a, b, c, e, temp, lphi, t, E; -int d, mod, npio2, sign; - -if( m == 0.0L ) - return( phi ); -lphi = phi; -npio2 = floorl( lphi/PIO2L ); -if( npio2 & 1 ) - npio2 += 1; -lphi = lphi - npio2 * PIO2L; -if( lphi < 0.0L ) - { - lphi = -lphi; - sign = -1; - } -else - { - sign = 1; - } -a = 1.0L - m; -E = ellpel( a ); -if( a == 0.0L ) - { - temp = sinl( lphi ); - goto done; - } -t = tanl( lphi ); -b = sqrtl(a); -if( fabsl(t) > 10.0L ) - { - /* Transform the amplitude */ - e = 1.0L/(b*t); - /* ... but avoid multiple recursions. */ - if( fabsl(e) < 10.0L ) - { - e = atanl(e); - temp = E + m * sinl( lphi ) * sinl( e ) - elliel( e, m ); - goto done; - } - } -c = sqrtl(m); -a = 1.0L; -d = 1; -e = 0.0L; -mod = 0; - -while( fabsl(c/a) > MACHEPL ) - { - temp = b/a; - lphi = lphi + atanl(t*temp) + mod * PIL; - mod = (lphi + PIO2L)/PIL; - t = t * ( 1.0L + temp )/( 1.0L - temp * t * t ); - c = 0.5L*( a - b ); - temp = sqrtl( a * b ); - a = 0.5L*( a + b ); - b = temp; - d += d; - e += c * sinl(lphi); - } - -temp = E / ellpkl( 1.0L - m ); -temp *= (atanl(t) + mod * PIL)/(d * a); -temp += e; - -done: - -if( sign < 0 ) - temp = -temp; -temp += npio2 * E; -return( temp ); -} diff --git a/libm/ldouble/ellikl.c b/libm/ldouble/ellikl.c deleted file mode 100644 index 4eeffe0f5..000000000 --- a/libm/ldouble/ellikl.c +++ /dev/null @@ -1,148 +0,0 @@ -/* ellikl.c - * - * Incomplete elliptic integral of the first kind - * - * - * - * SYNOPSIS: - * - * long double phi, m, y, ellikl(); - * - * y = ellikl( phi, m ); - * - * - * - * DESCRIPTION: - * - * Approximates the integral - * - * - * - * phi - * - - * | | - * | dt - * F(phi_\m) = | ------------------ - * | 2 - * | | sqrt( 1 - m sin t ) - * - - * 0 - * - * of amplitude phi and modulus m, using the arithmetic - - * geometric mean algorithm. - * - * - * - * - * ACCURACY: - * - * Tested at random points with m in [0, 1] and phi as indicated. - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -10,10 30000 3.6e-18 4.1e-19 - * - * - */ - - -/* -Cephes Math Library Release 2.3: November, 1995 -Copyright 1984, 1987, 1995 by Stephen L. Moshier -*/ - -/* Incomplete elliptic integral of first kind */ - -#include <math.h> -#ifdef ANSIPROT -extern long double sqrtl ( long double ); -extern long double fabsl ( long double ); -extern long double logl ( long double ); -extern long double tanl ( long double ); -extern long double atanl ( long double ); -extern long double floorl ( long double ); -extern long double ellpkl ( long double ); -long double ellikl ( long double, long double ); -#else -long double sqrtl(), fabsl(), logl(), tanl(), atanl(), floorl(), ellpkl(); -long double ellikl(); -#endif -extern long double PIL, PIO2L, MACHEPL, MAXNUML; - -long double ellikl( phi, m ) -long double phi, m; -{ -long double a, b, c, e, temp, t, K; -int d, mod, sign, npio2; - -if( m == 0.0L ) - return( phi ); -a = 1.0L - m; -if( a == 0.0L ) - { - if( fabsl(phi) >= PIO2L ) - { - mtherr( "ellikl", SING ); - return( MAXNUML ); - } - return( logl( tanl( 0.5L*(PIO2L + phi) ) ) ); - } -npio2 = floorl( phi/PIO2L ); -if( npio2 & 1 ) - npio2 += 1; -if( npio2 ) - { - K = ellpkl( a ); - phi = phi - npio2 * PIO2L; - } -else - K = 0.0L; -if( phi < 0.0L ) - { - phi = -phi; - sign = -1; - } -else - sign = 0; -b = sqrtl(a); -t = tanl( phi ); -if( fabsl(t) > 10.0L ) - { - /* Transform the amplitude */ - e = 1.0L/(b*t); - /* ... but avoid multiple recursions. */ - if( fabsl(e) < 10.0L ) - { - e = atanl(e); - if( npio2 == 0 ) - K = ellpkl( a ); - temp = K - ellikl( e, m ); - goto done; - } - } -a = 1.0L; -c = sqrtl(m); -d = 1; -mod = 0; - -while( fabsl(c/a) > MACHEPL ) - { - temp = b/a; - phi = phi + atanl(t*temp) + mod * PIL; - mod = (phi + PIO2L)/PIL; - t = t * ( 1.0L + temp )/( 1.0L - temp * t * t ); - c = 0.5L * ( a - b ); - temp = sqrtl( a * b ); - a = 0.5L * ( a + b ); - b = temp; - d += d; - } - -temp = (atanl(t) + mod * PIL)/(d * a); - -done: -if( sign < 0 ) - temp = -temp; -temp += npio2 * K; -return( temp ); -} diff --git a/libm/ldouble/ellpel.c b/libm/ldouble/ellpel.c deleted file mode 100644 index 6965db066..000000000 --- a/libm/ldouble/ellpel.c +++ /dev/null @@ -1,173 +0,0 @@ -/* ellpel.c - * - * Complete elliptic integral of the second kind - * - * - * - * SYNOPSIS: - * - * long double m1, y, ellpel(); - * - * y = ellpel( m1 ); - * - * - * - * DESCRIPTION: - * - * Approximates the integral - * - * - * pi/2 - * - - * | | 2 - * E(m) = | sqrt( 1 - m sin t ) dt - * | | - * - - * 0 - * - * Where m = 1 - m1, using the approximation - * - * P(x) - x log x Q(x). - * - * Though there are no singularities, the argument m1 is used - * rather than m for compatibility with ellpk(). - * - * E(1) = 1; E(0) = pi/2. - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 0, 1 10000 1.1e-19 3.5e-20 - * - * - * ERROR MESSAGES: - * - * message condition value returned - * ellpel domain x<0, x>1 0.0 - * - */ - -/* ellpe.c */ - -/* Elliptic integral of second kind */ - -/* -Cephes Math Library, Release 2.3: October, 1995 -Copyright 1984, 1987, 1989, 1995 by Stephen L. Moshier -*/ - -#include <math.h> - -#if UNK -static long double P[12] = { - 3.198937812032341294902E-5L, - 7.742523238588775116241E-4L, - 4.140384701571542000550E-3L, - 7.963509564694454269086E-3L, - 7.280911706839967541799E-3L, - 5.044067167184043853799E-3L, - 5.076832243257395296304E-3L, - 7.155775630578315248130E-3L, - 1.154485760526450950611E-2L, - 2.183137319801117971860E-2L, - 5.680519271556930583433E-2L, - 4.431471805599467050354E-1L, -}; -static long double Q[12] = { - 6.393938134301205485085E-6L, - 2.741404591220851603273E-4L, - 2.480876752984331133799E-3L, - 8.770638497964078750003E-3L, - 1.676835725889463343319E-2L, - 2.281970801531577700830E-2L, - 2.767367465121309044166E-2L, - 3.364167778770018154356E-2L, - 4.272453406734691973083E-2L, - 5.859374951483909267451E-2L, - 9.374999999923942267270E-2L, - 2.499999999999998643587E-1L, -}; -#endif -#if IBMPC -static short P[] = { -0x7a78,0x5a02,0x554d,0x862c,0x3ff0, XPD -0x34db,0xa965,0x31a3,0xcaf7,0x3ff4, XPD -0xca6c,0x6c00,0x1071,0x87ac,0x3ff7, XPD -0x4cdb,0x125d,0x6149,0x8279,0x3ff8, XPD -0xadbd,0x3d8f,0xb6d5,0xee94,0x3ff7, XPD -0x8189,0xcd0e,0xb3c2,0xa548,0x3ff7, XPD -0x32b5,0xdd64,0x8e39,0xa65b,0x3ff7, XPD -0x0344,0xc9db,0xff27,0xea7a,0x3ff7, XPD -0xba2d,0x806a,0xa476,0xbd26,0x3ff8, XPD -0xc3e0,0x30fa,0xb53d,0xb2d7,0x3ff9, XPD -0x23b8,0x4d33,0x8fcf,0xe8ac,0x3ffa, XPD -0xbc79,0xa39f,0x2fef,0xe2e4,0x3ffd, XPD -}; -static short Q[] = { -0x89f1,0xe234,0x82a6,0xd68b,0x3fed, XPD -0x202a,0x96b3,0x8273,0x8fba,0x3ff3, XPD -0xc183,0xfc45,0x3484,0xa296,0x3ff6, XPD -0x683e,0xe201,0xb960,0x8fb2,0x3ff8, XPD -0x721a,0x1b6a,0xcb41,0x895d,0x3ff9, XPD -0x4eee,0x295f,0x6574,0xbaf0,0x3ff9, XPD -0x3ade,0xc98f,0xe6f2,0xe2b3,0x3ff9, XPD -0xd470,0x1784,0xdb1e,0x89cb,0x3ffa, XPD -0xa649,0xe5c1,0xebc8,0xaeff,0x3ffa, XPD -0x84c0,0xa8f5,0xffde,0xefff,0x3ffa, XPD -0x5506,0xf94f,0xffff,0xbfff,0x3ffb, XPD -0xd8e7,0xffff,0xffff,0xffff,0x3ffc, XPD -}; -#endif -#if MIEEE -static long P[36] = { -0x3ff00000,0x862c554d,0x5a027a78, -0x3ff40000,0xcaf731a3,0xa96534db, -0x3ff70000,0x87ac1071,0x6c00ca6c, -0x3ff80000,0x82796149,0x125d4cdb, -0x3ff70000,0xee94b6d5,0x3d8fadbd, -0x3ff70000,0xa548b3c2,0xcd0e8189, -0x3ff70000,0xa65b8e39,0xdd6432b5, -0x3ff70000,0xea7aff27,0xc9db0344, -0x3ff80000,0xbd26a476,0x806aba2d, -0x3ff90000,0xb2d7b53d,0x30fac3e0, -0x3ffa0000,0xe8ac8fcf,0x4d3323b8, -0x3ffd0000,0xe2e42fef,0xa39fbc79, -}; -static long Q[36] = { -0x3fed0000,0xd68b82a6,0xe23489f1, -0x3ff30000,0x8fba8273,0x96b3202a, -0x3ff60000,0xa2963484,0xfc45c183, -0x3ff80000,0x8fb2b960,0xe201683e, -0x3ff90000,0x895dcb41,0x1b6a721a, -0x3ff90000,0xbaf06574,0x295f4eee, -0x3ff90000,0xe2b3e6f2,0xc98f3ade, -0x3ffa0000,0x89cbdb1e,0x1784d470, -0x3ffa0000,0xaeffebc8,0xe5c1a649, -0x3ffa0000,0xefffffde,0xa8f584c0, -0x3ffb0000,0xbfffffff,0xf94f5506, -0x3ffc0000,0xffffffff,0xffffd8e7, -}; -#endif - -#ifdef ANSIPROT -extern long double polevll ( long double, void *, int ); -extern long double logl ( long double ); -#else -long double polevll(), logl(); -#endif - -long double ellpel(x) -long double x; -{ - -if( (x <= 0.0L) || (x > 1.0L) ) - { - if( x == 0.0L ) - return( 1.0L ); - mtherr( "ellpel", DOMAIN ); - return( 0.0L ); - } -return( 1.0L + x * polevll(x,P,11) - logl(x) * (x * polevll(x,Q,11)) ); -} diff --git a/libm/ldouble/ellpjl.c b/libm/ldouble/ellpjl.c deleted file mode 100644 index bb57fe6a1..000000000 --- a/libm/ldouble/ellpjl.c +++ /dev/null @@ -1,164 +0,0 @@ -/* ellpjl.c - * - * Jacobian Elliptic Functions - * - * - * - * SYNOPSIS: - * - * long double u, m, sn, cn, dn, phi; - * int ellpjl(); - * - * ellpjl( u, m, _&sn, _&cn, _&dn, _&phi ); - * - * - * - * DESCRIPTION: - * - * - * Evaluates the Jacobian elliptic functions sn(u|m), cn(u|m), - * and dn(u|m) of parameter m between 0 and 1, and real - * argument u. - * - * These functions are periodic, with quarter-period on the - * real axis equal to the complete elliptic integral - * ellpk(1.0-m). - * - * Relation to incomplete elliptic integral: - * If u = ellik(phi,m), then sn(u|m) = sin(phi), - * and cn(u|m) = cos(phi). Phi is called the amplitude of u. - * - * Computation is by means of the arithmetic-geometric mean - * algorithm, except when m is within 1e-12 of 0 or 1. In the - * latter case with m close to 1, the approximation applies - * only for phi < pi/2. - * - * ACCURACY: - * - * Tested at random points with u between 0 and 10, m between - * 0 and 1. - * - * Absolute error (* = relative error): - * arithmetic function # trials peak rms - * IEEE sn 10000 1.7e-18 2.3e-19 - * IEEE cn 20000 1.6e-18 2.2e-19 - * IEEE dn 10000 4.7e-15 2.7e-17 - * IEEE phi 10000 4.0e-19* 6.6e-20* - * - * Accuracy deteriorates when u is large. - * - */ - -/* -Cephes Math Library Release 2.3: November, 1995 -Copyright 1984, 1987, 1995 by Stephen L. Moshier -*/ - -#include <math.h> -#ifdef ANSIPROT -extern long double sqrtl ( long double ); -extern long double fabsl ( long double ); -extern long double sinl ( long double ); -extern long double cosl ( long double ); -extern long double asinl ( long double ); -extern long double tanhl ( long double ); -extern long double sinhl ( long double ); -extern long double coshl ( long double ); -extern long double atanl ( long double ); -extern long double expl ( long double ); -#else -long double sqrtl(), fabsl(), sinl(), cosl(), asinl(), tanhl(); -long double sinhl(), coshl(), atanl(), expl(); -#endif -extern long double PIO2L, MACHEPL; - -int ellpjl( u, m, sn, cn, dn, ph ) -long double u, m; -long double *sn, *cn, *dn, *ph; -{ -long double ai, b, phi, t, twon; -long double a[9], c[9]; -int i; - - -/* Check for special cases */ - -if( m < 0.0L || m > 1.0L ) - { - mtherr( "ellpjl", DOMAIN ); - *sn = 0.0L; - *cn = 0.0L; - *ph = 0.0L; - *dn = 0.0L; - return(-1); - } -if( m < 1.0e-12L ) - { - t = sinl(u); - b = cosl(u); - ai = 0.25L * m * (u - t*b); - *sn = t - ai*b; - *cn = b + ai*t; - *ph = u - ai; - *dn = 1.0L - 0.5L*m*t*t; - return(0); - } - -if( m >= 0.999999999999L ) - { - ai = 0.25L * (1.0L-m); - b = coshl(u); - t = tanhl(u); - phi = 1.0L/b; - twon = b * sinhl(u); - *sn = t + ai * (twon - u)/(b*b); - *ph = 2.0L*atanl(expl(u)) - PIO2L + ai*(twon - u)/b; - ai *= t * phi; - *cn = phi - ai * (twon - u); - *dn = phi + ai * (twon + u); - return(0); - } - - -/* A. G. M. scale */ -a[0] = 1.0L; -b = sqrtl(1.0L - m); -c[0] = sqrtl(m); -twon = 1.0L; -i = 0; - -while( fabsl(c[i]/a[i]) > MACHEPL ) - { - if( i > 7 ) - { - mtherr( "ellpjl", OVERFLOW ); - goto done; - } - ai = a[i]; - ++i; - c[i] = 0.5L * ( ai - b ); - t = sqrtl( ai * b ); - a[i] = 0.5L * ( ai + b ); - b = t; - twon *= 2.0L; - } - -done: - -/* backward recurrence */ -phi = twon * a[i] * u; -do - { - t = c[i] * sinl(phi) / a[i]; - b = phi; - phi = 0.5L * (asinl(t) + phi); - } -while( --i ); - -*sn = sinl(phi); -t = cosl(phi); -*cn = t; -*dn = t/cosl(phi-b); -*ph = phi; -return(0); -} diff --git a/libm/ldouble/ellpkl.c b/libm/ldouble/ellpkl.c deleted file mode 100644 index dd42ac861..000000000 --- a/libm/ldouble/ellpkl.c +++ /dev/null @@ -1,203 +0,0 @@ -/* ellpkl.c - * - * Complete elliptic integral of the first kind - * - * - * - * SYNOPSIS: - * - * long double m1, y, ellpkl(); - * - * y = ellpkl( m1 ); - * - * - * - * DESCRIPTION: - * - * Approximates the integral - * - * - * - * pi/2 - * - - * | | - * | dt - * K(m) = | ------------------ - * | 2 - * | | sqrt( 1 - m sin t ) - * - - * 0 - * - * where m = 1 - m1, using the approximation - * - * P(x) - log x Q(x). - * - * The argument m1 is used rather than m so that the logarithmic - * singularity at m = 1 will be shifted to the origin; this - * preserves maximum accuracy. - * - * K(0) = pi/2. - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 0,1 10000 1.1e-19 3.3e-20 - * - * ERROR MESSAGES: - * - * message condition value returned - * ellpkl domain x<0, x>1 0.0 - * - */ - -/* ellpkl.c */ - - -/* -Cephes Math Library, Release 2.3: October, 1995 -Copyright 1984, 1987, 1995 by Stephen L. Moshier -*/ - -#include <math.h> - -#if UNK -static long double P[13] = { - 1.247539729154838838628E-6L, - 2.149421654232011240659E-4L, - 2.265267575136470585139E-3L, - 6.723088676584254248821E-3L, - 8.092066790639263075808E-3L, - 5.664069509748147028621E-3L, - 4.579865994050801042865E-3L, - 5.797368411662027645234E-3L, - 8.767698209432225911803E-3L, - 1.493761594388688915057E-2L, - 3.088514457872042326871E-2L, - 9.657359027999314232753E-2L, - 1.386294361119890618992E0L, -}; -static long double Q[12] = { - 5.568631677757315398993E-5L, - 1.036110372590318802997E-3L, - 5.500459122138244213579E-3L, - 1.337330436245904844528E-2L, - 2.033103735656990487115E-2L, - 2.522868345512332304268E-2L, - 3.026786461242788135379E-2L, - 3.738370118296930305919E-2L, - 4.882812208418620146046E-2L, - 7.031249999330222751046E-2L, - 1.249999999999978263154E-1L, - 4.999999999999999999924E-1L, -}; -static long double C1 = 1.386294361119890618834L; /* log(4) */ -#endif -#if IBMPC -static short P[] = { -0xf098,0xad01,0x2381,0xa771,0x3feb, XPD -0xd6ed,0xea22,0x1922,0xe162,0x3ff2, XPD -0x3733,0xe2f1,0xe226,0x9474,0x3ff6, XPD -0x3031,0x3c9d,0x5aff,0xdc4d,0x3ff7, XPD -0x9a46,0x4310,0x968e,0x8494,0x3ff8, XPD -0xbe4c,0x3ff2,0xa8a7,0xb999,0x3ff7, XPD -0xf35c,0x0eaf,0xb355,0x9612,0x3ff7, XPD -0xbc56,0x8fd4,0xd9dd,0xbdf7,0x3ff7, XPD -0xc01e,0x867f,0x6444,0x8fa6,0x3ff8, XPD -0x4ba3,0x6392,0xe6fd,0xf4bc,0x3ff8, XPD -0x62c3,0xbb12,0xd7bc,0xfd02,0x3ff9, XPD -0x08fe,0x476c,0x5fdf,0xc5c8,0x3ffb, XPD -0x79ad,0xd1cf,0x17f7,0xb172,0x3fff, XPD -}; -static short Q[] = { -0x96a4,0x8474,0xba33,0xe990,0x3ff0, XPD -0xe5a7,0xa50e,0x1854,0x87ce,0x3ff5, XPD -0x8999,0x72e3,0x3205,0xb43d,0x3ff7, XPD -0x3255,0x13eb,0xb438,0xdb1b,0x3ff8, XPD -0xb717,0x497f,0x4691,0xa68d,0x3ff9, XPD -0x30be,0x8c6b,0x624b,0xceac,0x3ff9, XPD -0xa858,0x2a0d,0x5014,0xf7f4,0x3ff9, XPD -0x8615,0xbfa6,0xa6df,0x991f,0x3ffa, XPD -0x103c,0xa076,0xff37,0xc7ff,0x3ffa, XPD -0xf508,0xc515,0xffff,0x8fff,0x3ffb, XPD -0x1af5,0xfffb,0xffff,0xffff,0x3ffb, XPD -0x0000,0x0000,0x0000,0x8000,0x3ffe, XPD -}; -static unsigned short ac1[] = { -0x79ac,0xd1cf,0x17f7,0xb172,0x3fff, XPD -}; -#define C1 (*(long double *)ac1) -#endif - -#ifdef MIEEE -static long P[39] = { -0x3feb0000,0xa7712381,0xad01f098, -0x3ff20000,0xe1621922,0xea22d6ed, -0x3ff60000,0x9474e226,0xe2f13733, -0x3ff70000,0xdc4d5aff,0x3c9d3031, -0x3ff80000,0x8494968e,0x43109a46, -0x3ff70000,0xb999a8a7,0x3ff2be4c, -0x3ff70000,0x9612b355,0x0eaff35c, -0x3ff70000,0xbdf7d9dd,0x8fd4bc56, -0x3ff80000,0x8fa66444,0x867fc01e, -0x3ff80000,0xf4bce6fd,0x63924ba3, -0x3ff90000,0xfd02d7bc,0xbb1262c3, -0x3ffb0000,0xc5c85fdf,0x476c08fe, -0x3fff0000,0xb17217f7,0xd1cf79ad, -}; -static long Q[36] = { -0x3ff00000,0xe990ba33,0x847496a4, -0x3ff50000,0x87ce1854,0xa50ee5a7, -0x3ff70000,0xb43d3205,0x72e38999, -0x3ff80000,0xdb1bb438,0x13eb3255, -0x3ff90000,0xa68d4691,0x497fb717, -0x3ff90000,0xceac624b,0x8c6b30be, -0x3ff90000,0xf7f45014,0x2a0da858, -0x3ffa0000,0x991fa6df,0xbfa68615, -0x3ffa0000,0xc7ffff37,0xa076103c, -0x3ffb0000,0x8fffffff,0xc515f508, -0x3ffb0000,0xffffffff,0xfffb1af5, -0x3ffe0000,0x80000000,0x00000000, -}; -static unsigned long ac1[] = { -0x3fff0000,0xb17217f7,0xd1cf79ac -}; -#define C1 (*(long double *)ac1) -#endif - - -#ifdef ANSIPROT -extern long double polevll ( long double, void *, int ); -extern long double logl ( long double ); -#else -long double polevll(), logl(); -#endif -extern long double MACHEPL, MAXNUML; - -long double ellpkl(x) -long double x; -{ - -if( (x < 0.0L) || (x > 1.0L) ) - { - mtherr( "ellpkl", DOMAIN ); - return( 0.0L ); - } - -if( x > MACHEPL ) - { - return( polevll(x,P,12) - logl(x) * polevll(x,Q,11) ); - } -else - { - if( x == 0.0L ) - { - mtherr( "ellpkl", SING ); - return( MAXNUML ); - } - else - { - return( C1 - 0.5L * logl(x) ); - } - } -} diff --git a/libm/ldouble/exp10l.c b/libm/ldouble/exp10l.c deleted file mode 100644 index b837571b4..000000000 --- a/libm/ldouble/exp10l.c +++ /dev/null @@ -1,192 +0,0 @@ -/* exp10l.c - * - * Base 10 exponential function, long double precision - * (Common antilogarithm) - * - * - * - * SYNOPSIS: - * - * long double x, y, exp10l() - * - * y = exp10l( x ); - * - * - * - * DESCRIPTION: - * - * Returns 10 raised to the x power. - * - * Range reduction is accomplished by expressing the argument - * as 10**x = 2**n 10**f, with |f| < 0.5 log10(2). - * The Pade' form - * - * 1 + 2x P(x**2)/( Q(x**2) - P(x**2) ) - * - * is used to approximate 10**f. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE +-4900 30000 1.0e-19 2.7e-20 - * - * ERROR MESSAGES: - * - * message condition value returned - * exp10l underflow x < -MAXL10 0.0 - * exp10l overflow x > MAXL10 MAXNUM - * - * IEEE arithmetic: MAXL10 = 4932.0754489586679023819 - * - */ - -/* -Cephes Math Library Release 2.2: January, 1991 -Copyright 1984, 1991 by Stephen L. Moshier -Direct inquiries to 30 Frost Street, Cambridge, MA 02140 -*/ - - -#include <math.h> - -#ifdef UNK -static long double P[] = { - 3.1341179396892496811523E1L, - 4.5618283154904699073999E3L, - 1.3433113468542797218610E5L, - 7.6025447914440301593592E5L, -}; -static long double Q[] = { -/* 1.0000000000000000000000E0,*/ - 4.7705440288425157637739E2L, - 2.9732606548049614870598E4L, - 4.0843697951001026189583E5L, - 6.6034865026929015925608E5L, -}; -/*static long double LOG102 = 3.0102999566398119521373889e-1L;*/ -static long double LOG210 = 3.3219280948873623478703L; -static long double LG102A = 3.01025390625e-1L; -static long double LG102B = 4.6050389811952137388947e-6L; -#endif - - -#ifdef IBMPC -static short P[] = { -0x399a,0x7dc7,0xbc43,0xfaba,0x4003, XPD -0xb526,0xdf32,0xa063,0x8e8e,0x400b, XPD -0x18da,0xafa1,0xc89e,0x832e,0x4010, XPD -0x503d,0x9352,0xe7aa,0xb99b,0x4012, XPD -}; -static short Q[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ -0x947d,0x7855,0xf6ac,0xee86,0x4007, XPD -0x18cf,0x7749,0x368d,0xe849,0x400d, XPD -0x85be,0x2560,0x9f58,0xc76e,0x4011, XPD -0x6d3c,0x80c5,0xca67,0xa137,0x4012, XPD -}; -/* -static short L102[] = {0xf799,0xfbcf,0x9a84,0x9a20,0x3ffd, XPD}; -#define LOG102 *(long double *)L102 -*/ -static short L210[] = {0x8afe,0xcd1b,0x784b,0xd49a,0x4000, XPD}; -#define LOG210 *(long double *)L210 -static short L102A[] = {0x0000,0x0000,0x0000,0x9a20,0x3ffd, XPD}; -#define LG102A *(long double *)L102A -static short L102B[] = {0x8f89,0xf798,0xfbcf,0x9a84,0x3fed, XPD}; -#define LG102B *(long double *)L102B -#endif - -#ifdef MIEEE -static long P[] = { -0x40030000,0xfababc43,0x7dc7399a, -0x400b0000,0x8e8ea063,0xdf32b526, -0x40100000,0x832ec89e,0xafa118da, -0x40120000,0xb99be7aa,0x9352503d, -}; -static long Q[] = { -/* 0x3fff0000,0x80000000,0x00000000, */ -0x40070000,0xee86f6ac,0x7855947d, -0x400d0000,0xe849368d,0x774918cf, -0x40110000,0xc76e9f58,0x256085be, -0x40120000,0xa137ca67,0x80c56d3c, -}; -/* -static long L102[] = {0x3ffd0000,0x9a209a84,0xfbcff799}; -#define LOG102 *(long double *)L102 -*/ -static long L210[] = {0x40000000,0xd49a784b,0xcd1b8afe}; -#define LOG210 *(long double *)L210 -static long L102A[] = {0x3ffd0000,0x9a200000,0x00000000}; -#define LG102A *(long double *)L102A -static long L102B[] = {0x3fed0000,0x9a84fbcf,0xf7988f89}; -#define LG102B *(long double *)L102B -#endif - -static long double MAXL10 = 4.9320754489586679023819e3L; -extern long double MAXNUML; -#ifdef ANSIPROT -extern long double floorl ( long double ); -extern long double ldexpl ( long double, int ); -extern long double polevll ( long double, void *, int ); -extern long double p1evll ( long double, void *, int ); -extern int isnanl ( long double ); -#else -long double floorl(), ldexpl(), polevll(), p1evll(), isnanl(); -#endif -#ifdef INFINITIES -extern long double INFINITYL; -#endif - -long double exp10l(x) -long double x; -{ -long double px, xx; -short n; - -#ifdef NANS -if( isnanl(x) ) - return(x); -#endif -if( x > MAXL10 ) - { -#ifdef INFINITIES - return( INFINITYL ); -#else - mtherr( "exp10l", OVERFLOW ); - return( MAXNUML ); -#endif - } - -if( x < -MAXL10 ) /* Would like to use MINLOG but can't */ - { -#ifndef INFINITIES - mtherr( "exp10l", UNDERFLOW ); -#endif - return(0.0L); - } - -/* Express 10**x = 10**g 2**n - * = 10**g 10**( n log10(2) ) - * = 10**( g + n log10(2) ) - */ -px = floorl( LOG210 * x + 0.5L ); -n = px; -x -= px * LG102A; -x -= px * LG102B; - -/* rational approximation for exponential - * of the fractional part: - * 10**x = 1 + 2x P(x**2)/( Q(x**2) - P(x**2) ) - */ -xx = x * x; -px = x * polevll( xx, P, 3 ); -x = px/( p1evll( xx, Q, 4 ) - px ); -x = 1.0L + ldexpl( x, 1 ); - -/* multiply by power of 2 */ -x = ldexpl( x, n ); -return(x); -} diff --git a/libm/ldouble/exp2l.c b/libm/ldouble/exp2l.c deleted file mode 100644 index 076f8bca5..000000000 --- a/libm/ldouble/exp2l.c +++ /dev/null @@ -1,166 +0,0 @@ -/* exp2l.c - * - * Base 2 exponential function, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, exp2l(); - * - * y = exp2l( x ); - * - * - * - * DESCRIPTION: - * - * Returns 2 raised to the x power. - * - * Range reduction is accomplished by separating the argument - * into an integer k and fraction f such that - * x k f - * 2 = 2 2. - * - * A Pade' form - * - * 1 + 2x P(x**2) / (Q(x**2) - x P(x**2) ) - * - * approximates 2**x in the basic range [-0.5, 0.5]. - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE +-16300 300000 9.1e-20 2.6e-20 - * - * - * See exp.c for comments on error amplification. - * - * - * ERROR MESSAGES: - * - * message condition value returned - * exp2l underflow x < -16382 0.0 - * exp2l overflow x >= 16384 MAXNUM - * - */ - - -/* -Cephes Math Library Release 2.7: May, 1998 -Copyright 1984, 1991, 1998 by Stephen L. Moshier -*/ - - - -#include <math.h> - -#ifdef UNK -static long double P[] = { - 6.0614853552242266094567E1L, - 3.0286971917562792508623E4L, - 2.0803843631901852422887E6L, -}; -static long double Q[] = { -/* 1.0000000000000000000000E0,*/ - 1.7492876999891839021063E3L, - 3.2772515434906797273099E5L, - 6.0027204078348487957118E6L, -}; -#endif - - -#ifdef IBMPC -static short P[] = { -0xffd8,0x6ad6,0x9c2b,0xf275,0x4004, XPD -0x3426,0x2dc5,0xf19f,0xec9d,0x400d, XPD -0x7ec0,0xd041,0x02e7,0xfdf4,0x4013, XPD -}; -static short Q[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ -0x575b,0x9b93,0x34d6,0xdaa9,0x4009, XPD -0xe38d,0x6d74,0xa4f0,0xa005,0x4011, XPD -0xb37e,0xcfba,0x40d0,0xb730,0x4015, XPD -}; -#endif - -#ifdef MIEEE -static long P[] = { -0x40040000,0xf2759c2b,0x6ad6ffd8, -0x400d0000,0xec9df19f,0x2dc53426, -0x40130000,0xfdf402e7,0xd0417ec0, -}; -static long Q[] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0x40090000,0xdaa934d6,0x9b93575b, -0x40110000,0xa005a4f0,0x6d74e38d, -0x40150000,0xb73040d0,0xcfbab37e, -}; -#endif - -#define MAXL2L 16384.0L -#define MINL2L -16382.0L - - -extern long double MAXNUML; -#ifdef ANSIPROT -extern long double polevll ( long double, void *, int ); -extern long double p1evll ( long double, void *, int ); -extern long double floorl ( long double ); -extern long double ldexpl ( long double, int ); -extern int isnanl ( long double ); -#else -long double polevll(), p1evll(), floorl(), ldexpl(), isnanl(); -#endif -#ifdef INFINITIES -extern long double INFINITYL; -#endif - -long double exp2l(x) -long double x; -{ -long double px, xx; -int n; - -#ifdef NANS -if( isnanl(x) ) - return(x); -#endif -if( x > MAXL2L) - { -#ifdef INFINITIES - return( INFINITYL ); -#else - mtherr( "exp2l", OVERFLOW ); - return( MAXNUML ); -#endif - } - -if( x < MINL2L ) - { -#ifndef INFINITIES - mtherr( "exp2l", UNDERFLOW ); -#endif - return(0.0L); - } - -xx = x; /* save x */ -/* separate into integer and fractional parts */ -px = floorl(x+0.5L); -n = px; -x = x - px; - -/* rational approximation - * exp2(x) = 1.0 + 2xP(xx)/(Q(xx) - P(xx)) - * where xx = x**2 - */ -xx = x * x; -px = x * polevll( xx, P, 2 ); -x = px / ( p1evll( xx, Q, 3 ) - px ); -x = 1.0L + ldexpl( x, 1 ); - -/* scale by power of 2 */ -x = ldexpl( x, n ); -return(x); -} diff --git a/libm/ldouble/expl.c b/libm/ldouble/expl.c deleted file mode 100644 index 524246987..000000000 --- a/libm/ldouble/expl.c +++ /dev/null @@ -1,183 +0,0 @@ -/* expl.c - * - * Exponential function, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, expl(); - * - * y = expl( x ); - * - * - * - * DESCRIPTION: - * - * Returns e (2.71828...) raised to the x power. - * - * Range reduction is accomplished by separating the argument - * into an integer k and fraction f such that - * - * x k f - * e = 2 e. - * - * A Pade' form of degree 2/3 is used to approximate exp(f) - 1 - * in the basic range [-0.5 ln 2, 0.5 ln 2]. - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE +-10000 50000 1.12e-19 2.81e-20 - * - * - * Error amplification in the exponential function can be - * a serious matter. The error propagation involves - * exp( X(1+delta) ) = exp(X) ( 1 + X*delta + ... ), - * which shows that a 1 lsb error in representing X produces - * a relative error of X times 1 lsb in the function. - * While the routine gives an accurate result for arguments - * that are exactly represented by a long double precision - * computer number, the result contains amplified roundoff - * error for large arguments not exactly represented. - * - * - * ERROR MESSAGES: - * - * message condition value returned - * exp underflow x < MINLOG 0.0 - * exp overflow x > MAXLOG MAXNUM - * - */ - -/* -Cephes Math Library Release 2.7: May, 1998 -Copyright 1984, 1990, 1998 by Stephen L. Moshier -*/ - - -/* Exponential function */ - -#include <math.h> - -#ifdef UNK -static long double P[3] = { - 1.2617719307481059087798E-4L, - 3.0299440770744196129956E-2L, - 9.9999999999999999991025E-1L, -}; -static long double Q[4] = { - 3.0019850513866445504159E-6L, - 2.5244834034968410419224E-3L, - 2.2726554820815502876593E-1L, - 2.0000000000000000000897E0L, -}; -static long double C1 = 6.9314575195312500000000E-1L; -static long double C2 = 1.4286068203094172321215E-6L; -#endif - -#ifdef DEC -not supported in long double precision -#endif - -#ifdef IBMPC -static short P[] = { -0x424e,0x225f,0x6eaf,0x844e,0x3ff2, XPD -0xf39e,0x5163,0x8866,0xf836,0x3ff9, XPD -0xfffe,0xffff,0xffff,0xffff,0x3ffe, XPD -}; -static short Q[] = { -0xff1e,0xb2fc,0xb5e1,0xc975,0x3fec, XPD -0xff3e,0x45b5,0xcda8,0xa571,0x3ff6, XPD -0x9ee1,0x3f03,0x4cc4,0xe8b8,0x3ffc, XPD -0x0000,0x0000,0x0000,0x8000,0x4000, XPD -}; -static short sc1[] = {0x0000,0x0000,0x0000,0xb172,0x3ffe, XPD}; -#define C1 (*(long double *)sc1) -static short sc2[] = {0x4f1e,0xcd5e,0x8e7b,0xbfbe,0x3feb, XPD}; -#define C2 (*(long double *)sc2) -#endif - -#ifdef MIEEE -static long P[9] = { -0x3ff20000,0x844e6eaf,0x225f424e, -0x3ff90000,0xf8368866,0x5163f39e, -0x3ffe0000,0xffffffff,0xfffffffe, -}; -static long Q[12] = { -0x3fec0000,0xc975b5e1,0xb2fcff1e, -0x3ff60000,0xa571cda8,0x45b5ff3e, -0x3ffc0000,0xe8b84cc4,0x3f039ee1, -0x40000000,0x80000000,0x00000000, -}; -static long sc1[] = {0x3ffe0000,0xb1720000,0x00000000}; -#define C1 (*(long double *)sc1) -static long sc2[] = {0x3feb0000,0xbfbe8e7b,0xcd5e4f1e}; -#define C2 (*(long double *)sc2) -#endif - -extern long double LOG2EL, MAXLOGL, MINLOGL, MAXNUML; -#ifdef ANSIPROT -extern long double polevll ( long double, void *, int ); -extern long double floorl ( long double ); -extern long double ldexpl ( long double, int ); -extern int isnanl ( long double ); -#else -long double polevll(), floorl(), ldexpl(), isnanl(); -#endif -#ifdef INFINITIES -extern long double INFINITYL; -#endif - -long double expl(x) -long double x; -{ -long double px, xx; -int n; - -#ifdef NANS -if( isnanl(x) ) - return(x); -#endif -if( x > MAXLOGL) - { -#ifdef INFINITIES - return( INFINITYL ); -#else - mtherr( "expl", OVERFLOW ); - return( MAXNUML ); -#endif - } - -if( x < MINLOGL ) - { -#ifndef INFINITIES - mtherr( "expl", UNDERFLOW ); -#endif - return(0.0L); - } - -/* Express e**x = e**g 2**n - * = e**g e**( n loge(2) ) - * = e**( g + n loge(2) ) - */ -px = floorl( LOG2EL * x + 0.5L ); /* floor() truncates toward -infinity. */ -n = px; -x -= px * C1; -x -= px * C2; - - -/* rational approximation for exponential - * of the fractional part: - * e**x = 1 + 2x P(x**2)/( Q(x**2) - P(x**2) ) - */ -xx = x * x; -px = x * polevll( xx, P, 2 ); -x = px/( polevll( xx, Q, 3 ) - px ); -x = 1.0L + ldexpl( x, 1 ); - -x = ldexpl( x, n ); -return(x); -} diff --git a/libm/ldouble/fdtrl.c b/libm/ldouble/fdtrl.c deleted file mode 100644 index da2f8910a..000000000 --- a/libm/ldouble/fdtrl.c +++ /dev/null @@ -1,237 +0,0 @@ -/* fdtrl.c - * - * F distribution, long double precision - * - * - * - * SYNOPSIS: - * - * int df1, df2; - * long double x, y, fdtrl(); - * - * y = fdtrl( df1, df2, x ); - * - * - * - * DESCRIPTION: - * - * Returns the area from zero to x under the F density - * function (also known as Snedcor's density or the - * variance ratio density). This is the density - * of x = (u1/df1)/(u2/df2), where u1 and u2 are random - * variables having Chi square distributions with df1 - * and df2 degrees of freedom, respectively. - * - * The incomplete beta integral is used, according to the - * formula - * - * P(x) = incbetl( df1/2, df2/2, (df1*x/(df2 + df1*x) ). - * - * - * The arguments a and b are greater than zero, and x - * x is nonnegative. - * - * ACCURACY: - * - * Tested at random points (a,b,x) in the indicated intervals. - * x a,b Relative error: - * arithmetic domain domain # trials peak rms - * IEEE 0,1 1,100 10000 9.3e-18 2.9e-19 - * IEEE 0,1 1,10000 10000 1.9e-14 2.9e-15 - * IEEE 1,5 1,10000 10000 5.8e-15 1.4e-16 - * - * ERROR MESSAGES: - * - * message condition value returned - * fdtrl domain a<0, b<0, x<0 0.0 - * - */ - /* fdtrcl() - * - * Complemented F distribution - * - * - * - * SYNOPSIS: - * - * int df1, df2; - * long double x, y, fdtrcl(); - * - * y = fdtrcl( df1, df2, x ); - * - * - * - * DESCRIPTION: - * - * Returns the area from x to infinity under the F density - * function (also known as Snedcor's density or the - * variance ratio density). - * - * - * inf. - * - - * 1 | | a-1 b-1 - * 1-P(x) = ------ | t (1-t) dt - * B(a,b) | | - * - - * x - * - * (See fdtr.c.) - * - * The incomplete beta integral is used, according to the - * formula - * - * P(x) = incbet( df2/2, df1/2, (df2/(df2 + df1*x) ). - * - * - * ACCURACY: - * - * See incbet.c. - * Tested at random points (a,b,x). - * - * x a,b Relative error: - * arithmetic domain domain # trials peak rms - * IEEE 0,1 0,100 10000 4.2e-18 3.3e-19 - * IEEE 0,1 1,10000 10000 7.2e-15 2.6e-16 - * IEEE 1,5 1,10000 10000 1.7e-14 3.0e-15 - * - * ERROR MESSAGES: - * - * message condition value returned - * fdtrcl domain a<0, b<0, x<0 0.0 - * - */ - /* fdtril() - * - * Inverse of complemented F distribution - * - * - * - * SYNOPSIS: - * - * int df1, df2; - * long double x, p, fdtril(); - * - * x = fdtril( df1, df2, p ); - * - * DESCRIPTION: - * - * Finds the F density argument x such that the integral - * from x to infinity of the F density is equal to the - * given probability p. - * - * This is accomplished using the inverse beta integral - * function and the relations - * - * z = incbi( df2/2, df1/2, p ) - * x = df2 (1-z) / (df1 z). - * - * Note: the following relations hold for the inverse of - * the uncomplemented F distribution: - * - * z = incbi( df1/2, df2/2, p ) - * x = df2 z / (df1 (1-z)). - * - * ACCURACY: - * - * See incbi.c. - * Tested at random points (a,b,p). - * - * a,b Relative error: - * arithmetic domain # trials peak rms - * For p between .001 and 1: - * IEEE 1,100 40000 4.6e-18 2.7e-19 - * IEEE 1,10000 30000 1.7e-14 1.4e-16 - * For p between 10^-6 and .001: - * IEEE 1,100 20000 1.9e-15 3.9e-17 - * IEEE 1,10000 30000 2.7e-15 4.0e-17 - * - * ERROR MESSAGES: - * - * message condition value returned - * fdtril domain p <= 0 or p > 1 0.0 - * v < 1 - */ - - -/* -Cephes Math Library Release 2.3: March, 1995 -Copyright 1984, 1995 by Stephen L. Moshier -*/ - - -#include <math.h> -#ifdef ANSIPROT -extern long double incbetl ( long double, long double, long double ); -extern long double incbil ( long double, long double, long double ); -#else -long double incbetl(), incbil(); -#endif - -long double fdtrcl( ia, ib, x ) -int ia, ib; -long double x; -{ -long double a, b, w; - -if( (ia < 1) || (ib < 1) || (x < 0.0L) ) - { - mtherr( "fdtrcl", DOMAIN ); - return( 0.0L ); - } -a = ia; -b = ib; -w = b / (b + a * x); -return( incbetl( 0.5L*b, 0.5L*a, w ) ); -} - - - -long double fdtrl( ia, ib, x ) -int ia, ib; -long double x; -{ -long double a, b, w; - -if( (ia < 1) || (ib < 1) || (x < 0.0L) ) - { - mtherr( "fdtrl", DOMAIN ); - return( 0.0L ); - } -a = ia; -b = ib; -w = a * x; -w = w / (b + w); -return( incbetl(0.5L*a, 0.5L*b, w) ); -} - - -long double fdtril( ia, ib, y ) -int ia, ib; -long double y; -{ -long double a, b, w, x; - -if( (ia < 1) || (ib < 1) || (y <= 0.0L) || (y > 1.0L) ) - { - mtherr( "fdtril", DOMAIN ); - return( 0.0L ); - } -a = ia; -b = ib; -/* Compute probability for x = 0.5. */ -w = incbetl( 0.5L*b, 0.5L*a, 0.5L ); -/* If that is greater than y, then the solution w < .5. - Otherwise, solve at 1-y to remove cancellation in (b - b*w). */ -if( w > y || y < 0.001L) - { - w = incbil( 0.5L*b, 0.5L*a, y ); - x = (b - b*w)/(a*w); - } -else - { - w = incbil( 0.5L*a, 0.5L*b, 1.0L - y ); - x = b*w/(a*(1.0L-w)); - } -return(x); -} diff --git a/libm/ldouble/floorl.c b/libm/ldouble/floorl.c deleted file mode 100644 index 1abdfb2cd..000000000 --- a/libm/ldouble/floorl.c +++ /dev/null @@ -1,432 +0,0 @@ -/* ceill() - * floorl() - * frexpl() - * ldexpl() - * fabsl() - * signbitl() - * isnanl() - * isfinitel() - * - * Floating point numeric utilities - * - * - * - * SYNOPSIS: - * - * long double ceill(), floorl(), frexpl(), ldexpl(), fabsl(); - * int signbitl(), isnanl(), isfinitel(); - * long double x, y; - * int expnt, n; - * - * y = floorl(x); - * y = ceill(x); - * y = frexpl( x, &expnt ); - * y = ldexpl( x, n ); - * y = fabsl( x ); - * n = signbitl(x); - * n = isnanl(x); - * n = isfinitel(x); - * - * - * - * DESCRIPTION: - * - * The following routines return a long double precision floating point - * result: - * - * floorl() returns the largest integer less than or equal to x. - * It truncates toward minus infinity. - * - * ceill() returns the smallest integer greater than or equal - * to x. It truncates toward plus infinity. - * - * frexpl() extracts the exponent from x. It returns an integer - * power of two to expnt and the significand between 0.5 and 1 - * to y. Thus x = y * 2**expn. - * - * ldexpl() multiplies x by 2**n. - * - * fabsl() returns the absolute value of its argument. - * - * These functions are part of the standard C run time library - * for some but not all C compilers. The ones supplied are - * written in C for IEEE arithmetic. They should - * be used only if your compiler library does not already have - * them. - * - * The IEEE versions assume that denormal numbers are implemented - * in the arithmetic. Some modifications will be required if - * the arithmetic has abrupt rather than gradual underflow. - */ - - -/* -Cephes Math Library Release 2.7: May, 1998 -Copyright 1984, 1987, 1988, 1992, 1998 by Stephen L. Moshier -*/ - - -#include <math.h> - -/* This is defined in mconf.h. */ -/* #define DENORMAL 1 */ - -#ifdef UNK -/* Change UNK into something else. */ -#undef UNK -#if BIGENDIAN -#define MIEEE 1 -#else -#define IBMPC 1 -#endif -#endif - -#ifdef IBMPC -#define EXPMSK 0x800f -#define MEXP 0x7ff -#define NBITS 64 -#endif - -#ifdef MIEEE -#define EXPMSK 0x800f -#define MEXP 0x7ff -#define NBITS 64 -#endif - -extern double MAXNUML; - -#ifdef ANSIPROT -extern long double fabsl ( long double ); -extern long double floorl ( long double ); -extern int isnanl ( long double ); -#else -long double fabsl(), floorl(); -int isnanl(); -#endif -#ifdef INFINITIES -extern long double INFINITYL; -#endif -#ifdef NANS -extern long double NANL; -#endif - -long double fabsl(x) -long double x; -{ -union - { - long double d; - short i[6]; - } u; - -u.d = x; -#ifdef IBMPC - u.i[4] &= 0x7fff; -#endif -#ifdef MIEEE - u.i[0] &= 0x7fff; -#endif -return( u.d ); -} - - - -long double ceill(x) -long double x; -{ -long double y; - -#ifdef UNK -mtherr( "ceill", DOMAIN ); -return(0.0L); -#endif -#ifdef INFINITIES -if(x == -INFINITYL) - return(x); -#endif -#ifdef MINUSZERO -if(x == 0.0L) - return(x); -#endif -y = floorl(x); -if( y < x ) - y += 1.0L; -return(y); -} - - - - -/* Bit clearing masks: */ - -static unsigned short bmask[] = { -0xffff, -0xfffe, -0xfffc, -0xfff8, -0xfff0, -0xffe0, -0xffc0, -0xff80, -0xff00, -0xfe00, -0xfc00, -0xf800, -0xf000, -0xe000, -0xc000, -0x8000, -0x0000, -}; - - - - -long double floorl(x) -long double x; -{ -unsigned short *p; -union - { - long double y; - unsigned short sh[6]; - } u; -int e; - -#ifdef UNK -mtherr( "floor", DOMAIN ); -return(0.0L); -#endif -#ifdef INFINITIES -if( x == INFINITYL ) - return(x); -#endif -#ifdef MINUSZERO -if(x == 0.0L) - return(x); -#endif -u.y = x; -/* find the exponent (power of 2) */ -#ifdef IBMPC -p = (unsigned short *)&u.sh[4]; -e = (*p & 0x7fff) - 0x3fff; -p -= 4; -#endif - -#ifdef MIEEE -p = (unsigned short *)&u.sh[0]; -e = (*p & 0x7fff) - 0x3fff; -p += 5; -#endif - -if( e < 0 ) - { - if( u.y < 0.0L ) - return( -1.0L ); - else - return( 0.0L ); - } - -e = (NBITS -1) - e; -/* clean out 16 bits at a time */ -while( e >= 16 ) - { -#ifdef IBMPC - *p++ = 0; -#endif - -#ifdef MIEEE - *p-- = 0; -#endif - e -= 16; - } - -/* clear the remaining bits */ -if( e > 0 ) - *p &= bmask[e]; - -if( (x < 0) && (u.y != x) ) - u.y -= 1.0L; - -return(u.y); -} - - - -long double frexpl( x, pw2 ) -long double x; -int *pw2; -{ -union - { - long double y; - unsigned short sh[6]; - } u; -int i, k; -short *q; - -u.y = x; - -#ifdef NANS -if(isnanl(x)) - { - *pw2 = 0; - return(x); - } -#endif -#ifdef INFINITIES -if(x == -INFINITYL) - { - *pw2 = 0; - return(x); - } -#endif -#ifdef MINUSZERO -if(x == 0.0L) - { - *pw2 = 0; - return(x); - } -#endif - -#ifdef UNK -mtherr( "frexpl", DOMAIN ); -return(0.0L); -#endif - -/* find the exponent (power of 2) */ -#ifdef IBMPC -q = (short *)&u.sh[4]; -i = *q & 0x7fff; -#endif - -#ifdef MIEEE -q = (short *)&u.sh[0]; -i = *q & 0x7fff; -#endif - -if( i == 0 ) - { - if( u.y == 0.0L ) - { - *pw2 = 0; - return(0.0L); - } -/* Number is denormal or zero */ -#ifdef DENORMAL -/* Handle denormal number. */ -do - { - u.y *= 2.0L; - i -= 1; - k = *q & 0x7fff; - } -while( (k == 0) && (i > -66) ); -i = i + k; -#else - *pw2 = 0; - return(0.0L); -#endif /* DENORMAL */ - } - -*pw2 = i - 0x3ffe; -/* *q = 0x3ffe; */ -/* Preserve sign of argument. */ -*q &= 0x8000; -*q |= 0x3ffe; -return( u.y ); -} - - - - - - -long double ldexpl( x, pw2 ) -long double x; -int pw2; -{ -union - { - long double y; - unsigned short sh[6]; - } u; -unsigned short *q; -long e; - -#ifdef UNK -mtherr( "ldexp", DOMAIN ); -return(0.0L); -#endif - -u.y = x; -#ifdef IBMPC -q = (unsigned short *)&u.sh[4]; -#endif -#ifdef MIEEE -q = (unsigned short *)&u.sh[0]; -#endif -while( (e = (*q & 0x7fffL)) == 0 ) - { -#ifdef DENORMAL - if( u.y == 0.0L ) - { - return( 0.0L ); - } -/* Input is denormal. */ - if( pw2 > 0 ) - { - u.y *= 2.0L; - pw2 -= 1; - } - if( pw2 < 0 ) - { - if( pw2 < -64 ) - return(0.0L); - u.y *= 0.5L; - pw2 += 1; - } - if( pw2 == 0 ) - return(u.y); -#else - return( 0.0L ); -#endif - } - -e = e + pw2; - -/* Handle overflow */ -if( e > 0x7fffL ) - { - return( MAXNUML ); - } -*q &= 0x8000; -/* Handle denormalized results */ -if( e < 1 ) - { -#ifdef DENORMAL - if( e < -64 ) - return(0.0L); - -#ifdef IBMPC - *(q-1) |= 0x8000; -#endif -#ifdef MIEEE - *(q+2) |= 0x8000; -#endif - - while( e < 1 ) - { - u.y *= 0.5L; - e += 1; - } - e = 0; -#else - return(0.0L); -#endif - } - -*q |= (unsigned short) e & 0x7fff; -return(u.y); -} - diff --git a/libm/ldouble/flrtstl.c b/libm/ldouble/flrtstl.c deleted file mode 100644 index 77a389324..000000000 --- a/libm/ldouble/flrtstl.c +++ /dev/null @@ -1,104 +0,0 @@ -long double floorl(), ldexpl(), frexpl(); - -#define N 16382 -void prnum(); -int printf(); -void exit(); - -void main() -{ -long double x, f, y, last, z, z0, y1; -int i, k, e, e0, errs; - -errs = 0; -f = 0.1L; -x = f; -last = x; -z0 = frexpl( x, &e0 ); -printf( "frexpl(%.2Le) = %.5Le, %d\n", x, z0, e0 ); -k = 0; -for( i=0; i<N+5; i++ ) - { - y = ldexpl( f, k ); - if( y != x ) - { - printf( "ldexpl(%.1Le, %d) = %.5Le, s.b. %.5Le\n", - f, k, y, x ); - ++errs; - } - z = frexpl( y, &e ); - if( (e != k+e0) || (z != z0) ) - { - printf( "frexpl(%.1Le) = %.5Le, %d; s.b. %.5Le, %d\n", - y, z, e, z0, k+e0 ); - ++errs; - } - x += x; - if( x == last ) - break; - last = x; - k += 1; - } -printf( "i = %d\n", k ); -prnum( "last y =", &y ); -printf("\n"); - -f = 0.1L; -x = f; -last = x; -k = 0; -for( i=0; i<N+64; i++ ) - { - y = ldexpl( f, k ); - if( y != x ) - { - printf( "ldexpl(%.1Le, %d) = %.5Le, s.b. %.5Le\n", - f, k, y, x ); - ++errs; - } - z = frexpl( y, &e ); - if( -#if 1 - (e > -N+1) && -#endif - ((e != k+e0) || (z != z0)) ) - { - printf( "frexpl(%.1Le) = %.5Le, %d; s.b. %.5Le, %d\n", - y, z, e, z0, k+e0 ); - ++errs; - } - y1 = ldexpl( z, e ); - if( y1 != y ) - { - printf( "ldexpl(%.1Le, %d) = %.5Le, s.b. %.5Le\n", - z, e, y1, y ); - ++errs; - } - - x *= 0.5L; - if( x == 0.0L ) - break; - if( x == last ) - break; - last = x; - k -= 1; - } -printf( "i = %d\n", k ); -prnum( "last y =", &y ); - -printf( "\n%d errors\n", errs ); -exit(0); -} - - -void prnum(str, x) -char *str; -unsigned short *x; -{ -int i; - -printf( "%s ", str ); -printf( "%.5Le = ", *(long double *)x ); -for( i=0; i<5; i++ ) - printf( "%04x ", *x++ ); -} diff --git a/libm/ldouble/fltestl.c b/libm/ldouble/fltestl.c deleted file mode 100644 index 963e92467..000000000 --- a/libm/ldouble/fltestl.c +++ /dev/null @@ -1,265 +0,0 @@ -/* fltest.c - * Test program for floor(), frexp(), ldexp() - */ - -/* -Cephes Math Library Release 2.1: December, 1988 -Copyright 1984, 1987, 1988 by Stephen L. Moshier (moshier@world.std.com) -*/ - - - -/*#include <math.h>*/ -#define MACHEPL 5.42101086242752217003726400434970855712890625E-20L -#define N 16300 - -void flierr(); -int printf(); -void exit(); - -int -main() -{ -long double x, y, y0, z, f, x00, y00; -int i, j, e, e0; -int errfr, errld, errfl, underexp, err, errth, e00; -long double frexpl(), ldexpl(), floorl(); - - -/* -if( 1 ) - goto flrtst; -*/ - -printf( "Testing frexpl() and ldexpl().\n" ); -errth = 0.0L; -errfr = 0; -errld = 0; -underexp = 0; -f = 1.0L; -x00 = 2.0L; -y00 = 0.5L; -e00 = 2; - -for( j=0; j<20; j++ ) -{ -if( j == 10 ) - { - f = 1.0L; - x00 = 2.0L; - e00 = 1; -/* Find 2**(2**14) / 2 */ - for( i=0; i<13; i++ ) - { - x00 *= x00; - e00 += e00; - } - y00 = x00/2.0L; - x00 = x00 * y00; - e00 += e00; - y00 = 0.5L; - } -x = x00 * f; -y0 = y00 * f; -e0 = e00; - -#if 1 -/* If ldexp, frexp support denormal numbers, this should work. */ -for( i=0; i<16448; i++ ) -#else -for( i=0; i<16383; i++ ) -#endif - { - x /= 2.0L; - e0 -= 1; - if( x == 0.0L ) - { - if( f == 1.0L ) - underexp = e0; - y0 = 0.0L; - e0 = 0; - } - y = frexpl( x, &e ); - if( (e0 < -16383) && (e != e0) ) - { - if( e == (e0 - 1) ) - { - e += 1; - y /= 2.0L; - } - if( e == (e0 + 1) ) - { - e -= 1; - y *= 2.0L; - } - } - err = y - y0; - if( y0 != 0.0L ) - err /= y0; - if( err < 0.0L ) - err = -err; - if( e0 > -1023 ) - errth = 0.0L; - else - {/* Denormal numbers may have rounding errors */ - if( e0 == -16383 ) - { - errth = 2.0L * MACHEPL; - } - else - { - errth *= 2.0L; - } - } - - if( (x != 0.0L) && ((err > errth) || (e != e0)) ) - { - printf( "Test %d: ", j+1 ); - printf( " frexpl( %.20Le) =?= %.20Le * 2**%d;", x, y, e ); - printf( " should be %.20Le * 2**%d\n", y0, e0 ); - errfr += 1; - } - y = ldexpl( x, 1-e0 ); - err = y - 1.0L; - if( err < 0.0L ) - err = -err; - if( (err > errth) && ((x == 0.0L) && (y != 0.0L)) ) - { - printf( "Test %d: ", j+1 ); - printf( "ldexpl( %.15Le, %d ) =?= %.15Le;", x, 1-e0, y ); - if( x != 0.0L ) - printf( " should be %.15Le\n", f ); - else - printf( " should be %.15Le\n", 0.0L ); - errld += 1; - } - if( x == 0.0L ) - { - break; - } - } -f = f * 1.08005973889L; -} - -if( (errld == 0) && (errfr == 0) ) - { - printf( "No errors found.\n" ); - } - -/*flrtst:*/ - -printf( "Testing floorl().\n" ); -errfl = 0; - -f = 1.0L/MACHEPL; -x00 = 1.0L; -for( j=0; j<57; j++ ) -{ -x = x00 - 1.0L; -for( i=0; i<128; i++ ) - { - y = floorl(x); - if( y != x ) - { - flierr( x, y, j ); - errfl += 1; - } -/* Warning! the if() statement is compiler dependent, - * since x-0.49 may be held in extra precision accumulator - * so would never compare equal to x! The subroutine call - * y = floor() forces z to be stored as a double and reloaded - * for the if() statement. - */ - z = x - 0.49L; - y = floorl(z); - if( z == x ) - break; - if( y != (x - 1.0L) ) - { - flierr( z, y, j ); - errfl += 1; - } - - z = x + 0.49L; - y = floorl(z); - if( z != x ) - { - if( y != x ) - { - flierr( z, y, j ); - errfl += 1; - } - } - x = -x; - y = floorl(x); - if( z != x ) - { - if( y != x ) - { - flierr( x, y, j ); - errfl += 1; - } - } - z = x + 0.49L; - y = floorl(z); - if( z != x ) - { - if( y != x ) - { - flierr( z, y, j ); - errfl += 1; - } - } - z = x - 0.49L; - y = floorl(z); - if( z != x ) - { - if( y != (x - 1.0L) ) - { - flierr( z, y, j ); - errfl += 1; - } - } - x = -x; - x += 1.0L; - } -x00 = x00 + x00; -} -y = floorl(0.0L); -if( y != 0.0L ) - { - flierr( 0.0L, y, 57 ); - errfl += 1; - } -y = floorl(-0.0L); -if( y != 0.0L ) - { - flierr( -0.0L, y, 58 ); - errfl += 1; - } -y = floorl(-1.0L); -if( y != -1.0L ) - { - flierr( -1.0L, y, 59 ); - errfl += 1; - } -y = floorl(-0.1L); -if( y != -1.0l ) - { - flierr( -0.1L, y, 60 ); - errfl += 1; - } - -if( errfl == 0 ) - printf( "No errors found in floorl().\n" ); -exit(0); -return 0; -} - -void flierr( x, y, k ) -long double x, y; -int k; -{ -printf( "Test %d: ", k+1 ); -printf( "floorl(%.15Le) =?= %.15Le\n", x, y ); -} diff --git a/libm/ldouble/gammal.c b/libm/ldouble/gammal.c deleted file mode 100644 index de7ed89a2..000000000 --- a/libm/ldouble/gammal.c +++ /dev/null @@ -1,764 +0,0 @@ -/* gammal.c - * - * Gamma function - * - * - * - * SYNOPSIS: - * - * long double x, y, gammal(); - * extern int sgngam; - * - * y = gammal( x ); - * - * - * - * DESCRIPTION: - * - * Returns gamma function of the argument. The result is - * correctly signed, and the sign (+1 or -1) is also - * returned in a global (extern) variable named sgngam. - * This variable is also filled in by the logarithmic gamma - * function lgam(). - * - * Arguments |x| <= 13 are reduced by recurrence and the function - * approximated by a rational function of degree 7/8 in the - * interval (2,3). Large arguments are handled by Stirling's - * formula. Large negative arguments are made positive using - * a reflection formula. - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -40,+40 10000 3.6e-19 7.9e-20 - * IEEE -1755,+1755 10000 4.8e-18 6.5e-19 - * - * Accuracy for large arguments is dominated by error in powl(). - * - */ -/* lgaml() - * - * Natural logarithm of gamma function - * - * - * - * SYNOPSIS: - * - * long double x, y, lgaml(); - * extern int sgngam; - * - * y = lgaml( x ); - * - * - * - * DESCRIPTION: - * - * Returns the base e (2.718...) logarithm of the absolute - * value of the gamma function of the argument. - * The sign (+1 or -1) of the gamma function is returned in a - * global (extern) variable named sgngam. - * - * For arguments greater than 33, the logarithm of the gamma - * function is approximated by the logarithmic version of - * Stirling's formula using a polynomial approximation of - * degree 4. Arguments between -33 and +33 are reduced by - * recurrence to the interval [2,3] of a rational approximation. - * The cosecant reflection formula is employed for arguments - * less than -33. - * - * Arguments greater than MAXLGML (10^4928) return MAXNUML. - * - * - * - * ACCURACY: - * - * - * arithmetic domain # trials peak rms - * IEEE -40, 40 100000 2.2e-19 4.6e-20 - * IEEE 10^-2000,10^+2000 20000 1.6e-19 3.3e-20 - * The error criterion was relative when the function magnitude - * was greater than one but absolute when it was less than one. - * - */ - -/* gamma.c */ -/* gamma function */ - -/* -Copyright 1994 by Stephen L. Moshier -*/ - - -#include <math.h> -/* -gamma(x+2) = gamma(x+2) P(x)/Q(x) -0 <= x <= 1 -Relative error -n=7, d=8 -Peak error = 1.83e-20 -Relative error spread = 8.4e-23 -*/ -#if UNK -static long double P[8] = { - 4.212760487471622013093E-5L, - 4.542931960608009155600E-4L, - 4.092666828394035500949E-3L, - 2.385363243461108252554E-2L, - 1.113062816019361559013E-1L, - 3.629515436640239168939E-1L, - 8.378004301573126728826E-1L, - 1.000000000000000000009E0L, -}; -static long double Q[9] = { --1.397148517476170440917E-5L, - 2.346584059160635244282E-4L, --1.237799246653152231188E-3L, --7.955933682494738320586E-4L, - 2.773706565840072979165E-2L, --4.633887671244534213831E-2L, --2.243510905670329164562E-1L, - 4.150160950588455434583E-1L, - 9.999999999999999999908E-1L, -}; -#endif -#if IBMPC -static short P[] = { -0x434a,0x3f22,0x2bda,0xb0b2,0x3ff0, XPD -0xf5aa,0xe82f,0x335b,0xee2e,0x3ff3, XPD -0xbe6c,0x3757,0xc717,0x861b,0x3ff7, XPD -0x7f43,0x5196,0xb166,0xc368,0x3ff9, XPD -0x9549,0x8eb5,0x8c3a,0xe3f4,0x3ffb, XPD -0x8d75,0x23af,0xc8e4,0xb9d4,0x3ffd, XPD -0x29cf,0x19b3,0x16c8,0xd67a,0x3ffe, XPD -0x0000,0x0000,0x0000,0x8000,0x3fff, XPD -}; -static short Q[] = { -0x5473,0x2de8,0x1268,0xea67,0xbfee, XPD -0x334b,0xc2f0,0xa2dd,0xf60e,0x3ff2, XPD -0xbeed,0x1853,0xa691,0xa23d,0xbff5, XPD -0x296e,0x7cb1,0x5dfd,0xd08f,0xbff4, XPD -0x0417,0x7989,0xd7bc,0xe338,0x3ff9, XPD -0x3295,0x3698,0xd580,0xbdcd,0xbffa, XPD -0x75ef,0x3ab7,0x4ad3,0xe5bc,0xbffc, XPD -0xe458,0x2ec7,0xfd57,0xd47c,0x3ffd, XPD -0x0000,0x0000,0x0000,0x8000,0x3fff, XPD -}; -#endif -#if MIEEE -static long P[24] = { -0x3ff00000,0xb0b22bda,0x3f22434a, -0x3ff30000,0xee2e335b,0xe82ff5aa, -0x3ff70000,0x861bc717,0x3757be6c, -0x3ff90000,0xc368b166,0x51967f43, -0x3ffb0000,0xe3f48c3a,0x8eb59549, -0x3ffd0000,0xb9d4c8e4,0x23af8d75, -0x3ffe0000,0xd67a16c8,0x19b329cf, -0x3fff0000,0x80000000,0x00000000, -}; -static long Q[27] = { -0xbfee0000,0xea671268,0x2de85473, -0x3ff20000,0xf60ea2dd,0xc2f0334b, -0xbff50000,0xa23da691,0x1853beed, -0xbff40000,0xd08f5dfd,0x7cb1296e, -0x3ff90000,0xe338d7bc,0x79890417, -0xbffa0000,0xbdcdd580,0x36983295, -0xbffc0000,0xe5bc4ad3,0x3ab775ef, -0x3ffd0000,0xd47cfd57,0x2ec7e458, -0x3fff0000,0x80000000,0x00000000, -}; -#endif -/* -static long double P[] = { --3.01525602666895735709e0L, --3.25157411956062339893e1L, --2.92929976820724030353e2L, --1.70730828800510297666e3L, --7.96667499622741999770e3L, --2.59780216007146401957e4L, --5.99650230220855581642e4L, --7.15743521530849602425e4L -}; -static long double Q[] = { - 1.00000000000000000000e0L, --1.67955233807178858919e1L, - 8.85946791747759881659e1L, - 5.69440799097468430177e1L, --1.98526250512761318471e3L, - 3.31667508019495079814e3L, - 1.60577839621734713377e4L, --2.97045081369399940529e4L, --7.15743521530849602412e4L -}; -*/ -#define MAXGAML 1755.455L -/*static long double LOGPI = 1.14472988584940017414L;*/ - -/* Stirling's formula for the gamma function -gamma(x) = sqrt(2 pi) x^(x-.5) exp(-x) (1 + 1/x P(1/x)) -z(x) = x -13 <= x <= 1024 -Relative error -n=8, d=0 -Peak error = 9.44e-21 -Relative error spread = 8.8e-4 -*/ -#if UNK -static long double STIR[9] = { - 7.147391378143610789273E-4L, --2.363848809501759061727E-5L, --5.950237554056330156018E-4L, - 6.989332260623193171870E-5L, - 7.840334842744753003862E-4L, --2.294719747873185405699E-4L, --2.681327161876304418288E-3L, - 3.472222222230075327854E-3L, - 8.333333333333331800504E-2L, -}; -#endif -#if IBMPC -static short STIR[] = { -0x6ede,0x69f7,0x54e3,0xbb5d,0x3ff4, XPD -0xc395,0x0295,0x4443,0xc64b,0xbfef, XPD -0xba6f,0x7c59,0x5e47,0x9bfb,0xbff4, XPD -0x5704,0x1a39,0xb11d,0x9293,0x3ff1, XPD -0x30b7,0x1a21,0x98b2,0xcd87,0x3ff4, XPD -0xbef3,0x7023,0x6a08,0xf09e,0xbff2, XPD -0x3a1c,0x5ac8,0x3478,0xafb9,0xbff6, XPD -0xc3c9,0x906e,0x38e3,0xe38e,0x3ff6, XPD -0xa1d5,0xaaaa,0xaaaa,0xaaaa,0x3ffb, XPD -}; -#endif -#if MIEEE -static long STIR[27] = { -0x3ff40000,0xbb5d54e3,0x69f76ede, -0xbfef0000,0xc64b4443,0x0295c395, -0xbff40000,0x9bfb5e47,0x7c59ba6f, -0x3ff10000,0x9293b11d,0x1a395704, -0x3ff40000,0xcd8798b2,0x1a2130b7, -0xbff20000,0xf09e6a08,0x7023bef3, -0xbff60000,0xafb93478,0x5ac83a1c, -0x3ff60000,0xe38e38e3,0x906ec3c9, -0x3ffb0000,0xaaaaaaaa,0xaaaaa1d5, -}; -#endif -#define MAXSTIR 1024.0L -static long double SQTPI = 2.50662827463100050242E0L; - -/* 1/gamma(x) = z P(z) - * z(x) = 1/x - * 0 < x < 0.03125 - * Peak relative error 4.2e-23 - */ -#if UNK -static long double S[9] = { --1.193945051381510095614E-3L, - 7.220599478036909672331E-3L, --9.622023360406271645744E-3L, --4.219773360705915470089E-2L, - 1.665386113720805206758E-1L, --4.200263503403344054473E-2L, --6.558780715202540684668E-1L, - 5.772156649015328608253E-1L, - 1.000000000000000000000E0L, -}; -#endif -#if IBMPC -static short S[] = { -0xbaeb,0xd6d3,0x25e5,0x9c7e,0xbff5, XPD -0xfe9a,0xceb4,0xc74e,0xec9a,0x3ff7, XPD -0x9225,0xdfef,0xb0e9,0x9da5,0xbff8, XPD -0x10b0,0xec17,0x87dc,0xacd7,0xbffa, XPD -0x6b8d,0x7515,0x1905,0xaa89,0x3ffc, XPD -0xf183,0x126b,0xf47d,0xac0a,0xbffa, XPD -0x7bf6,0x57d1,0xa013,0xa7e7,0xbffe, XPD -0xc7a9,0x7db0,0x67e3,0x93c4,0x3ffe, XPD -0x0000,0x0000,0x0000,0x8000,0x3fff, XPD -}; -#endif -#if MIEEE -static long S[27] = { -0xbff50000,0x9c7e25e5,0xd6d3baeb, -0x3ff70000,0xec9ac74e,0xceb4fe9a, -0xbff80000,0x9da5b0e9,0xdfef9225, -0xbffa0000,0xacd787dc,0xec1710b0, -0x3ffc0000,0xaa891905,0x75156b8d, -0xbffa0000,0xac0af47d,0x126bf183, -0xbffe0000,0xa7e7a013,0x57d17bf6, -0x3ffe0000,0x93c467e3,0x7db0c7a9, -0x3fff0000,0x80000000,0x00000000, -}; -#endif -/* 1/gamma(-x) = z P(z) - * z(x) = 1/x - * 0 < x < 0.03125 - * Peak relative error 5.16e-23 - * Relative error spread = 2.5e-24 - */ -#if UNK -static long double SN[9] = { - 1.133374167243894382010E-3L, - 7.220837261893170325704E-3L, - 9.621911155035976733706E-3L, --4.219773343731191721664E-2L, --1.665386113944413519335E-1L, --4.200263503402112910504E-2L, - 6.558780715202536547116E-1L, - 5.772156649015328608727E-1L, --1.000000000000000000000E0L, -}; -#endif -#if IBMPC -static short SN[] = { -0x5dd1,0x02de,0xb9f7,0x948d,0x3ff5, XPD -0x989b,0xdd68,0xc5f1,0xec9c,0x3ff7, XPD -0x2ca1,0x18f0,0x386f,0x9da5,0x3ff8, XPD -0x783f,0x41dd,0x87d1,0xacd7,0xbffa, XPD -0x7a5b,0xd76d,0x1905,0xaa89,0xbffc, XPD -0x7f64,0x1234,0xf47d,0xac0a,0xbffa, XPD -0x5e26,0x57d1,0xa013,0xa7e7,0x3ffe, XPD -0xc7aa,0x7db0,0x67e3,0x93c4,0x3ffe, XPD -0x0000,0x0000,0x0000,0x8000,0xbfff, XPD -}; -#endif -#if MIEEE -static long SN[27] = { -0x3ff50000,0x948db9f7,0x02de5dd1, -0x3ff70000,0xec9cc5f1,0xdd68989b, -0x3ff80000,0x9da5386f,0x18f02ca1, -0xbffa0000,0xacd787d1,0x41dd783f, -0xbffc0000,0xaa891905,0xd76d7a5b, -0xbffa0000,0xac0af47d,0x12347f64, -0x3ffe0000,0xa7e7a013,0x57d15e26, -0x3ffe0000,0x93c467e3,0x7db0c7aa, -0xbfff0000,0x80000000,0x00000000, -}; -#endif - -int sgngaml = 0; -extern int sgngaml; -extern long double MAXLOGL, MAXNUML, PIL; -/* #define PIL 3.14159265358979323846L */ -/* #define MAXNUML 1.189731495357231765021263853E4932L */ - -#ifdef ANSIPROT -extern long double fabsl ( long double ); -extern long double lgaml ( long double ); -extern long double logl ( long double ); -extern long double expl ( long double ); -extern long double gammal ( long double ); -extern long double sinl ( long double ); -extern long double floorl ( long double ); -extern long double powl ( long double, long double ); -extern long double polevll ( long double, void *, int ); -extern long double p1evll ( long double, void *, int ); -extern int isnanl ( long double ); -extern int isfinitel ( long double ); -static long double stirf ( long double ); -#else -long double fabsl(), lgaml(), logl(), expl(), gammal(), sinl(); -long double floorl(), powl(), polevll(), p1evll(), isnanl(), isfinitel(); -static long double stirf(); -#endif -#ifdef INFINITIES -extern long double INFINITYL; -#endif -#ifdef NANS -extern long double NANL; -#endif - -/* Gamma function computed by Stirling's formula. - */ -static long double stirf(x) -long double x; -{ -long double y, w, v; - -w = 1.0L/x; -/* For large x, use rational coefficients from the analytical expansion. */ -if( x > 1024.0L ) - w = (((((6.97281375836585777429E-5L * w - + 7.84039221720066627474E-4L) * w - - 2.29472093621399176955E-4L) * w - - 2.68132716049382716049E-3L) * w - + 3.47222222222222222222E-3L) * w - + 8.33333333333333333333E-2L) * w - + 1.0L; -else - w = 1.0L + w * polevll( w, STIR, 8 ); -y = expl(x); -if( x > MAXSTIR ) - { /* Avoid overflow in pow() */ - v = powl( x, 0.5L * x - 0.25L ); - y = v * (v / y); - } -else - { - y = powl( x, x - 0.5L ) / y; - } -y = SQTPI * y * w; -return( y ); -} - - - -long double gammal(x) -long double x; -{ -long double p, q, z; -int i; - -sgngaml = 1; -#ifdef NANS -if( isnanl(x) ) - return(NANL); -#endif -#ifdef INFINITIES -if(x == INFINITYL) - return(INFINITYL); -#ifdef NANS -if(x == -INFINITYL) - goto gamnan; -#endif -#endif -q = fabsl(x); - -if( q > 13.0L ) - { - if( q > MAXGAML ) - goto goverf; - if( x < 0.0L ) - { - p = floorl(q); - if( p == q ) - { -gamnan: -#ifdef NANS - mtherr( "gammal", DOMAIN ); - return (NANL); -#else - goto goverf; -#endif - } - i = p; - if( (i & 1) == 0 ) - sgngaml = -1; - z = q - p; - if( z > 0.5L ) - { - p += 1.0L; - z = q - p; - } - z = q * sinl( PIL * z ); - z = fabsl(z) * stirf(q); - if( z <= PIL/MAXNUML ) - { -goverf: -#ifdef INFINITIES - return( sgngaml * INFINITYL); -#else - mtherr( "gammal", OVERFLOW ); - return( sgngaml * MAXNUML); -#endif - } - z = PIL/z; - } - else - { - z = stirf(x); - } - return( sgngaml * z ); - } - -z = 1.0L; -while( x >= 3.0L ) - { - x -= 1.0L; - z *= x; - } - -while( x < -0.03125L ) - { - z /= x; - x += 1.0L; - } - -if( x <= 0.03125L ) - goto small; - -while( x < 2.0L ) - { - z /= x; - x += 1.0L; - } - -if( x == 2.0L ) - return(z); - -x -= 2.0L; -p = polevll( x, P, 7 ); -q = polevll( x, Q, 8 ); -return( z * p / q ); - -small: -if( x == 0.0L ) - { - goto gamnan; - } -else - { - if( x < 0.0L ) - { - x = -x; - q = z / (x * polevll( x, SN, 8 )); - } - else - q = z / (x * polevll( x, S, 8 )); - } -return q; -} - - - -/* A[]: Stirling's formula expansion of log gamma - * B[], C[]: log gamma function between 2 and 3 - */ - - -/* log gamma(x) = ( x - 0.5 ) * log(x) - x + LS2PI + 1/x A(1/x^2) - * x >= 8 - * Peak relative error 1.51e-21 - * Relative spread of error peaks 5.67e-21 - */ -#if UNK -static long double A[7] = { - 4.885026142432270781165E-3L, --1.880801938119376907179E-3L, - 8.412723297322498080632E-4L, --5.952345851765688514613E-4L, - 7.936507795855070755671E-4L, --2.777777777750349603440E-3L, - 8.333333333333331447505E-2L, -}; -#endif -#if IBMPC -static short A[] = { -0xd984,0xcc08,0x91c2,0xa012,0x3ff7, XPD -0x3d91,0x0304,0x3da1,0xf685,0xbff5, XPD -0x3bdc,0xaad1,0xd492,0xdc88,0x3ff4, XPD -0x8b20,0x9fce,0x844e,0x9c09,0xbff4, XPD -0xf8f2,0x30e5,0x0092,0xd00d,0x3ff4, XPD -0x4d88,0x03a8,0x60b6,0xb60b,0xbff6, XPD -0x9fcc,0xaaaa,0xaaaa,0xaaaa,0x3ffb, XPD -}; -#endif -#if MIEEE -static long A[21] = { -0x3ff70000,0xa01291c2,0xcc08d984, -0xbff50000,0xf6853da1,0x03043d91, -0x3ff40000,0xdc88d492,0xaad13bdc, -0xbff40000,0x9c09844e,0x9fce8b20, -0x3ff40000,0xd00d0092,0x30e5f8f2, -0xbff60000,0xb60b60b6,0x03a84d88, -0x3ffb0000,0xaaaaaaaa,0xaaaa9fcc, -}; -#endif - -/* log gamma(x+2) = x B(x)/C(x) - * 0 <= x <= 1 - * Peak relative error 7.16e-22 - * Relative spread of error peaks 4.78e-20 - */ -#if UNK -static long double B[7] = { --2.163690827643812857640E3L, --8.723871522843511459790E4L, --1.104326814691464261197E6L, --6.111225012005214299996E6L, --1.625568062543700591014E7L, --2.003937418103815175475E7L, --8.875666783650703802159E6L, -}; -static long double C[7] = { -/* 1.000000000000000000000E0L,*/ --5.139481484435370143617E2L, --3.403570840534304670537E4L, --6.227441164066219501697E5L, --4.814940379411882186630E6L, --1.785433287045078156959E7L, --3.138646407656182662088E7L, --2.099336717757895876142E7L, -}; -#endif -#if IBMPC -static short B[] = { -0x9557,0x4995,0x0da1,0x873b,0xc00a, XPD -0xfe44,0x9af8,0x5b8c,0xaa63,0xc00f, XPD -0x5aa8,0x7cf5,0x3684,0x86ce,0xc013, XPD -0x259a,0x258c,0xf206,0xba7f,0xc015, XPD -0xbe18,0x1ca3,0xc0a0,0xf80a,0xc016, XPD -0x168f,0x2c42,0x6717,0x98e3,0xc017, XPD -0x2051,0x9d55,0x92c8,0x876e,0xc016, XPD -}; -static short C[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ -0xaa77,0xcf2f,0xae76,0x807c,0xc008, XPD -0xb280,0x0d74,0xb55a,0x84f3,0xc00e, XPD -0xa505,0xcd30,0x81dc,0x9809,0xc012, XPD -0x3369,0x4246,0xb8c2,0x92f0,0xc015, XPD -0x63cf,0x6aee,0xbe6f,0x8837,0xc017, XPD -0x26bb,0xccc7,0xb009,0xef75,0xc017, XPD -0x462b,0xbae8,0xab96,0xa02a,0xc017, XPD -}; -#endif -#if MIEEE -static long B[21] = { -0xc00a0000,0x873b0da1,0x49959557, -0xc00f0000,0xaa635b8c,0x9af8fe44, -0xc0130000,0x86ce3684,0x7cf55aa8, -0xc0150000,0xba7ff206,0x258c259a, -0xc0160000,0xf80ac0a0,0x1ca3be18, -0xc0170000,0x98e36717,0x2c42168f, -0xc0160000,0x876e92c8,0x9d552051, -}; -static long C[21] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0xc0080000,0x807cae76,0xcf2faa77, -0xc00e0000,0x84f3b55a,0x0d74b280, -0xc0120000,0x980981dc,0xcd30a505, -0xc0150000,0x92f0b8c2,0x42463369, -0xc0170000,0x8837be6f,0x6aee63cf, -0xc0170000,0xef75b009,0xccc726bb, -0xc0170000,0xa02aab96,0xbae8462b, -}; -#endif - -/* log( sqrt( 2*pi ) ) */ -static long double LS2PI = 0.91893853320467274178L; -#define MAXLGM 1.04848146839019521116e+4928L - - -/* Logarithm of gamma function */ - - -long double lgaml(x) -long double x; -{ -long double p, q, w, z, f, nx; -int i; - -sgngaml = 1; -#ifdef NANS -if( isnanl(x) ) - return(NANL); -#endif -#ifdef INFINITIES -if( !isfinitel(x) ) - return(INFINITYL); -#endif -if( x < -34.0L ) - { - q = -x; - w = lgaml(q); /* note this modifies sgngam! */ - p = floorl(q); - if( p == q ) - { -#ifdef INFINITIES - mtherr( "lgaml", SING ); - return (INFINITYL); -#else - goto loverf; -#endif - } - i = p; - if( (i & 1) == 0 ) - sgngaml = -1; - else - sgngaml = 1; - z = q - p; - if( z > 0.5L ) - { - p += 1.0L; - z = p - q; - } - z = q * sinl( PIL * z ); - if( z == 0.0L ) - goto loverf; -/* z = LOGPI - logl( z ) - w; */ - z = logl( PIL/z ) - w; - return( z ); - } - -if( x < 13.0L ) - { - z = 1.0L; - nx = floorl( x + 0.5L ); - f = x - nx; - while( x >= 3.0L ) - { - nx -= 1.0L; - x = nx + f; - z *= x; - } - while( x < 2.0L ) - { - if( fabsl(x) <= 0.03125 ) - goto lsmall; - z /= nx + f; - nx += 1.0L; - x = nx + f; - } - if( z < 0.0L ) - { - sgngaml = -1; - z = -z; - } - else - sgngaml = 1; - if( x == 2.0L ) - return( logl(z) ); - x = (nx - 2.0L) + f; - p = x * polevll( x, B, 6 ) / p1evll( x, C, 7); - return( logl(z) + p ); - } - -if( x > MAXLGM ) - { -loverf: -#ifdef INFINITIES - return( sgngaml * INFINITYL ); -#else - mtherr( "lgaml", OVERFLOW ); - return( sgngaml * MAXNUML ); -#endif - } - -q = ( x - 0.5L ) * logl(x) - x + LS2PI; -if( x > 1.0e10L ) - return(q); -p = 1.0L/(x*x); -q += polevll( p, A, 6 ) / x; -return( q ); - - -lsmall: -if( x == 0.0L ) - goto loverf; -if( x < 0.0L ) - { - x = -x; - q = z / (x * polevll( x, SN, 8 )); - } -else - q = z / (x * polevll( x, S, 8 )); -if( q < 0.0L ) - { - sgngaml = -1; - q = -q; - } -else - sgngaml = 1; -q = logl( q ); -return(q); -} diff --git a/libm/ldouble/gdtrl.c b/libm/ldouble/gdtrl.c deleted file mode 100644 index 9a41790cb..000000000 --- a/libm/ldouble/gdtrl.c +++ /dev/null @@ -1,130 +0,0 @@ -/* gdtrl.c - * - * Gamma distribution function - * - * - * - * SYNOPSIS: - * - * long double a, b, x, y, gdtrl(); - * - * y = gdtrl( a, b, x ); - * - * - * - * DESCRIPTION: - * - * Returns the integral from zero to x of the gamma probability - * density function: - * - * - * x - * b - - * a | | b-1 -at - * y = ----- | t e dt - * - | | - * | (b) - - * 0 - * - * The incomplete gamma integral is used, according to the - * relation - * - * y = igam( b, ax ). - * - * - * ACCURACY: - * - * See igam(). - * - * ERROR MESSAGES: - * - * message condition value returned - * gdtrl domain x < 0 0.0 - * - */ - /* gdtrcl.c - * - * Complemented gamma distribution function - * - * - * - * SYNOPSIS: - * - * long double a, b, x, y, gdtrcl(); - * - * y = gdtrcl( a, b, x ); - * - * - * - * DESCRIPTION: - * - * Returns the integral from x to infinity of the gamma - * probability density function: - * - * - * inf. - * b - - * a | | b-1 -at - * y = ----- | t e dt - * - | | - * | (b) - - * x - * - * The incomplete gamma integral is used, according to the - * relation - * - * y = igamc( b, ax ). - * - * - * ACCURACY: - * - * See igamc(). - * - * ERROR MESSAGES: - * - * message condition value returned - * gdtrcl domain x < 0 0.0 - * - */ - -/* gdtrl() */ - - -/* -Cephes Math Library Release 2.3: March, 1995 -Copyright 1984, 1995 by Stephen L. Moshier -*/ - -#include <math.h> -#ifdef ANSIPROT -extern long double igaml ( long double, long double ); -extern long double igamcl ( long double, long double ); -#else -long double igaml(), igamcl(); -#endif - -long double gdtrl( a, b, x ) -long double a, b, x; -{ - -if( x < 0.0L ) - { - mtherr( "gdtrl", DOMAIN ); - return( 0.0L ); - } -return( igaml( b, a * x ) ); -} - - - -long double gdtrcl( a, b, x ) -long double a, b, x; -{ - -if( x < 0.0L ) - { - mtherr( "gdtrcl", DOMAIN ); - return( 0.0L ); - } -return( igamcl( b, a * x ) ); -} diff --git a/libm/ldouble/gelsl.c b/libm/ldouble/gelsl.c deleted file mode 100644 index d66ad55e9..000000000 --- a/libm/ldouble/gelsl.c +++ /dev/null @@ -1,240 +0,0 @@ -/* -C -C .................................................................. -C -C SUBROUTINE GELS -C -C PURPOSE -C TO SOLVE A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH -C SYMMETRIC COEFFICIENT MATRIX UPPER TRIANGULAR PART OF WHICH -C IS ASSUMED TO BE STORED COLUMNWISE. -C -C USAGE -C CALL GELS(R,A,M,N,EPS,IER,AUX) -C -C DESCRIPTION OF PARAMETERS -C R - M BY N RIGHT HAND SIDE MATRIX. (DESTROYED) -C ON RETURN R CONTAINS THE SOLUTION OF THE EQUATIONS. -C A - UPPER TRIANGULAR PART OF THE SYMMETRIC -C M BY M COEFFICIENT MATRIX. (DESTROYED) -C M - THE NUMBER OF EQUATIONS IN THE SYSTEM. -C N - THE NUMBER OF RIGHT HAND SIDE VECTORS. -C EPS - AN INPUT CONSTANT WHICH IS USED AS RELATIVE -C TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE. -C IER - RESULTING ERROR PARAMETER CODED AS FOLLOWS -C IER=0 - NO ERROR, -C IER=-1 - NO RESULT BECAUSE OF M LESS THAN 1 OR -C PIVOT ELEMENT AT ANY ELIMINATION STEP -C EQUAL TO 0, -C IER=K - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI- -C CANCE INDICATED AT ELIMINATION STEP K+1, -C WHERE PIVOT ELEMENT WAS LESS THAN OR -C EQUAL TO THE INTERNAL TOLERANCE EPS TIMES -C ABSOLUTELY GREATEST MAIN DIAGONAL -C ELEMENT OF MATRIX A. -C AUX - AN AUXILIARY STORAGE ARRAY WITH DIMENSION M-1. -C -C REMARKS -C UPPER TRIANGULAR PART OF MATRIX A IS ASSUMED TO BE STORED -C COLUMNWISE IN M*(M+1)/2 SUCCESSIVE STORAGE LOCATIONS, RIGHT -C HAND SIDE MATRIX R COLUMNWISE IN N*M SUCCESSIVE STORAGE -C LOCATIONS. ON RETURN SOLUTION MATRIX R IS STORED COLUMNWISE -C TOO. -C THE PROCEDURE GIVES RESULTS IF THE NUMBER OF EQUATIONS M IS -C GREATER THAN 0 AND PIVOT ELEMENTS AT ALL ELIMINATION STEPS -C ARE DIFFERENT FROM 0. HOWEVER WARNING IER=K - IF GIVEN - -C INDICATES POSSIBLE LOSS OF SIGNIFICANCE. IN CASE OF A WELL -C SCALED MATRIX A AND APPROPRIATE TOLERANCE EPS, IER=K MAY BE -C INTERPRETED THAT MATRIX A HAS THE RANK K. NO WARNING IS -C GIVEN IN CASE M=1. -C ERROR PARAMETER IER=-1 DOES NOT NECESSARILY MEAN THAT -C MATRIX A IS SINGULAR, AS ONLY MAIN DIAGONAL ELEMENTS -C ARE USED AS PIVOT ELEMENTS. POSSIBLY SUBROUTINE GELG (WHICH -C WORKS WITH TOTAL PIVOTING) WOULD BE ABLE TO FIND A SOLUTION. -C -C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED -C NONE -C -C METHOD -C SOLUTION IS DONE BY MEANS OF GAUSS-ELIMINATION WITH -C PIVOTING IN MAIN DIAGONAL, IN ORDER TO PRESERVE -C SYMMETRY IN REMAINING COEFFICIENT MATRICES. -C -C .................................................................. -C -*/ - -#include <stdio.h> -#define fabsl(x) ( (x) < 0.0L ? -(x) : (x) ) - -int gels( A, R, M, EPS, AUX ) -long double A[],R[]; -int M; -long double EPS; -long double AUX[]; -{ -int I, J, K, L, IER; -int II, LL, LLD, LR, LT, LST, LLST, LEND; -long double tb, piv, tol, pivi; - -IER = 0; -if( M <= 0 ) - { -fatal: - IER = -1; - goto done; - } -/* SEARCH FOR GREATEST MAIN DIAGONAL ELEMENT */ - -/* Diagonal elements are at A(i,i) = 0, 2, 5, 9, 14, ... - * A(i,j) = A( i(i-1)/2 + j - 1 ) - */ -piv = 0.0L; -I = 0; -J = 0; -L = 0; -for( K=1; K<=M; K++ ) - { - L += K; - tb = fabsl( A[L-1] ); - if( tb > piv ) - { - piv = tb; - I = L; - J = K; - } - } -tol = EPS * piv; - -/* -C MAIN DIAGONAL ELEMENT A(I)=A(J,J) IS FIRST PIVOT ELEMENT. -C PIV CONTAINS THE ABSOLUTE VALUE OF A(I). -*/ - -/* START ELIMINATION LOOP */ -LST = 0; -LEND = M - 1; -for( K=1; K<=M; K++ ) - { -/* TEST ON USEFULNESS OF SYMMETRIC ALGORITHM */ - if( piv <= 0.0L ) - { - printf( "gels: piv <= 0 at K = %d\n", K ); - goto fatal; - } - if( IER == 0 ) - { - if( piv <= tol ) - { - IER = K; -/* - goto done; -*/ - } - } - LT = J - K; - LST += K; - -/* PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R */ - pivi = 1.0L / A[I-1]; - L = K; - LL = L + LT; - tb = pivi * R[LL-1]; - R[LL-1] = R[L-1]; - R[L-1] = tb; -/* IS ELIMINATION TERMINATED */ - if( K >= M ) - break; -/* -C ROW AND COLUMN INTERCHANGE AND PIVOT ROW REDUCTION IN MATRIX A. -C ELEMENTS OF PIVOT COLUMN ARE SAVED IN AUXILIARY VECTOR AUX. -*/ - LR = LST + (LT*(K+J-1))/2; - LL = LR; - L=LST; - for( II=K; II<=LEND; II++ ) - { - L += II; - LL += 1; - if( L == LR ) - { - A[LL-1] = A[LST-1]; - tb = A[L-1]; - goto lab13; - } - if( L > LR ) - LL = L + LT; - - tb = A[LL-1]; - A[LL-1] = A[L-1]; -lab13: - AUX[II-1] = tb; - A[L-1] = pivi * tb; - } -/* SAVE COLUMN INTERCHANGE INFORMATION */ - A[LST-1] = LT; -/* ELEMENT REDUCTION AND SEARCH FOR NEXT PIVOT */ - piv = 0.0L; - LLST = LST; - LT = 0; - for( II=K; II<=LEND; II++ ) - { - pivi = -AUX[II-1]; - LL = LLST; - LT += 1; - for( LLD=II; LLD<=LEND; LLD++ ) - { - LL += LLD; - L = LL + LT; - A[L-1] += pivi * A[LL-1]; - } - LLST += II; - LR = LLST + LT; - tb =fabsl( A[LR-1] ); - if( tb > piv ) - { - piv = tb; - I = LR; - J = II + 1; - } - LR = K; - LL = LR + LT; - R[LL-1] += pivi * R[LR-1]; - } - } -/* END OF ELIMINATION LOOP */ - -/* BACK SUBSTITUTION AND BACK INTERCHANGE */ - -if( LEND <= 0 ) - { - printf( "gels: LEND = %d\n", LEND ); - if( LEND < 0 ) - goto fatal; - goto done; - } -II = M; -for( I=2; I<=M; I++ ) - { - LST -= II; - II -= 1; - L = A[LST-1] + 0.5L; - J = II; - tb = R[J-1]; - LL = J; - K = LST; - for( LT=II; LT<=LEND; LT++ ) - { - LL += 1; - K += LT; - tb -= A[K-1] * R[LL-1]; - } - K = J + L; - R[J-1] = R[K-1]; - R[K-1] = tb; - } -done: -if( IER ) - printf( "gels error %d!\n", IER ); -return( IER ); -} diff --git a/libm/ldouble/ieee.c b/libm/ldouble/ieee.c deleted file mode 100644 index 584329b0c..000000000 --- a/libm/ldouble/ieee.c +++ /dev/null @@ -1,4182 +0,0 @@ -/* ieee.c - * - * Extended precision IEEE binary floating point arithmetic routines - * - * Numbers are stored in C language as arrays of 16-bit unsigned - * short integers. The arguments of the routines are pointers to - * the arrays. - * - * - * External e type data structure, simulates Intel 8087 chip - * temporary real format but possibly with a larger significand: - * - * NE-1 significand words (least significant word first, - * most significant bit is normally set) - * exponent (value = EXONE for 1.0, - * top bit is the sign) - * - * - * Internal data structure of a number (a "word" is 16 bits): - * - * ei[0] sign word (0 for positive, 0xffff for negative) - * ei[1] biased exponent (value = EXONE for the number 1.0) - * ei[2] high guard word (always zero after normalization) - * ei[3] - * to ei[NI-2] significand (NI-4 significand words, - * most significant word first, - * most significant bit is set) - * ei[NI-1] low guard word (0x8000 bit is rounding place) - * - * - * - * Routines for external format numbers - * - * asctoe( string, e ) ASCII string to extended double e type - * asctoe64( string, &d ) ASCII string to long double - * asctoe53( string, &d ) ASCII string to double - * asctoe24( string, &f ) ASCII string to single - * asctoeg( string, e, prec ) ASCII string to specified precision - * e24toe( &f, e ) IEEE single precision to e type - * e53toe( &d, e ) IEEE double precision to e type - * e64toe( &d, e ) IEEE long double precision to e type - * eabs(e) absolute value - * eadd( a, b, c ) c = b + a - * eclear(e) e = 0 - * ecmp (a, b) Returns 1 if a > b, 0 if a == b, - * -1 if a < b, -2 if either a or b is a NaN. - * ediv( a, b, c ) c = b / a - * efloor( a, b ) truncate to integer, toward -infinity - * efrexp( a, exp, s ) extract exponent and significand - * eifrac( e, &l, frac ) e to long integer and e type fraction - * euifrac( e, &l, frac ) e to unsigned long integer and e type fraction - * einfin( e ) set e to infinity, leaving its sign alone - * eldexp( a, n, b ) multiply by 2**n - * emov( a, b ) b = a - * emul( a, b, c ) c = b * a - * eneg(e) e = -e - * eround( a, b ) b = nearest integer value to a - * esub( a, b, c ) c = b - a - * e24toasc( &f, str, n ) single to ASCII string, n digits after decimal - * e53toasc( &d, str, n ) double to ASCII string, n digits after decimal - * e64toasc( &d, str, n ) long double to ASCII string - * etoasc( e, str, n ) e to ASCII string, n digits after decimal - * etoe24( e, &f ) convert e type to IEEE single precision - * etoe53( e, &d ) convert e type to IEEE double precision - * etoe64( e, &d ) convert e type to IEEE long double precision - * ltoe( &l, e ) long (32 bit) integer to e type - * ultoe( &l, e ) unsigned long (32 bit) integer to e type - * eisneg( e ) 1 if sign bit of e != 0, else 0 - * eisinf( e ) 1 if e has maximum exponent (non-IEEE) - * or is infinite (IEEE) - * eisnan( e ) 1 if e is a NaN - * esqrt( a, b ) b = square root of a - * - * - * Routines for internal format numbers - * - * eaddm( ai, bi ) add significands, bi = bi + ai - * ecleaz(ei) ei = 0 - * ecleazs(ei) set ei = 0 but leave its sign alone - * ecmpm( ai, bi ) compare significands, return 1, 0, or -1 - * edivm( ai, bi ) divide significands, bi = bi / ai - * emdnorm(ai,l,s,exp) normalize and round off - * emovi( a, ai ) convert external a to internal ai - * emovo( ai, a ) convert internal ai to external a - * emovz( ai, bi ) bi = ai, low guard word of bi = 0 - * emulm( ai, bi ) multiply significands, bi = bi * ai - * enormlz(ei) left-justify the significand - * eshdn1( ai ) shift significand and guards down 1 bit - * eshdn8( ai ) shift down 8 bits - * eshdn6( ai ) shift down 16 bits - * eshift( ai, n ) shift ai n bits up (or down if n < 0) - * eshup1( ai ) shift significand and guards up 1 bit - * eshup8( ai ) shift up 8 bits - * eshup6( ai ) shift up 16 bits - * esubm( ai, bi ) subtract significands, bi = bi - ai - * - * - * The result is always normalized and rounded to NI-4 word precision - * after each arithmetic operation. - * - * Exception flags are NOT fully supported. - * - * Define INFINITY in mconf.h for support of infinity; otherwise a - * saturation arithmetic is implemented. - * - * Define NANS for support of Not-a-Number items; otherwise the - * arithmetic will never produce a NaN output, and might be confused - * by a NaN input. - * If NaN's are supported, the output of ecmp(a,b) is -2 if - * either a or b is a NaN. This means asking if(ecmp(a,b) < 0) - * may not be legitimate. Use if(ecmp(a,b) == -1) for less-than - * if in doubt. - * Signaling NaN's are NOT supported; they are treated the same - * as quiet NaN's. - * - * Denormals are always supported here where appropriate (e.g., not - * for conversion to DEC numbers). - */ - -/* - * Revision history: - * - * 5 Jan 84 PDP-11 assembly language version - * 2 Mar 86 fixed bug in asctoq() - * 6 Dec 86 C language version - * 30 Aug 88 100 digit version, improved rounding - * 15 May 92 80-bit long double support - * - * Author: S. L. Moshier. - */ - -#include <stdio.h> -#include <math.h> -#include "ehead.h" - -/* Change UNK into something else. */ -#ifdef UNK -#undef UNK -#if BIGENDIAN -#define MIEEE 1 -#else -#define IBMPC 1 -#endif -#endif - -/* NaN's require infinity support. */ -#ifdef NANS -#ifndef INFINITY -#define INFINITY -#endif -#endif - -/* This handles 64-bit long ints. */ -#define LONGBITS (8 * sizeof(long)) - -/* Control register for rounding precision. - * This can be set to 80 (if NE=6), 64, 56, 53, or 24 bits. - */ -int rndprc = NBITS; -extern int rndprc; - -#ifdef ANSIPROT -extern void eaddm ( unsigned short *, unsigned short * ); -extern void esubm ( unsigned short *, unsigned short * ); -extern void emdnorm ( unsigned short *, int, int, long, int ); -extern void asctoeg ( char *, unsigned short *, int ); -extern void enan ( unsigned short *, int ); -extern void asctoe24 ( char *, unsigned short * ); -extern void asctoe53 ( char *, unsigned short * ); -extern void asctoe64 ( char *, unsigned short * ); -extern void asctoe113 ( char *, unsigned short * ); -extern void eremain ( unsigned short *, unsigned short *, unsigned short * ); -extern void einit ( void ); -extern void eiremain ( unsigned short *, unsigned short * ); -extern int ecmp ( unsigned short *, unsigned short * ); -extern int edivm ( unsigned short *, unsigned short * ); -extern int emulm ( unsigned short *, unsigned short * ); -extern int eisneg ( unsigned short * ); -extern int eisinf ( unsigned short * ); -extern void emovi ( unsigned short *, unsigned short * ); -extern void emovo ( unsigned short *, unsigned short * ); -extern void emovz ( unsigned short *, unsigned short * ); -extern void ecleaz ( unsigned short * ); -extern void eadd1 ( unsigned short *, unsigned short *, unsigned short * ); -extern int eisnan ( unsigned short * ); -extern int eiisnan ( unsigned short * ); -static void toe24( unsigned short *, unsigned short * ); -static void toe53( unsigned short *, unsigned short * ); -static void toe64( unsigned short *, unsigned short * ); -static void toe113( unsigned short *, unsigned short * ); -void einfin ( unsigned short * ); -void eshdn1 ( unsigned short * ); -void eshup1 ( unsigned short * ); -void eshup6 ( unsigned short * ); -void eshdn6 ( unsigned short * ); -void eshup8 ( unsigned short * ); -void eshdn8 ( unsigned short * ); -void m16m ( unsigned short, unsigned short *, unsigned short * ); -int ecmpm ( unsigned short *, unsigned short * ); -int enormlz ( unsigned short * ); -void ecleazs ( unsigned short * ); -int eshift ( unsigned short *, int ); -void emov ( unsigned short *, unsigned short * ); -void eneg ( unsigned short * ); -void eclear ( unsigned short * ); -void efloor ( unsigned short *, unsigned short * ); -void eadd ( unsigned short *, unsigned short *, unsigned short * ); -void esub ( unsigned short *, unsigned short *, unsigned short * ); -void ediv ( unsigned short *, unsigned short *, unsigned short * ); -void emul ( unsigned short *, unsigned short *, unsigned short * ); -void e24toe ( unsigned short *, unsigned short * ); -void e53toe ( unsigned short *, unsigned short * ); -void e64toe ( unsigned short *, unsigned short * ); -void e113toe ( unsigned short *, unsigned short * ); -void etoasc ( unsigned short *, char *, int ); -static int eiisinf ( unsigned short * ); -#else -void eaddm(), esubm(), emdnorm(), asctoeg(), enan(); -static void toe24(), toe53(), toe64(), toe113(); -void eremain(), einit(), eiremain(); -int ecmpm(), edivm(), emulm(), eisneg(), eisinf(); -void emovi(), emovo(), emovz(), ecleaz(), eadd1(); -/* void etodec(), todec(), dectoe(); */ -int eisnan(), eiisnan(), ecmpm(), enormlz(), eshift(); -void einfin(), eshdn1(), eshup1(), eshup6(), eshdn6(); -void eshup8(), eshdn8(), m16m(); -void eadd(), esub(), ediv(), emul(); -void ecleazs(), emov(), eneg(), eclear(), efloor(); -void e24toe(), e53toe(), e64toe(), e113toe(), etoasc(); -static int eiisinf(); -#endif - - -void einit() -{ -} - -/* -; Clear out entire external format number. -; -; unsigned short x[]; -; eclear( x ); -*/ - -void eclear( x ) -register unsigned short *x; -{ -register int i; - -for( i=0; i<NE; i++ ) - *x++ = 0; -} - - - -/* Move external format number from a to b. - * - * emov( a, b ); - */ - -void emov( a, b ) -register unsigned short *a, *b; -{ -register int i; - -for( i=0; i<NE; i++ ) - *b++ = *a++; -} - - -/* -; Absolute value of external format number -; -; short x[NE]; -; eabs( x ); -*/ - -void eabs(x) -unsigned short x[]; /* x is the memory address of a short */ -{ - -x[NE-1] &= 0x7fff; /* sign is top bit of last word of external format */ -} - - - - -/* -; Negate external format number -; -; unsigned short x[NE]; -; eneg( x ); -*/ - -void eneg(x) -unsigned short x[]; -{ - -#ifdef NANS -if( eisnan(x) ) - return; -#endif -x[NE-1] ^= 0x8000; /* Toggle the sign bit */ -} - - - -/* Return 1 if external format number is negative, - * else return zero. - */ -int eisneg(x) -unsigned short x[]; -{ - -#ifdef NANS -if( eisnan(x) ) - return( 0 ); -#endif -if( x[NE-1] & 0x8000 ) - return( 1 ); -else - return( 0 ); -} - - -/* Return 1 if external format number has maximum possible exponent, - * else return zero. - */ -int eisinf(x) -unsigned short x[]; -{ - -if( (x[NE-1] & 0x7fff) == 0x7fff ) - { -#ifdef NANS - if( eisnan(x) ) - return( 0 ); -#endif - return( 1 ); - } -else - return( 0 ); -} - -/* Check if e-type number is not a number. - */ -int eisnan(x) -unsigned short x[]; -{ - -#ifdef NANS -int i; -/* NaN has maximum exponent */ -if( (x[NE-1] & 0x7fff) != 0x7fff ) - return (0); -/* ... and non-zero significand field. */ -for( i=0; i<NE-1; i++ ) - { - if( *x++ != 0 ) - return (1); - } -#endif -return (0); -} - -/* -; Fill entire number, including exponent and significand, with -; largest possible number. These programs implement a saturation -; value that is an ordinary, legal number. A special value -; "infinity" may also be implemented; this would require tests -; for that value and implementation of special rules for arithmetic -; operations involving inifinity. -*/ - -void einfin(x) -register unsigned short *x; -{ -register int i; - -#ifdef INFINITY -for( i=0; i<NE-1; i++ ) - *x++ = 0; -*x |= 32767; -#else -for( i=0; i<NE-1; i++ ) - *x++ = 0xffff; -*x |= 32766; -if( rndprc < NBITS ) - { - if (rndprc == 113) - { - *(x - 9) = 0; - *(x - 8) = 0; - } - if( rndprc == 64 ) - { - *(x-5) = 0; - } - if( rndprc == 53 ) - { - *(x-4) = 0xf800; - } - else - { - *(x-4) = 0; - *(x-3) = 0; - *(x-2) = 0xff00; - } - } -#endif -} - - - -/* Move in external format number, - * converting it to internal format. - */ -void emovi( a, b ) -unsigned short *a, *b; -{ -register unsigned short *p, *q; -int i; - -q = b; -p = a + (NE-1); /* point to last word of external number */ -/* get the sign bit */ -if( *p & 0x8000 ) - *q++ = 0xffff; -else - *q++ = 0; -/* get the exponent */ -*q = *p--; -*q++ &= 0x7fff; /* delete the sign bit */ -#ifdef INFINITY -if( (*(q-1) & 0x7fff) == 0x7fff ) - { -#ifdef NANS - if( eisnan(a) ) - { - *q++ = 0; - for( i=3; i<NI; i++ ) - *q++ = *p--; - return; - } -#endif - for( i=2; i<NI; i++ ) - *q++ = 0; - return; - } -#endif -/* clear high guard word */ -*q++ = 0; -/* move in the significand */ -for( i=0; i<NE-1; i++ ) - *q++ = *p--; -/* clear low guard word */ -*q = 0; -} - - -/* Move internal format number out, - * converting it to external format. - */ -void emovo( a, b ) -unsigned short *a, *b; -{ -register unsigned short *p, *q; -unsigned short i; - -p = a; -q = b + (NE-1); /* point to output exponent */ -/* combine sign and exponent */ -i = *p++; -if( i ) - *q-- = *p++ | 0x8000; -else - *q-- = *p++; -#ifdef INFINITY -if( *(p-1) == 0x7fff ) - { -#ifdef NANS - if( eiisnan(a) ) - { - enan( b, NBITS ); - return; - } -#endif - einfin(b); - return; - } -#endif -/* skip over guard word */ -++p; -/* move the significand */ -for( i=0; i<NE-1; i++ ) - *q-- = *p++; -} - - - - -/* Clear out internal format number. - */ - -void ecleaz( xi ) -register unsigned short *xi; -{ -register int i; - -for( i=0; i<NI; i++ ) - *xi++ = 0; -} - -/* same, but don't touch the sign. */ - -void ecleazs( xi ) -register unsigned short *xi; -{ -register int i; - -++xi; -for(i=0; i<NI-1; i++) - *xi++ = 0; -} - - - - -/* Move internal format number from a to b. - */ -void emovz( a, b ) -register unsigned short *a, *b; -{ -register int i; - -for( i=0; i<NI-1; i++ ) - *b++ = *a++; -/* clear low guard word */ -*b = 0; -} - -/* Return nonzero if internal format number is a NaN. - */ - -int eiisnan (x) -unsigned short x[]; -{ -int i; - -if( (x[E] & 0x7fff) == 0x7fff ) - { - for( i=M+1; i<NI; i++ ) - { - if( x[i] != 0 ) - return(1); - } - } -return(0); -} - -#ifdef INFINITY -/* Return nonzero if internal format number is infinite. */ - -static int -eiisinf (x) - unsigned short x[]; -{ - -#ifdef NANS - if (eiisnan (x)) - return (0); -#endif - if ((x[E] & 0x7fff) == 0x7fff) - return (1); - return (0); -} -#endif - -/* -; Compare significands of numbers in internal format. -; Guard words are included in the comparison. -; -; unsigned short a[NI], b[NI]; -; cmpm( a, b ); -; -; for the significands: -; returns +1 if a > b -; 0 if a == b -; -1 if a < b -*/ -int ecmpm( a, b ) -register unsigned short *a, *b; -{ -int i; - -a += M; /* skip up to significand area */ -b += M; -for( i=M; i<NI; i++ ) - { - if( *a++ != *b++ ) - goto difrnt; - } -return(0); - -difrnt: -if( *(--a) > *(--b) ) - return(1); -else - return(-1); -} - - -/* -; Shift significand down by 1 bit -*/ - -void eshdn1(x) -register unsigned short *x; -{ -register unsigned short bits; -int i; - -x += M; /* point to significand area */ - -bits = 0; -for( i=M; i<NI; i++ ) - { - if( *x & 1 ) - bits |= 1; - *x >>= 1; - if( bits & 2 ) - *x |= 0x8000; - bits <<= 1; - ++x; - } -} - - - -/* -; Shift significand up by 1 bit -*/ - -void eshup1(x) -register unsigned short *x; -{ -register unsigned short bits; -int i; - -x += NI-1; -bits = 0; - -for( i=M; i<NI; i++ ) - { - if( *x & 0x8000 ) - bits |= 1; - *x <<= 1; - if( bits & 2 ) - *x |= 1; - bits <<= 1; - --x; - } -} - - - -/* -; Shift significand down by 8 bits -*/ - -void eshdn8(x) -register unsigned short *x; -{ -register unsigned short newbyt, oldbyt; -int i; - -x += M; -oldbyt = 0; -for( i=M; i<NI; i++ ) - { - newbyt = *x << 8; - *x >>= 8; - *x |= oldbyt; - oldbyt = newbyt; - ++x; - } -} - -/* -; Shift significand up by 8 bits -*/ - -void eshup8(x) -register unsigned short *x; -{ -int i; -register unsigned short newbyt, oldbyt; - -x += NI-1; -oldbyt = 0; - -for( i=M; i<NI; i++ ) - { - newbyt = *x >> 8; - *x <<= 8; - *x |= oldbyt; - oldbyt = newbyt; - --x; - } -} - -/* -; Shift significand up by 16 bits -*/ - -void eshup6(x) -register unsigned short *x; -{ -int i; -register unsigned short *p; - -p = x + M; -x += M + 1; - -for( i=M; i<NI-1; i++ ) - *p++ = *x++; - -*p = 0; -} - -/* -; Shift significand down by 16 bits -*/ - -void eshdn6(x) -register unsigned short *x; -{ -int i; -register unsigned short *p; - -x += NI-1; -p = x + 1; - -for( i=M; i<NI-1; i++ ) - *(--p) = *(--x); - -*(--p) = 0; -} - -/* -; Add significands -; x + y replaces y -*/ - -void eaddm( x, y ) -unsigned short *x, *y; -{ -register unsigned long a; -int i; -unsigned int carry; - -x += NI-1; -y += NI-1; -carry = 0; -for( i=M; i<NI; i++ ) - { - a = (unsigned long )(*x) + (unsigned long )(*y) + carry; - if( a & 0x10000 ) - carry = 1; - else - carry = 0; - *y = (unsigned short )a; - --x; - --y; - } -} - -/* -; Subtract significands -; y - x replaces y -*/ - -void esubm( x, y ) -unsigned short *x, *y; -{ -unsigned long a; -int i; -unsigned int carry; - -x += NI-1; -y += NI-1; -carry = 0; -for( i=M; i<NI; i++ ) - { - a = (unsigned long )(*y) - (unsigned long )(*x) - carry; - if( a & 0x10000 ) - carry = 1; - else - carry = 0; - *y = (unsigned short )a; - --x; - --y; - } -} - - -/* Divide significands */ - -static unsigned short equot[NI] = {0}; /* was static */ - -#if 0 -int edivm( den, num ) -unsigned short den[], num[]; -{ -int i; -register unsigned short *p, *q; -unsigned short j; - -p = &equot[0]; -*p++ = num[0]; -*p++ = num[1]; - -for( i=M; i<NI; i++ ) - { - *p++ = 0; - } - -/* Use faster compare and subtraction if denominator - * has only 15 bits of significane. - */ -p = &den[M+2]; -if( *p++ == 0 ) - { - for( i=M+3; i<NI; i++ ) - { - if( *p++ != 0 ) - goto fulldiv; - } - if( (den[M+1] & 1) != 0 ) - goto fulldiv; - eshdn1(num); - eshdn1(den); - - p = &den[M+1]; - q = &num[M+1]; - - for( i=0; i<NBITS+2; i++ ) - { - if( *p <= *q ) - { - *q -= *p; - j = 1; - } - else - { - j = 0; - } - eshup1(equot); - equot[NI-2] |= j; - eshup1(num); - } - goto divdon; - } - -/* The number of quotient bits to calculate is - * NBITS + 1 scaling guard bit + 1 roundoff bit. - */ -fulldiv: - -p = &equot[NI-2]; -for( i=0; i<NBITS+2; i++ ) - { - if( ecmpm(den,num) <= 0 ) - { - esubm(den, num); - j = 1; /* quotient bit = 1 */ - } - else - j = 0; - eshup1(equot); - *p |= j; - eshup1(num); - } - -divdon: - -eshdn1( equot ); -eshdn1( equot ); - -/* test for nonzero remainder after roundoff bit */ -p = &num[M]; -j = 0; -for( i=M; i<NI; i++ ) - { - j |= *p++; - } -if( j ) - j = 1; - - -for( i=0; i<NI; i++ ) - num[i] = equot[i]; -return( (int )j ); -} - -/* Multiply significands */ -int emulm( a, b ) -unsigned short a[], b[]; -{ -unsigned short *p, *q; -int i, j, k; - -equot[0] = b[0]; -equot[1] = b[1]; -for( i=M; i<NI; i++ ) - equot[i] = 0; - -p = &a[NI-2]; -k = NBITS; -while( *p == 0 ) /* significand is not supposed to be all zero */ - { - eshdn6(a); - k -= 16; - } -if( (*p & 0xff) == 0 ) - { - eshdn8(a); - k -= 8; - } - -q = &equot[NI-1]; -j = 0; -for( i=0; i<k; i++ ) - { - if( *p & 1 ) - eaddm(b, equot); -/* remember if there were any nonzero bits shifted out */ - if( *q & 1 ) - j |= 1; - eshdn1(a); - eshdn1(equot); - } - -for( i=0; i<NI; i++ ) - b[i] = equot[i]; - -/* return flag for lost nonzero bits */ -return(j); -} - -#else - -/* Multiply significand of e-type number b -by 16-bit quantity a, e-type result to c. */ - -void m16m( a, b, c ) -unsigned short a; -unsigned short b[], c[]; -{ -register unsigned short *pp; -register unsigned long carry; -unsigned short *ps; -unsigned short p[NI]; -unsigned long aa, m; -int i; - -aa = a; -pp = &p[NI-2]; -*pp++ = 0; -*pp = 0; -ps = &b[NI-1]; - -for( i=M+1; i<NI; i++ ) - { - if( *ps == 0 ) - { - --ps; - --pp; - *(pp-1) = 0; - } - else - { - m = (unsigned long) aa * *ps--; - carry = (m & 0xffff) + *pp; - *pp-- = (unsigned short )carry; - carry = (carry >> 16) + (m >> 16) + *pp; - *pp = (unsigned short )carry; - *(pp-1) = carry >> 16; - } - } -for( i=M; i<NI; i++ ) - c[i] = p[i]; -} - - -/* Divide significands. Neither the numerator nor the denominator -is permitted to have its high guard word nonzero. */ - - -int edivm( den, num ) -unsigned short den[], num[]; -{ -int i; -register unsigned short *p; -unsigned long tnum; -unsigned short j, tdenm, tquot; -unsigned short tprod[NI+1]; - -p = &equot[0]; -*p++ = num[0]; -*p++ = num[1]; - -for( i=M; i<NI; i++ ) - { - *p++ = 0; - } -eshdn1( num ); -tdenm = den[M+1]; -for( i=M; i<NI; i++ ) - { - /* Find trial quotient digit (the radix is 65536). */ - tnum = (((unsigned long) num[M]) << 16) + num[M+1]; - - /* Do not execute the divide instruction if it will overflow. */ - if( (tdenm * ((unsigned long)0xffffL)) < tnum ) - tquot = 0xffff; - else - tquot = tnum / tdenm; - - /* Prove that the divide worked. */ -/* - tcheck = (unsigned long )tquot * tdenm; - if( tnum - tcheck > tdenm ) - tquot = 0xffff; -*/ - /* Multiply denominator by trial quotient digit. */ - m16m( tquot, den, tprod ); - /* The quotient digit may have been overestimated. */ - if( ecmpm( tprod, num ) > 0 ) - { - tquot -= 1; - esubm( den, tprod ); - if( ecmpm( tprod, num ) > 0 ) - { - tquot -= 1; - esubm( den, tprod ); - } - } -/* - if( ecmpm( tprod, num ) > 0 ) - { - eshow( "tprod", tprod ); - eshow( "num ", num ); - printf( "tnum = %08lx, tden = %04x, tquot = %04x\n", - tnum, den[M+1], tquot ); - } -*/ - esubm( tprod, num ); -/* - if( ecmpm( num, den ) >= 0 ) - { - eshow( "num ", num ); - eshow( "den ", den ); - printf( "tnum = %08lx, tden = %04x, tquot = %04x\n", - tnum, den[M+1], tquot ); - } -*/ - equot[i] = tquot; - eshup6(num); - } -/* test for nonzero remainder after roundoff bit */ -p = &num[M]; -j = 0; -for( i=M; i<NI; i++ ) - { - j |= *p++; - } -if( j ) - j = 1; - -for( i=0; i<NI; i++ ) - num[i] = equot[i]; - -return( (int )j ); -} - - - -/* Multiply significands */ -int emulm( a, b ) -unsigned short a[], b[]; -{ -unsigned short *p, *q; -unsigned short pprod[NI]; -unsigned short j; -int i; - -equot[0] = b[0]; -equot[1] = b[1]; -for( i=M; i<NI; i++ ) - equot[i] = 0; - -j = 0; -p = &a[NI-1]; -q = &equot[NI-1]; -for( i=M+1; i<NI; i++ ) - { - if( *p == 0 ) - { - --p; - } - else - { - m16m( *p--, b, pprod ); - eaddm(pprod, equot); - } - j |= *q; - eshdn6(equot); - } - -for( i=0; i<NI; i++ ) - b[i] = equot[i]; - -/* return flag for lost nonzero bits */ -return( (int)j ); -} - - -/* -eshow(str, x) -char *str; -unsigned short *x; -{ -int i; - -printf( "%s ", str ); -for( i=0; i<NI; i++ ) - printf( "%04x ", *x++ ); -printf( "\n" ); -} -*/ -#endif - - - -/* - * Normalize and round off. - * - * The internal format number to be rounded is "s". - * Input "lost" indicates whether the number is exact. - * This is the so-called sticky bit. - * - * Input "subflg" indicates whether the number was obtained - * by a subtraction operation. In that case if lost is nonzero - * then the number is slightly smaller than indicated. - * - * Input "exp" is the biased exponent, which may be negative. - * the exponent field of "s" is ignored but is replaced by - * "exp" as adjusted by normalization and rounding. - * - * Input "rcntrl" is the rounding control. - */ - -static int rlast = -1; -static int rw = 0; -static unsigned short rmsk = 0; -static unsigned short rmbit = 0; -static unsigned short rebit = 0; -static int re = 0; -static unsigned short rbit[NI] = {0,0,0,0,0,0,0,0}; - -void emdnorm( s, lost, subflg, exp, rcntrl ) -unsigned short s[]; -int lost; -int subflg; -long exp; -int rcntrl; -{ -int i, j; -unsigned short r; - -/* Normalize */ -j = enormlz( s ); - -/* a blank significand could mean either zero or infinity. */ -#ifndef INFINITY -if( j > NBITS ) - { - ecleazs( s ); - return; - } -#endif -exp -= j; -#ifndef INFINITY -if( exp >= 32767L ) - goto overf; -#else -if( (j > NBITS) && (exp < 32767L) ) - { - ecleazs( s ); - return; - } -#endif -if( exp < 0L ) - { - if( exp > (long )(-NBITS-1) ) - { - j = (int )exp; - i = eshift( s, j ); - if( i ) - lost = 1; - } - else - { - ecleazs( s ); - return; - } - } -/* Round off, unless told not to by rcntrl. */ -if( rcntrl == 0 ) - goto mdfin; -/* Set up rounding parameters if the control register changed. */ -if( rndprc != rlast ) - { - ecleaz( rbit ); - switch( rndprc ) - { - default: - case NBITS: - rw = NI-1; /* low guard word */ - rmsk = 0xffff; - rmbit = 0x8000; - rebit = 1; - re = rw - 1; - break; - case 113: - rw = 10; - rmsk = 0x7fff; - rmbit = 0x4000; - rebit = 0x8000; - re = rw; - break; - case 64: - rw = 7; - rmsk = 0xffff; - rmbit = 0x8000; - rebit = 1; - re = rw-1; - break; -/* For DEC arithmetic */ - case 56: - rw = 6; - rmsk = 0xff; - rmbit = 0x80; - rebit = 0x100; - re = rw; - break; - case 53: - rw = 6; - rmsk = 0x7ff; - rmbit = 0x0400; - rebit = 0x800; - re = rw; - break; - case 24: - rw = 4; - rmsk = 0xff; - rmbit = 0x80; - rebit = 0x100; - re = rw; - break; - } - rbit[re] = rebit; - rlast = rndprc; - } - -/* Shift down 1 temporarily if the data structure has an implied - * most significant bit and the number is denormal. - * For rndprc = 64 or NBITS, there is no implied bit. - * But Intel long double denormals lose one bit of significance even so. - */ -#ifdef IBMPC -if( (exp <= 0) && (rndprc != NBITS) ) -#else -if( (exp <= 0) && (rndprc != 64) && (rndprc != NBITS) ) -#endif - { - lost |= s[NI-1] & 1; - eshdn1(s); - } -/* Clear out all bits below the rounding bit, - * remembering in r if any were nonzero. - */ -r = s[rw] & rmsk; -if( rndprc < NBITS ) - { - i = rw + 1; - while( i < NI ) - { - if( s[i] ) - r |= 1; - s[i] = 0; - ++i; - } - } -s[rw] &= ~rmsk; -if( (r & rmbit) != 0 ) - { - if( r == rmbit ) - { - if( lost == 0 ) - { /* round to even */ - if( (s[re] & rebit) == 0 ) - goto mddone; - } - else - { - if( subflg != 0 ) - goto mddone; - } - } - eaddm( rbit, s ); - } -mddone: -#ifdef IBMPC -if( (exp <= 0) && (rndprc != NBITS) ) -#else -if( (exp <= 0) && (rndprc != 64) && (rndprc != NBITS) ) -#endif - { - eshup1(s); - } -if( s[2] != 0 ) - { /* overflow on roundoff */ - eshdn1(s); - exp += 1; - } -mdfin: -s[NI-1] = 0; -if( exp >= 32767L ) - { -#ifndef INFINITY -overf: -#endif -#ifdef INFINITY - s[1] = 32767; - for( i=2; i<NI-1; i++ ) - s[i] = 0; -#else - s[1] = 32766; - s[2] = 0; - for( i=M+1; i<NI-1; i++ ) - s[i] = 0xffff; - s[NI-1] = 0; - if( (rndprc < 64) || (rndprc == 113) ) - { - s[rw] &= ~rmsk; - if( rndprc == 24 ) - { - s[5] = 0; - s[6] = 0; - } - } -#endif - return; - } -if( exp < 0 ) - s[1] = 0; -else - s[1] = (unsigned short )exp; -} - - - -/* -; Subtract external format numbers. -; -; unsigned short a[NE], b[NE], c[NE]; -; esub( a, b, c ); c = b - a -*/ - -static int subflg = 0; - -void esub( a, b, c ) -unsigned short *a, *b, *c; -{ - -#ifdef NANS -if( eisnan(a) ) - { - emov (a, c); - return; - } -if( eisnan(b) ) - { - emov(b,c); - return; - } -/* Infinity minus infinity is a NaN. - * Test for subtracting infinities of the same sign. - */ -if( eisinf(a) && eisinf(b) && ((eisneg (a) ^ eisneg (b)) == 0)) - { - mtherr( "esub", DOMAIN ); - enan( c, NBITS ); - return; - } -#endif -subflg = 1; -eadd1( a, b, c ); -} - - -/* -; Add. -; -; unsigned short a[NE], b[NE], c[NE]; -; eadd( a, b, c ); c = b + a -*/ -void eadd( a, b, c ) -unsigned short *a, *b, *c; -{ - -#ifdef NANS -/* NaN plus anything is a NaN. */ -if( eisnan(a) ) - { - emov(a,c); - return; - } -if( eisnan(b) ) - { - emov(b,c); - return; - } -/* Infinity minus infinity is a NaN. - * Test for adding infinities of opposite signs. - */ -if( eisinf(a) && eisinf(b) - && ((eisneg(a) ^ eisneg(b)) != 0) ) - { - mtherr( "eadd", DOMAIN ); - enan( c, NBITS ); - return; - } -#endif -subflg = 0; -eadd1( a, b, c ); -} - -void eadd1( a, b, c ) -unsigned short *a, *b, *c; -{ -unsigned short ai[NI], bi[NI], ci[NI]; -int i, lost, j, k; -long lt, lta, ltb; - -#ifdef INFINITY -if( eisinf(a) ) - { - emov(a,c); - if( subflg ) - eneg(c); - return; - } -if( eisinf(b) ) - { - emov(b,c); - return; - } -#endif -emovi( a, ai ); -emovi( b, bi ); -if( subflg ) - ai[0] = ~ai[0]; - -/* compare exponents */ -lta = ai[E]; -ltb = bi[E]; -lt = lta - ltb; -if( lt > 0L ) - { /* put the larger number in bi */ - emovz( bi, ci ); - emovz( ai, bi ); - emovz( ci, ai ); - ltb = bi[E]; - lt = -lt; - } -lost = 0; -if( lt != 0L ) - { - if( lt < (long )(-NBITS-1) ) - goto done; /* answer same as larger addend */ - k = (int )lt; - lost = eshift( ai, k ); /* shift the smaller number down */ - } -else - { -/* exponents were the same, so must compare significands */ - i = ecmpm( ai, bi ); - if( i == 0 ) - { /* the numbers are identical in magnitude */ - /* if different signs, result is zero */ - if( ai[0] != bi[0] ) - { - eclear(c); - return; - } - /* if same sign, result is double */ - /* double denomalized tiny number */ - if( (bi[E] == 0) && ((bi[3] & 0x8000) == 0) ) - { - eshup1( bi ); - goto done; - } - /* add 1 to exponent unless both are zero! */ - for( j=1; j<NI-1; j++ ) - { - if( bi[j] != 0 ) - { -/* This could overflow, but let emovo take care of that. */ - ltb += 1; - break; - } - } - bi[E] = (unsigned short )ltb; - goto done; - } - if( i > 0 ) - { /* put the larger number in bi */ - emovz( bi, ci ); - emovz( ai, bi ); - emovz( ci, ai ); - } - } -if( ai[0] == bi[0] ) - { - eaddm( ai, bi ); - subflg = 0; - } -else - { - esubm( ai, bi ); - subflg = 1; - } -emdnorm( bi, lost, subflg, ltb, 64 ); - -done: -emovo( bi, c ); -} - - - -/* -; Divide. -; -; unsigned short a[NE], b[NE], c[NE]; -; ediv( a, b, c ); c = b / a -*/ -void ediv( a, b, c ) -unsigned short *a, *b, *c; -{ -unsigned short ai[NI], bi[NI]; -int i, sign; -long lt, lta, ltb; - -/* IEEE says if result is not a NaN, the sign is "-" if and only if - operands have opposite signs -- but flush -0 to 0 later if not IEEE. */ -sign = eisneg(a) ^ eisneg(b); - -#ifdef NANS -/* Return any NaN input. */ -if( eisnan(a) ) - { - emov(a,c); - return; - } -if( eisnan(b) ) - { - emov(b,c); - return; - } -/* Zero over zero, or infinity over infinity, is a NaN. */ -if( ((ecmp(a,ezero) == 0) && (ecmp(b,ezero) == 0)) - || (eisinf (a) && eisinf (b)) ) - { - mtherr( "ediv", DOMAIN ); - enan( c, NBITS ); - return; - } -#endif -/* Infinity over anything else is infinity. */ -#ifdef INFINITY -if( eisinf(b) ) - { - einfin(c); - goto divsign; - } -if( eisinf(a) ) - { - eclear(c); - goto divsign; - } -#endif -emovi( a, ai ); -emovi( b, bi ); -lta = ai[E]; -ltb = bi[E]; -if( bi[E] == 0 ) - { /* See if numerator is zero. */ - for( i=1; i<NI-1; i++ ) - { - if( bi[i] != 0 ) - { - ltb -= enormlz( bi ); - goto dnzro1; - } - } - eclear(c); - goto divsign; - } -dnzro1: - -if( ai[E] == 0 ) - { /* possible divide by zero */ - for( i=1; i<NI-1; i++ ) - { - if( ai[i] != 0 ) - { - lta -= enormlz( ai ); - goto dnzro2; - } - } - einfin(c); - mtherr( "ediv", SING ); - goto divsign; - } -dnzro2: - -i = edivm( ai, bi ); -/* calculate exponent */ -lt = ltb - lta + EXONE; -emdnorm( bi, i, 0, lt, 64 ); -emovo( bi, c ); - -divsign: - -if( sign ) - *(c+(NE-1)) |= 0x8000; -else - *(c+(NE-1)) &= ~0x8000; -} - - - -/* -; Multiply. -; -; unsigned short a[NE], b[NE], c[NE]; -; emul( a, b, c ); c = b * a -*/ -void emul( a, b, c ) -unsigned short *a, *b, *c; -{ -unsigned short ai[NI], bi[NI]; -int i, j, sign; -long lt, lta, ltb; - -/* IEEE says if result is not a NaN, the sign is "-" if and only if - operands have opposite signs -- but flush -0 to 0 later if not IEEE. */ -sign = eisneg(a) ^ eisneg(b); - -#ifdef NANS -/* NaN times anything is the same NaN. */ -if( eisnan(a) ) - { - emov(a,c); - return; - } -if( eisnan(b) ) - { - emov(b,c); - return; - } -/* Zero times infinity is a NaN. */ -if( (eisinf(a) && (ecmp(b,ezero) == 0)) - || (eisinf(b) && (ecmp(a,ezero) == 0)) ) - { - mtherr( "emul", DOMAIN ); - enan( c, NBITS ); - return; - } -#endif -/* Infinity times anything else is infinity. */ -#ifdef INFINITY -if( eisinf(a) || eisinf(b) ) - { - einfin(c); - goto mulsign; - } -#endif -emovi( a, ai ); -emovi( b, bi ); -lta = ai[E]; -ltb = bi[E]; -if( ai[E] == 0 ) - { - for( i=1; i<NI-1; i++ ) - { - if( ai[i] != 0 ) - { - lta -= enormlz( ai ); - goto mnzer1; - } - } - eclear(c); - goto mulsign; - } -mnzer1: - -if( bi[E] == 0 ) - { - for( i=1; i<NI-1; i++ ) - { - if( bi[i] != 0 ) - { - ltb -= enormlz( bi ); - goto mnzer2; - } - } - eclear(c); - goto mulsign; - } -mnzer2: - -/* Multiply significands */ -j = emulm( ai, bi ); -/* calculate exponent */ -lt = lta + ltb - (EXONE - 1); -emdnorm( bi, j, 0, lt, 64 ); -emovo( bi, c ); -/* IEEE says sign is "-" if and only if operands have opposite signs. */ -mulsign: -if( sign ) - *(c+(NE-1)) |= 0x8000; -else - *(c+(NE-1)) &= ~0x8000; -} - - - - -/* -; Convert IEEE double precision to e type -; double d; -; unsigned short x[N+2]; -; e53toe( &d, x ); -*/ -void e53toe( pe, y ) -unsigned short *pe, *y; -{ -#ifdef DEC - -dectoe( pe, y ); /* see etodec.c */ - -#else - -register unsigned short r; -register unsigned short *p, *e; -unsigned short yy[NI]; -int denorm, k; - -e = pe; -denorm = 0; /* flag if denormalized number */ -ecleaz(yy); -#ifdef IBMPC -e += 3; -#endif -r = *e; -yy[0] = 0; -if( r & 0x8000 ) - yy[0] = 0xffff; -yy[M] = (r & 0x0f) | 0x10; -r &= ~0x800f; /* strip sign and 4 significand bits */ -#ifdef INFINITY -if( r == 0x7ff0 ) - { -#ifdef NANS -#ifdef IBMPC - if( ((pe[3] & 0xf) != 0) || (pe[2] != 0) - || (pe[1] != 0) || (pe[0] != 0) ) - { - enan( y, NBITS ); - return; - } -#else - if( ((pe[0] & 0xf) != 0) || (pe[1] != 0) - || (pe[2] != 0) || (pe[3] != 0) ) - { - enan( y, NBITS ); - return; - } -#endif -#endif /* NANS */ - eclear( y ); - einfin( y ); - if( yy[0] ) - eneg(y); - return; - } -#endif -r >>= 4; -/* If zero exponent, then the significand is denormalized. - * So, take back the understood high significand bit. */ -if( r == 0 ) - { - denorm = 1; - yy[M] &= ~0x10; - } -r += EXONE - 01777; -yy[E] = r; -p = &yy[M+1]; -#ifdef IBMPC -*p++ = *(--e); -*p++ = *(--e); -*p++ = *(--e); -#endif -#ifdef MIEEE -++e; -*p++ = *e++; -*p++ = *e++; -*p++ = *e++; -#endif -(void )eshift( yy, -5 ); -if( denorm ) - { /* if zero exponent, then normalize the significand */ - if( (k = enormlz(yy)) > NBITS ) - ecleazs(yy); - else - yy[E] -= (unsigned short )(k-1); - } -emovo( yy, y ); -#endif /* not DEC */ -} - -void e64toe( pe, y ) -unsigned short *pe, *y; -{ -unsigned short yy[NI]; -unsigned short *p, *q, *e; -int i; - -e = pe; -p = yy; -for( i=0; i<NE-5; i++ ) - *p++ = 0; -#ifdef IBMPC -for( i=0; i<5; i++ ) - *p++ = *e++; -#endif -#ifdef DEC -for( i=0; i<5; i++ ) - *p++ = *e++; -#endif -#ifdef MIEEE -p = &yy[0] + (NE-1); -*p-- = *e++; -++e; -for( i=0; i<4; i++ ) - *p-- = *e++; -#endif - -#ifdef IBMPC -/* For Intel long double, shift denormal significand up 1 - -- but only if the top significand bit is zero. */ -if((yy[NE-1] & 0x7fff) == 0 && (yy[NE-2] & 0x8000) == 0) - { - unsigned short temp[NI+1]; - emovi(yy, temp); - eshup1(temp); - emovo(temp,y); - return; - } -#endif -#ifdef INFINITY -/* Point to the exponent field. */ -p = &yy[NE-1]; -if( *p == 0x7fff ) - { -#ifdef NANS -#ifdef IBMPC - for( i=0; i<4; i++ ) - { - if((i != 3 && pe[i] != 0) - /* Check for Intel long double infinity pattern. */ - || (i == 3 && pe[i] != 0x8000)) - { - enan( y, NBITS ); - return; - } - } -#else - for( i=1; i<=4; i++ ) - { - if( pe[i] != 0 ) - { - enan( y, NBITS ); - return; - } - } -#endif -#endif /* NANS */ - eclear( y ); - einfin( y ); - if( *p & 0x8000 ) - eneg(y); - return; - } -#endif -p = yy; -q = y; -for( i=0; i<NE; i++ ) - *q++ = *p++; -} - -void e113toe(pe,y) -unsigned short *pe, *y; -{ -register unsigned short r; -unsigned short *e, *p; -unsigned short yy[NI]; -int i; - -e = pe; -ecleaz(yy); -#ifdef IBMPC -e += 7; -#endif -r = *e; -yy[0] = 0; -if( r & 0x8000 ) - yy[0] = 0xffff; -r &= 0x7fff; -#ifdef INFINITY -if( r == 0x7fff ) - { -#ifdef NANS -#ifdef IBMPC - for( i=0; i<7; i++ ) - { - if( pe[i] != 0 ) - { - enan( y, NBITS ); - return; - } - } -#else - for( i=1; i<8; i++ ) - { - if( pe[i] != 0 ) - { - enan( y, NBITS ); - return; - } - } -#endif -#endif /* NANS */ - eclear( y ); - einfin( y ); - if( *e & 0x8000 ) - eneg(y); - return; - } -#endif /* INFINITY */ -yy[E] = r; -p = &yy[M + 1]; -#ifdef IBMPC -for( i=0; i<7; i++ ) - *p++ = *(--e); -#endif -#ifdef MIEEE -++e; -for( i=0; i<7; i++ ) - *p++ = *e++; -#endif -/* If denormal, remove the implied bit; else shift down 1. */ -if( r == 0 ) - { - yy[M] = 0; - } -else - { - yy[M] = 1; - eshift( yy, -1 ); - } -emovo(yy,y); -} - - -/* -; Convert IEEE single precision to e type -; float d; -; unsigned short x[N+2]; -; dtox( &d, x ); -*/ -void e24toe( pe, y ) -unsigned short *pe, *y; -{ -register unsigned short r; -register unsigned short *p, *e; -unsigned short yy[NI]; -int denorm, k; - -e = pe; -denorm = 0; /* flag if denormalized number */ -ecleaz(yy); -#ifdef IBMPC -e += 1; -#endif -#ifdef DEC -e += 1; -#endif -r = *e; -yy[0] = 0; -if( r & 0x8000 ) - yy[0] = 0xffff; -yy[M] = (r & 0x7f) | 0200; -r &= ~0x807f; /* strip sign and 7 significand bits */ -#ifdef INFINITY -if( r == 0x7f80 ) - { -#ifdef NANS -#ifdef MIEEE - if( ((pe[0] & 0x7f) != 0) || (pe[1] != 0) ) - { - enan( y, NBITS ); - return; - } -#else - if( ((pe[1] & 0x7f) != 0) || (pe[0] != 0) ) - { - enan( y, NBITS ); - return; - } -#endif -#endif /* NANS */ - eclear( y ); - einfin( y ); - if( yy[0] ) - eneg(y); - return; - } -#endif -r >>= 7; -/* If zero exponent, then the significand is denormalized. - * So, take back the understood high significand bit. */ -if( r == 0 ) - { - denorm = 1; - yy[M] &= ~0200; - } -r += EXONE - 0177; -yy[E] = r; -p = &yy[M+1]; -#ifdef IBMPC -*p++ = *(--e); -#endif -#ifdef DEC -*p++ = *(--e); -#endif -#ifdef MIEEE -++e; -*p++ = *e++; -#endif -(void )eshift( yy, -8 ); -if( denorm ) - { /* if zero exponent, then normalize the significand */ - if( (k = enormlz(yy)) > NBITS ) - ecleazs(yy); - else - yy[E] -= (unsigned short )(k-1); - } -emovo( yy, y ); -} - -void etoe113(x,e) -unsigned short *x, *e; -{ -unsigned short xi[NI]; -long exp; -int rndsav; - -#ifdef NANS -if( eisnan(x) ) - { - enan( e, 113 ); - return; - } -#endif -emovi( x, xi ); -exp = (long )xi[E]; -#ifdef INFINITY -if( eisinf(x) ) - goto nonorm; -#endif -/* round off to nearest or even */ -rndsav = rndprc; -rndprc = 113; -emdnorm( xi, 0, 0, exp, 64 ); -rndprc = rndsav; -nonorm: -toe113 (xi, e); -} - -/* move out internal format to ieee long double */ -static void toe113(a,b) -unsigned short *a, *b; -{ -register unsigned short *p, *q; -unsigned short i; - -#ifdef NANS -if( eiisnan(a) ) - { - enan( b, 113 ); - return; - } -#endif -p = a; -#ifdef MIEEE -q = b; -#else -q = b + 7; /* point to output exponent */ -#endif - -/* If not denormal, delete the implied bit. */ -if( a[E] != 0 ) - { - eshup1 (a); - } -/* combine sign and exponent */ -i = *p++; -#ifdef MIEEE -if( i ) - *q++ = *p++ | 0x8000; -else - *q++ = *p++; -#else -if( i ) - *q-- = *p++ | 0x8000; -else - *q-- = *p++; -#endif -/* skip over guard word */ -++p; -/* move the significand */ -#ifdef MIEEE -for (i = 0; i < 7; i++) - *q++ = *p++; -#else -for (i = 0; i < 7; i++) - *q-- = *p++; -#endif -} - - -void etoe64( x, e ) -unsigned short *x, *e; -{ -unsigned short xi[NI]; -long exp; -int rndsav; - -#ifdef NANS -if( eisnan(x) ) - { - enan( e, 64 ); - return; - } -#endif -emovi( x, xi ); -exp = (long )xi[E]; /* adjust exponent for offset */ -#ifdef INFINITY -if( eisinf(x) ) - goto nonorm; -#endif -/* round off to nearest or even */ -rndsav = rndprc; -rndprc = 64; -emdnorm( xi, 0, 0, exp, 64 ); -rndprc = rndsav; -nonorm: -toe64( xi, e ); -} - -/* move out internal format to ieee long double */ -static void toe64( a, b ) -unsigned short *a, *b; -{ -register unsigned short *p, *q; -unsigned short i; - -#ifdef NANS -if( eiisnan(a) ) - { - enan( b, 64 ); - return; - } -#endif -#ifdef IBMPC -/* Shift Intel denormal significand down 1. */ -if( a[E] == 0 ) - eshdn1(a); -#endif -p = a; -#ifdef MIEEE -q = b; -#else -q = b + 4; /* point to output exponent */ -#if 1 -/* NOTE: if data type is 96 bits wide, clear the last word here. */ -*(q+1)= 0; -#endif -#endif - -/* combine sign and exponent */ -i = *p++; -#ifdef MIEEE -if( i ) - *q++ = *p++ | 0x8000; -else - *q++ = *p++; -*q++ = 0; -#else -if( i ) - *q-- = *p++ | 0x8000; -else - *q-- = *p++; -#endif -/* skip over guard word */ -++p; -/* move the significand */ -#ifdef MIEEE -for( i=0; i<4; i++ ) - *q++ = *p++; -#else -#ifdef INFINITY -if (eiisinf (a)) - { - /* Intel long double infinity. */ - *q-- = 0x8000; - *q-- = 0; - *q-- = 0; - *q = 0; - return; - } -#endif -for( i=0; i<4; i++ ) - *q-- = *p++; -#endif -} - - -/* -; e type to IEEE double precision -; double d; -; unsigned short x[NE]; -; etoe53( x, &d ); -*/ - -#ifdef DEC - -void etoe53( x, e ) -unsigned short *x, *e; -{ -etodec( x, e ); /* see etodec.c */ -} - -static void toe53( x, y ) -unsigned short *x, *y; -{ -todec( x, y ); -} - -#else - -void etoe53( x, e ) -unsigned short *x, *e; -{ -unsigned short xi[NI]; -long exp; -int rndsav; - -#ifdef NANS -if( eisnan(x) ) - { - enan( e, 53 ); - return; - } -#endif -emovi( x, xi ); -exp = (long )xi[E] - (EXONE - 0x3ff); /* adjust exponent for offsets */ -#ifdef INFINITY -if( eisinf(x) ) - goto nonorm; -#endif -/* round off to nearest or even */ -rndsav = rndprc; -rndprc = 53; -emdnorm( xi, 0, 0, exp, 64 ); -rndprc = rndsav; -nonorm: -toe53( xi, e ); -} - - -static void toe53( x, y ) -unsigned short *x, *y; -{ -unsigned short i; -unsigned short *p; - - -#ifdef NANS -if( eiisnan(x) ) - { - enan( y, 53 ); - return; - } -#endif -p = &x[0]; -#ifdef IBMPC -y += 3; -#endif -*y = 0; /* output high order */ -if( *p++ ) - *y = 0x8000; /* output sign bit */ - -i = *p++; -if( i >= (unsigned int )2047 ) - { /* Saturate at largest number less than infinity. */ -#ifdef INFINITY - *y |= 0x7ff0; -#ifdef IBMPC - *(--y) = 0; - *(--y) = 0; - *(--y) = 0; -#endif -#ifdef MIEEE - ++y; - *y++ = 0; - *y++ = 0; - *y++ = 0; -#endif -#else - *y |= (unsigned short )0x7fef; -#ifdef IBMPC - *(--y) = 0xffff; - *(--y) = 0xffff; - *(--y) = 0xffff; -#endif -#ifdef MIEEE - ++y; - *y++ = 0xffff; - *y++ = 0xffff; - *y++ = 0xffff; -#endif -#endif - return; - } -if( i == 0 ) - { - (void )eshift( x, 4 ); - } -else - { - i <<= 4; - (void )eshift( x, 5 ); - } -i |= *p++ & (unsigned short )0x0f; /* *p = xi[M] */ -*y |= (unsigned short )i; /* high order output already has sign bit set */ -#ifdef IBMPC -*(--y) = *p++; -*(--y) = *p++; -*(--y) = *p; -#endif -#ifdef MIEEE -++y; -*y++ = *p++; -*y++ = *p++; -*y++ = *p++; -#endif -} - -#endif /* not DEC */ - - - -/* -; e type to IEEE single precision -; float d; -; unsigned short x[N+2]; -; xtod( x, &d ); -*/ -void etoe24( x, e ) -unsigned short *x, *e; -{ -long exp; -unsigned short xi[NI]; -int rndsav; - -#ifdef NANS -if( eisnan(x) ) - { - enan( e, 24 ); - return; - } -#endif -emovi( x, xi ); -exp = (long )xi[E] - (EXONE - 0177); /* adjust exponent for offsets */ -#ifdef INFINITY -if( eisinf(x) ) - goto nonorm; -#endif -/* round off to nearest or even */ -rndsav = rndprc; -rndprc = 24; -emdnorm( xi, 0, 0, exp, 64 ); -rndprc = rndsav; -nonorm: -toe24( xi, e ); -} - -static void toe24( x, y ) -unsigned short *x, *y; -{ -unsigned short i; -unsigned short *p; - -#ifdef NANS -if( eiisnan(x) ) - { - enan( y, 24 ); - return; - } -#endif -p = &x[0]; -#ifdef IBMPC -y += 1; -#endif -#ifdef DEC -y += 1; -#endif -*y = 0; /* output high order */ -if( *p++ ) - *y = 0x8000; /* output sign bit */ - -i = *p++; -if( i >= 255 ) - { /* Saturate at largest number less than infinity. */ -#ifdef INFINITY - *y |= (unsigned short )0x7f80; -#ifdef IBMPC - *(--y) = 0; -#endif -#ifdef DEC - *(--y) = 0; -#endif -#ifdef MIEEE - ++y; - *y = 0; -#endif -#else - *y |= (unsigned short )0x7f7f; -#ifdef IBMPC - *(--y) = 0xffff; -#endif -#ifdef DEC - *(--y) = 0xffff; -#endif -#ifdef MIEEE - ++y; - *y = 0xffff; -#endif -#endif - return; - } -if( i == 0 ) - { - (void )eshift( x, 7 ); - } -else - { - i <<= 7; - (void )eshift( x, 8 ); - } -i |= *p++ & (unsigned short )0x7f; /* *p = xi[M] */ -*y |= i; /* high order output already has sign bit set */ -#ifdef IBMPC -*(--y) = *p; -#endif -#ifdef DEC -*(--y) = *p; -#endif -#ifdef MIEEE -++y; -*y = *p; -#endif -} - - -/* Compare two e type numbers. - * - * unsigned short a[NE], b[NE]; - * ecmp( a, b ); - * - * returns +1 if a > b - * 0 if a == b - * -1 if a < b - * -2 if either a or b is a NaN. - */ -int ecmp( a, b ) -unsigned short *a, *b; -{ -unsigned short ai[NI], bi[NI]; -register unsigned short *p, *q; -register int i; -int msign; - -#ifdef NANS -if (eisnan (a) || eisnan (b)) - return( -2 ); -#endif -emovi( a, ai ); -p = ai; -emovi( b, bi ); -q = bi; - -if( *p != *q ) - { /* the signs are different */ -/* -0 equals + 0 */ - for( i=1; i<NI-1; i++ ) - { - if( ai[i] != 0 ) - goto nzro; - if( bi[i] != 0 ) - goto nzro; - } - return(0); -nzro: - if( *p == 0 ) - return( 1 ); - else - return( -1 ); - } -/* both are the same sign */ -if( *p == 0 ) - msign = 1; -else - msign = -1; -i = NI-1; -do - { - if( *p++ != *q++ ) - { - goto diff; - } - } -while( --i > 0 ); - -return(0); /* equality */ - - - -diff: - -if( *(--p) > *(--q) ) - return( msign ); /* p is bigger */ -else - return( -msign ); /* p is littler */ -} - - - - -/* Find nearest integer to x = floor( x + 0.5 ) - * - * unsigned short x[NE], y[NE] - * eround( x, y ); - */ -void eround( x, y ) -unsigned short *x, *y; -{ - -eadd( ehalf, x, y ); -efloor( y, y ); -} - - - - -/* -; convert long (32-bit) integer to e type -; -; long l; -; unsigned short x[NE]; -; ltoe( &l, x ); -; note &l is the memory address of l -*/ -void ltoe( lp, y ) -long *lp; /* lp is the memory address of a long integer */ -unsigned short *y; /* y is the address of a short */ -{ -unsigned short yi[NI]; -unsigned long ll; -int k; - -ecleaz( yi ); -if( *lp < 0 ) - { - ll = (unsigned long )( -(*lp) ); /* make it positive */ - yi[0] = 0xffff; /* put correct sign in the e type number */ - } -else - { - ll = (unsigned long )( *lp ); - } -/* move the long integer to yi significand area */ -if( sizeof(long) == 8 ) - { - yi[M] = (unsigned short) (ll >> (LONGBITS - 16)); - yi[M + 1] = (unsigned short) (ll >> (LONGBITS - 32)); - yi[M + 2] = (unsigned short) (ll >> 16); - yi[M + 3] = (unsigned short) ll; - yi[E] = EXONE + 47; /* exponent if normalize shift count were 0 */ - } -else - { - yi[M] = (unsigned short )(ll >> 16); - yi[M+1] = (unsigned short )ll; - yi[E] = EXONE + 15; /* exponent if normalize shift count were 0 */ - } -if( (k = enormlz( yi )) > NBITS ) /* normalize the significand */ - ecleaz( yi ); /* it was zero */ -else - yi[E] -= (unsigned short )k; /* subtract shift count from exponent */ -emovo( yi, y ); /* output the answer */ -} - -/* -; convert unsigned long (32-bit) integer to e type -; -; unsigned long l; -; unsigned short x[NE]; -; ltox( &l, x ); -; note &l is the memory address of l -*/ -void ultoe( lp, y ) -unsigned long *lp; /* lp is the memory address of a long integer */ -unsigned short *y; /* y is the address of a short */ -{ -unsigned short yi[NI]; -unsigned long ll; -int k; - -ecleaz( yi ); -ll = *lp; - -/* move the long integer to ayi significand area */ -if( sizeof(long) == 8 ) - { - yi[M] = (unsigned short) (ll >> (LONGBITS - 16)); - yi[M + 1] = (unsigned short) (ll >> (LONGBITS - 32)); - yi[M + 2] = (unsigned short) (ll >> 16); - yi[M + 3] = (unsigned short) ll; - yi[E] = EXONE + 47; /* exponent if normalize shift count were 0 */ - } -else - { - yi[M] = (unsigned short )(ll >> 16); - yi[M+1] = (unsigned short )ll; - yi[E] = EXONE + 15; /* exponent if normalize shift count were 0 */ - } -if( (k = enormlz( yi )) > NBITS ) /* normalize the significand */ - ecleaz( yi ); /* it was zero */ -else - yi[E] -= (unsigned short )k; /* subtract shift count from exponent */ -emovo( yi, y ); /* output the answer */ -} - - -/* -; Find long integer and fractional parts - -; long i; -; unsigned short x[NE], frac[NE]; -; xifrac( x, &i, frac ); - - The integer output has the sign of the input. The fraction is - the positive fractional part of abs(x). -*/ -void eifrac( x, i, frac ) -unsigned short *x; -long *i; -unsigned short *frac; -{ -unsigned short xi[NI]; -int j, k; -unsigned long ll; - -emovi( x, xi ); -k = (int )xi[E] - (EXONE - 1); -if( k <= 0 ) - { -/* if exponent <= 0, integer = 0 and real output is fraction */ - *i = 0L; - emovo( xi, frac ); - return; - } -if( k > (8 * sizeof(long) - 1) ) - { -/* -; long integer overflow: output large integer -; and correct fraction -*/ - j = 8 * sizeof(long) - 1; - if( xi[0] ) - *i = (long) ((unsigned long) 1) << j; - else - *i = (long) (((unsigned long) (~(0L))) >> 1); - (void )eshift( xi, k ); - } -if( k > 16 ) - { -/* - Shift more than 16 bits: shift up k-16 mod 16 - then shift by 16's. -*/ - j = k - ((k >> 4) << 4); - eshift (xi, j); - ll = xi[M]; - k -= j; - do - { - eshup6 (xi); - ll = (ll << 16) | xi[M]; - } - while ((k -= 16) > 0); - *i = ll; - if (xi[0]) - *i = -(*i); - } -else - { -/* shift not more than 16 bits */ - eshift( xi, k ); - *i = (long )xi[M] & 0xffff; - if( xi[0] ) - *i = -(*i); - } -xi[0] = 0; -xi[E] = EXONE - 1; -xi[M] = 0; -if( (k = enormlz( xi )) > NBITS ) - ecleaz( xi ); -else - xi[E] -= (unsigned short )k; - -emovo( xi, frac ); -} - - -/* -; Find unsigned long integer and fractional parts - -; unsigned long i; -; unsigned short x[NE], frac[NE]; -; xifrac( x, &i, frac ); - - A negative e type input yields integer output = 0 - but correct fraction. -*/ -void euifrac( x, i, frac ) -unsigned short *x; -unsigned long *i; -unsigned short *frac; -{ -unsigned short xi[NI]; -int j, k; -unsigned long ll; - -emovi( x, xi ); -k = (int )xi[E] - (EXONE - 1); -if( k <= 0 ) - { -/* if exponent <= 0, integer = 0 and argument is fraction */ - *i = 0L; - emovo( xi, frac ); - return; - } -if( k > (8 * sizeof(long)) ) - { -/* -; long integer overflow: output large integer -; and correct fraction -*/ - *i = ~(0L); - (void )eshift( xi, k ); - } -else if( k > 16 ) - { -/* - Shift more than 16 bits: shift up k-16 mod 16 - then shift up by 16's. -*/ - j = k - ((k >> 4) << 4); - eshift (xi, j); - ll = xi[M]; - k -= j; - do - { - eshup6 (xi); - ll = (ll << 16) | xi[M]; - } - while ((k -= 16) > 0); - *i = ll; - } -else - { -/* shift not more than 16 bits */ - eshift( xi, k ); - *i = (long )xi[M] & 0xffff; - } - -if( xi[0] ) /* A negative value yields unsigned integer 0. */ - *i = 0L; - -xi[0] = 0; -xi[E] = EXONE - 1; -xi[M] = 0; -if( (k = enormlz( xi )) > NBITS ) - ecleaz( xi ); -else - xi[E] -= (unsigned short )k; - -emovo( xi, frac ); -} - - - -/* -; Shift significand -; -; Shifts significand area up or down by the number of bits -; given by the variable sc. -*/ -int eshift( x, sc ) -unsigned short *x; -int sc; -{ -unsigned short lost; -unsigned short *p; - -if( sc == 0 ) - return( 0 ); - -lost = 0; -p = x + NI-1; - -if( sc < 0 ) - { - sc = -sc; - while( sc >= 16 ) - { - lost |= *p; /* remember lost bits */ - eshdn6(x); - sc -= 16; - } - - while( sc >= 8 ) - { - lost |= *p & 0xff; - eshdn8(x); - sc -= 8; - } - - while( sc > 0 ) - { - lost |= *p & 1; - eshdn1(x); - sc -= 1; - } - } -else - { - while( sc >= 16 ) - { - eshup6(x); - sc -= 16; - } - - while( sc >= 8 ) - { - eshup8(x); - sc -= 8; - } - - while( sc > 0 ) - { - eshup1(x); - sc -= 1; - } - } -if( lost ) - lost = 1; -return( (int )lost ); -} - - - -/* -; normalize -; -; Shift normalizes the significand area pointed to by argument -; shift count (up = positive) is returned. -*/ -int enormlz(x) -unsigned short x[]; -{ -register unsigned short *p; -int sc; - -sc = 0; -p = &x[M]; -if( *p != 0 ) - goto normdn; -++p; -if( *p & 0x8000 ) - return( 0 ); /* already normalized */ -while( *p == 0 ) - { - eshup6(x); - sc += 16; -/* With guard word, there are NBITS+16 bits available. - * return true if all are zero. - */ - if( sc > NBITS ) - return( sc ); - } -/* see if high byte is zero */ -while( (*p & 0xff00) == 0 ) - { - eshup8(x); - sc += 8; - } -/* now shift 1 bit at a time */ -while( (*p & 0x8000) == 0) - { - eshup1(x); - sc += 1; - if( sc > (NBITS+16) ) - { - mtherr( "enormlz", UNDERFLOW ); - return( sc ); - } - } -return( sc ); - -/* Normalize by shifting down out of the high guard word - of the significand */ -normdn: - -if( *p & 0xff00 ) - { - eshdn8(x); - sc -= 8; - } -while( *p != 0 ) - { - eshdn1(x); - sc -= 1; - - if( sc < -NBITS ) - { - mtherr( "enormlz", OVERFLOW ); - return( sc ); - } - } -return( sc ); -} - - - - -/* Convert e type number to decimal format ASCII string. - * The constants are for 64 bit precision. - */ - -#define NTEN 12 -#define MAXP 4096 - -#if NE == 10 -static unsigned short etens[NTEN + 1][NE] = -{ - {0x6576, 0x4a92, 0x804a, 0x153f, - 0xc94c, 0x979a, 0x8a20, 0x5202, 0xc460, 0x7525,}, /* 10**4096 */ - {0x6a32, 0xce52, 0x329a, 0x28ce, - 0xa74d, 0x5de4, 0xc53d, 0x3b5d, 0x9e8b, 0x5a92,}, /* 10**2048 */ - {0x526c, 0x50ce, 0xf18b, 0x3d28, - 0x650d, 0x0c17, 0x8175, 0x7586, 0xc976, 0x4d48,}, - {0x9c66, 0x58f8, 0xbc50, 0x5c54, - 0xcc65, 0x91c6, 0xa60e, 0xa0ae, 0xe319, 0x46a3,}, - {0x851e, 0xeab7, 0x98fe, 0x901b, - 0xddbb, 0xde8d, 0x9df9, 0xebfb, 0xaa7e, 0x4351,}, - {0x0235, 0x0137, 0x36b1, 0x336c, - 0xc66f, 0x8cdf, 0x80e9, 0x47c9, 0x93ba, 0x41a8,}, - {0x50f8, 0x25fb, 0xc76b, 0x6b71, - 0x3cbf, 0xa6d5, 0xffcf, 0x1f49, 0xc278, 0x40d3,}, - {0x0000, 0x0000, 0x0000, 0x0000, - 0xf020, 0xb59d, 0x2b70, 0xada8, 0x9dc5, 0x4069,}, - {0x0000, 0x0000, 0x0000, 0x0000, - 0x0000, 0x0000, 0x0400, 0xc9bf, 0x8e1b, 0x4034,}, - {0x0000, 0x0000, 0x0000, 0x0000, - 0x0000, 0x0000, 0x0000, 0x2000, 0xbebc, 0x4019,}, - {0x0000, 0x0000, 0x0000, 0x0000, - 0x0000, 0x0000, 0x0000, 0x0000, 0x9c40, 0x400c,}, - {0x0000, 0x0000, 0x0000, 0x0000, - 0x0000, 0x0000, 0x0000, 0x0000, 0xc800, 0x4005,}, - {0x0000, 0x0000, 0x0000, 0x0000, - 0x0000, 0x0000, 0x0000, 0x0000, 0xa000, 0x4002,}, /* 10**1 */ -}; - -static unsigned short emtens[NTEN + 1][NE] = -{ - {0x2030, 0xcffc, 0xa1c3, 0x8123, - 0x2de3, 0x9fde, 0xd2ce, 0x04c8, 0xa6dd, 0x0ad8,}, /* 10**-4096 */ - {0x8264, 0xd2cb, 0xf2ea, 0x12d4, - 0x4925, 0x2de4, 0x3436, 0x534f, 0xceae, 0x256b,}, /* 10**-2048 */ - {0xf53f, 0xf698, 0x6bd3, 0x0158, - 0x87a6, 0xc0bd, 0xda57, 0x82a5, 0xa2a6, 0x32b5,}, - {0xe731, 0x04d4, 0xe3f2, 0xd332, - 0x7132, 0xd21c, 0xdb23, 0xee32, 0x9049, 0x395a,}, - {0xa23e, 0x5308, 0xfefb, 0x1155, - 0xfa91, 0x1939, 0x637a, 0x4325, 0xc031, 0x3cac,}, - {0xe26d, 0xdbde, 0xd05d, 0xb3f6, - 0xac7c, 0xe4a0, 0x64bc, 0x467c, 0xddd0, 0x3e55,}, - {0x2a20, 0x6224, 0x47b3, 0x98d7, - 0x3f23, 0xe9a5, 0xa539, 0xea27, 0xa87f, 0x3f2a,}, - {0x0b5b, 0x4af2, 0xa581, 0x18ed, - 0x67de, 0x94ba, 0x4539, 0x1ead, 0xcfb1, 0x3f94,}, - {0xbf71, 0xa9b3, 0x7989, 0xbe68, - 0x4c2e, 0xe15b, 0xc44d, 0x94be, 0xe695, 0x3fc9,}, - {0x3d4d, 0x7c3d, 0x36ba, 0x0d2b, - 0xfdc2, 0xcefc, 0x8461, 0x7711, 0xabcc, 0x3fe4,}, - {0xc155, 0xa4a8, 0x404e, 0x6113, - 0xd3c3, 0x652b, 0xe219, 0x1758, 0xd1b7, 0x3ff1,}, - {0xd70a, 0x70a3, 0x0a3d, 0xa3d7, - 0x3d70, 0xd70a, 0x70a3, 0x0a3d, 0xa3d7, 0x3ff8,}, - {0xcccd, 0xcccc, 0xcccc, 0xcccc, - 0xcccc, 0xcccc, 0xcccc, 0xcccc, 0xcccc, 0x3ffb,}, /* 10**-1 */ -}; -#else -static unsigned short etens[NTEN+1][NE] = { -{0xc94c,0x979a,0x8a20,0x5202,0xc460,0x7525,},/* 10**4096 */ -{0xa74d,0x5de4,0xc53d,0x3b5d,0x9e8b,0x5a92,},/* 10**2048 */ -{0x650d,0x0c17,0x8175,0x7586,0xc976,0x4d48,}, -{0xcc65,0x91c6,0xa60e,0xa0ae,0xe319,0x46a3,}, -{0xddbc,0xde8d,0x9df9,0xebfb,0xaa7e,0x4351,}, -{0xc66f,0x8cdf,0x80e9,0x47c9,0x93ba,0x41a8,}, -{0x3cbf,0xa6d5,0xffcf,0x1f49,0xc278,0x40d3,}, -{0xf020,0xb59d,0x2b70,0xada8,0x9dc5,0x4069,}, -{0x0000,0x0000,0x0400,0xc9bf,0x8e1b,0x4034,}, -{0x0000,0x0000,0x0000,0x2000,0xbebc,0x4019,}, -{0x0000,0x0000,0x0000,0x0000,0x9c40,0x400c,}, -{0x0000,0x0000,0x0000,0x0000,0xc800,0x4005,}, -{0x0000,0x0000,0x0000,0x0000,0xa000,0x4002,}, /* 10**1 */ -}; - -static unsigned short emtens[NTEN+1][NE] = { -{0x2de4,0x9fde,0xd2ce,0x04c8,0xa6dd,0x0ad8,}, /* 10**-4096 */ -{0x4925,0x2de4,0x3436,0x534f,0xceae,0x256b,}, /* 10**-2048 */ -{0x87a6,0xc0bd,0xda57,0x82a5,0xa2a6,0x32b5,}, -{0x7133,0xd21c,0xdb23,0xee32,0x9049,0x395a,}, -{0xfa91,0x1939,0x637a,0x4325,0xc031,0x3cac,}, -{0xac7d,0xe4a0,0x64bc,0x467c,0xddd0,0x3e55,}, -{0x3f24,0xe9a5,0xa539,0xea27,0xa87f,0x3f2a,}, -{0x67de,0x94ba,0x4539,0x1ead,0xcfb1,0x3f94,}, -{0x4c2f,0xe15b,0xc44d,0x94be,0xe695,0x3fc9,}, -{0xfdc2,0xcefc,0x8461,0x7711,0xabcc,0x3fe4,}, -{0xd3c3,0x652b,0xe219,0x1758,0xd1b7,0x3ff1,}, -{0x3d71,0xd70a,0x70a3,0x0a3d,0xa3d7,0x3ff8,}, -{0xcccd,0xcccc,0xcccc,0xcccc,0xcccc,0x3ffb,}, /* 10**-1 */ -}; -#endif - -void e24toasc( x, string, ndigs ) -unsigned short x[]; -char *string; -int ndigs; -{ -unsigned short w[NI]; - -e24toe( x, w ); -etoasc( w, string, ndigs ); -} - - -void e53toasc( x, string, ndigs ) -unsigned short x[]; -char *string; -int ndigs; -{ -unsigned short w[NI]; - -e53toe( x, w ); -etoasc( w, string, ndigs ); -} - - -void e64toasc( x, string, ndigs ) -unsigned short x[]; -char *string; -int ndigs; -{ -unsigned short w[NI]; - -e64toe( x, w ); -etoasc( w, string, ndigs ); -} - -void e113toasc (x, string, ndigs) -unsigned short x[]; -char *string; -int ndigs; -{ -unsigned short w[NI]; - -e113toe (x, w); -etoasc (w, string, ndigs); -} - - -void etoasc( x, string, ndigs ) -unsigned short x[]; -char *string; -int ndigs; -{ -long digit; -unsigned short y[NI], t[NI], u[NI], w[NI]; -unsigned short *p, *r, *ten; -unsigned short sign; -int i, j, k, expon, rndsav; -char *s, *ss; -unsigned short m; - -rndsav = rndprc; -#ifdef NANS -if( eisnan(x) ) - { - sprintf( string, " NaN " ); - goto bxit; - } -#endif -rndprc = NBITS; /* set to full precision */ -emov( x, y ); /* retain external format */ -if( y[NE-1] & 0x8000 ) - { - sign = 0xffff; - y[NE-1] &= 0x7fff; - } -else - { - sign = 0; - } -expon = 0; -ten = &etens[NTEN][0]; -emov( eone, t ); -/* Test for zero exponent */ -if( y[NE-1] == 0 ) - { - for( k=0; k<NE-1; k++ ) - { - if( y[k] != 0 ) - goto tnzro; /* denormalized number */ - } - goto isone; /* legal all zeros */ - } -tnzro: - -/* Test for infinity. - */ -if( y[NE-1] == 0x7fff ) - { - if( sign ) - sprintf( string, " -Infinity " ); - else - sprintf( string, " Infinity " ); - goto bxit; - } - -/* Test for exponent nonzero but significand denormalized. - * This is an error condition. - */ -if( (y[NE-1] != 0) && ((y[NE-2] & 0x8000) == 0) ) - { - mtherr( "etoasc", DOMAIN ); - sprintf( string, "NaN" ); - goto bxit; - } - -/* Compare to 1.0 */ -i = ecmp( eone, y ); -if( i == 0 ) - goto isone; - -if( i < 0 ) - { /* Number is greater than 1 */ -/* Convert significand to an integer and strip trailing decimal zeros. */ - emov( y, u ); - u[NE-1] = EXONE + NBITS - 1; - - p = &etens[NTEN-4][0]; - m = 16; -do - { - ediv( p, u, t ); - efloor( t, w ); - for( j=0; j<NE-1; j++ ) - { - if( t[j] != w[j] ) - goto noint; - } - emov( t, u ); - expon += (int )m; -noint: - p += NE; - m >>= 1; - } -while( m != 0 ); - -/* Rescale from integer significand */ - u[NE-1] += y[NE-1] - (unsigned int )(EXONE + NBITS - 1); - emov( u, y ); -/* Find power of 10 */ - emov( eone, t ); - m = MAXP; - p = &etens[0][0]; - while( ecmp( ten, u ) <= 0 ) - { - if( ecmp( p, u ) <= 0 ) - { - ediv( p, u, u ); - emul( p, t, t ); - expon += (int )m; - } - m >>= 1; - if( m == 0 ) - break; - p += NE; - } - } -else - { /* Number is less than 1.0 */ -/* Pad significand with trailing decimal zeros. */ - if( y[NE-1] == 0 ) - { - while( (y[NE-2] & 0x8000) == 0 ) - { - emul( ten, y, y ); - expon -= 1; - } - } - else - { - emovi( y, w ); - for( i=0; i<NDEC+1; i++ ) - { - if( (w[NI-1] & 0x7) != 0 ) - break; -/* multiply by 10 */ - emovz( w, u ); - eshdn1( u ); - eshdn1( u ); - eaddm( w, u ); - u[1] += 3; - while( u[2] != 0 ) - { - eshdn1(u); - u[1] += 1; - } - if( u[NI-1] != 0 ) - break; - if( eone[NE-1] <= u[1] ) - break; - emovz( u, w ); - expon -= 1; - } - emovo( w, y ); - } - k = -MAXP; - p = &emtens[0][0]; - r = &etens[0][0]; - emov( y, w ); - emov( eone, t ); - while( ecmp( eone, w ) > 0 ) - { - if( ecmp( p, w ) >= 0 ) - { - emul( r, w, w ); - emul( r, t, t ); - expon += k; - } - k /= 2; - if( k == 0 ) - break; - p += NE; - r += NE; - } - ediv( t, eone, t ); - } -isone: -/* Find the first (leading) digit. */ -emovi( t, w ); -emovz( w, t ); -emovi( y, w ); -emovz( w, y ); -eiremain( t, y ); -digit = equot[NI-1]; -while( (digit == 0) && (ecmp(y,ezero) != 0) ) - { - eshup1( y ); - emovz( y, u ); - eshup1( u ); - eshup1( u ); - eaddm( u, y ); - eiremain( t, y ); - digit = equot[NI-1]; - expon -= 1; - } -s = string; -if( sign ) - *s++ = '-'; -else - *s++ = ' '; -/* Examine number of digits requested by caller. */ -if( ndigs < 0 ) - ndigs = 0; -if( ndigs > NDEC ) - ndigs = NDEC; -if( digit == 10 ) - { - *s++ = '1'; - *s++ = '.'; - if( ndigs > 0 ) - { - *s++ = '0'; - ndigs -= 1; - } - expon += 1; - } -else - { - *s++ = (char )digit + '0'; - *s++ = '.'; - } -/* Generate digits after the decimal point. */ -for( k=0; k<=ndigs; k++ ) - { -/* multiply current number by 10, without normalizing */ - eshup1( y ); - emovz( y, u ); - eshup1( u ); - eshup1( u ); - eaddm( u, y ); - eiremain( t, y ); - *s++ = (char )equot[NI-1] + '0'; - } -digit = equot[NI-1]; ---s; -ss = s; -/* round off the ASCII string */ -if( digit > 4 ) - { -/* Test for critical rounding case in ASCII output. */ - if( digit == 5 ) - { - emovo( y, t ); - if( ecmp(t,ezero) != 0 ) - goto roun; /* round to nearest */ - if( (*(s-1) & 1) == 0 ) - goto doexp; /* round to even */ - } -/* Round up and propagate carry-outs */ -roun: - --s; - k = *s & 0x7f; -/* Carry out to most significant digit? */ - if( k == '.' ) - { - --s; - k = *s; - k += 1; - *s = (char )k; -/* Most significant digit carries to 10? */ - if( k > '9' ) - { - expon += 1; - *s = '1'; - } - goto doexp; - } -/* Round up and carry out from less significant digits */ - k += 1; - *s = (char )k; - if( k > '9' ) - { - *s = '0'; - goto roun; - } - } -doexp: -/* -if( expon >= 0 ) - sprintf( ss, "e+%d", expon ); -else - sprintf( ss, "e%d", expon ); -*/ - sprintf( ss, "E%d", expon ); -bxit: -rndprc = rndsav; -} - - - - -/* -; ASCTOQ -; ASCTOQ.MAC LATEST REV: 11 JAN 84 -; SLM, 3 JAN 78 -; -; Convert ASCII string to quadruple precision floating point -; -; Numeric input is free field decimal number -; with max of 15 digits with or without -; decimal point entered as ASCII from teletype. -; Entering E after the number followed by a second -; number causes the second number to be interpreted -; as a power of 10 to be multiplied by the first number -; (i.e., "scientific" notation). -; -; Usage: -; asctoq( string, q ); -*/ - -/* ASCII to single */ -void asctoe24( s, y ) -char *s; -unsigned short *y; -{ -asctoeg( s, y, 24 ); -} - - -/* ASCII to double */ -void asctoe53( s, y ) -char *s; -unsigned short *y; -{ -#ifdef DEC -asctoeg( s, y, 56 ); -#else -asctoeg( s, y, 53 ); -#endif -} - - -/* ASCII to long double */ -void asctoe64( s, y ) -char *s; -unsigned short *y; -{ -asctoeg( s, y, 64 ); -} - -/* ASCII to 128-bit long double */ -void asctoe113 (s, y) -char *s; -unsigned short *y; -{ -asctoeg( s, y, 113 ); -} - -/* ASCII to super double */ -void asctoe( s, y ) -char *s; -unsigned short *y; -{ -asctoeg( s, y, NBITS ); -} - -/* Space to make a copy of the input string: */ -static char lstr[82] = {0}; - -void asctoeg( ss, y, oprec ) -char *ss; -unsigned short *y; -int oprec; -{ -unsigned short yy[NI], xt[NI], tt[NI]; -int esign, decflg, sgnflg, nexp, exp, prec, lost; -int k, trail, c, rndsav; -long lexp; -unsigned short nsign, *p; -char *sp, *s; - -/* Copy the input string. */ -s = ss; -while( *s == ' ' ) /* skip leading spaces */ - ++s; -sp = lstr; -for( k=0; k<79; k++ ) - { - if( (*sp++ = *s++) == '\0' ) - break; - } -*sp = '\0'; -s = lstr; - -rndsav = rndprc; -rndprc = NBITS; /* Set to full precision */ -lost = 0; -nsign = 0; -decflg = 0; -sgnflg = 0; -nexp = 0; -exp = 0; -prec = 0; -ecleaz( yy ); -trail = 0; - -nxtcom: -k = *s - '0'; -if( (k >= 0) && (k <= 9) ) - { -/* Ignore leading zeros */ - if( (prec == 0) && (decflg == 0) && (k == 0) ) - goto donchr; -/* Identify and strip trailing zeros after the decimal point. */ - if( (trail == 0) && (decflg != 0) ) - { - sp = s; - while( (*sp >= '0') && (*sp <= '9') ) - ++sp; -/* Check for syntax error */ - c = *sp & 0x7f; - if( (c != 'e') && (c != 'E') && (c != '\0') - && (c != '\n') && (c != '\r') && (c != ' ') - && (c != ',') ) - goto error; - --sp; - while( *sp == '0' ) - *sp-- = 'z'; - trail = 1; - if( *s == 'z' ) - goto donchr; - } -/* If enough digits were given to more than fill up the yy register, - * continuing until overflow into the high guard word yy[2] - * guarantees that there will be a roundoff bit at the top - * of the low guard word after normalization. - */ - if( yy[2] == 0 ) - { - if( decflg ) - nexp += 1; /* count digits after decimal point */ - eshup1( yy ); /* multiply current number by 10 */ - emovz( yy, xt ); - eshup1( xt ); - eshup1( xt ); - eaddm( xt, yy ); - ecleaz( xt ); - xt[NI-2] = (unsigned short )k; - eaddm( xt, yy ); - } - else - { - /* Mark any lost non-zero digit. */ - lost |= k; - /* Count lost digits before the decimal point. */ - if (decflg == 0) - nexp -= 1; - } - prec += 1; - goto donchr; - } - -switch( *s ) - { - case 'z': - break; - case 'E': - case 'e': - goto expnt; - case '.': /* decimal point */ - if( decflg ) - goto error; - ++decflg; - break; - case '-': - nsign = 0xffff; - if( sgnflg ) - goto error; - ++sgnflg; - break; - case '+': - if( sgnflg ) - goto error; - ++sgnflg; - break; - case ',': - case ' ': - case '\0': - case '\n': - case '\r': - goto daldone; - case 'i': - case 'I': - goto infinite; - default: - error: -#ifdef NANS - enan( yy, NI*16 ); -#else - mtherr( "asctoe", DOMAIN ); - ecleaz(yy); -#endif - goto aexit; - } -donchr: -++s; -goto nxtcom; - -/* Exponent interpretation */ -expnt: - -esign = 1; -exp = 0; -++s; -/* check for + or - */ -if( *s == '-' ) - { - esign = -1; - ++s; - } -if( *s == '+' ) - ++s; -while( (*s >= '0') && (*s <= '9') ) - { - exp *= 10; - exp += *s++ - '0'; - if (exp > 4977) - { - if (esign < 0) - goto zero; - else - goto infinite; - } - } -if( esign < 0 ) - exp = -exp; -if( exp > 4932 ) - { -infinite: - ecleaz(yy); - yy[E] = 0x7fff; /* infinity */ - goto aexit; - } -if( exp < -4977 ) - { -zero: - ecleaz(yy); - goto aexit; - } - -daldone: -nexp = exp - nexp; -/* Pad trailing zeros to minimize power of 10, per IEEE spec. */ -while( (nexp > 0) && (yy[2] == 0) ) - { - emovz( yy, xt ); - eshup1( xt ); - eshup1( xt ); - eaddm( yy, xt ); - eshup1( xt ); - if( xt[2] != 0 ) - break; - nexp -= 1; - emovz( xt, yy ); - } -if( (k = enormlz(yy)) > NBITS ) - { - ecleaz(yy); - goto aexit; - } -lexp = (EXONE - 1 + NBITS) - k; -emdnorm( yy, lost, 0, lexp, 64 ); -/* convert to external format */ - - -/* Multiply by 10**nexp. If precision is 64 bits, - * the maximum relative error incurred in forming 10**n - * for 0 <= n <= 324 is 8.2e-20, at 10**180. - * For 0 <= n <= 999, the peak relative error is 1.4e-19 at 10**947. - * For 0 >= n >= -999, it is -1.55e-19 at 10**-435. - */ -lexp = yy[E]; -if( nexp == 0 ) - { - k = 0; - goto expdon; - } -esign = 1; -if( nexp < 0 ) - { - nexp = -nexp; - esign = -1; - if( nexp > 4096 ) - { /* Punt. Can't handle this without 2 divides. */ - emovi( etens[0], tt ); - lexp -= tt[E]; - k = edivm( tt, yy ); - lexp += EXONE; - nexp -= 4096; - } - } -p = &etens[NTEN][0]; -emov( eone, xt ); -exp = 1; -do - { - if( exp & nexp ) - emul( p, xt, xt ); - p -= NE; - exp = exp + exp; - } -while( exp <= MAXP ); - -emovi( xt, tt ); -if( esign < 0 ) - { - lexp -= tt[E]; - k = edivm( tt, yy ); - lexp += EXONE; - } -else - { - lexp += tt[E]; - k = emulm( tt, yy ); - lexp -= EXONE - 1; - } - -expdon: - -/* Round and convert directly to the destination type */ -if( oprec == 53 ) - lexp -= EXONE - 0x3ff; -else if( oprec == 24 ) - lexp -= EXONE - 0177; -#ifdef DEC -else if( oprec == 56 ) - lexp -= EXONE - 0201; -#endif -rndprc = oprec; -emdnorm( yy, k, 0, lexp, 64 ); - -aexit: - -rndprc = rndsav; -yy[0] = nsign; -switch( oprec ) - { -#ifdef DEC - case 56: - todec( yy, y ); /* see etodec.c */ - break; -#endif - case 53: - toe53( yy, y ); - break; - case 24: - toe24( yy, y ); - break; - case 64: - toe64( yy, y ); - break; - case 113: - toe113( yy, y ); - break; - case NBITS: - emovo( yy, y ); - break; - } -} - - - -/* y = largest integer not greater than x - * (truncated toward minus infinity) - * - * unsigned short x[NE], y[NE] - * - * efloor( x, y ); - */ -static unsigned short bmask[] = { -0xffff, -0xfffe, -0xfffc, -0xfff8, -0xfff0, -0xffe0, -0xffc0, -0xff80, -0xff00, -0xfe00, -0xfc00, -0xf800, -0xf000, -0xe000, -0xc000, -0x8000, -0x0000, -}; - -void efloor( x, y ) -unsigned short x[], y[]; -{ -register unsigned short *p; -int e, expon, i; -unsigned short f[NE]; - -emov( x, f ); /* leave in external format */ -expon = (int )f[NE-1]; -e = (expon & 0x7fff) - (EXONE - 1); -if( e <= 0 ) - { - eclear(y); - goto isitneg; - } -/* number of bits to clear out */ -e = NBITS - e; -emov( f, y ); -if( e <= 0 ) - return; - -p = &y[0]; -while( e >= 16 ) - { - *p++ = 0; - e -= 16; - } -/* clear the remaining bits */ -*p &= bmask[e]; -/* truncate negatives toward minus infinity */ -isitneg: - -if( (unsigned short )expon & (unsigned short )0x8000 ) - { - for( i=0; i<NE-1; i++ ) - { - if( f[i] != y[i] ) - { - esub( eone, y, y ); - break; - } - } - } -} - - -/* unsigned short x[], s[]; - * long *exp; - * - * efrexp( x, exp, s ); - * - * Returns s and exp such that s * 2**exp = x and .5 <= s < 1. - * For example, 1.1 = 0.55 * 2**1 - * Handles denormalized numbers properly using long integer exp. - */ -void efrexp( x, exp, s ) -unsigned short x[]; -long *exp; -unsigned short s[]; -{ -unsigned short xi[NI]; -long li; - -emovi( x, xi ); -li = (long )((short )xi[1]); - -if( li == 0 ) - { - li -= enormlz( xi ); - } -xi[1] = 0x3ffe; -emovo( xi, s ); -*exp = li - 0x3ffe; -} - - - -/* unsigned short x[], y[]; - * long pwr2; - * - * eldexp( x, pwr2, y ); - * - * Returns y = x * 2**pwr2. - */ -void eldexp( x, pwr2, y ) -unsigned short x[]; -long pwr2; -unsigned short y[]; -{ -unsigned short xi[NI]; -long li; -int i; - -emovi( x, xi ); -li = xi[1]; -li += pwr2; -i = 0; -emdnorm( xi, i, i, li, 64 ); -emovo( xi, y ); -} - - -/* c = remainder after dividing b by a - * Least significant integer quotient bits left in equot[]. - */ -void eremain( a, b, c ) -unsigned short a[], b[], c[]; -{ -unsigned short den[NI], num[NI]; - -#ifdef NANS -if( eisinf(b) || (ecmp(a,ezero) == 0) || eisnan(a) || eisnan(b)) - { - enan( c, NBITS ); - return; - } -#endif -if( ecmp(a,ezero) == 0 ) - { - mtherr( "eremain", SING ); - eclear( c ); - return; - } -emovi( a, den ); -emovi( b, num ); -eiremain( den, num ); -/* Sign of remainder = sign of quotient */ -if( a[0] == b[0] ) - num[0] = 0; -else - num[0] = 0xffff; -emovo( num, c ); -} - - -void eiremain( den, num ) -unsigned short den[], num[]; -{ -long ld, ln; -unsigned short j; - -ld = den[E]; -ld -= enormlz( den ); -ln = num[E]; -ln -= enormlz( num ); -ecleaz( equot ); -while( ln >= ld ) - { - if( ecmpm(den,num) <= 0 ) - { - esubm(den, num); - j = 1; - } - else - { - j = 0; - } - eshup1(equot); - equot[NI-1] |= j; - eshup1(num); - ln -= 1; - } -emdnorm( num, 0, 0, ln, 0 ); -} - -/* NaN bit patterns - */ -#ifdef MIEEE -unsigned short nan113[8] = { - 0x7fff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff}; -unsigned short nan64[6] = {0x7fff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff}; -unsigned short nan53[4] = {0x7fff, 0xffff, 0xffff, 0xffff}; -unsigned short nan24[2] = {0x7fff, 0xffff}; -#endif - -#ifdef IBMPC -unsigned short nan113[8] = {0, 0, 0, 0, 0, 0, 0xc000, 0xffff}; -unsigned short nan64[6] = {0, 0, 0, 0xc000, 0xffff, 0}; -unsigned short nan53[4] = {0, 0, 0, 0xfff8}; -unsigned short nan24[2] = {0, 0xffc0}; -#endif - - -void enan (nan, size) -unsigned short *nan; -int size; -{ -int i, n; -unsigned short *p; - -switch( size ) - { -#ifndef DEC - case 113: - n = 8; - p = nan113; - break; - - case 64: - n = 6; - p = nan64; - break; - - case 53: - n = 4; - p = nan53; - break; - - case 24: - n = 2; - p = nan24; - break; - - case NBITS: - for( i=0; i<NE-2; i++ ) - *nan++ = 0; - *nan++ = 0xc000; - *nan++ = 0x7fff; - return; - - case NI*16: - *nan++ = 0; - *nan++ = 0x7fff; - *nan++ = 0; - *nan++ = 0xc000; - for( i=4; i<NI; i++ ) - *nan++ = 0; - return; -#endif - default: - mtherr( "enan", DOMAIN ); - return; - } -for (i=0; i < n; i++) - *nan++ = *p++; -} - - - -/* Longhand square root. */ - -static int esqinited = 0; -static unsigned short sqrndbit[NI]; - -void esqrt( x, y ) -unsigned short *x, *y; -{ -unsigned short temp[NI], num[NI], sq[NI], xx[NI]; -int i, j, k, n, nlups; -long m, exp; - -if( esqinited == 0 ) - { - ecleaz( sqrndbit ); - sqrndbit[NI-2] = 1; - esqinited = 1; - } -/* Check for arg <= 0 */ -i = ecmp( x, ezero ); -if( i <= 0 ) - { -#ifdef NANS - if (i == -2) - { - enan (y, NBITS); - return; - } -#endif - eclear(y); - if( i < 0 ) - mtherr( "esqrt", DOMAIN ); - return; - } - -#ifdef INFINITY -if( eisinf(x) ) - { - eclear(y); - einfin(y); - return; - } -#endif -/* Bring in the arg and renormalize if it is denormal. */ -emovi( x, xx ); -m = (long )xx[1]; /* local long word exponent */ -if( m == 0 ) - m -= enormlz( xx ); - -/* Divide exponent by 2 */ -m -= 0x3ffe; -exp = (unsigned short )( (m / 2) + 0x3ffe ); - -/* Adjust if exponent odd */ -if( (m & 1) != 0 ) - { - if( m > 0 ) - exp += 1; - eshdn1( xx ); - } - -ecleaz( sq ); -ecleaz( num ); -n = 8; /* get 8 bits of result per inner loop */ -nlups = rndprc; -j = 0; - -while( nlups > 0 ) - { -/* bring in next word of arg */ - if( j < NE ) - num[NI-1] = xx[j+3]; -/* Do additional bit on last outer loop, for roundoff. */ - if( nlups <= 8 ) - n = nlups + 1; - for( i=0; i<n; i++ ) - { -/* Next 2 bits of arg */ - eshup1( num ); - eshup1( num ); -/* Shift up answer */ - eshup1( sq ); -/* Make trial divisor */ - for( k=0; k<NI; k++ ) - temp[k] = sq[k]; - eshup1( temp ); - eaddm( sqrndbit, temp ); -/* Subtract and insert answer bit if it goes in */ - if( ecmpm( temp, num ) <= 0 ) - { - esubm( temp, num ); - sq[NI-2] |= 1; - } - } - nlups -= n; - j += 1; - } - -/* Adjust for extra, roundoff loop done. */ -exp += (NBITS - 1) - rndprc; - -/* Sticky bit = 1 if the remainder is nonzero. */ -k = 0; -for( i=3; i<NI; i++ ) - k |= (int )num[i]; - -/* Renormalize and round off. */ -emdnorm( sq, k, 0, exp, 64 ); -emovo( sq, y ); -} diff --git a/libm/ldouble/igamil.c b/libm/ldouble/igamil.c deleted file mode 100644 index 1abe503e9..000000000 --- a/libm/ldouble/igamil.c +++ /dev/null @@ -1,193 +0,0 @@ -/* igamil() - * - * Inverse of complemented imcomplete gamma integral - * - * - * - * SYNOPSIS: - * - * long double a, x, y, igamil(); - * - * x = igamil( a, y ); - * - * - * - * DESCRIPTION: - * - * Given y, the function finds x such that - * - * igamc( a, x ) = y. - * - * Starting with the approximate value - * - * 3 - * x = a t - * - * where - * - * t = 1 - d - ndtri(y) sqrt(d) - * - * and - * - * d = 1/9a, - * - * the routine performs up to 10 Newton iterations to find the - * root of igamc(a,x) - y = 0. - * - * - * ACCURACY: - * - * Tested for a ranging from 0.5 to 30 and x from 0 to 0.5. - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC 0,0.5 3400 8.8e-16 1.3e-16 - * IEEE 0,0.5 10000 1.1e-14 1.0e-15 - * - */ - -/* -Cephes Math Library Release 2.3: March, 1995 -Copyright 1984, 1995 by Stephen L. Moshier -*/ - -#include <math.h> - -extern long double MACHEPL, MAXNUML, MAXLOGL, MINLOGL; -#ifdef ANSIPROT -extern long double ndtril ( long double ); -extern long double expl ( long double ); -extern long double fabsl ( long double ); -extern long double logl ( long double ); -extern long double sqrtl ( long double ); -extern long double lgaml ( long double ); -extern long double igamcl ( long double, long double ); -#else -long double ndtril(), expl(), fabsl(), logl(), sqrtl(), lgaml(); -long double igamcl(); -#endif - -long double igamil( a, y0 ) -long double a, y0; -{ -long double x0, x1, x, yl, yh, y, d, lgm, dithresh; -int i, dir; - -/* bound the solution */ -x0 = MAXNUML; -yl = 0.0L; -x1 = 0.0L; -yh = 1.0L; -dithresh = 4.0 * MACHEPL; - -/* approximation to inverse function */ -d = 1.0L/(9.0L*a); -y = ( 1.0L - d - ndtril(y0) * sqrtl(d) ); -x = a * y * y * y; - -lgm = lgaml(a); - -for( i=0; i<10; i++ ) - { - if( x > x0 || x < x1 ) - goto ihalve; - y = igamcl(a,x); - if( y < yl || y > yh ) - goto ihalve; - if( y < y0 ) - { - x0 = x; - yl = y; - } - else - { - x1 = x; - yh = y; - } -/* compute the derivative of the function at this point */ - d = (a - 1.0L) * logl(x0) - x0 - lgm; - if( d < -MAXLOGL ) - goto ihalve; - d = -expl(d); -/* compute the step to the next approximation of x */ - d = (y - y0)/d; - x = x - d; - if( i < 3 ) - continue; - if( fabsl(d/x) < dithresh ) - goto done; - } - -/* Resort to interval halving if Newton iteration did not converge. */ -ihalve: - -d = 0.0625L; -if( x0 == MAXNUML ) - { - if( x <= 0.0L ) - x = 1.0L; - while( x0 == MAXNUML ) - { - x = (1.0L + d) * x; - y = igamcl( a, x ); - if( y < y0 ) - { - x0 = x; - yl = y; - break; - } - d = d + d; - } - } -d = 0.5L; -dir = 0; - -for( i=0; i<400; i++ ) - { - x = x1 + d * (x0 - x1); - y = igamcl( a, x ); - lgm = (x0 - x1)/(x1 + x0); - if( fabsl(lgm) < dithresh ) - break; - lgm = (y - y0)/y0; - if( fabsl(lgm) < dithresh ) - break; - if( x <= 0.0L ) - break; - if( y > y0 ) - { - x1 = x; - yh = y; - if( dir < 0 ) - { - dir = 0; - d = 0.5L; - } - else if( dir > 1 ) - d = 0.5L * d + 0.5L; - else - d = (y0 - yl)/(yh - yl); - dir += 1; - } - else - { - x0 = x; - yl = y; - if( dir > 0 ) - { - dir = 0; - d = 0.5L; - } - else if( dir < -1 ) - d = 0.5L * d; - else - d = (y0 - yl)/(yh - yl); - dir -= 1; - } - } -if( x == 0.0L ) - mtherr( "igamil", UNDERFLOW ); - -done: -return( x ); -} diff --git a/libm/ldouble/igaml.c b/libm/ldouble/igaml.c deleted file mode 100644 index 0e59c5404..000000000 --- a/libm/ldouble/igaml.c +++ /dev/null @@ -1,220 +0,0 @@ -/* igaml.c - * - * Incomplete gamma integral - * - * - * - * SYNOPSIS: - * - * long double a, x, y, igaml(); - * - * y = igaml( a, x ); - * - * - * - * DESCRIPTION: - * - * The function is defined by - * - * x - * - - * 1 | | -t a-1 - * igam(a,x) = ----- | e t dt. - * - | | - * | (a) - - * 0 - * - * - * In this implementation both arguments must be positive. - * The integral is evaluated by either a power series or - * continued fraction expansion, depending on the relative - * values of a and x. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC 0,30 4000 4.4e-15 6.3e-16 - * IEEE 0,30 10000 3.6e-14 5.1e-15 - * - */ - /* igamcl() - * - * Complemented incomplete gamma integral - * - * - * - * SYNOPSIS: - * - * long double a, x, y, igamcl(); - * - * y = igamcl( a, x ); - * - * - * - * DESCRIPTION: - * - * The function is defined by - * - * - * igamc(a,x) = 1 - igam(a,x) - * - * inf. - * - - * 1 | | -t a-1 - * = ----- | e t dt. - * - | | - * | (a) - - * x - * - * - * In this implementation both arguments must be positive. - * The integral is evaluated by either a power series or - * continued fraction expansion, depending on the relative - * values of a and x. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * DEC 0,30 2000 2.7e-15 4.0e-16 - * IEEE 0,30 60000 1.4e-12 6.3e-15 - * - */ - -/* -Cephes Math Library Release 2.3: March, 1995 -Copyright 1985, 1995 by Stephen L. Moshier -*/ - -#include <math.h> -#ifdef ANSIPROT -extern long double lgaml ( long double ); -extern long double expl ( long double ); -extern long double logl ( long double ); -extern long double fabsl ( long double ); -extern long double gammal ( long double ); -long double igaml ( long double, long double ); -long double igamcl ( long double, long double ); -#else -long double lgaml(), expl(), logl(), fabsl(), igaml(), gammal(); -long double igamcl(); -#endif - -#define BIG 9.223372036854775808e18L -#define MAXGAML 1755.455L -extern long double MACHEPL, MINLOGL; - -long double igamcl( a, x ) -long double a, x; -{ -long double ans, c, yc, ax, y, z, r, t; -long double pk, pkm1, pkm2, qk, qkm1, qkm2; - -if( (x <= 0.0L) || ( a <= 0.0L) ) - return( 1.0L ); - -if( (x < 1.0L) || (x < a) ) - return( 1.0L - igaml(a,x) ); - -ax = a * logl(x) - x - lgaml(a); -if( ax < MINLOGL ) - { - mtherr( "igamcl", UNDERFLOW ); - return( 0.0L ); - } -ax = expl(ax); - -/* continued fraction */ -y = 1.0L - a; -z = x + y + 1.0L; -c = 0.0L; -pkm2 = 1.0L; -qkm2 = x; -pkm1 = x + 1.0L; -qkm1 = z * x; -ans = pkm1/qkm1; - -do - { - c += 1.0L; - y += 1.0L; - z += 2.0L; - yc = y * c; - pk = pkm1 * z - pkm2 * yc; - qk = qkm1 * z - qkm2 * yc; - if( qk != 0.0L ) - { - r = pk/qk; - t = fabsl( (ans - r)/r ); - ans = r; - } - else - t = 1.0L; - pkm2 = pkm1; - pkm1 = pk; - qkm2 = qkm1; - qkm1 = qk; - if( fabsl(pk) > BIG ) - { - pkm2 /= BIG; - pkm1 /= BIG; - qkm2 /= BIG; - qkm1 /= BIG; - } - } -while( t > MACHEPL ); - -return( ans * ax ); -} - - - -/* left tail of incomplete gamma function: - * - * inf. k - * a -x - x - * x e > ---------- - * - - - * k=0 | (a+k+1) - * - */ - -long double igaml( a, x ) -long double a, x; -{ -long double ans, ax, c, r; - -if( (x <= 0.0L) || ( a <= 0.0L) ) - return( 0.0L ); - -if( (x > 1.0L) && (x > a ) ) - return( 1.0L - igamcl(a,x) ); - -ax = a * logl(x) - x - lgaml(a); -if( ax < MINLOGL ) - { - mtherr( "igaml", UNDERFLOW ); - return( 0.0L ); - } -ax = expl(ax); - -/* power series */ -r = a; -c = 1.0L; -ans = 1.0L; - -do - { - r += 1.0L; - c *= x/r; - ans += c; - } -while( c/ans > MACHEPL ); - -return( ans * ax/a ); -} diff --git a/libm/ldouble/incbetl.c b/libm/ldouble/incbetl.c deleted file mode 100644 index fc85ead4c..000000000 --- a/libm/ldouble/incbetl.c +++ /dev/null @@ -1,406 +0,0 @@ -/* incbetl.c - * - * Incomplete beta integral - * - * - * SYNOPSIS: - * - * long double a, b, x, y, incbetl(); - * - * y = incbetl( a, b, x ); - * - * - * DESCRIPTION: - * - * Returns incomplete beta integral of the arguments, evaluated - * from zero to x. The function is defined as - * - * x - * - - - * | (a+b) | | a-1 b-1 - * ----------- | t (1-t) dt. - * - - | | - * | (a) | (b) - - * 0 - * - * The domain of definition is 0 <= x <= 1. In this - * implementation a and b are restricted to positive values. - * The integral from x to 1 may be obtained by the symmetry - * relation - * - * 1 - incbet( a, b, x ) = incbet( b, a, 1-x ). - * - * The integral is evaluated by a continued fraction expansion - * or, when b*x is small, by a power series. - * - * ACCURACY: - * - * Tested at random points (a,b,x) with x between 0 and 1. - * arithmetic domain # trials peak rms - * IEEE 0,5 20000 4.5e-18 2.4e-19 - * IEEE 0,100 100000 3.9e-17 1.0e-17 - * Half-integer a, b: - * IEEE .5,10000 100000 3.9e-14 4.4e-15 - * Outputs smaller than the IEEE gradual underflow threshold - * were excluded from these statistics. - * - * ERROR MESSAGES: - * - * message condition value returned - * incbetl domain x<0, x>1 0.0 - */ - - -/* -Cephes Math Library, Release 2.3: January, 1995 -Copyright 1984, 1995 by Stephen L. Moshier -*/ - -#include <math.h> - -#define MAXGAML 1755.455L -static long double big = 9.223372036854775808e18L; -static long double biginv = 1.084202172485504434007e-19L; -extern long double MACHEPL, MINLOGL, MAXLOGL; - -#ifdef ANSIPROT -extern long double gammal ( long double ); -extern long double lgaml ( long double ); -extern long double expl ( long double ); -extern long double logl ( long double ); -extern long double fabsl ( long double ); -extern long double powl ( long double, long double ); -static long double incbcfl( long double, long double, long double ); -static long double incbdl( long double, long double, long double ); -static long double pseriesl( long double, long double, long double ); -#else -long double gammal(), lgaml(), expl(), logl(), fabsl(), powl(); -static long double incbcfl(), incbdl(), pseriesl(); -#endif - -long double incbetl( aa, bb, xx ) -long double aa, bb, xx; -{ -long double a, b, t, x, w, xc, y; -int flag; - -if( aa <= 0.0L || bb <= 0.0L ) - goto domerr; - -if( (xx <= 0.0L) || ( xx >= 1.0L) ) - { - if( xx == 0.0L ) - return( 0.0L ); - if( xx == 1.0L ) - return( 1.0L ); -domerr: - mtherr( "incbetl", DOMAIN ); - return( 0.0L ); - } - -flag = 0; -if( (bb * xx) <= 1.0L && xx <= 0.95L) - { - t = pseriesl(aa, bb, xx); - goto done; - } - -w = 1.0L - xx; - -/* Reverse a and b if x is greater than the mean. */ -if( xx > (aa/(aa+bb)) ) - { - flag = 1; - a = bb; - b = aa; - xc = xx; - x = w; - } -else - { - a = aa; - b = bb; - xc = w; - x = xx; - } - -if( flag == 1 && (b * x) <= 1.0L && x <= 0.95L) - { - t = pseriesl(a, b, x); - goto done; - } - -/* Choose expansion for optimal convergence */ -y = x * (a+b-2.0L) - (a-1.0L); -if( y < 0.0L ) - w = incbcfl( a, b, x ); -else - w = incbdl( a, b, x ) / xc; - -/* Multiply w by the factor - a b _ _ _ - x (1-x) | (a+b) / ( a | (a) | (b) ) . */ - -y = a * logl(x); -t = b * logl(xc); -if( (a+b) < MAXGAML && fabsl(y) < MAXLOGL && fabsl(t) < MAXLOGL ) - { - t = powl(xc,b); - t *= powl(x,a); - t /= a; - t *= w; - t *= gammal(a+b) / (gammal(a) * gammal(b)); - goto done; - } -else - { - /* Resort to logarithms. */ - y += t + lgaml(a+b) - lgaml(a) - lgaml(b); - y += logl(w/a); - if( y < MINLOGL ) - t = 0.0L; - else - t = expl(y); - } - -done: - -if( flag == 1 ) - { - if( t <= MACHEPL ) - t = 1.0L - MACHEPL; - else - t = 1.0L - t; - } -return( t ); -} - -/* Continued fraction expansion #1 - * for incomplete beta integral - */ - -static long double incbcfl( a, b, x ) -long double a, b, x; -{ -long double xk, pk, pkm1, pkm2, qk, qkm1, qkm2; -long double k1, k2, k3, k4, k5, k6, k7, k8; -long double r, t, ans, thresh; -int n; - -k1 = a; -k2 = a + b; -k3 = a; -k4 = a + 1.0L; -k5 = 1.0L; -k6 = b - 1.0L; -k7 = k4; -k8 = a + 2.0L; - -pkm2 = 0.0L; -qkm2 = 1.0L; -pkm1 = 1.0L; -qkm1 = 1.0L; -ans = 1.0L; -r = 1.0L; -n = 0; -thresh = 3.0L * MACHEPL; -do - { - - xk = -( x * k1 * k2 )/( k3 * k4 ); - pk = pkm1 + pkm2 * xk; - qk = qkm1 + qkm2 * xk; - pkm2 = pkm1; - pkm1 = pk; - qkm2 = qkm1; - qkm1 = qk; - - xk = ( x * k5 * k6 )/( k7 * k8 ); - pk = pkm1 + pkm2 * xk; - qk = qkm1 + qkm2 * xk; - pkm2 = pkm1; - pkm1 = pk; - qkm2 = qkm1; - qkm1 = qk; - - if( qk != 0.0L ) - r = pk/qk; - if( r != 0.0L ) - { - t = fabsl( (ans - r)/r ); - ans = r; - } - else - t = 1.0L; - - if( t < thresh ) - goto cdone; - - k1 += 1.0L; - k2 += 1.0L; - k3 += 2.0L; - k4 += 2.0L; - k5 += 1.0L; - k6 -= 1.0L; - k7 += 2.0L; - k8 += 2.0L; - - if( (fabsl(qk) + fabsl(pk)) > big ) - { - pkm2 *= biginv; - pkm1 *= biginv; - qkm2 *= biginv; - qkm1 *= biginv; - } - if( (fabsl(qk) < biginv) || (fabsl(pk) < biginv) ) - { - pkm2 *= big; - pkm1 *= big; - qkm2 *= big; - qkm1 *= big; - } - } -while( ++n < 400 ); -mtherr( "incbetl", PLOSS ); - -cdone: -return(ans); -} - - -/* Continued fraction expansion #2 - * for incomplete beta integral - */ - -static long double incbdl( a, b, x ) -long double a, b, x; -{ -long double xk, pk, pkm1, pkm2, qk, qkm1, qkm2; -long double k1, k2, k3, k4, k5, k6, k7, k8; -long double r, t, ans, z, thresh; -int n; - -k1 = a; -k2 = b - 1.0L; -k3 = a; -k4 = a + 1.0L; -k5 = 1.0L; -k6 = a + b; -k7 = a + 1.0L; -k8 = a + 2.0L; - -pkm2 = 0.0L; -qkm2 = 1.0L; -pkm1 = 1.0L; -qkm1 = 1.0L; -z = x / (1.0L-x); -ans = 1.0L; -r = 1.0L; -n = 0; -thresh = 3.0L * MACHEPL; -do - { - - xk = -( z * k1 * k2 )/( k3 * k4 ); - pk = pkm1 + pkm2 * xk; - qk = qkm1 + qkm2 * xk; - pkm2 = pkm1; - pkm1 = pk; - qkm2 = qkm1; - qkm1 = qk; - - xk = ( z * k5 * k6 )/( k7 * k8 ); - pk = pkm1 + pkm2 * xk; - qk = qkm1 + qkm2 * xk; - pkm2 = pkm1; - pkm1 = pk; - qkm2 = qkm1; - qkm1 = qk; - - if( qk != 0.0L ) - r = pk/qk; - if( r != 0.0L ) - { - t = fabsl( (ans - r)/r ); - ans = r; - } - else - t = 1.0L; - - if( t < thresh ) - goto cdone; - - k1 += 1.0L; - k2 -= 1.0L; - k3 += 2.0L; - k4 += 2.0L; - k5 += 1.0L; - k6 += 1.0L; - k7 += 2.0L; - k8 += 2.0L; - - if( (fabsl(qk) + fabsl(pk)) > big ) - { - pkm2 *= biginv; - pkm1 *= biginv; - qkm2 *= biginv; - qkm1 *= biginv; - } - if( (fabsl(qk) < biginv) || (fabsl(pk) < biginv) ) - { - pkm2 *= big; - pkm1 *= big; - qkm2 *= big; - qkm1 *= big; - } - } -while( ++n < 400 ); -mtherr( "incbetl", PLOSS ); - -cdone: -return(ans); -} - -/* Power series for incomplete gamma integral. - Use when b*x is small. */ - -static long double pseriesl( a, b, x ) -long double a, b, x; -{ -long double s, t, u, v, n, t1, z, ai; - -ai = 1.0L / a; -u = (1.0L - b) * x; -v = u / (a + 1.0L); -t1 = v; -t = u; -n = 2.0L; -s = 0.0L; -z = MACHEPL * ai; -while( fabsl(v) > z ) - { - u = (n - b) * x / n; - t *= u; - v = t / (a + n); - s += v; - n += 1.0L; - } -s += t1; -s += ai; - -u = a * logl(x); -if( (a+b) < MAXGAML && fabsl(u) < MAXLOGL ) - { - t = gammal(a+b)/(gammal(a)*gammal(b)); - s = s * t * powl(x,a); - } -else - { - t = lgaml(a+b) - lgaml(a) - lgaml(b) + u + logl(s); - if( t < MINLOGL ) - s = 0.0L; - else - s = expl(t); - } -return(s); -} diff --git a/libm/ldouble/incbil.c b/libm/ldouble/incbil.c deleted file mode 100644 index b7610706b..000000000 --- a/libm/ldouble/incbil.c +++ /dev/null @@ -1,305 +0,0 @@ -/* incbil() - * - * Inverse of imcomplete beta integral - * - * - * - * SYNOPSIS: - * - * long double a, b, x, y, incbil(); - * - * x = incbil( a, b, y ); - * - * - * - * DESCRIPTION: - * - * Given y, the function finds x such that - * - * incbet( a, b, x ) = y. - * - * the routine performs up to 10 Newton iterations to find the - * root of incbet(a,b,x) - y = 0. - * - * - * ACCURACY: - * - * Relative error: - * x a,b - * arithmetic domain domain # trials peak rms - * IEEE 0,1 .5,10000 10000 1.1e-14 1.4e-16 - */ - - -/* -Cephes Math Library Release 2.3: March, 1995 -Copyright 1984, 1995 by Stephen L. Moshier -*/ - -#include <math.h> - -extern long double MACHEPL, MAXNUML, MAXLOGL, MINLOGL; -#ifdef ANSIPROT -extern long double incbetl ( long double, long double, long double ); -extern long double expl ( long double ); -extern long double fabsl ( long double ); -extern long double logl ( long double ); -extern long double sqrtl ( long double ); -extern long double lgaml ( long double ); -extern long double ndtril ( long double ); -#else -long double incbetl(), expl(), fabsl(), logl(), sqrtl(), lgaml(); -long double ndtril(); -#endif - -long double incbil( aa, bb, yy0 ) -long double aa, bb, yy0; -{ -long double a, b, y0, d, y, x, x0, x1, lgm, yp, di, dithresh, yl, yh, xt; -int i, rflg, dir, nflg; - - -if( yy0 <= 0.0L ) - return(0.0L); -if( yy0 >= 1.0L ) - return(1.0L); -x0 = 0.0L; -yl = 0.0L; -x1 = 1.0L; -yh = 1.0L; -if( aa <= 1.0L || bb <= 1.0L ) - { - dithresh = 1.0e-7L; - rflg = 0; - a = aa; - b = bb; - y0 = yy0; - x = a/(a+b); - y = incbetl( a, b, x ); - nflg = 0; - goto ihalve; - } -else - { - nflg = 0; - dithresh = 1.0e-4L; - } - -/* approximation to inverse function */ - -yp = -ndtril( yy0 ); - -if( yy0 > 0.5L ) - { - rflg = 1; - a = bb; - b = aa; - y0 = 1.0L - yy0; - yp = -yp; - } -else - { - rflg = 0; - a = aa; - b = bb; - y0 = yy0; - } - -lgm = (yp * yp - 3.0L)/6.0L; -x = 2.0L/( 1.0L/(2.0L * a-1.0L) + 1.0L/(2.0L * b - 1.0L) ); -d = yp * sqrtl( x + lgm ) / x - - ( 1.0L/(2.0L * b - 1.0L) - 1.0L/(2.0L * a - 1.0L) ) - * (lgm + (5.0L/6.0L) - 2.0L/(3.0L * x)); -d = 2.0L * d; -if( d < MINLOGL ) - { - x = 1.0L; - goto under; - } -x = a/( a + b * expl(d) ); -y = incbetl( a, b, x ); -yp = (y - y0)/y0; -if( fabsl(yp) < 0.2 ) - goto newt; - -/* Resort to interval halving if not close enough. */ -ihalve: - -dir = 0; -di = 0.5L; -for( i=0; i<400; i++ ) - { - if( i != 0 ) - { - x = x0 + di * (x1 - x0); - if( x == 1.0L ) - x = 1.0L - MACHEPL; - if( x == 0.0L ) - { - di = 0.5; - x = x0 + di * (x1 - x0); - if( x == 0.0 ) - goto under; - } - y = incbetl( a, b, x ); - yp = (x1 - x0)/(x1 + x0); - if( fabsl(yp) < dithresh ) - goto newt; - yp = (y-y0)/y0; - if( fabsl(yp) < dithresh ) - goto newt; - } - if( y < y0 ) - { - x0 = x; - yl = y; - if( dir < 0 ) - { - dir = 0; - di = 0.5L; - } - else if( dir > 3 ) - di = 1.0L - (1.0L - di) * (1.0L - di); - else if( dir > 1 ) - di = 0.5L * di + 0.5L; - else - di = (y0 - y)/(yh - yl); - dir += 1; - if( x0 > 0.95L ) - { - if( rflg == 1 ) - { - rflg = 0; - a = aa; - b = bb; - y0 = yy0; - } - else - { - rflg = 1; - a = bb; - b = aa; - y0 = 1.0 - yy0; - } - x = 1.0L - x; - y = incbetl( a, b, x ); - x0 = 0.0; - yl = 0.0; - x1 = 1.0; - yh = 1.0; - goto ihalve; - } - } - else - { - x1 = x; - if( rflg == 1 && x1 < MACHEPL ) - { - x = 0.0L; - goto done; - } - yh = y; - if( dir > 0 ) - { - dir = 0; - di = 0.5L; - } - else if( dir < -3 ) - di = di * di; - else if( dir < -1 ) - di = 0.5L * di; - else - di = (y - y0)/(yh - yl); - dir -= 1; - } - } -mtherr( "incbil", PLOSS ); -if( x0 >= 1.0L ) - { - x = 1.0L - MACHEPL; - goto done; - } -if( x <= 0.0L ) - { -under: - mtherr( "incbil", UNDERFLOW ); - x = 0.0L; - goto done; - } - -newt: - -if( nflg ) - goto done; -nflg = 1; -lgm = lgaml(a+b) - lgaml(a) - lgaml(b); - -for( i=0; i<15; i++ ) - { - /* Compute the function at this point. */ - if( i != 0 ) - y = incbetl(a,b,x); - if( y < yl ) - { - x = x0; - y = yl; - } - else if( y > yh ) - { - x = x1; - y = yh; - } - else if( y < y0 ) - { - x0 = x; - yl = y; - } - else - { - x1 = x; - yh = y; - } - if( x == 1.0L || x == 0.0L ) - break; - /* Compute the derivative of the function at this point. */ - d = (a - 1.0L) * logl(x) + (b - 1.0L) * logl(1.0L - x) + lgm; - if( d < MINLOGL ) - goto done; - if( d > MAXLOGL ) - break; - d = expl(d); - /* Compute the step to the next approximation of x. */ - d = (y - y0)/d; - xt = x - d; - if( xt <= x0 ) - { - y = (x - x0) / (x1 - x0); - xt = x0 + 0.5L * y * (x - x0); - if( xt <= 0.0L ) - break; - } - if( xt >= x1 ) - { - y = (x1 - x) / (x1 - x0); - xt = x1 - 0.5L * y * (x1 - x); - if( xt >= 1.0L ) - break; - } - x = xt; - if( fabsl(d/x) < (128.0L * MACHEPL) ) - goto done; - } -/* Did not converge. */ -dithresh = 256.0L * MACHEPL; -goto ihalve; - -done: -if( rflg ) - { - if( x <= MACHEPL ) - x = 1.0L - MACHEPL; - else - x = 1.0L - x; - } -return( x ); -} diff --git a/libm/ldouble/isnanl.c b/libm/ldouble/isnanl.c deleted file mode 100644 index 44158ecc7..000000000 --- a/libm/ldouble/isnanl.c +++ /dev/null @@ -1,186 +0,0 @@ -/* isnanl() - * isfinitel() - * signbitl() - * - * Floating point IEEE special number tests - * - * - * - * SYNOPSIS: - * - * int signbitl(), isnanl(), isfinitel(); - * long double x, y; - * - * n = signbitl(x); - * n = isnanl(x); - * n = isfinitel(x); - * - * - * - * DESCRIPTION: - * - * These functions are part of the standard C run time library - * for some but not all C compilers. The ones supplied are - * written in C for IEEE arithmetic. They should - * be used only if your compiler library does not already have - * them. - * - */ - - -/* -Cephes Math Library Release 2.7: June, 1998 -Copyright 1992, 1998 by Stephen L. Moshier -*/ - - -#include <math.h> - -/* This is defined in mconf.h. */ -/* #define DENORMAL 1 */ - -#ifdef UNK -/* Change UNK into something else. */ -#undef UNK -#if BIGENDIAN -#define MIEEE 1 -#else -#define IBMPC 1 -#endif -#endif - - -/* Return 1 if the sign bit of x is 1, else 0. */ - -int signbitl(x) -long double x; -{ -union - { - long double d; - short s[6]; - int i[3]; - } u; - -u.d = x; - -if( sizeof(int) == 4 ) - { -#ifdef IBMPC - return( u.s[4] < 0 ); -#endif -#ifdef MIEEE - return( u.i[0] < 0 ); -#endif - } -else - { -#ifdef IBMPC - return( u.s[4] < 0 ); -#endif -#ifdef MIEEE - return( u.s[0] < 0 ); -#endif - } -} - - -/* Return 1 if x is a number that is Not a Number, else return 0. */ - -int isnanl(x) -long double x; -{ -#ifdef NANS -union - { - long double d; - unsigned short s[6]; - unsigned int i[3]; - } u; - -u.d = x; - -if( sizeof(int) == 4 ) - { -#ifdef IBMPC - if( ((u.s[4] & 0x7fff) == 0x7fff) - && (((u.i[1] & 0x7fffffff)!= 0) || (u.i[0] != 0))) - return 1; -#endif -#ifdef MIEEE - if( ((u.i[0] & 0x7fff0000) == 0x7fff0000) - && (((u.i[1] & 0x7fffffff) != 0) || (u.i[2] != 0))) - return 1; -#endif - return(0); - } -else - { /* size int not 4 */ -#ifdef IBMPC - if( (u.s[4] & 0x7fff) == 0x7fff) - { - if((u.s[3] & 0x7fff) | u.s[2] | u.s[1] | u.s[0]) - return(1); - } -#endif -#ifdef MIEEE - if( (u.s[0] & 0x7fff) == 0x7fff) - { - if((u.s[2] & 0x7fff) | u.s[3] | u.s[4] | u.s[5]) - return(1); - } -#endif - return(0); - } /* size int not 4 */ - -#else -/* No NANS. */ -return(0); -#endif -} - - -/* Return 1 if x is not infinite and is not a NaN. */ - -int isfinitel(x) -long double x; -{ -#ifdef INFINITIES -union - { - long double d; - unsigned short s[6]; - unsigned int i[3]; - } u; - -u.d = x; - -if( sizeof(int) == 4 ) - { -#ifdef IBMPC - if( (u.s[4] & 0x7fff) != 0x7fff) - return 1; -#endif -#ifdef MIEEE - if( (u.i[0] & 0x7fff0000) != 0x7fff0000) - return 1; -#endif - return(0); - } -else - { -#ifdef IBMPC - if( (u.s[4] & 0x7fff) != 0x7fff) - return 1; -#endif -#ifdef MIEEE - if( (u.s[0] & 0x7fff) != 0x7fff) - return 1; -#endif - return(0); - } -#else -/* No INFINITY. */ -return(1); -#endif -} diff --git a/libm/ldouble/j0l.c b/libm/ldouble/j0l.c deleted file mode 100644 index a30a65a4f..000000000 --- a/libm/ldouble/j0l.c +++ /dev/null @@ -1,541 +0,0 @@ -/* j0l.c - * - * Bessel function of order zero - * - * - * - * SYNOPSIS: - * - * long double x, y, j0l(); - * - * y = j0l( x ); - * - * - * - * DESCRIPTION: - * - * Returns Bessel function of first kind, order zero of the argument. - * - * The domain is divided into the intervals [0, 9] and - * (9, infinity). In the first interval the rational approximation - * is (x^2 - r^2) (x^2 - s^2) (x^2 - t^2) P7(x^2) / Q8(x^2), - * where r, s, t are the first three zeros of the function. - * In the second interval the expansion is in terms of the - * modulus M0(x) = sqrt(J0(x)^2 + Y0(x)^2) and phase P0(x) - * = atan(Y0(x)/J0(x)). M0 is approximated by sqrt(1/x)P7(1/x)/Q7(1/x). - * The approximation to J0 is M0 * cos(x - pi/4 + 1/x P5(1/x^2)/Q6(1/x^2)). - * - * - * ACCURACY: - * - * Absolute error: - * arithmetic domain # trials peak rms - * IEEE 0, 30 100000 2.8e-19 7.4e-20 - * - * - */ - /* y0l.c - * - * Bessel function of the second kind, order zero - * - * - * - * SYNOPSIS: - * - * double x, y, y0l(); - * - * y = y0l( x ); - * - * - * - * DESCRIPTION: - * - * Returns Bessel function of the second kind, of order - * zero, of the argument. - * - * The domain is divided into the intervals [0, 5>, [5,9> and - * [9, infinity). In the first interval a rational approximation - * R(x) is employed to compute y0(x) = R(x) + 2/pi * log(x) * j0(x). - * - * In the second interval, the approximation is - * (x - p)(x - q)(x - r)(x - s)P7(x)/Q7(x) - * where p, q, r, s are zeros of y0(x). - * - * The third interval uses the same approximations to modulus - * and phase as j0(x), whence y0(x) = modulus * sin(phase). - * - * ACCURACY: - * - * Absolute error, when y0(x) < 1; else relative error: - * - * arithmetic domain # trials peak rms - * IEEE 0, 30 100000 3.4e-19 7.6e-20 - * - */ - -/* Copyright 1994 by Stephen L. Moshier (moshier@world.std.com). */ - -#include <math.h> - -/* -j0(x) = (x^2-JZ1)(x^2-JZ2)(x^2-JZ3)P(x**2)/Q(x**2) -0 <= x <= 9 -Relative error -n=7, d=8 -Peak error = 8.49e-22 -Relative error spread = 2.2e-3 -*/ -#if UNK -static long double j0n[8] = { - 1.296848754518641770562E0L, --3.239201943301299801018E3L, - 3.490002040733471400107E6L, --2.076797068740966813173E9L, - 7.283696461857171054941E11L, --1.487926133645291056388E14L, - 1.620335009643150402368E16L, --7.173386747526788067407E17L, -}; -static long double j0d[8] = { -/* 1.000000000000000000000E0L,*/ - 2.281959869176887763845E3L, - 2.910386840401647706984E6L, - 2.608400226578100610991E9L, - 1.752689035792859338860E12L, - 8.879132373286001289461E14L, - 3.265560832845194013669E17L, - 7.881340554308432241892E19L, - 9.466475654163919450528E21L, -}; -#endif -#if IBMPC -static short j0n[] = { -0xf759,0x4208,0x23d6,0xa5ff,0x3fff, XPD -0xa9a8,0xe62b,0x3b28,0xca73,0xc00a, XPD -0xfe10,0xb608,0x4829,0xd503,0x4014, XPD -0x008c,0x7b60,0xd119,0xf792,0xc01d, XPD -0x943a,0x69b7,0x36ca,0xa996,0x4026, XPD -0x1b0b,0x6331,0x7add,0x8753,0xc02e, XPD -0x4018,0xad26,0x71ba,0xe643,0x4034, XPD -0xb96c,0xc486,0xfb95,0x9f47,0xc03a, XPD -}; -static short j0d[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ -0xbdfe,0xc832,0x5b9f,0x8e9f,0x400a, XPD -0xe1a0,0x923f,0xcb5c,0xb1a2,0x4014, XPD -0x66d2,0x93fe,0x0762,0x9b79,0x401e, XPD -0xfed1,0x086d,0x3425,0xcc0a,0x4027, XPD -0x0841,0x8cb6,0x5a46,0xc9e3,0x4030, XPD -0x3d2c,0xed55,0x20e1,0x9105,0x4039, XPD -0xfdce,0xa4ca,0x2ed8,0x88b8,0x4041, XPD -0x00ac,0xfb2b,0x6f62,0x804b,0x4048, XPD -}; -#endif -#if MIEEE -static long j0n[24] = { -0x3fff0000,0xa5ff23d6,0x4208f759, -0xc00a0000,0xca733b28,0xe62ba9a8, -0x40140000,0xd5034829,0xb608fe10, -0xc01d0000,0xf792d119,0x7b60008c, -0x40260000,0xa99636ca,0x69b7943a, -0xc02e0000,0x87537add,0x63311b0b, -0x40340000,0xe64371ba,0xad264018, -0xc03a0000,0x9f47fb95,0xc486b96c, -}; -static long j0d[24] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0x400a0000,0x8e9f5b9f,0xc832bdfe, -0x40140000,0xb1a2cb5c,0x923fe1a0, -0x401e0000,0x9b790762,0x93fe66d2, -0x40270000,0xcc0a3425,0x086dfed1, -0x40300000,0xc9e35a46,0x8cb60841, -0x40390000,0x910520e1,0xed553d2c, -0x40410000,0x88b82ed8,0xa4cafdce, -0x40480000,0x804b6f62,0xfb2b00ac, -}; -#endif -/* -sqrt(j0^2(1/x^2) + y0^2(1/x^2)) = z P(z**2)/Q(z**2) -z(x) = 1/sqrt(x) -Relative error -n=7, d=7 -Peak error = 1.80e-20 -Relative error spread = 5.1e-2 -*/ -#if UNK -static long double modulusn[8] = { - 3.947542376069224461532E-1L, - 6.864682945702134624126E0L, - 1.021369773577974343844E1L, - 7.626141421290849630523E0L, - 2.842537511425216145635E0L, - 7.162842530423205720962E-1L, - 9.036664453160200052296E-2L, - 8.461833426898867839659E-3L, -}; -static long double modulusd[7] = { -/* 1.000000000000000000000E0L,*/ - 9.117176038171821115904E0L, - 1.301235226061478261481E1L, - 9.613002539386213788182E0L, - 3.569671060989910901903E0L, - 8.983920141407590632423E-1L, - 1.132577931332212304986E-1L, - 1.060533546154121770442E-2L, -}; -#endif -#if IBMPC -static short modulusn[] = { -0x8559,0xf552,0x3a38,0xca1d,0x3ffd, XPD -0x38a3,0xa663,0x7b91,0xdbab,0x4001, XPD -0xb343,0x2673,0x4e51,0xa36b,0x4002, XPD -0x5e4b,0xe3af,0x59bb,0xf409,0x4001, XPD -0xb1cd,0x4e5e,0x2274,0xb5ec,0x4000, XPD -0xcfe9,0x74e0,0x67a1,0xb75e,0x3ffe, XPD -0x6b78,0x4cc6,0x25b7,0xb912,0x3ffb, XPD -0xcb2b,0x4b73,0x8075,0x8aa3,0x3ff8, XPD -}; -static short modulusd[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ -0x4498,0x3d2a,0xf3fb,0x91df,0x4002, XPD -0x5e3d,0xb5f4,0x9848,0xd032,0x4002, XPD -0xb837,0x3075,0xdbc0,0x99ce,0x4002, XPD -0x775a,0x1b79,0x7d9c,0xe475,0x4000, XPD -0x7e3f,0xb8dd,0x04df,0xe5fd,0x3ffe, XPD -0xed5a,0x31cd,0xb3ac,0xe7f3,0x3ffb, XPD -0x8a83,0x1b80,0x003e,0xadc2,0x3ff8, XPD -}; -#endif -#if MIEEE -static long modulusn[24] = { -0x3ffd0000,0xca1d3a38,0xf5528559, -0x40010000,0xdbab7b91,0xa66338a3, -0x40020000,0xa36b4e51,0x2673b343, -0x40010000,0xf40959bb,0xe3af5e4b, -0x40000000,0xb5ec2274,0x4e5eb1cd, -0x3ffe0000,0xb75e67a1,0x74e0cfe9, -0x3ffb0000,0xb91225b7,0x4cc66b78, -0x3ff80000,0x8aa38075,0x4b73cb2b, -}; -static long modulusd[21] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0x40020000,0x91dff3fb,0x3d2a4498, -0x40020000,0xd0329848,0xb5f45e3d, -0x40020000,0x99cedbc0,0x3075b837, -0x40000000,0xe4757d9c,0x1b79775a, -0x3ffe0000,0xe5fd04df,0xb8dd7e3f, -0x3ffb0000,0xe7f3b3ac,0x31cded5a, -0x3ff80000,0xadc2003e,0x1b808a83, -}; -#endif -/* -atan(y0(x)/j0(x)) = x - pi/4 + x P(x**2)/Q(x**2) -Absolute error -n=5, d=6 -Peak error = 2.80e-21 -Relative error spread = 5.5e-1 -*/ -#if UNK -static long double phasen[6] = { --7.356766355393571519038E-1L, --5.001635199922493694706E-1L, --7.737323518141516881715E-2L, --3.998893155826990642730E-3L, --7.496317036829964150970E-5L, --4.290885090773112963542E-7L, -}; -static long double phased[6] = { -/* 1.000000000000000000000E0L,*/ - 7.377856408614376072745E0L, - 4.285043297797736118069E0L, - 6.348446472935245102890E-1L, - 3.229866782185025048457E-2L, - 6.014932317342190404134E-4L, - 3.432708072618490390095E-6L, -}; -#endif -#if IBMPC -static short phasen[] = { -0x5106,0x12a6,0x4dd2,0xbc55,0xbffe, XPD -0x1e30,0x04da,0xb769,0x800a,0xbffe, XPD -0x8d8a,0x84e7,0xdbd5,0x9e75,0xbffb, XPD -0xe514,0x8866,0x25a9,0x8309,0xbff7, XPD -0xdc17,0x325e,0x8baf,0x9d35,0xbff1, XPD -0x4c2f,0x2dd8,0x79c3,0xe65d,0xbfe9, XPD -}; -static short phased[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ -0xf3e9,0xb2a5,0x6652,0xec17,0x4001, XPD -0x4b69,0x3f87,0x131f,0x891f,0x4001, XPD -0x6f25,0x2a95,0x2dc6,0xa285,0x3ffe, XPD -0x37bf,0xfcc8,0x9b9f,0x844b,0x3ffa, XPD -0xac5c,0x4806,0x8709,0x9dad,0x3ff4, XPD -0x4c8c,0x2dd8,0x79c3,0xe65d,0x3fec, XPD -}; -#endif -#if MIEEE -static long phasen[18] = { -0xbffe0000,0xbc554dd2,0x12a65106, -0xbffe0000,0x800ab769,0x04da1e30, -0xbffb0000,0x9e75dbd5,0x84e78d8a, -0xbff70000,0x830925a9,0x8866e514, -0xbff10000,0x9d358baf,0x325edc17, -0xbfe90000,0xe65d79c3,0x2dd84c2f, -}; -static long phased[18] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0x40010000,0xec176652,0xb2a5f3e9, -0x40010000,0x891f131f,0x3f874b69, -0x3ffe0000,0xa2852dc6,0x2a956f25, -0x3ffa0000,0x844b9b9f,0xfcc837bf, -0x3ff40000,0x9dad8709,0x4806ac5c, -0x3fec0000,0xe65d79c3,0x2dd84c8c, -}; -#endif -#define JZ1 5.783185962946784521176L -#define JZ2 30.47126234366208639908L -#define JZ3 7.488700679069518344489e1L - -#define PIO4L 0.78539816339744830961566L -#ifdef ANSIPROT -extern long double sqrtl ( long double ); -extern long double fabsl ( long double ); -extern long double polevll ( long double, void *, int ); -extern long double p1evll ( long double, void *, int ); -extern long double cosl ( long double ); -extern long double sinl ( long double ); -extern long double logl ( long double ); -long double j0l ( long double ); -#else -long double sqrtl(), fabsl(), polevll(), p1evll(), cosl(), sinl(), logl(); -long double j0l(); -#endif - -long double j0l(x) -long double x; -{ -long double xx, y, z, modulus, phase; - -xx = x * x; -if( xx < 81.0L ) - { - y = (xx - JZ1) * (xx - JZ2) * (xx -JZ3); - y *= polevll( xx, j0n, 7 ) / p1evll( xx, j0d, 8 ); - return y; - } - -y = fabsl(x); -xx = 1.0/xx; -phase = polevll( xx, phasen, 5 ) / p1evll( xx, phased, 6 ); - -z = 1.0/y; -modulus = polevll( z, modulusn, 7 ) / p1evll( z, modulusd, 7 ); - -y = modulus * cosl( y - PIO4L + z*phase) / sqrtl(y); -return y; -} - - -/* -y0(x) = 2/pi * log(x) * j0(x) + P(z**2)/Q(z**2) -0 <= x <= 5 -Absolute error -n=7, d=7 -Peak error = 8.55e-22 -Relative error spread = 2.7e-1 -*/ -#if UNK -static long double y0n[8] = { - 1.556909814120445353691E4L, --1.464324149797947303151E7L, - 5.427926320587133391307E9L, --9.808510181632626683952E11L, - 8.747842804834934784972E13L, --3.461898868011666236539E15L, - 4.421767595991969611983E16L, --1.847183690384811186958E16L, -}; -static long double y0d[7] = { -/* 1.000000000000000000000E0L,*/ - 1.040792201755841697889E3L, - 6.256391154086099882302E5L, - 2.686702051957904669677E8L, - 8.630939306572281881328E10L, - 2.027480766502742538763E13L, - 3.167750475899536301562E15L, - 2.502813268068711844040E17L, -}; -#endif -#if IBMPC -static short y0n[] = { -0x126c,0x20be,0x647f,0xf344,0x400c, XPD -0x2ec0,0x7b95,0x297f,0xdf70,0xc016, XPD -0x2fdd,0x4b27,0xca98,0xa1c3,0x401f, XPD -0x3e3c,0xb343,0x46c9,0xe45f,0xc026, XPD -0xb219,0x37ba,0x5142,0x9f1f,0x402d, XPD -0x23c9,0x6b29,0x4244,0xc4c9,0xc032, XPD -0x501f,0x6264,0xbdf4,0x9d17,0x4036, XPD -0x5fbd,0x0171,0x135a,0x8340,0xc035, XPD -}; -static short y0d[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ -0x9057,0x7f25,0x59b7,0x8219,0x4009, XPD -0xd938,0xb6b2,0x71d8,0x98be,0x4012, XPD -0x97a4,0x90fa,0xa7e9,0x801c,0x401b, XPD -0x553b,0x4dc8,0x8695,0xa0c3,0x4023, XPD -0x6732,0x8c1b,0xc5ab,0x9384,0x402b, XPD -0x04d3,0xa629,0xd61d,0xb410,0x4032, XPD -0x241a,0x8f2b,0x629a,0xde4b,0x4038, XPD -}; -#endif -#if MIEEE -static long y0n[24] = { -0x400c0000,0xf344647f,0x20be126c, -0xc0160000,0xdf70297f,0x7b952ec0, -0x401f0000,0xa1c3ca98,0x4b272fdd, -0xc0260000,0xe45f46c9,0xb3433e3c, -0x402d0000,0x9f1f5142,0x37bab219, -0xc0320000,0xc4c94244,0x6b2923c9, -0x40360000,0x9d17bdf4,0x6264501f, -0xc0350000,0x8340135a,0x01715fbd, -}; -static long y0d[21] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0x40090000,0x821959b7,0x7f259057, -0x40120000,0x98be71d8,0xb6b2d938, -0x401b0000,0x801ca7e9,0x90fa97a4, -0x40230000,0xa0c38695,0x4dc8553b, -0x402b0000,0x9384c5ab,0x8c1b6732, -0x40320000,0xb410d61d,0xa62904d3, -0x40380000,0xde4b629a,0x8f2b241a, -}; -#endif -/* -y0(x) = (x-Y0Z1)(x-Y0Z2)(x-Y0Z3)(x-Y0Z4)P(x)/Q(x) -4.5 <= x <= 9 -Absolute error -n=9, d=9 -Peak error = 2.35e-20 -Relative error spread = 7.8e-13 -*/ -#if UNK -static long double y059n[10] = { - 2.368715538373384869796E-2L, --1.472923738545276751402E0L, - 2.525993724177105060507E1L, - 7.727403527387097461580E1L, --4.578271827238477598563E3L, - 7.051411242092171161986E3L, - 1.951120419910720443331E5L, - 6.515211089266670755622E5L, --1.164760792144532266855E5L, --5.566567444353735925323E5L, -}; -static long double y059d[9] = { -/* 1.000000000000000000000E0L,*/ --6.235501989189125881723E1L, - 2.224790285641017194158E3L, --5.103881883748705381186E4L, - 8.772616606054526158657E5L, --1.096162986826467060921E7L, - 1.083335477747278958468E8L, --7.045635226159434678833E8L, - 3.518324187204647941098E9L, - 1.173085288957116938494E9L, -}; -#endif -#if IBMPC -static short y059n[] = { -0x992f,0xab45,0x90b6,0xc20b,0x3ff9, XPD -0x1207,0x46ea,0xc3db,0xbc88,0xbfff, XPD -0x5504,0x035a,0x59fa,0xca14,0x4003, XPD -0xd5a3,0xf673,0x4e59,0x9a8c,0x4005, XPD -0x62e0,0xc25b,0x2cb3,0x8f12,0xc00b, XPD -0xe8fa,0x4b44,0x4a39,0xdc5b,0x400b, XPD -0x49e2,0xfb52,0x02af,0xbe8a,0x4010, XPD -0x8c07,0x29e3,0x11be,0x9f10,0x4012, XPD -0xfd54,0xb2fe,0x0a23,0xe37e,0xc00f, XPD -0xf90c,0x3510,0x0be9,0x87e7,0xc012, XPD -}; -static short y059d[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ -0xdebf,0xa468,0x8a55,0xf96b,0xc004, XPD -0xad09,0x8e6a,0xa502,0x8b0c,0x400a, XPD -0xa28c,0x5563,0xd19f,0xc75e,0xc00e, XPD -0xe8b6,0xd705,0xda91,0xd62c,0x4012, XPD -0xec8a,0x4697,0xddde,0xa742,0xc016, XPD -0x27ff,0xca92,0x3d78,0xcea1,0x4019, XPD -0xe26b,0x76b9,0x250a,0xa7fb,0xc01c, XPD -0xceb6,0x3463,0x5ddb,0xd1b5,0x401e, XPD -0x3b3b,0xea0b,0xb8d1,0x8bd7,0x401d, XPD -}; -#endif -#if MIEEE -static long y059n[30] = { -0x3ff90000,0xc20b90b6,0xab45992f, -0xbfff0000,0xbc88c3db,0x46ea1207, -0x40030000,0xca1459fa,0x035a5504, -0x40050000,0x9a8c4e59,0xf673d5a3, -0xc00b0000,0x8f122cb3,0xc25b62e0, -0x400b0000,0xdc5b4a39,0x4b44e8fa, -0x40100000,0xbe8a02af,0xfb5249e2, -0x40120000,0x9f1011be,0x29e38c07, -0xc00f0000,0xe37e0a23,0xb2fefd54, -0xc0120000,0x87e70be9,0x3510f90c, -}; -static long y059d[27] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0xc0040000,0xf96b8a55,0xa468debf, -0x400a0000,0x8b0ca502,0x8e6aad09, -0xc00e0000,0xc75ed19f,0x5563a28c, -0x40120000,0xd62cda91,0xd705e8b6, -0xc0160000,0xa742ddde,0x4697ec8a, -0x40190000,0xcea13d78,0xca9227ff, -0xc01c0000,0xa7fb250a,0x76b9e26b, -0x401e0000,0xd1b55ddb,0x3463ceb6, -0x401d0000,0x8bd7b8d1,0xea0b3b3b, -}; -#endif -#define TWOOPI 6.36619772367581343075535E-1L -#define Y0Z1 3.957678419314857868376e0L -#define Y0Z2 7.086051060301772697624e0L -#define Y0Z3 1.022234504349641701900e1L -#define Y0Z4 1.336109747387276347827e1L -/* #define MAXNUML 1.189731495357231765021e4932L */ -extern long double MAXNUML; - -long double y0l(x) -long double x; -{ -long double xx, y, z, modulus, phase; - -if( x < 0.0 ) - { - return (-MAXNUML); - } -xx = x * x; -if( xx < 81.0L ) - { - if( xx < 20.25L ) - { - y = TWOOPI * logl(x) * j0l(x); - y += polevll( xx, y0n, 7 ) / p1evll( xx, y0d, 7 ); - } - else - { - y = (x - Y0Z1)*(x - Y0Z2)*(x - Y0Z3)*(x - Y0Z4); - y *= polevll( x, y059n, 9 ) / p1evll( x, y059d, 9 ); - } - return y; - } - -y = fabsl(x); -xx = 1.0/xx; -phase = polevll( xx, phasen, 5 ) / p1evll( xx, phased, 6 ); - -z = 1.0/y; -modulus = polevll( z, modulusn, 7 ) / p1evll( z, modulusd, 7 ); - -y = modulus * sinl( y - PIO4L + z*phase) / sqrtl(y); -return y; -} diff --git a/libm/ldouble/j1l.c b/libm/ldouble/j1l.c deleted file mode 100644 index 83428473e..000000000 --- a/libm/ldouble/j1l.c +++ /dev/null @@ -1,551 +0,0 @@ -/* j1l.c - * - * Bessel function of order one - * - * - * - * SYNOPSIS: - * - * long double x, y, j1l(); - * - * y = j1l( x ); - * - * - * - * DESCRIPTION: - * - * Returns Bessel function of order one of the argument. - * - * The domain is divided into the intervals [0, 9] and - * (9, infinity). In the first interval the rational approximation - * is (x^2 - r^2) (x^2 - s^2) (x^2 - t^2) x P8(x^2) / Q8(x^2), - * where r, s, t are the first three zeros of the function. - * In the second interval the expansion is in terms of the - * modulus M1(x) = sqrt(J1(x)^2 + Y1(x)^2) and phase P1(x) - * = atan(Y1(x)/J1(x)). M1 is approximated by sqrt(1/x)P7(1/x)/Q8(1/x). - * The approximation to j1 is M1 * cos(x - 3 pi/4 + 1/x P5(1/x^2)/Q6(1/x^2)). - * - * - * ACCURACY: - * - * Absolute error: - * arithmetic domain # trials peak rms - * IEEE 0, 30 40000 1.8e-19 5.0e-20 - * - * - */ - /* y1l.c - * - * Bessel function of the second kind, order zero - * - * - * - * SYNOPSIS: - * - * double x, y, y1l(); - * - * y = y1l( x ); - * - * - * - * DESCRIPTION: - * - * Returns Bessel function of the second kind, of order - * zero, of the argument. - * - * The domain is divided into the intervals [0, 4.5>, [4.5,9> and - * [9, infinity). In the first interval a rational approximation - * R(x) is employed to compute y0(x) = R(x) + 2/pi * log(x) * j0(x). - * - * In the second interval, the approximation is - * (x - p)(x - q)(x - r)(x - s)P9(x)/Q10(x) - * where p, q, r, s are zeros of y1(x). - * - * The third interval uses the same approximations to modulus - * and phase as j1(x), whence y1(x) = modulus * sin(phase). - * - * ACCURACY: - * - * Absolute error, when y0(x) < 1; else relative error: - * - * arithmetic domain # trials peak rms - * IEEE 0, 30 36000 2.7e-19 5.3e-20 - * - */ - -/* Copyright 1994 by Stephen L. Moshier (moshier@world.std.com). */ - -#include <math.h> - -/* -j1(x) = (x^2-r0^2)(x^2-r1^2)(x^2-r2^2) x P(x**2)/Q(x**2) -0 <= x <= 9 -Relative error -n=8, d=8 -Peak error = 2e-21 -*/ -#if UNK -static long double j1n[9] = { --2.63469779622127762897E-4L, - 9.31329762279632791262E-1L, --1.46280142797793933909E3L, - 1.32000129539331214495E6L, --7.41183271195454042842E8L, - 2.626500686552841932403E11L, --5.68263073022183470933E13L, - 6.80006297997263446982E15L, --3.41470097444474566748E17L, -}; -static long double j1d[8] = { -/* 1.00000000000000000000E0L,*/ - 2.95267951972943745733E3L, - 4.78723926343829674773E6L, - 5.37544732957807543920E9L, - 4.46866213886267829490E12L, - 2.76959756375961607085E15L, - 1.23367806884831151194E18L, - 3.57325874689695599524E20L, - 5.10779045516141578461E22L, -}; -#endif -#if IBMPC -static short j1n[] = { -0xf72f,0x18cc,0x50b2,0x8a22,0xbff3, XPD -0x6dc3,0xc850,0xa096,0xee6b,0x3ffe, XPD -0x29f3,0x496b,0xa54c,0xb6d9,0xc009, XPD -0x38f5,0xf72b,0x0a5c,0xa122,0x4013, XPD -0x1ac8,0xc825,0x3c9c,0xb0b6,0xc01c, XPD -0x038e,0xbd23,0xa7fa,0xf49c,0x4024, XPD -0x636c,0x4d29,0x9f71,0xcebb,0xc02c, XPD -0xd3c2,0xf8f0,0xf852,0xc144,0x4033, XPD -0xd8d8,0x7311,0xa7d2,0x97a4,0xc039, XPD -}; -static short j1d[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ -0xbaf9,0x146e,0xdf50,0xb88a,0x400a, XPD -0x6a17,0xe162,0x4e86,0x9218,0x4015, XPD -0x6041,0xc9fe,0x6890,0xa033,0x401f, XPD -0xb498,0xfdd5,0x209e,0x820e,0x4029, XPD -0x0122,0x56c0,0xf2ef,0x9d6e,0x4032, XPD -0xe6c0,0xa725,0x3d56,0x88f7,0x403b, XPD -0x665d,0xb178,0x242e,0x9af7,0x4043, XPD -0xdd67,0xf5b3,0x0522,0xad0f,0x404a, XPD -}; -#endif -#if MIEEE -static long j1n[27] = { -0xbff30000,0x8a2250b2,0x18ccf72f, -0x3ffe0000,0xee6ba096,0xc8506dc3, -0xc0090000,0xb6d9a54c,0x496b29f3, -0x40130000,0xa1220a5c,0xf72b38f5, -0xc01c0000,0xb0b63c9c,0xc8251ac8, -0x40240000,0xf49ca7fa,0xbd23038e, -0xc02c0000,0xcebb9f71,0x4d29636c, -0x40330000,0xc144f852,0xf8f0d3c2, -0xc0390000,0x97a4a7d2,0x7311d8d8, -}; -static long j1d[24] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0x400a0000,0xb88adf50,0x146ebaf9, -0x40150000,0x92184e86,0xe1626a17, -0x401f0000,0xa0336890,0xc9fe6041, -0x40290000,0x820e209e,0xfdd5b498, -0x40320000,0x9d6ef2ef,0x56c00122, -0x403b0000,0x88f73d56,0xa725e6c0, -0x40430000,0x9af7242e,0xb178665d, -0x404a0000,0xad0f0522,0xf5b3dd67, -}; -#endif -/* -sqrt(j0^2(1/x^2) + y0^2(1/x^2)) = z P(z**2)/Q(z**2) -z(x) = 1/sqrt(x) -Relative error -n=7, d=8 -Peak error = 1.35e=20 -Relative error spread = 9.9e0 -*/ -#if UNK -static long double modulusn[8] = { --5.041742205078442098874E0L, - 3.918474430130242177355E-1L, - 2.527521168680500659056E0L, - 7.172146812845906480743E0L, - 2.859499532295180940060E0L, - 1.014671139779858141347E0L, - 1.255798064266130869132E-1L, - 1.596507617085714650238E-2L, -}; -static long double modulusd[8] = { -/* 1.000000000000000000000E0L,*/ --6.233092094568239317498E0L, --9.214128701852838347002E-1L, - 2.531772200570435289832E0L, - 8.755081357265851765640E0L, - 3.554340386955608261463E0L, - 1.267949948774331531237E0L, - 1.573909467558180942219E-1L, - 2.000925566825407466160E-2L, -}; -#endif -#if IBMPC -static short modulusn[] = { -0x3d53,0xb598,0xf3bf,0xa155,0xc001, XPD -0x3111,0x863a,0x3a61,0xc8a0,0x3ffd, XPD -0x7d55,0xdb8c,0xe825,0xa1c2,0x4000, XPD -0xe5e2,0x6914,0x3a08,0xe582,0x4001, XPD -0x71e6,0x88a5,0x0a53,0xb702,0x4000, XPD -0x2cb0,0xc657,0xbe70,0x81e0,0x3fff, XPD -0x6de4,0x8fae,0xfe26,0x8097,0x3ffc, XPD -0xa905,0x05fb,0x3101,0x82c9,0x3ff9, XPD -}; -static short modulusd[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ -0x2603,0x640e,0x7d8d,0xc775,0xc001, XPD -0x77b5,0x8f2d,0xb6bf,0xebe1,0xbffe, XPD -0x6420,0x97ce,0x8e44,0xa208,0x4000, XPD -0x0260,0x746b,0xd030,0x8c14,0x4002, XPD -0x77b6,0x34e2,0x501a,0xe37a,0x4000, XPD -0x37ce,0x79ae,0x2f15,0xa24c,0x3fff, XPD -0xfc82,0x02c7,0x17a4,0xa12b,0x3ffc, XPD -0x1237,0xcc6c,0x7356,0xa3ea,0x3ff9, XPD -}; -#endif -#if MIEEE -static long modulusn[24] = { -0xc0010000,0xa155f3bf,0xb5983d53, -0x3ffd0000,0xc8a03a61,0x863a3111, -0x40000000,0xa1c2e825,0xdb8c7d55, -0x40010000,0xe5823a08,0x6914e5e2, -0x40000000,0xb7020a53,0x88a571e6, -0x3fff0000,0x81e0be70,0xc6572cb0, -0x3ffc0000,0x8097fe26,0x8fae6de4, -0x3ff90000,0x82c93101,0x05fba905, -}; -static long modulusd[24] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0xc0010000,0xc7757d8d,0x640e2603, -0xbffe0000,0xebe1b6bf,0x8f2d77b5, -0x40000000,0xa2088e44,0x97ce6420, -0x40020000,0x8c14d030,0x746b0260, -0x40000000,0xe37a501a,0x34e277b6, -0x3fff0000,0xa24c2f15,0x79ae37ce, -0x3ffc0000,0xa12b17a4,0x02c7fc82, -0x3ff90000,0xa3ea7356,0xcc6c1237, -}; -#endif -/* -atan(y1(x)/j1(x)) = x - 3pi/4 + z P(z**2)/Q(z**2) -z(x) = 1/x -Absolute error -n=5, d=6 -Peak error = 4.83e-21 -Relative error spread = 1.9e0 -*/ -#if UNK -static long double phasen[6] = { - 2.010456367705144783933E0L, - 1.587378144541918176658E0L, - 2.682837461073751055565E-1L, - 1.472572645054468815027E-2L, - 2.884976126715926258586E-4L, - 1.708502235134706284899E-6L, -}; -static long double phased[6] = { -/* 1.000000000000000000000E0L,*/ - 6.809332495854873089362E0L, - 4.518597941618813112665E0L, - 7.320149039410806471101E-1L, - 3.960155028960712309814E-2L, - 7.713202197319040439861E-4L, - 4.556005960359216767984E-6L, -}; -#endif -#if IBMPC -static short phasen[] = { -0xebc0,0x5506,0x512f,0x80ab,0x4000, XPD -0x6050,0x98aa,0x3500,0xcb2f,0x3fff, XPD -0xe907,0x28b9,0x7cb7,0x895c,0x3ffd, XPD -0xa830,0xf4a3,0x2c60,0xf144,0x3ff8, XPD -0xf74f,0xbe87,0x7e7d,0x9741,0x3ff3, XPD -0x540c,0xc1d5,0xb096,0xe54f,0x3feb, XPD -}; -static short phased[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ -0xefe3,0x292c,0x0d43,0xd9e6,0x4001, XPD -0xb1f2,0xe0d2,0x5ab5,0x9098,0x4001, XPD -0xc39e,0x9c8c,0x5428,0xbb65,0x3ffe, XPD -0x98f8,0xd610,0x3c35,0xa235,0x3ffa, XPD -0xa853,0x55fb,0x6c79,0xca32,0x3ff4, XPD -0x8d72,0x2be3,0xcb0f,0x98df,0x3fed, XPD -}; -#endif -#if MIEEE -static long phasen[18] = { -0x40000000,0x80ab512f,0x5506ebc0, -0x3fff0000,0xcb2f3500,0x98aa6050, -0x3ffd0000,0x895c7cb7,0x28b9e907, -0x3ff80000,0xf1442c60,0xf4a3a830, -0x3ff30000,0x97417e7d,0xbe87f74f, -0x3feb0000,0xe54fb096,0xc1d5540c, -}; -static long phased[18] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0x40010000,0xd9e60d43,0x292cefe3, -0x40010000,0x90985ab5,0xe0d2b1f2, -0x3ffe0000,0xbb655428,0x9c8cc39e, -0x3ffa0000,0xa2353c35,0xd61098f8, -0x3ff40000,0xca326c79,0x55fba853, -0x3fed0000,0x98dfcb0f,0x2be38d72, -}; -#endif -#define JZ1 1.46819706421238932572e1L -#define JZ2 4.92184563216946036703e1L -#define JZ3 1.03499453895136580332e2L - -#define THPIO4L 2.35619449019234492885L -#ifdef ANSIPROT -extern long double sqrtl ( long double ); -extern long double fabsl ( long double ); -extern long double polevll ( long double, void *, int ); -extern long double p1evll ( long double, void *, int ); -extern long double cosl ( long double ); -extern long double sinl ( long double ); -extern long double logl ( long double ); -long double j1l (long double ); -#else -long double sqrtl(), fabsl(), polevll(), p1evll(), cosl(), sinl(), logl(); -long double j1l(); -#endif - -long double j1l(x) -long double x; -{ -long double xx, y, z, modulus, phase; - -xx = x * x; -if( xx < 81.0L ) - { - y = (xx - JZ1) * (xx - JZ2) * (xx - JZ3); - y *= x * polevll( xx, j1n, 8 ) / p1evll( xx, j1d, 8 ); - return y; - } - -y = fabsl(x); -xx = 1.0/xx; -phase = polevll( xx, phasen, 5 ) / p1evll( xx, phased, 6 ); - -z = 1.0/y; -modulus = polevll( z, modulusn, 7 ) / p1evll( z, modulusd, 8 ); - -y = modulus * cosl( y - THPIO4L + z*phase) / sqrtl(y); -if( x < 0 ) - y = -y; -return y; -} - -/* -y1(x) = 2/pi * (log(x) * j1(x) - 1/x) + R(x^2) z P(z**2)/Q(z**2) -0 <= x <= 4.5 -z(x) = x -Absolute error -n=6, d=7 -Peak error = 7.25e-22 -Relative error spread = 4.5e-2 -*/ -#if UNK -static long double y1n[7] = { --1.288901054372751879531E5L, - 9.914315981558815369372E7L, --2.906793378120403577274E10L, - 3.954354656937677136266E12L, --2.445982226888344140154E14L, - 5.685362960165615942886E15L, --2.158855258453711703120E16L, -}; -static long double y1d[7] = { -/* 1.000000000000000000000E0L,*/ - 8.926354644853231136073E2L, - 4.679841933793707979659E5L, - 1.775133253792677466651E8L, - 5.089532584184822833416E10L, - 1.076474894829072923244E13L, - 1.525917240904692387994E15L, - 1.101136026928555260168E17L, -}; -#endif -#if IBMPC -static short y1n[] = { -0x5b16,0xf7f8,0x0d7e,0xfbbd,0xc00f, XPD -0x53e4,0x194c,0xbefa,0xbd19,0x4019, XPD -0x7607,0xa687,0xaf0a,0xd892,0xc021, XPD -0x5633,0xaa6b,0x79e5,0xe62c,0x4028, XPD -0x69fd,0x1242,0xf62d,0xde75,0xc02e, XPD -0x7f8b,0x4757,0x75bd,0xa196,0x4033, XPD -0x3a10,0x0848,0x5930,0x9965,0xc035, XPD -}; -static short y1d[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ -0xdd1a,0x3b8e,0xab73,0xdf28,0x4008, XPD -0x298c,0x29ef,0x0630,0xe482,0x4011, XPD -0x0e86,0x117b,0x36d6,0xa94a,0x401a, XPD -0x57e0,0x1d92,0x90a9,0xbd99,0x4022, XPD -0xaaf0,0x342b,0xd098,0x9ca5,0x402a, XPD -0x8c6a,0x397e,0x0963,0xad7a,0x4031, XPD -0x7302,0xb91b,0xde7e,0xc399,0x4037, XPD -}; -#endif -#if MIEEE -static long y1n[21] = { -0xc00f0000,0xfbbd0d7e,0xf7f85b16, -0x40190000,0xbd19befa,0x194c53e4, -0xc0210000,0xd892af0a,0xa6877607, -0x40280000,0xe62c79e5,0xaa6b5633, -0xc02e0000,0xde75f62d,0x124269fd, -0x40330000,0xa19675bd,0x47577f8b, -0xc0350000,0x99655930,0x08483a10, -}; -static long y1d[21] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0x40080000,0xdf28ab73,0x3b8edd1a, -0x40110000,0xe4820630,0x29ef298c, -0x401a0000,0xa94a36d6,0x117b0e86, -0x40220000,0xbd9990a9,0x1d9257e0, -0x402a0000,0x9ca5d098,0x342baaf0, -0x40310000,0xad7a0963,0x397e8c6a, -0x40370000,0xc399de7e,0xb91b7302, -}; -#endif -/* -y1(x) = (x-YZ1)(x-YZ2)(x-YZ3)(x-YZ4)R(x) P(z)/Q(z) -z(x) = x -4.5 <= x <= 9 -Absolute error -n=9, d=10 -Peak error = 3.27e-22 -Relative error spread = 4.5e-2 -*/ -#if UNK -static long double y159n[10] = { --6.806634906054210550896E-1L, - 4.306669585790359450532E1L, --9.230477746767243316014E2L, - 6.171186628598134035237E3L, - 2.096869860275353982829E4L, --1.238961670382216747944E5L, --1.781314136808997406109E6L, --1.803400156074242435454E6L, --1.155761550219364178627E6L, - 3.112221202330688509818E5L, -}; -static long double y159d[10] = { -/* 1.000000000000000000000E0L,*/ --6.181482377814679766978E1L, - 2.238187927382180589099E3L, --5.225317824142187494326E4L, - 9.217235006983512475118E5L, --1.183757638771741974521E7L, - 1.208072488974110742912E8L, --8.193431077523942651173E8L, - 4.282669747880013349981E9L, --1.171523459555524458808E9L, - 1.078445545755236785692E8L, -}; -#endif -#if IBMPC -static short y159n[] = { -0xb5e5,0xbb42,0xf667,0xae3f,0xbffe, XPD -0xfdf1,0x41e5,0x4beb,0xac44,0x4004, XPD -0xe917,0x8486,0x0ebd,0xe6c3,0xc008, XPD -0xdf40,0x226b,0x7e37,0xc0d9,0x400b, XPD -0xb2bf,0x4296,0x65af,0xa3d1,0x400d, XPD -0xa33b,0x8229,0x1561,0xf1fc,0xc00f, XPD -0xcd43,0x2f50,0x1118,0xd972,0xc013, XPD -0x3811,0xa3da,0x413f,0xdc24,0xc013, XPD -0xf62f,0xd968,0x8c66,0x8d15,0xc013, XPD -0x539b,0xf305,0xc3d8,0x97f6,0x4011, XPD -}; -static short y159d[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ -0x1a6c,0x1c93,0x612a,0xf742,0xc004, XPD -0xd0fe,0x2487,0x01c0,0x8be3,0x400a, XPD -0xbed4,0x3ad5,0x2da1,0xcc1d,0xc00e, XPD -0x3c4f,0xdc46,0xb802,0xe107,0x4012, XPD -0xe5e5,0x4172,0x8863,0xb4a0,0xc016, XPD -0x6de5,0xb797,0xea1c,0xe66b,0x4019, XPD -0xa46a,0x0273,0xbc0f,0xc358,0xc01c, XPD -0x8e0e,0xe148,0x5ab3,0xff44,0x401e, XPD -0xb3ad,0x1c6d,0x0f07,0x8ba8,0xc01d, XPD -0xa231,0x6ab0,0x7952,0xcdb2,0x4019, XPD -}; -#endif -#if MIEEE -static long y159n[30] = { -0xbffe0000,0xae3ff667,0xbb42b5e5, -0x40040000,0xac444beb,0x41e5fdf1, -0xc0080000,0xe6c30ebd,0x8486e917, -0x400b0000,0xc0d97e37,0x226bdf40, -0x400d0000,0xa3d165af,0x4296b2bf, -0xc00f0000,0xf1fc1561,0x8229a33b, -0xc0130000,0xd9721118,0x2f50cd43, -0xc0130000,0xdc24413f,0xa3da3811, -0xc0130000,0x8d158c66,0xd968f62f, -0x40110000,0x97f6c3d8,0xf305539b, -}; -static long y159d[30] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0xc0040000,0xf742612a,0x1c931a6c, -0x400a0000,0x8be301c0,0x2487d0fe, -0xc00e0000,0xcc1d2da1,0x3ad5bed4, -0x40120000,0xe107b802,0xdc463c4f, -0xc0160000,0xb4a08863,0x4172e5e5, -0x40190000,0xe66bea1c,0xb7976de5, -0xc01c0000,0xc358bc0f,0x0273a46a, -0x401e0000,0xff445ab3,0xe1488e0e, -0xc01d0000,0x8ba80f07,0x1c6db3ad, -0x40190000,0xcdb27952,0x6ab0a231, -}; -#endif - -extern long double MAXNUML; -/* #define MAXNUML 1.18973149535723176502e4932L */ -#define TWOOPI 6.36619772367581343075535e-1L -#define THPIO4 2.35619449019234492885L -#define Y1Z1 2.19714132603101703515e0L -#define Y1Z2 5.42968104079413513277e0L -#define Y1Z3 8.59600586833116892643e0L -#define Y1Z4 1.17491548308398812434e1L - -long double y1l(x) -long double x; -{ -long double xx, y, z, modulus, phase; - -if( x < 0.0 ) - { - return (-MAXNUML); - } -z = 1.0/x; -xx = x * x; -if( xx < 81.0L ) - { - if( xx < 20.25L ) - { - y = TWOOPI * (logl(x) * j1l(x) - z); - y += x * polevll( xx, y1n, 6 ) / p1evll( xx, y1d, 7 ); - } - else - { - y = (x - Y1Z1)*(x - Y1Z2)*(x - Y1Z3)*(x - Y1Z4); - y *= polevll( x, y159n, 9 ) / p1evll( x, y159d, 10 ); - } - return y; - } - -xx = 1.0/xx; -phase = polevll( xx, phasen, 5 ) / p1evll( xx, phased, 6 ); - -modulus = polevll( z, modulusn, 7 ) / p1evll( z, modulusd, 8 ); - -z = modulus * sinl( x - THPIO4L + z*phase) / sqrtl(x); -return z; -} diff --git a/libm/ldouble/jnl.c b/libm/ldouble/jnl.c deleted file mode 100644 index 1b24c50c7..000000000 --- a/libm/ldouble/jnl.c +++ /dev/null @@ -1,130 +0,0 @@ -/* jnl.c - * - * Bessel function of integer order - * - * - * - * SYNOPSIS: - * - * int n; - * long double x, y, jnl(); - * - * y = jnl( n, x ); - * - * - * - * DESCRIPTION: - * - * Returns Bessel function of order n, where n is a - * (possibly negative) integer. - * - * The ratio of jn(x) to j0(x) is computed by backward - * recurrence. First the ratio jn/jn-1 is found by a - * continued fraction expansion. Then the recurrence - * relating successive orders is applied until j0 or j1 is - * reached. - * - * If n = 0 or 1 the routine for j0 or j1 is called - * directly. - * - * - * - * ACCURACY: - * - * Absolute error: - * arithmetic domain # trials peak rms - * IEEE -30, 30 5000 3.3e-19 4.7e-20 - * - * - * Not suitable for large n or x. - * - */ - -/* jn.c -Cephes Math Library Release 2.0: April, 1987 -Copyright 1984, 1987 by Stephen L. Moshier -Direct inquiries to 30 Frost Street, Cambridge, MA 02140 -*/ -#include <math.h> - -extern long double MACHEPL; -#ifdef ANSIPROT -extern long double fabsl ( long double ); -extern long double j0l ( long double ); -extern long double j1l ( long double ); -#else -long double fabsl(), j0l(), j1l(); -#endif - -long double jnl( n, x ) -int n; -long double x; -{ -long double pkm2, pkm1, pk, xk, r, ans; -int k, sign; - -if( n < 0 ) - { - n = -n; - if( (n & 1) == 0 ) /* -1**n */ - sign = 1; - else - sign = -1; - } -else - sign = 1; - -if( x < 0.0L ) - { - if( n & 1 ) - sign = -sign; - x = -x; - } - - -if( n == 0 ) - return( sign * j0l(x) ); -if( n == 1 ) - return( sign * j1l(x) ); -if( n == 2 ) - return( sign * (2.0L * j1l(x) / x - j0l(x)) ); - -if( x < MACHEPL ) - return( 0.0L ); - -/* continued fraction */ -k = 53; -pk = 2 * (n + k); -ans = pk; -xk = x * x; - -do - { - pk -= 2.0L; - ans = pk - (xk/ans); - } -while( --k > 0 ); -ans = x/ans; - -/* backward recurrence */ - -pk = 1.0L; -pkm1 = 1.0L/ans; -k = n-1; -r = 2 * k; - -do - { - pkm2 = (pkm1 * r - pk * x) / x; - pk = pkm1; - pkm1 = pkm2; - r -= 2.0L; - } -while( --k > 0 ); - -if( fabsl(pk) > fabsl(pkm1) ) - ans = j1l(x)/pk; -else - ans = j0l(x)/pkm1; -return( sign * ans ); -} diff --git a/libm/ldouble/lcalc.c b/libm/ldouble/lcalc.c deleted file mode 100644 index 87250952f..000000000 --- a/libm/ldouble/lcalc.c +++ /dev/null @@ -1,1484 +0,0 @@ -/* calc.c */ -/* Keyboard command interpreter */ -/* by Stephen L. Moshier */ - -/* Include functions for IEEE special values */ -#define NANS 1 - -/* length of command line: */ -#define LINLEN 128 - -#define XON 0x11 -#define XOFF 0x13 - -#define SALONE 1 -#define DECPDP 0 -#define INTLOGIN 0 -#define INTHELP 1 -#ifndef TRUE -#define TRUE 1 -#endif - -/* Initialize squirrel printf: */ -#define INIPRINTF 0 - -#if DECPDP -#define TRUE 1 -#endif - -#include <stdio.h> -#include <string.h> -static char idterp[] = { -"\n\nSteve Moshier's command interpreter V1.3\n"}; -#define ISLOWER(c) ((c >= 'a') && (c <= 'z')) -#define ISUPPER(c) ((c >= 'A') && (c <= 'Z')) -#define ISALPHA(c) (ISLOWER(c) || ISUPPER(c)) -#define ISDIGIT(c) ((c >= '0') && (c <= '9')) -#define ISATF(c) (((c >= 'a')&&(c <= 'f')) || ((c >= 'A')&&(c <= 'F'))) -#define ISXDIGIT(c) (ISDIGIT(c) || ISATF(c)) -#define ISOCTAL(c) ((c >= '0') && (c < '8')) -#define ISALNUM(c) (ISALPHA(c) || (ISDIGIT(c)) -FILE *fopen(); - -#include "lcalc.h" -#include "ehead.h" - -/* space for working precision numbers */ -static long double vs[22]; - -/* the symbol table of temporary variables: */ - -#define NTEMP 4 -struct varent temp[NTEMP] = { -{"T", OPR | TEMP, &vs[14]}, -{"T", OPR | TEMP, &vs[15]}, -{"T", OPR | TEMP, &vs[16]}, -{"\0", OPR | TEMP, &vs[17]} -}; - -/* the symbol table of operators */ -/* EOL is interpreted on null, newline, or ; */ -struct symbol oprtbl[] = { -{"BOL", OPR | BOL, 0}, -{"EOL", OPR | EOL, 0}, -{"-", OPR | UMINUS, 8}, -/*"~", OPR | COMP, 8,*/ -{",", OPR | EOE, 1}, -{"=", OPR | EQU, 2}, -/*"|", OPR | LOR, 3,*/ -/*"^", OPR | LXOR, 4,*/ -/*"&", OPR | LAND, 5,*/ -{"+", OPR | PLUS, 6}, -{"-", OPR | MINUS, 6}, -{"*", OPR | MULT, 7}, -{"/", OPR | DIV, 7}, -/*"%", OPR | MOD, 7,*/ -{"(", OPR | LPAREN, 11}, -{")", OPR | RPAREN, 11}, -{"\0", ILLEG, 0} -}; - -#define NOPR 8 - -/* the symbol table of indirect variables: */ -extern long double PIL; -struct varent indtbl[] = { -{"t", VAR | IND, &vs[21]}, -{"u", VAR | IND, &vs[20]}, -{"v", VAR | IND, &vs[19]}, -{"w", VAR | IND, &vs[18]}, -{"x", VAR | IND, &vs[10]}, -{"y", VAR | IND, &vs[11]}, -{"z", VAR | IND, &vs[12]}, -{"pi", VAR | IND, &PIL}, -{"\0", ILLEG, 0} -}; - -/* the symbol table of constants: */ - -#define NCONST 10 -struct varent contbl[NCONST] = { -{"C",CONST,&vs[0]}, -{"C",CONST,&vs[1]}, -{"C",CONST,&vs[2]}, -{"C",CONST,&vs[3]}, -{"C",CONST,&vs[4]}, -{"C",CONST,&vs[5]}, -{"C",CONST,&vs[6]}, -{"C",CONST,&vs[7]}, -{"C",CONST,&vs[8]}, -{"\0",CONST,&vs[9]} -}; - -/* the symbol table of string variables: */ - -static char strngs[160] = {0}; - -#define NSTRNG 5 -struct strent strtbl[NSTRNG] = { -{0, VAR | STRING, 0}, -{0, VAR | STRING, 0}, -{0, VAR | STRING, 0}, -{0, VAR | STRING, 0}, -{"\0",ILLEG,0}, -}; - - -/* Help messages */ -#if INTHELP -static char *intmsg[] = { -"?", -"Unkown symbol", -"Expression ends in illegal operator", -"Precede ( by operator", -")( is illegal", -"Unmatched )", -"Missing )", -"Illegal left hand side", -"Missing symbol", -"Must assign to a variable", -"Divide by zero", -"Missing symbol", -"Missing operator", -"Precede quantity by operator", -"Quantity preceded by )", -"Function syntax", -"Too many function args", -"No more temps", -"Arg list" -}; -#endif - -/* the symbol table of functions: */ -#if SALONE -long double hex(), cmdh(), cmdhlp(); -long double cmddm(), cmdtm(), cmdem(); -long double take(), mxit(), exit(), bits(), csys(); -long double cmddig(), prhlst(), abmac(); -long double ifrac(), xcmpl(); -long double floorl(), logl(), powl(), sqrtl(), tanhl(), expl(); -long double ellpel(), ellpkl(), incbetl(), incbil(); -long double stdtrl(), stdtril(), zstdtrl(), zstdtril(); -long double sinl(), cosl(), tanl(), asinl(), acosl(), atanl(), atan2l(); -long double tanhl(), atanhl(); -#ifdef NANS -int isnanl(), isfinitel(), signbitl(); -long double zisnan(), zisfinite(), zsignbit(); -#endif - -struct funent funtbl[] = { -{"h", OPR | FUNC, cmdh}, -{"help", OPR | FUNC, cmdhlp}, -{"hex", OPR | FUNC, hex}, -/*"view", OPR | FUNC, view,*/ -{"exp", OPR | FUNC, expl}, -{"floor", OPR | FUNC, floorl}, -{"log", OPR | FUNC, logl}, -{"pow", OPR | FUNC, powl}, -{"sqrt", OPR | FUNC, sqrtl}, -{"tanh", OPR | FUNC, tanhl}, -{"sin", OPR | FUNC, sinl}, -{"cos", OPR | FUNC, cosl}, -{"tan", OPR | FUNC, tanl}, -{"asin", OPR | FUNC, asinl}, -{"acos", OPR | FUNC, acosl}, -{"atan", OPR | FUNC, atanl}, -{"atantwo", OPR | FUNC, atan2l}, -{"tanh", OPR | FUNC, tanhl}, -{"atanh", OPR | FUNC, atanhl}, -{"ellpe", OPR | FUNC, ellpel}, -{"ellpk", OPR | FUNC, ellpkl}, -{"incbet", OPR | FUNC, incbetl}, -{"incbi", OPR | FUNC, incbil}, -{"stdtr", OPR | FUNC, zstdtrl}, -{"stdtri", OPR | FUNC, zstdtril}, -{"ifrac", OPR | FUNC, ifrac}, -{"cmp", OPR | FUNC, xcmpl}, -#ifdef NANS -{"isnan", OPR | FUNC, zisnan}, -{"isfinite", OPR | FUNC, zisfinite}, -{"signbit", OPR | FUNC, zsignbit}, -#endif -{"bits", OPR | FUNC, bits}, -{"digits", OPR | FUNC, cmddig}, -{"dm", OPR | FUNC, cmddm}, -{"tm", OPR | FUNC, cmdtm}, -{"em", OPR | FUNC, cmdem}, -{"take", OPR | FUNC | COMMAN, take}, -{"system", OPR | FUNC | COMMAN, csys}, -{"exit", OPR | FUNC, mxit}, -/* -"remain", OPR | FUNC, eremain, -*/ -{"\0", OPR | FUNC, 0} -}; - -/* the symbol table of key words */ -struct funent keytbl[] = { -{"\0", ILLEG, 0} -}; -#endif - -void zgets(), init(); - -/* Number of decimals to display */ -#define DEFDIS 70 -static int ndigits = DEFDIS; - -/* Menu stack */ -struct funent *menstk[5] = {&funtbl[0], NULL, NULL, NULL, NULL}; -int menptr = 0; - -/* Take file stack */ -FILE *takstk[10] = {0}; -int takptr = -1; - -/* size of the expression scan list: */ -#define NSCAN 20 - -/* previous token, saved for syntax checking: */ -struct symbol *lastok = 0; - -/* variables used by parser: */ -static char str[128] = {0}; -int uposs = 0; /* possible unary operator */ -static long double qnc; -char lc[40] = { '\n' }; /* ASCII string of token symbol */ -static char line[LINLEN] = { '\n','\0' }; /* input command line */ -static char maclin[LINLEN] = { '\n','\0' }; /* macro command */ -char *interl = line; /* pointer into line */ -extern char *interl; -static int maccnt = 0; /* number of times to execute macro command */ -static int comptr = 0; /* comma stack pointer */ -static long double comstk[5]; /* comma argument stack */ -static int narptr = 0; /* pointer to number of args */ -static int narstk[5] = {0}; /* stack of number of function args */ - -/* main() */ - -/* Entire program starts here */ - -int main() -{ - -/* the scan table: */ - -/* array of pointers to symbols which have been parsed: */ -struct symbol *ascsym[NSCAN]; - -/* current place in ascsym: */ -register struct symbol **as; - -/* array of attributes of operators parsed: */ -int ascopr[NSCAN]; - -/* current place in ascopr: */ -register int *ao; - -#if LARGEMEM -/* array of precedence levels of operators: */ -long asclev[NSCAN]; -/* current place in asclev: */ -long *al; -long symval; /* value of symbol just parsed */ -#else -int asclev[NSCAN]; -int *al; -int symval; -#endif - -long double acc; /* the accumulator, for arithmetic */ -int accflg; /* flags accumulator in use */ -long double val; /* value to be combined into accumulator */ -register struct symbol *psym; /* pointer to symbol just parsed */ -struct varent *pvar; /* pointer to an indirect variable symbol */ -struct funent *pfun; /* pointer to a function symbol */ -struct strent *pstr; /* pointer to a string symbol */ -int att; /* attributes of symbol just parsed */ -int i; /* counter */ -int offset; /* parenthesis level */ -int lhsflg; /* kluge to detect illegal assignments */ -struct symbol *parser(); /* parser returns pointer to symbol */ -int errcod; /* for syntax error printout */ - - -/* Perform general initialization */ - -init(); - -menstk[0] = &funtbl[0]; -menptr = 0; -cmdhlp(); /* print out list of symbols */ - - -/* Return here to get next command line to execute */ -getcmd: - -/* initialize registers and mutable symbols */ - -accflg = 0; /* Accumulator not in use */ -acc = 0.0L; /* Clear the accumulator */ -offset = 0; /* Parenthesis level zero */ -comptr = 0; /* Start of comma stack */ -narptr = -1; /* Start of function arg counter stack */ - -psym = (struct symbol *)&contbl[0]; -for( i=0; i<NCONST; i++ ) - { - psym->attrib = CONST; /* clearing the busy bit */ - ++psym; - } -psym = (struct symbol *)&temp[0]; -for( i=0; i<NTEMP; i++ ) - { - psym->attrib = VAR | TEMP; /* clearing the busy bit */ - ++psym; - } - -pstr = &strtbl[0]; -for( i=0; i<NSTRNG; i++ ) - { - pstr->spel = &strngs[ 40*i ]; - pstr->attrib = STRING | VAR; - pstr->string = &strngs[ 40*i ]; - ++pstr; - } - -/* List of scanned symbols is empty: */ -as = &ascsym[0]; -*as = 0; ---as; -/* First item in scan list is Beginning of Line operator */ -ao = &ascopr[0]; -*ao = oprtbl[0].attrib & 0xf; /* BOL */ -/* value of first item: */ -al = &asclev[0]; -*al = oprtbl[0].sym; - -lhsflg = 0; /* illegal left hand side flag */ -psym = &oprtbl[0]; /* pointer to current token */ - -/* get next token from input string */ - -gettok: -lastok = psym; /* last token = current token */ -psym = parser(); /* get a new current token */ -/*printf( "%s attrib %7o value %7o\n", psym->spel, psym->attrib & 0xffff, - psym->sym );*/ - -/* Examine attributes of the symbol returned by the parser */ -att = psym->attrib; -if( att == ILLEG ) - { - errcod = 1; - goto synerr; - } - -/* Push functions onto scan list without analyzing further */ -if( att & FUNC ) - { - /* A command is a function whose argument is - * a pointer to the rest of the input line. - * A second argument is also passed: the address - * of the last token parsed. - */ - if( att & COMMAN ) - { - pfun = (struct funent *)psym; - ( *(pfun->fun))( interl, lastok ); - abmac(); /* scrub the input line */ - goto getcmd; /* and ask for more input */ - } - ++narptr; /* offset to number of args */ - narstk[narptr] = 0; - i = lastok->attrib & 0xffff; /* attrib=short, i=int */ - if( ((i & OPR) == 0) - || (i == (OPR | RPAREN)) - || (i == (OPR | FUNC)) ) - { - errcod = 15; - goto synerr; - } - - ++lhsflg; - ++as; - *as = psym; - ++ao; - *ao = FUNC; - ++al; - *al = offset + UMINUS; - goto gettok; - } - -/* deal with operators */ -if( att & OPR ) - { - att &= 0xf; - /* expression cannot end with an operator other than - * (, ), BOL, or a function - */ - if( (att == RPAREN) || (att == EOL) || (att == EOE)) - { - i = lastok->attrib & 0xffff; /* attrib=short, i=int */ - if( (i & OPR) - && (i != (OPR | RPAREN)) - && (i != (OPR | LPAREN)) - && (i != (OPR | FUNC)) - && (i != (OPR | BOL)) ) - { - errcod = 2; - goto synerr; - } - } - ++lhsflg; /* any operator but ( and = is not a legal lhs */ - -/* operator processing, continued */ - - switch( att ) - { - case EOE: - lhsflg = 0; - break; - case LPAREN: - /* ( must be preceded by an operator of some sort. */ - if( ((lastok->attrib & OPR) == 0) ) - { - errcod = 3; - goto synerr; - } - /* also, a preceding ) is illegal */ - if( (unsigned short )lastok->attrib == (OPR|RPAREN)) - { - errcod = 4; - goto synerr; - } - /* Begin looking for illegal left hand sides: */ - lhsflg = 0; - offset += RPAREN; /* new parenthesis level */ - goto gettok; - case RPAREN: - offset -= RPAREN; /* parenthesis level */ - if( offset < 0 ) - { - errcod = 5; /* parenthesis error */ - goto synerr; - } - goto gettok; - case EOL: - if( offset != 0 ) - { - errcod = 6; /* parenthesis error */ - goto synerr; - } - break; - case EQU: - if( --lhsflg ) /* was incremented before switch{} */ - { - errcod = 7; - goto synerr; - } - case UMINUS: - case COMP: - goto pshopr; /* evaluate right to left */ - default: ; - } - - -/* evaluate expression whenever precedence is not increasing */ - -symval = psym->sym + offset; - -while( symval <= *al ) - { - /* if just starting, must fill accumulator with last - * thing on the line - */ - if( (accflg == 0) && (as >= ascsym) && (((*as)->attrib & FUNC) == 0 )) - { - pvar = (struct varent *)*as; -/* - if( pvar->attrib & STRING ) - strcpy( (char *)&acc, (char *)pvar->value ); - else -*/ - acc = *pvar->value; - --as; - accflg = 1; - } - -/* handle beginning of line type cases, where the symbol - * list ascsym[] may be empty. - */ - switch( *ao ) - { - case BOL: -/* printf( "%.16e\n", (double )acc ); */ -#if NE == 6 - e64toasc( &acc, str, 100 ); -#else - e113toasc( &acc, str, 100 ); -#endif - printf( "%s\n", str ); - goto getcmd; /* all finished */ - case UMINUS: - acc = -acc; - goto nochg; -/* - case COMP: - acc = ~acc; - goto nochg; -*/ - default: ; - } -/* Now it is illegal for symbol list to be empty, - * because we are going to need a symbol below. - */ - if( as < &ascsym[0] ) - { - errcod = 8; - goto synerr; - } -/* get attributes and value of current symbol */ - att = (*as)->attrib; - pvar = (struct varent *)*as; - if( att & FUNC ) - val = 0.0L; - else - { -/* - if( att & STRING ) - strcpy( (char *)&val, (char *)pvar->value ); - else -*/ - val = *pvar->value; - } - -/* Expression evaluation, continued. */ - - switch( *ao ) - { - case FUNC: - pfun = (struct funent *)*as; - /* Call the function with appropriate number of args */ - i = narstk[ narptr ]; - --narptr; - switch(i) - { - case 0: - acc = ( *(pfun->fun) )(acc); - break; - case 1: - acc = ( *(pfun->fun) )(acc, comstk[comptr-1]); - break; - case 2: - acc = ( *(pfun->fun) )(acc, comstk[comptr-2], - comstk[comptr-1]); - break; - case 3: - acc = ( *(pfun->fun) )(acc, comstk[comptr-3], - comstk[comptr-2], comstk[comptr-1]); - break; - default: - errcod = 16; - goto synerr; - } - comptr -= i; - accflg = 1; /* in case at end of line */ - break; - case EQU: - if( ( att & TEMP) || ((att & VAR) == 0) || (att & STRING) ) - { - errcod = 9; - goto synerr; /* can only assign to a variable */ - } - pvar = (struct varent *)*as; - *pvar->value = acc; - break; - case PLUS: - acc = acc + val; break; - case MINUS: - acc = val - acc; break; - case MULT: - acc = acc * val; break; - case DIV: - if( acc == 0.0L ) - { -/* -divzer: -*/ - errcod = 10; - goto synerr; - } - acc = val / acc; break; -/* - case MOD: - if( acc == 0 ) - goto divzer; - acc = val % acc; break; - case LOR: - acc |= val; break; - case LXOR: - acc ^= val; break; - case LAND: - acc &= val; break; -*/ - case EOE: - if( narptr < 0 ) - { - errcod = 18; - goto synerr; - } - narstk[narptr] += 1; - comstk[comptr++] = acc; -/* printf( "\ncomptr: %d narptr: %d %d\n", comptr, narptr, acc );*/ - acc = val; - break; - } - - -/* expression evaluation, continued */ - -/* Pop evaluated tokens from scan list: */ - /* make temporary variable not busy */ - if( att & TEMP ) - (*as)->attrib &= ~BUSY; - if( as < &ascsym[0] ) /* can this happen? */ - { - errcod = 11; - goto synerr; - } - --as; -nochg: - --ao; - --al; - if( ao < &ascopr[0] ) /* can this happen? */ - { - errcod = 12; - goto synerr; - } -/* If precedence level will now increase, then */ -/* save accumulator in a temporary location */ - if( symval > *al ) - { - /* find a free temp location */ - pvar = &temp[0]; - for( i=0; i<NTEMP; i++ ) - { - if( (pvar->attrib & BUSY) == 0) - goto temfnd; - ++pvar; - } - errcod = 17; - printf( "no more temps\n" ); - pvar = &temp[0]; - goto synerr; - - temfnd: - pvar->attrib |= BUSY; - *pvar->value = acc; - /*printf( "temp %d\n", acc );*/ - accflg = 0; - ++as; /* push the temp onto the scan list */ - *as = (struct symbol *)pvar; - } - } /* End of evaluation loop */ - - -/* Push operator onto scan list when precedence increases */ - -pshopr: - ++ao; - *ao = psym->attrib & 0xf; - ++al; - *al = psym->sym + offset; - goto gettok; - } /* end of OPR processing */ - - -/* Token was not an operator. Push symbol onto scan list. */ -if( (lastok->attrib & OPR) == 0 ) - { - errcod = 13; - goto synerr; /* quantities must be preceded by an operator */ - } -if( (unsigned short )lastok->attrib == (OPR | RPAREN) ) /* ...but not by ) */ - { - errcod = 14; - goto synerr; - } -++as; -*as = psym; -goto gettok; - -synerr: - -#if INTHELP -printf( "%s ", intmsg[errcod] ); -#endif -printf( " error %d\n", errcod ); -abmac(); /* flush the command line */ -goto getcmd; -} /* end of program */ - -/* parser() */ - -/* Get token from input string and identify it. */ - - -static char number[128]; - -struct symbol *parser( ) -{ -register struct symbol *psym; -register char *pline; -struct varent *pvar; -struct strent *pstr; -char *cp, *plc, *pn; -long lnc; -int i; -long double tem; - -/* reference for old Whitesmiths compiler: */ -/* - *extern FILE *stdout; - */ - -pline = interl; /* get current location in command string */ - - -/* If at beginning of string, must ask for more input */ -if( pline == line ) - { - - if( maccnt > 0 ) - { - --maccnt; - cp = maclin; - plc = pline; - while( (*plc++ = *cp++) != 0 ) - ; - goto mstart; - } - if( takptr < 0 ) - { /* no take file active: prompt keyboard input */ - printf("* "); - } -/* Various ways of typing in a command line. */ - -/* - * Old Whitesmiths call to print "*" immediately - * use RT11 .GTLIN to get command string - * from command file or terminal - */ - -/* - * fflush(stdout); - * gtlin(line); - */ - - - zgets( line, TRUE ); /* keyboard input for other systems: */ - - -mstart: - uposs = 1; /* unary operators possible at start of line */ - } - -ignore: -/* Skip over spaces */ -while( *pline == ' ' ) - ++pline; - -/* unary minus after operator */ -if( uposs && (*pline == '-') ) - { - psym = &oprtbl[2]; /* UMINUS */ - ++pline; - goto pdon3; - } - /* COMP */ -/* -if( uposs && (*pline == '~') ) - { - psym = &oprtbl[3]; - ++pline; - goto pdon3; - } -*/ -if( uposs && (*pline == '+') ) /* ignore leading plus sign */ - { - ++pline; - goto ignore; - } - -/* end of null terminated input */ -if( (*pline == '\n') || (*pline == '\0') || (*pline == '\r') ) - { - pline = line; - goto endlin; - } -if( *pline == ';' ) - { - ++pline; -endlin: - psym = &oprtbl[1]; /* EOL */ - goto pdon2; - } - - -/* parser() */ - - -/* Test for numeric input */ -if( (ISDIGIT(*pline)) || (*pline == '.') ) - { - lnc = 0; /* initialize numeric input to zero */ - qnc = 0.0L; - if( *pline == '0' ) - { /* leading "0" may mean octal or hex radix */ - ++pline; - if( *pline == '.' ) - goto decimal; /* 0.ddd */ - /* leading "0x" means hexadecimal radix */ - if( (*pline == 'x') || (*pline == 'X') ) - { - ++pline; - while( ISXDIGIT(*pline) ) - { - i = *pline++ & 0xff; - if( i >= 'a' ) - i -= 047; - if( i >= 'A' ) - i -= 07; - i -= 060; - lnc = (lnc << 4) + i; - qnc = lnc; - } - goto numdon; - } - else - { - while( ISOCTAL( *pline ) ) - { - i = ((*pline++) & 0xff) - 060; - lnc = (lnc << 3) + i; - qnc = lnc; - } - goto numdon; - } - } - else - { - /* no leading "0" means decimal radix */ -/******/ -decimal: - pn = number; - while( (ISDIGIT(*pline)) || (*pline == '.') ) - *pn++ = *pline++; -/* get possible exponent field */ - if( (*pline == 'e') || (*pline == 'E') ) - *pn++ = *pline++; - else - goto numcvt; - if( (*pline == '-') || (*pline == '+') ) - *pn++ = *pline++; - while( ISDIGIT(*pline) ) - *pn++ = *pline++; -numcvt: - *pn++ = ' '; - *pn++ = 0; -#if NE == 6 - asctoe64( number, &qnc ); -#else - asctoe113( number, &qnc ); -#endif -/* sscanf( number, "%le", &nc ); */ - } -/* output the number */ -numdon: - /* search the symbol table of constants */ - pvar = &contbl[0]; - for( i=0; i<NCONST; i++ ) - { - if( (pvar->attrib & BUSY) == 0 ) - goto confnd; - tem = *pvar->value; - if( tem == qnc ) - { - psym = (struct symbol *)pvar; - goto pdon2; - } - ++pvar; - } - printf( "no room for constant\n" ); - psym = (struct symbol *)&contbl[0]; - goto pdon2; - -confnd: - pvar->spel= contbl[0].spel; - pvar->attrib = CONST | BUSY; - *pvar->value = qnc; - psym = (struct symbol *)pvar; - goto pdon2; - } - -/* check for operators */ -psym = &oprtbl[3]; -for( i=0; i<NOPR; i++ ) - { - if( *pline == *(psym->spel) ) - goto pdon1; - ++psym; - } - -/* if quoted, it is a string variable */ -if( *pline == '"' ) - { - /* find an empty slot for the string */ - pstr = strtbl; /* string table */ - for( i=0; i<NSTRNG-1; i++ ) - { - if( (pstr->attrib & BUSY) == 0 ) - goto fndstr; - ++pstr; - } - printf( "No room for string\n" ); - pstr->attrib |= ILLEG; - psym = (struct symbol *)pstr; - goto pdon0; - -fndstr: - pstr->attrib |= BUSY; - plc = pstr->string; - ++pline; - for( i=0; i<39; i++ ) - { - *plc++ = *pline; - if( (*pline == '\n') || (*pline == '\0') || (*pline == '\r') ) - { -illstr: - pstr = &strtbl[NSTRNG-1]; - pstr->attrib |= ILLEG; - printf( "Missing string terminator\n" ); - psym = (struct symbol *)pstr; - goto pdon0; - } - if( *pline++ == '"' ) - goto finstr; - } - - goto illstr; /* no terminator found */ - -finstr: - --plc; - *plc = '\0'; - psym = (struct symbol *)pstr; - goto pdon2; - } -/* If none of the above, search function and symbol tables: */ - -/* copy character string to array lc[] */ -plc = &lc[0]; -while( ISALPHA(*pline) ) - { - /* convert to lower case characters */ - if( ISUPPER( *pline ) ) - *pline += 040; - *plc++ = *pline++; - } -*plc = 0; /* Null terminate the output string */ - -/* parser() */ - -psym = (struct symbol *)menstk[menptr]; /* function table */ -plc = &lc[0]; -cp = psym->spel; -do - { - if( strcmp( plc, cp ) == 0 ) - goto pdon3; /* following unary minus is possible */ - ++psym; - cp = psym->spel; - } -while( *cp != '\0' ); - -psym = (struct symbol *)&indtbl[0]; /* indirect symbol table */ -plc = &lc[0]; -cp = psym->spel; -do - { - if( strcmp( plc, cp ) == 0 ) - goto pdon2; - ++psym; - cp = psym->spel; - } -while( *cp != '\0' ); - -pdon0: -pline = line; /* scrub line if illegal symbol */ -goto pdon2; - -pdon1: -++pline; -if( (psym->attrib & 0xf) == RPAREN ) -pdon2: uposs = 0; -else -pdon3: uposs = 1; - -interl = pline; -return( psym ); -} /* end of parser */ - -/* exit from current menu */ - -long double cmdex() -{ - -if( menptr == 0 ) - { - printf( "Main menu is active.\n" ); - } -else - --menptr; - -cmdh(); -return(0.0L); -} - - -/* gets() */ - -void zgets( gline, echo ) -char *gline; -int echo; -{ -register char *pline; -register int i; - - -scrub: -pline = gline; -getsl: - if( (pline - gline) >= LINLEN ) - { - printf( "\nLine too long\n *" ); - goto scrub; - } - if( takptr < 0 ) - { /* get character from keyboard */ -/* -if DECPDP - gtlin( gline ); - return(0); -else -*/ - *pline = getchar(); -/*endif*/ - } - else - { /* get a character from take file */ - i = fgetc( takstk[takptr] ); - if( i == -1 ) - { /* end of take file */ - if( takptr >= 0 ) - { /* close file and bump take stack */ - fclose( takstk[takptr] ); - takptr -= 1; - } - if( takptr < 0 ) /* no more take files: */ - printf( "*" ); /* prompt keyboard input */ - goto scrub; /* start a new input line */ - } - *pline = i; - } - - *pline &= 0x7f; - /* xon or xoff characters need filtering out. */ - if ( *pline == XON || *pline == XOFF ) - goto getsl; - - /* control U or control C */ - if( (*pline == 025) || (*pline == 03) ) - { - printf( "\n" ); - goto scrub; - } - - /* Backspace or rubout */ - if( (*pline == 010) || (*pline == 0177) ) - { - pline -= 1; - if( pline >= gline ) - { - if ( echo ) - printf( "\010\040\010" ); - goto getsl; - } - else - goto scrub; - } - if ( echo ) - printf( "%c", *pline ); - if( (*pline != '\n') && (*pline != '\r') ) - { - ++pline; - goto getsl; - } - *pline = 0; - if ( echo ) - printf( "%c", '\n' ); /* \r already echoed */ -} - - -/* help function */ -long double cmdhlp() -{ - -printf( "%s", idterp ); -printf( "\nFunctions:\n" ); -prhlst( &funtbl[0] ); -printf( "\nVariables:\n" ); -prhlst( &indtbl[0] ); -printf( "\nOperators:\n" ); -prhlst( &oprtbl[2] ); -printf("\n"); -return(0.0L); -} - - -long double cmdh() -{ - -prhlst( menstk[menptr] ); -printf( "\n" ); -return(0.0L); -} - -/* print keyword spellings */ - -long double prhlst(ps) -register struct symbol *ps; -{ -register int j, k; -int m; - -j = 0; -while( *(ps->spel) != '\0' ) - { - k = strlen( ps->spel ) - 1; -/* size of a tab field is 2**3 chars */ - m = ((k >> 3) + 1) << 3; - j += m; - if( j > 72 ) - { - printf( "\n" ); - j = m; - } - printf( "%s\t", ps->spel ); - ++ps; - } -return(0.0L); -} - - -#if SALONE -void init(){} -#endif - - -/* macro commands */ - -/* define macro */ -long double cmddm() -{ - -zgets( maclin, TRUE ); -return(0.0L); -} - -/* type (i.e., display) macro */ -long double cmdtm() -{ - -printf( "%s\n", maclin ); -return(0.0L); -} - -/* execute macro # times */ -long double cmdem( arg ) -long double arg; -{ -long double f; -long n; -long double floorl(); - -f = floorl(arg); -n = f; -if( n <= 0 ) - n = 1; -maccnt = n; -return(0.0L); -} - - -/* open a take file */ - -long double take( fname ) -char *fname; -{ -FILE *f; - -while( *fname == ' ' ) - fname += 1; -f = fopen( fname, "r" ); - -if( f == 0 ) - { - printf( "Can't open take file %s\n", fname ); - takptr = -1; /* terminate all take file input */ - return(0.0L); - } -takptr += 1; -takstk[ takptr ] = f; -printf( "Running %s\n", fname ); -return(0.0L); -} - - -/* abort macro execution */ -long double abmac() -{ - -maccnt = 0; -interl = line; -return(0.0L); -} - - -/* display integer part in hex, octal, and decimal - */ -long double hex(qx) -long double qx; -{ -long double f; -long z; -long double floorl(); - -f = floorl(qx); -z = f; -printf( "0%lo 0x%lx %ld.\n", z, z, z ); -return(qx); -} - -#define NASC 16 - -long double bits( x ) -long double x; -{ -int i, j; -unsigned short dd[4], ee[10]; -char strx[40]; -unsigned short *p; - -p = (unsigned short *) &x; -for( i=0; i<NE; i++ ) - ee[i] = *p++; - -j = 0; -for( i=0; i<NE; i++ ) - { - printf( "0x%04x,", ee[i] & 0xffff ); - if( ++j > 7 ) - { - j = 0; - printf( "\n" ); - } - } -printf( "\n" ); - -/* double conversions - */ -*((double *)dd) = x; -printf( "double: " ); -for( i=0; i<4; i++ ) - printf( "0x%04x,", dd[i] & 0xffff ); -printf( "\n" ); - -#if 1 -printf( "double -> long double: " ); -*(long double *)ee = *(double *)dd; -for( i=0; i<6; i++ ) - printf( "0x%04x,", ee[i] & 0xffff ); -printf( "\n" ); -e53toasc( dd, strx, NASC ); -printf( "e53toasc: %s\n", strx ); -printf( "Native printf: %.17e\n", *(double *)dd ); - -/* float conversions - */ -*((float *)dd) = x; -printf( "float: " ); -for( i=0; i<2; i++ ) - printf( "0x%04x,", dd[i] & 0xffff ); -printf( "\n" ); -e24toe( dd, ee ); -printf( "e24toe: " ); -for( i=0; i<NE; i++ ) - printf( "0x%04x,", ee[i] & 0xffff ); -printf( "\n" ); -e24toasc( dd, strx, NASC ); -printf( "e24toasc: %s\n", strx ); -/* printf( "Native printf: %.16e\n", (double) *(float *)dd ); */ - -#ifdef DEC -printf( "etodec: " ); -etodec( x, dd ); -for( i=0; i<4; i++ ) - printf( "0x%04x,", dd[i] & 0xffff ); -printf( "\n" ); -printf( "dectoe: " ); -dectoe( dd, ee ); -for( i=0; i<NE; i++ ) - printf( "0x%04x,", ee[i] & 0xffff ); -printf( "\n" ); -printf( "DEC printf: %.16e\n", *(double *)dd ); -#endif -#endif /* 0 */ -return(x); -} - - -/* Exit to monitor. */ -long double mxit() -{ - -exit(0); -return(0.0L); -} - - -long double cmddig( x ) -long double x; -{ -long double f; -long lx; - -f = floorl(x); -lx = f; -ndigits = lx; -if( ndigits <= 0 ) - ndigits = DEFDIS; -return(f); -} - - -long double csys(x) -char *x; -{ -void system(); - -system( x+1 ); -cmdh(); -return(0.0L); -} - - -long double ifrac(x) -long double x; -{ -unsigned long lx; -long double y, z; - -z = floorl(x); -lx = z; -y = x - z; -printf( " int = %lx\n", lx ); -return(y); -} - -long double xcmpl(x,y) -long double x,y; -{ -long double ans; -char str[40]; - -#if NE == 6 - e64toasc( &x, str, 100 ); - printf( "x = %s\n", str ); - e64toasc( &y, str, 100 ); - printf( "y = %s\n", str ); -#else - e113toasc( &x, str, 100 ); - printf( "x = %s\n", str ); - e113toasc( &y, str, 100 ); - printf( "y = %s\n", str ); -#endif - -ans = -2.0; -if( x == y ) - { - printf( "x == y " ); - ans = 0.0; - } -if( x < y ) - { - printf( "x < y" ); - ans = -1.0; - } -if( x > y ) - { - printf( "x > y" ); - ans = 1.0; - } -return( ans ); -} - -long double zstdtrl(k,t) -long double k, t; -{ -int ki; -long double y; -ki = k; -y = stdtrl(ki,t); -return(y); -} - -long double zstdtril(k,t) -long double k, t; -{ -int ki; -long double y; -ki = k; -y = stdtril(ki,t); -return(y); -} - -#ifdef NANS -long double zisnan(x) -long double x; -{ - long double y; - int k; - k = isnanl(x); - y = k; - return(y); -} -long double zisfinite(x) -long double x; -{ - long double y; - int k; - k = isfinitel(x); - y = k; - return(y); -} -long double zsignbit(x) -long double x; -{ - long double y; - int k; - k = signbitl(x); - y = k; - return(y); -} -#endif diff --git a/libm/ldouble/lcalc.h b/libm/ldouble/lcalc.h deleted file mode 100644 index 7be51d79e..000000000 --- a/libm/ldouble/lcalc.h +++ /dev/null @@ -1,79 +0,0 @@ -/* calc.h - * include file for calc.c - */ - -/* 32 bit memory addresses: */ -#ifndef LARGEMEM -#define LARGEMEM 1 -#endif - -/* data structure of symbol table */ -struct symbol - { - char *spel; - short attrib; -#if LARGEMEM - long sym; -#else - short sym; -#endif - }; - -struct funent - { - char *spel; - short attrib; - long double (*fun )(); - }; - -struct varent - { - char *spel; - short attrib; - long double *value; - }; - -struct strent - { - char *spel; - short attrib; - char *string; - }; - - -/* general symbol attributes: */ -#define OPR 0x8000 -#define VAR 0x4000 -#define CONST 0x2000 -#define FUNC 0x1000 -#define ILLEG 0x800 -#define BUSY 0x400 -#define TEMP 0x200 -#define STRING 0x100 -#define COMMAN 0x80 -#define IND 0x1 - -/* attributes of operators (ordered by precedence): */ -#define BOL 1 -#define EOL 2 -/* end of expression (comma): */ -#define EOE 3 -#define EQU 4 -#define PLUS 5 -#define MINUS 6 -#define MULT 7 -#define DIV 8 -#define UMINUS 9 -#define LPAREN 10 -#define RPAREN 11 -#define COMP 12 -#define MOD 13 -#define LAND 14 -#define LOR 15 -#define LXOR 16 - - -extern struct funent funtbl[]; -/*extern struct symbol symtbl[];*/ -extern struct varent indtbl[]; - diff --git a/libm/ldouble/ldrand.c b/libm/ldouble/ldrand.c deleted file mode 100644 index 892b465df..000000000 --- a/libm/ldouble/ldrand.c +++ /dev/null @@ -1,175 +0,0 @@ -/* ldrand.c - * - * Pseudorandom number generator - * - * - * - * SYNOPSIS: - * - * double y; - * int ldrand(); - * - * ldrand( &y ); - * - * - * - * DESCRIPTION: - * - * Yields a random number 1.0 <= y < 2.0. - * - * The three-generator congruential algorithm by Brian - * Wichmann and David Hill (BYTE magazine, March, 1987, - * pp 127-8) is used. - * - * Versions invoked by the different arithmetic compile - * time options IBMPC, and MIEEE, produce the same sequences. - * - */ - - - -#include <math.h> -#ifdef ANSIPROT -int ranwh ( void ); -#else -int ranwh(); -#endif -#ifdef UNK -#undef UNK -#if BIGENDIAN -#define MIEEE -#else -#define IBMPC -#endif -#endif - -/* Three-generator random number algorithm - * of Brian Wichmann and David Hill - * BYTE magazine, March, 1987 pp 127-8 - * - * The period, given by them, is (p-1)(q-1)(r-1)/4 = 6.95e12. - */ - -static int sx = 1; -static int sy = 10000; -static int sz = 3000; - -static union { - long double d; - unsigned short s[8]; -} unkans; - -/* This function implements the three - * congruential generators. - */ - -int ranwh() -{ -int r, s; - -/* sx = sx * 171 mod 30269 */ -r = sx/177; -s = sx - 177 * r; -sx = 171 * s - 2 * r; -if( sx < 0 ) - sx += 30269; - - -/* sy = sy * 172 mod 30307 */ -r = sy/176; -s = sy - 176 * r; -sy = 172 * s - 35 * r; -if( sy < 0 ) - sy += 30307; - -/* sz = 170 * sz mod 30323 */ -r = sz/178; -s = sz - 178 * r; -sz = 170 * s - 63 * r; -if( sz < 0 ) - sz += 30323; -/* The results are in static sx, sy, sz. */ -return 0; -} - -/* ldrand.c - * - * Random double precision floating point number between 1 and 2. - * - * C callable: - * drand( &x ); - */ - -int ldrand( a ) -long double *a; -{ -unsigned short r; - -/* This algorithm of Wichmann and Hill computes a floating point - * result: - */ -ranwh(); -unkans.d = sx/30269.0L + sy/30307.0L + sz/30323.0L; -r = unkans.d; -unkans.d -= r; -unkans.d += 1.0L; - -if( sizeof(long double) == 16 ) - { -#ifdef MIEEE - ranwh(); - r = sx * sy + sz; - unkans.s[7] = r; - ranwh(); - r = sx * sy + sz; - unkans.s[6] = r; - ranwh(); - r = sx * sy + sz; - unkans.s[5] = r; - ranwh(); - r = sx * sy + sz; - unkans.s[4] = r; - ranwh(); - r = sx * sy + sz; - unkans.s[3] = r; -#endif -#ifdef IBMPC - ranwh(); - r = sx * sy + sz; - unkans.s[0] = r; - ranwh(); - r = sx * sy + sz; - unkans.s[1] = r; - ranwh(); - r = sx * sy + sz; - unkans.s[2] = r; - ranwh(); - r = sx * sy + sz; - unkans.s[3] = r; - ranwh(); - r = sx * sy + sz; - unkans.s[4] = r; -#endif - } -else - { -#ifdef MIEEE - ranwh(); - r = sx * sy + sz; - unkans.s[5] = r; - ranwh(); - r = sx * sy + sz; - unkans.s[4] = r; -#endif -#ifdef IBMPC - ranwh(); - r = sx * sy + sz; - unkans.s[0] = r; - ranwh(); - r = sx * sy + sz; - unkans.s[1] = r; -#endif - } -*a = unkans.d; -return 0; -} diff --git a/libm/ldouble/log10l.c b/libm/ldouble/log10l.c deleted file mode 100644 index fa13ff3a2..000000000 --- a/libm/ldouble/log10l.c +++ /dev/null @@ -1,319 +0,0 @@ -/* log10l.c - * - * Common logarithm, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, log10l(); - * - * y = log10l( x ); - * - * - * - * DESCRIPTION: - * - * Returns the base 10 logarithm of x. - * - * The argument is separated into its exponent and fractional - * parts. If the exponent is between -1 and +1, the logarithm - * of the fraction is approximated by - * - * log(1+x) = x - 0.5 x**2 + x**3 P(x)/Q(x). - * - * Otherwise, setting z = 2(x-1)/x+1), - * - * log(x) = z + z**3 P(z)/Q(z). - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 0.5, 2.0 30000 9.0e-20 2.6e-20 - * IEEE exp(+-10000) 30000 6.0e-20 2.3e-20 - * - * In the tests over the interval exp(+-10000), the logarithms - * of the random arguments were uniformly distributed over - * [-10000, +10000]. - * - * ERROR MESSAGES: - * - * log singularity: x = 0; returns MINLOG - * log domain: x < 0; returns MINLOG - */ - -/* -Cephes Math Library Release 2.2: January, 1991 -Copyright 1984, 1991 by Stephen L. Moshier -Direct inquiries to 30 Frost Street, Cambridge, MA 02140 -*/ - -#include <math.h> -static char fname[] = {"log10l"}; - -/* Coefficients for log(1+x) = x - x**2/2 + x**3 P(x)/Q(x) - * 1/sqrt(2) <= x < sqrt(2) - * Theoretical peak relative error = 6.2e-22 - */ -#ifdef UNK -static long double P[] = { - 4.9962495940332550844739E-1L, - 1.0767376367209449010438E1L, - 7.7671073698359539859595E1L, - 2.5620629828144409632571E2L, - 4.2401812743503691187826E2L, - 3.4258224542413922935104E2L, - 1.0747524399916215149070E2L, -}; -static long double Q[] = { -/* 1.0000000000000000000000E0,*/ - 2.3479774160285863271658E1L, - 1.9444210022760132894510E2L, - 7.7952888181207260646090E2L, - 1.6911722418503949084863E3L, - 2.0307734695595183428202E3L, - 1.2695660352705325274404E3L, - 3.2242573199748645407652E2L, -}; -#endif - -#ifdef IBMPC -static short P[] = { -0xfe72,0xce22,0xd7b9,0xffce,0x3ffd, XPD -0xb778,0x0e34,0x2c71,0xac47,0x4002, XPD -0xea8b,0xc751,0x96f8,0x9b57,0x4005, XPD -0xfeaf,0x6a02,0x67fb,0x801a,0x4007, XPD -0x6b5a,0xf252,0x51ff,0xd402,0x4007, XPD -0x39ce,0x9f76,0x8704,0xab4a,0x4007, XPD -0x1b39,0x740b,0x532e,0xd6f3,0x4005, XPD -}; -static short Q[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ -0x2f3a,0xbf26,0x93d5,0xbbd6,0x4003, XPD -0x13c8,0x031a,0x2d7b,0xc271,0x4006, XPD -0x449d,0x1993,0xd933,0xc2e1,0x4008, XPD -0x5b65,0x574e,0x8301,0xd365,0x4009, XPD -0xa65d,0x3bd2,0xc043,0xfdd8,0x4009, XPD -0x3b21,0xffea,0x1cf5,0x9eb2,0x4009, XPD -0x545c,0xd708,0x7e62,0xa136,0x4007, XPD -}; -#endif - -#ifdef MIEEE -static long P[] = { -0x3ffd0000,0xffced7b9,0xce22fe72, -0x40020000,0xac472c71,0x0e34b778, -0x40050000,0x9b5796f8,0xc751ea8b, -0x40070000,0x801a67fb,0x6a02feaf, -0x40070000,0xd40251ff,0xf2526b5a, -0x40070000,0xab4a8704,0x9f7639ce, -0x40050000,0xd6f3532e,0x740b1b39, -}; -static long Q[] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0x40030000,0xbbd693d5,0xbf262f3a, -0x40060000,0xc2712d7b,0x031a13c8, -0x40080000,0xc2e1d933,0x1993449d, -0x40090000,0xd3658301,0x574e5b65, -0x40090000,0xfdd8c043,0x3bd2a65d, -0x40090000,0x9eb21cf5,0xffea3b21, -0x40070000,0xa1367e62,0xd708545c, -}; -#endif - -/* Coefficients for log(x) = z + z^3 P(z^2)/Q(z^2), - * where z = 2(x-1)/(x+1) - * 1/sqrt(2) <= x < sqrt(2) - * Theoretical peak relative error = 6.16e-22 - */ - -#ifdef UNK -static long double R[4] = { - 1.9757429581415468984296E-3L, --7.1990767473014147232598E-1L, - 1.0777257190312272158094E1L, --3.5717684488096787370998E1L, -}; -static long double S[4] = { -/* 1.00000000000000000000E0L,*/ --2.6201045551331104417768E1L, - 1.9361891836232102174846E2L, --4.2861221385716144629696E2L, -}; -/* log10(2) */ -#define L102A 0.3125L -#define L102B -1.1470004336018804786261e-2L -/* log10(e) */ -#define L10EA 0.5L -#define L10EB -6.5705518096748172348871e-2L -#endif -#ifdef IBMPC -static short R[] = { -0x6ef4,0xf922,0x7763,0x817b,0x3ff6, XPD -0x15fd,0x1af9,0xde8f,0xb84b,0xbffe, XPD -0x8b96,0x4f8d,0xa53c,0xac6f,0x4002, XPD -0x8932,0xb4e3,0xe8ae,0x8ede,0xc004, XPD -}; -static short S[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ -0x7ce4,0x1fc9,0xbdc5,0xd19b,0xc003, XPD -0x0af3,0x0d10,0x716f,0xc19e,0x4006, XPD -0x4d7d,0x0f55,0x5d06,0xd64e,0xc007, XPD -}; -static short LG102A[] = {0x0000,0x0000,0x0000,0xa000,0x3ffd, XPD}; -#define L102A *(long double *)LG102A -static short LG102B[] = {0x0cee,0x8601,0xaf60,0xbbec,0xbff8, XPD}; -#define L102B *(long double *)LG102B -static short LG10EA[] = {0x0000,0x0000,0x0000,0x8000,0x3ffe, XPD}; -#define L10EA *(long double *)LG10EA -static short LG10EB[] = {0x39ab,0x235e,0x9d5b,0x8690,0xbffb, XPD}; -#define L10EB *(long double *)LG10EB -#endif - -#ifdef MIEEE -static long R[12] = { -0x3ff60000,0x817b7763,0xf9226ef4, -0xbffe0000,0xb84bde8f,0x1af915fd, -0x40020000,0xac6fa53c,0x4f8d8b96, -0xc0040000,0x8edee8ae,0xb4e38932, -}; -static long S[9] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0xc0030000,0xd19bbdc5,0x1fc97ce4, -0x40060000,0xc19e716f,0x0d100af3, -0xc0070000,0xd64e5d06,0x0f554d7d, -}; -static long LG102A[] = {0x3ffd0000,0xa0000000,0x00000000}; -#define L102A *(long double *)LG102A -static long LG102B[] = {0xbff80000,0xbbecaf60,0x86010cee}; -#define L102B *(long double *)LG102B -static long LG10EA[] = {0x3ffe0000,0x80000000,0x00000000}; -#define L10EA *(long double *)LG10EA -static long LG10EB[] = {0xbffb0000,0x86909d5b,0x235e39ab}; -#define L10EB *(long double *)LG10EB -#endif - - -#define SQRTH 0.70710678118654752440L -#ifdef ANSIPROT -extern long double frexpl ( long double, int * ); -extern long double ldexpl ( long double, int ); -extern long double polevll ( long double, void *, int ); -extern long double p1evll ( long double, void *, int ); -extern int isnanl ( long double ); -#else -long double frexpl(), ldexpl(), polevll(), p1evll(), isnanl(); -#endif -#ifdef INFINITIES -extern long double INFINITYL; -#endif -#ifdef NANS -extern long double NANL; -#endif - -long double log10l(x) -long double x; -{ -long double y; -VOLATILE long double z; -int e; - -#ifdef NANS -if( isnanl(x) ) - return(x); -#endif -/* Test for domain */ -if( x <= 0.0L ) - { - if( x == 0.0L ) - { - mtherr( fname, SING ); -#ifdef INFINITIES - return(-INFINITYL); -#else - return( -4.9314733889673399399914e3L ); -#endif - } - else - { - mtherr( fname, DOMAIN ); -#ifdef NANS - return(NANL); -#else - return( -4.9314733889673399399914e3L ); -#endif - } - } -#ifdef INFINITIES -if( x == INFINITYL ) - return(INFINITYL); -#endif -/* separate mantissa from exponent */ - -/* Note, frexp is used so that denormal numbers - * will be handled properly. - */ -x = frexpl( x, &e ); - - -/* logarithm using log(x) = z + z**3 P(z)/Q(z), - * where z = 2(x-1)/x+1) - */ -if( (e > 2) || (e < -2) ) -{ -if( x < SQRTH ) - { /* 2( 2x-1 )/( 2x+1 ) */ - e -= 1; - z = x - 0.5L; - y = 0.5L * z + 0.5L; - } -else - { /* 2 (x-1)/(x+1) */ - z = x - 0.5L; - z -= 0.5L; - y = 0.5L * x + 0.5L; - } -x = z / y; -z = x*x; -y = x * ( z * polevll( z, R, 3 ) / p1evll( z, S, 3 ) ); -goto done; -} - - -/* logarithm using log(1+x) = x - .5x**2 + x**3 P(x)/Q(x) */ - -if( x < SQRTH ) - { - e -= 1; - x = ldexpl( x, 1 ) - 1.0L; /* 2x - 1 */ - } -else - { - x = x - 1.0L; - } -z = x*x; -y = x * ( z * polevll( x, P, 6 ) / p1evll( x, Q, 7 ) ); -y = y - ldexpl( z, -1 ); /* -0.5x^2 + ... */ - -done: - -/* Multiply log of fraction by log10(e) - * and base 2 exponent by log10(2). - * - * ***CAUTION*** - * - * This sequence of operations is critical and it may - * be horribly defeated by some compiler optimizers. - */ -z = y * (L10EB); -z += x * (L10EB); -z += e * (L102B); -z += y * (L10EA); -z += x * (L10EA); -z += e * (L102A); - -return( z ); -} diff --git a/libm/ldouble/log2l.c b/libm/ldouble/log2l.c deleted file mode 100644 index 220b881ae..000000000 --- a/libm/ldouble/log2l.c +++ /dev/null @@ -1,302 +0,0 @@ -/* log2l.c - * - * Base 2 logarithm, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, log2l(); - * - * y = log2l( x ); - * - * - * - * DESCRIPTION: - * - * Returns the base 2 logarithm of x. - * - * The argument is separated into its exponent and fractional - * parts. If the exponent is between -1 and +1, the (natural) - * logarithm of the fraction is approximated by - * - * log(1+x) = x - 0.5 x**2 + x**3 P(x)/Q(x). - * - * Otherwise, setting z = 2(x-1)/x+1), - * - * log(x) = z + z**3 P(z)/Q(z). - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 0.5, 2.0 30000 9.8e-20 2.7e-20 - * IEEE exp(+-10000) 70000 5.4e-20 2.3e-20 - * - * In the tests over the interval exp(+-10000), the logarithms - * of the random arguments were uniformly distributed over - * [-10000, +10000]. - * - * ERROR MESSAGES: - * - * log singularity: x = 0; returns -INFINITYL - * log domain: x < 0; returns NANL - */ - -/* -Cephes Math Library Release 2.8: May, 1998 -Copyright 1984, 1991, 1998 by Stephen L. Moshier -*/ - -#include <math.h> - -/* Coefficients for ln(1+x) = x - x**2/2 + x**3 P(x)/Q(x) - * 1/sqrt(2) <= x < sqrt(2) - * Theoretical peak relative error = 6.2e-22 - */ -#ifdef UNK -static long double P[] = { - 4.9962495940332550844739E-1L, - 1.0767376367209449010438E1L, - 7.7671073698359539859595E1L, - 2.5620629828144409632571E2L, - 4.2401812743503691187826E2L, - 3.4258224542413922935104E2L, - 1.0747524399916215149070E2L, -}; -static long double Q[] = { -/* 1.0000000000000000000000E0,*/ - 2.3479774160285863271658E1L, - 1.9444210022760132894510E2L, - 7.7952888181207260646090E2L, - 1.6911722418503949084863E3L, - 2.0307734695595183428202E3L, - 1.2695660352705325274404E3L, - 3.2242573199748645407652E2L, -}; -#endif - -#ifdef IBMPC -static short P[] = { -0xfe72,0xce22,0xd7b9,0xffce,0x3ffd, XPD -0xb778,0x0e34,0x2c71,0xac47,0x4002, XPD -0xea8b,0xc751,0x96f8,0x9b57,0x4005, XPD -0xfeaf,0x6a02,0x67fb,0x801a,0x4007, XPD -0x6b5a,0xf252,0x51ff,0xd402,0x4007, XPD -0x39ce,0x9f76,0x8704,0xab4a,0x4007, XPD -0x1b39,0x740b,0x532e,0xd6f3,0x4005, XPD -}; -static short Q[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ -0x2f3a,0xbf26,0x93d5,0xbbd6,0x4003, XPD -0x13c8,0x031a,0x2d7b,0xc271,0x4006, XPD -0x449d,0x1993,0xd933,0xc2e1,0x4008, XPD -0x5b65,0x574e,0x8301,0xd365,0x4009, XPD -0xa65d,0x3bd2,0xc043,0xfdd8,0x4009, XPD -0x3b21,0xffea,0x1cf5,0x9eb2,0x4009, XPD -0x545c,0xd708,0x7e62,0xa136,0x4007, XPD -}; -#endif - -#ifdef MIEEE -static long P[] = { -0x3ffd0000,0xffced7b9,0xce22fe72, -0x40020000,0xac472c71,0x0e34b778, -0x40050000,0x9b5796f8,0xc751ea8b, -0x40070000,0x801a67fb,0x6a02feaf, -0x40070000,0xd40251ff,0xf2526b5a, -0x40070000,0xab4a8704,0x9f7639ce, -0x40050000,0xd6f3532e,0x740b1b39, -}; -static long Q[] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0x40030000,0xbbd693d5,0xbf262f3a, -0x40060000,0xc2712d7b,0x031a13c8, -0x40080000,0xc2e1d933,0x1993449d, -0x40090000,0xd3658301,0x574e5b65, -0x40090000,0xfdd8c043,0x3bd2a65d, -0x40090000,0x9eb21cf5,0xffea3b21, -0x40070000,0xa1367e62,0xd708545c, -}; -#endif - -/* Coefficients for log(x) = z + z^3 P(z^2)/Q(z^2), - * where z = 2(x-1)/(x+1) - * 1/sqrt(2) <= x < sqrt(2) - * Theoretical peak relative error = 6.16e-22 - */ -#ifdef UNK -static long double R[4] = { - 1.9757429581415468984296E-3L, --7.1990767473014147232598E-1L, - 1.0777257190312272158094E1L, --3.5717684488096787370998E1L, -}; -static long double S[4] = { -/* 1.00000000000000000000E0L,*/ --2.6201045551331104417768E1L, - 1.9361891836232102174846E2L, --4.2861221385716144629696E2L, -}; -/* log2(e) - 1 */ -#define LOG2EA 4.4269504088896340735992e-1L -#endif -#ifdef IBMPC -static short R[] = { -0x6ef4,0xf922,0x7763,0x817b,0x3ff6, XPD -0x15fd,0x1af9,0xde8f,0xb84b,0xbffe, XPD -0x8b96,0x4f8d,0xa53c,0xac6f,0x4002, XPD -0x8932,0xb4e3,0xe8ae,0x8ede,0xc004, XPD -}; -static short S[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ -0x7ce4,0x1fc9,0xbdc5,0xd19b,0xc003, XPD -0x0af3,0x0d10,0x716f,0xc19e,0x4006, XPD -0x4d7d,0x0f55,0x5d06,0xd64e,0xc007, XPD -}; -static short LG2EA[] = {0xc2ef,0x705f,0xeca5,0xe2a8,0x3ffd, XPD}; -#define LOG2EA *(long double *)LG2EA -#endif - -#ifdef MIEEE -static long R[12] = { -0x3ff60000,0x817b7763,0xf9226ef4, -0xbffe0000,0xb84bde8f,0x1af915fd, -0x40020000,0xac6fa53c,0x4f8d8b96, -0xc0040000,0x8edee8ae,0xb4e38932, -}; -static long S[9] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0xc0030000,0xd19bbdc5,0x1fc97ce4, -0x40060000,0xc19e716f,0x0d100af3, -0xc0070000,0xd64e5d06,0x0f554d7d, -}; -static long LG2EA[] = {0x3ffd0000,0xe2a8eca5,0x705fc2ef}; -#define LOG2EA *(long double *)LG2EA -#endif - - -#define SQRTH 0.70710678118654752440L -extern long double MINLOGL; -#ifdef ANSIPROT -extern long double frexpl ( long double, int * ); -extern long double ldexpl ( long double, int ); -extern long double polevll ( long double, void *, int ); -extern long double p1evll ( long double, void *, int ); -extern int isnanl ( long double ); -#else -long double frexpl(), ldexpl(), polevll(), p1evll(); -extern int isnanl (); -#endif -#ifdef INFINITIES -extern long double INFINITYL; -#endif -#ifdef NANS -extern long double NANL; -#endif - -long double log2l(x) -long double x; -{ -VOLATILE long double z; -long double y; -int e; - -#ifdef NANS -if( isnanl(x) ) - return(x); -#endif -#ifdef INFINITIES -if( x == INFINITYL ) - return(x); -#endif -/* Test for domain */ -if( x <= 0.0L ) - { - if( x == 0.0L ) - { -#ifdef INFINITIES - return( -INFINITYL ); -#else - mtherr( "log2l", SING ); - return( -16384.0L ); -#endif - } - else - { -#ifdef NANS - return( NANL ); -#else - mtherr( "log2l", DOMAIN ); - return( -16384.0L ); -#endif - } - } - -/* separate mantissa from exponent */ - -/* Note, frexp is used so that denormal numbers - * will be handled properly. - */ -x = frexpl( x, &e ); - - -/* logarithm using log(x) = z + z**3 P(z)/Q(z), - * where z = 2(x-1)/x+1) - */ -if( (e > 2) || (e < -2) ) -{ -if( x < SQRTH ) - { /* 2( 2x-1 )/( 2x+1 ) */ - e -= 1; - z = x - 0.5L; - y = 0.5L * z + 0.5L; - } -else - { /* 2 (x-1)/(x+1) */ - z = x - 0.5L; - z -= 0.5L; - y = 0.5L * x + 0.5L; - } -x = z / y; -z = x*x; -y = x * ( z * polevll( z, R, 3 ) / p1evll( z, S, 3 ) ); -goto done; -} - - -/* logarithm using log(1+x) = x - .5x**2 + x**3 P(x)/Q(x) */ - -if( x < SQRTH ) - { - e -= 1; - x = ldexpl( x, 1 ) - 1.0L; /* 2x - 1 */ - } -else - { - x = x - 1.0L; - } -z = x*x; -y = x * ( z * polevll( x, P, 6 ) / p1evll( x, Q, 7 ) ); -y = y - ldexpl( z, -1 ); /* -0.5x^2 + ... */ - -done: - -/* Multiply log of fraction by log2(e) - * and base 2 exponent by 1 - * - * ***CAUTION*** - * - * This sequence of operations is critical and it may - * be horribly defeated by some compiler optimizers. - */ -z = y * LOG2EA; -z += x * LOG2EA; -z += y; -z += x; -z += e; -return( z ); -} - diff --git a/libm/ldouble/logl.c b/libm/ldouble/logl.c deleted file mode 100644 index d6367eb19..000000000 --- a/libm/ldouble/logl.c +++ /dev/null @@ -1,292 +0,0 @@ -/* logl.c - * - * Natural logarithm, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, logl(); - * - * y = logl( x ); - * - * - * - * DESCRIPTION: - * - * Returns the base e (2.718...) logarithm of x. - * - * The argument is separated into its exponent and fractional - * parts. If the exponent is between -1 and +1, the logarithm - * of the fraction is approximated by - * - * log(1+x) = x - 0.5 x**2 + x**3 P(x)/Q(x). - * - * Otherwise, setting z = 2(x-1)/x+1), - * - * log(x) = z + z**3 P(z)/Q(z). - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 0.5, 2.0 150000 8.71e-20 2.75e-20 - * IEEE exp(+-10000) 100000 5.39e-20 2.34e-20 - * - * In the tests over the interval exp(+-10000), the logarithms - * of the random arguments were uniformly distributed over - * [-10000, +10000]. - * - * ERROR MESSAGES: - * - * log singularity: x = 0; returns -INFINITYL - * log domain: x < 0; returns NANL - */ - -/* -Cephes Math Library Release 2.7: May, 1998 -Copyright 1984, 1990, 1998 by Stephen L. Moshier -*/ - -#include <math.h> - -/* Coefficients for log(1+x) = x - x**2/2 + x**3 P(x)/Q(x) - * 1/sqrt(2) <= x < sqrt(2) - * Theoretical peak relative error = 2.32e-20 - */ -#ifdef UNK -static long double P[] = { - 4.5270000862445199635215E-5L, - 4.9854102823193375972212E-1L, - 6.5787325942061044846969E0L, - 2.9911919328553073277375E1L, - 6.0949667980987787057556E1L, - 5.7112963590585538103336E1L, - 2.0039553499201281259648E1L, -}; -static long double Q[] = { -/* 1.0000000000000000000000E0,*/ - 1.5062909083469192043167E1L, - 8.3047565967967209469434E1L, - 2.2176239823732856465394E2L, - 3.0909872225312059774938E2L, - 2.1642788614495947685003E2L, - 6.0118660497603843919306E1L, -}; -#endif - -#ifdef IBMPC -static short P[] = { -0x51b9,0x9cae,0x4b15,0xbde0,0x3ff0, XPD -0x19cf,0xf0d4,0xc507,0xff40,0x3ffd, XPD -0x9942,0xa7d2,0xfa37,0xd284,0x4001, XPD -0x4add,0x65ce,0x9c5c,0xef4b,0x4003, XPD -0x8445,0x619a,0x75c3,0xf3cc,0x4004, XPD -0x81ab,0x3cd0,0xacba,0xe473,0x4004, XPD -0x4cbf,0xcc18,0x016c,0xa051,0x4003, XPD -}; -static short Q[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ -0xb8b7,0x81f1,0xacf4,0xf101,0x4002, XPD -0xbc31,0x09a4,0x5a91,0xa618,0x4005, XPD -0xaeec,0xe7da,0x2c87,0xddc3,0x4006, XPD -0x2bde,0x4845,0xa2ee,0x9a8c,0x4007, XPD -0x3120,0x4703,0x89f2,0xd86d,0x4006, XPD -0x7347,0x3224,0x8223,0xf079,0x4004, XPD -}; -#endif - -#ifdef MIEEE -static long P[] = { -0x3ff00000,0xbde04b15,0x9cae51b9, -0x3ffd0000,0xff40c507,0xf0d419cf, -0x40010000,0xd284fa37,0xa7d29942, -0x40030000,0xef4b9c5c,0x65ce4add, -0x40040000,0xf3cc75c3,0x619a8445, -0x40040000,0xe473acba,0x3cd081ab, -0x40030000,0xa051016c,0xcc184cbf, -}; -static long Q[] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0x40020000,0xf101acf4,0x81f1b8b7, -0x40050000,0xa6185a91,0x09a4bc31, -0x40060000,0xddc32c87,0xe7daaeec, -0x40070000,0x9a8ca2ee,0x48452bde, -0x40060000,0xd86d89f2,0x47033120, -0x40040000,0xf0798223,0x32247347, -}; -#endif - -/* Coefficients for log(x) = z + z^3 P(z^2)/Q(z^2), - * where z = 2(x-1)/(x+1) - * 1/sqrt(2) <= x < sqrt(2) - * Theoretical peak relative error = 6.16e-22 - */ - -#ifdef UNK -static long double R[4] = { - 1.9757429581415468984296E-3L, --7.1990767473014147232598E-1L, - 1.0777257190312272158094E1L, --3.5717684488096787370998E1L, -}; -static long double S[4] = { -/* 1.00000000000000000000E0L,*/ --2.6201045551331104417768E1L, - 1.9361891836232102174846E2L, --4.2861221385716144629696E2L, -}; -static long double C1 = 6.9314575195312500000000E-1L; -static long double C2 = 1.4286068203094172321215E-6L; -#endif -#ifdef IBMPC -static short R[] = { -0x6ef4,0xf922,0x7763,0x817b,0x3ff6, XPD -0x15fd,0x1af9,0xde8f,0xb84b,0xbffe, XPD -0x8b96,0x4f8d,0xa53c,0xac6f,0x4002, XPD -0x8932,0xb4e3,0xe8ae,0x8ede,0xc004, XPD -}; -static short S[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ -0x7ce4,0x1fc9,0xbdc5,0xd19b,0xc003, XPD -0x0af3,0x0d10,0x716f,0xc19e,0x4006, XPD -0x4d7d,0x0f55,0x5d06,0xd64e,0xc007, XPD -}; -static short sc1[] = {0x0000,0x0000,0x0000,0xb172,0x3ffe, XPD}; -#define C1 (*(long double *)sc1) -static short sc2[] = {0x4f1e,0xcd5e,0x8e7b,0xbfbe,0x3feb, XPD}; -#define C2 (*(long double *)sc2) -#endif -#ifdef MIEEE -static long R[12] = { -0x3ff60000,0x817b7763,0xf9226ef4, -0xbffe0000,0xb84bde8f,0x1af915fd, -0x40020000,0xac6fa53c,0x4f8d8b96, -0xc0040000,0x8edee8ae,0xb4e38932, -}; -static long S[9] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0xc0030000,0xd19bbdc5,0x1fc97ce4, -0x40060000,0xc19e716f,0x0d100af3, -0xc0070000,0xd64e5d06,0x0f554d7d, -}; -static long sc1[] = {0x3ffe0000,0xb1720000,0x00000000}; -#define C1 (*(long double *)sc1) -static long sc2[] = {0x3feb0000,0xbfbe8e7b,0xcd5e4f1e}; -#define C2 (*(long double *)sc2) -#endif - - -#define SQRTH 0.70710678118654752440L -extern long double MINLOGL; -#ifdef ANSIPROT -extern long double frexpl ( long double, int * ); -extern long double ldexpl ( long double, int ); -extern long double polevll ( long double, void *, int ); -extern long double p1evll ( long double, void *, int ); -extern int isnanl ( long double ); -#else -long double frexpl(), ldexpl(), polevll(), p1evll(), isnanl(); -#endif -#ifdef INFINITIES -extern long double INFINITYL; -#endif -#ifdef NANS -extern long double NANL; -#endif - -long double logl(x) -long double x; -{ -long double y, z; -int e; - -#ifdef NANS -if( isnanl(x) ) - return(x); -#endif -#ifdef INFINITIES -if( x == INFINITYL ) - return(x); -#endif -/* Test for domain */ -if( x <= 0.0L ) - { - if( x == 0.0L ) - { -#ifdef INFINITIES - return( -INFINITYL ); -#else - mtherr( "logl", SING ); - return( MINLOGL ); -#endif - } - else - { -#ifdef NANS - return( NANL ); -#else - mtherr( "logl", DOMAIN ); - return( MINLOGL ); -#endif - } - } - -/* separate mantissa from exponent */ - -/* Note, frexp is used so that denormal numbers - * will be handled properly. - */ -x = frexpl( x, &e ); - -/* logarithm using log(x) = z + z**3 P(z)/Q(z), - * where z = 2(x-1)/x+1) - */ -if( (e > 2) || (e < -2) ) -{ -if( x < SQRTH ) - { /* 2( 2x-1 )/( 2x+1 ) */ - e -= 1; - z = x - 0.5L; - y = 0.5L * z + 0.5L; - } -else - { /* 2 (x-1)/(x+1) */ - z = x - 0.5L; - z -= 0.5L; - y = 0.5L * x + 0.5L; - } -x = z / y; -z = x*x; -z = x * ( z * polevll( z, R, 3 ) / p1evll( z, S, 3 ) ); -z = z + e * C2; -z = z + x; -z = z + e * C1; -return( z ); -} - - -/* logarithm using log(1+x) = x - .5x**2 + x**3 P(x)/Q(x) */ - -if( x < SQRTH ) - { - e -= 1; - x = ldexpl( x, 1 ) - 1.0L; /* 2x - 1 */ - } -else - { - x = x - 1.0L; - } -z = x*x; -y = x * ( z * polevll( x, P, 6 ) / p1evll( x, Q, 6 ) ); -y = y + e * C2; -z = y - ldexpl( z, -1 ); /* y - 0.5 * z */ -/* Note, the sum of above terms does not exceed x/4, - * so it contributes at most about 1/4 lsb to the error. - */ -z = z + x; -z = z + e * C1; /* This sum has an error of 1/2 lsb. */ -return( z ); -} diff --git a/libm/ldouble/lparanoi.c b/libm/ldouble/lparanoi.c deleted file mode 100644 index eb8fd25c7..000000000 --- a/libm/ldouble/lparanoi.c +++ /dev/null @@ -1,2348 +0,0 @@ -/* A C version of Kahan's Floating Point Test "Paranoia" - - Thos Sumner, UCSF, Feb. 1985 - David Gay, BTL, Jan. 1986 - - This is a rewrite from the Pascal version by - - B. A. Wichmann, 18 Jan. 1985 - - (and does NOT exhibit good C programming style). - -(C) Apr 19 1983 in BASIC version by: - Professor W. M. Kahan, - 567 Evans Hall - Electrical Engineering & Computer Science Dept. - University of California - Berkeley, California 94720 - USA - -converted to Pascal by: - B. A. Wichmann - National Physical Laboratory - Teddington Middx - TW11 OLW - UK - -converted to C by: - - David M. Gay and Thos Sumner - AT&T Bell Labs Computer Center, Rm. U-76 - 600 Mountainn Avenue University of California - Murray Hill, NJ 07974 San Francisco, CA 94143 - USA USA - -with simultaneous corrections to the Pascal source (reflected -in the Pascal source available over netlib). - -Reports of results on various systems from all the versions -of Paranoia are being collected by Richard Karpinski at the -same address as Thos Sumner. This includes sample outputs, -bug reports, and criticisms. - -You may copy this program freely if you acknowledge its source. -Comments on the Pascal version to NPL, please. - - -The C version catches signals from floating-point exceptions. -If signal(SIGFPE,...) is unavailable in your environment, you may -#define NOSIGNAL to comment out the invocations of signal. - -This source file is too big for some C compilers, but may be split -into pieces. Comments containing "SPLIT" suggest convenient places -for this splitting. At the end of these comments is an "ed script" -(for the UNIX(tm) editor ed) that will do this splitting. - -By #defining Single when you compile this source, you may obtain -a single-precision C version of Paranoia. - - -The following is from the introductory commentary from Wichmann's work: - -The BASIC program of Kahan is written in Microsoft BASIC using many -facilities which have no exact analogy in Pascal. The Pascal -version below cannot therefore be exactly the same. Rather than be -a minimal transcription of the BASIC program, the Pascal coding -follows the conventional style of block-structured languages. Hence -the Pascal version could be useful in producing versions in other -structured languages. - -Rather than use identifiers of minimal length (which therefore have -little mnemonic significance), the Pascal version uses meaningful -identifiers as follows [Note: A few changes have been made for C]: - - -BASIC C BASIC C BASIC C - - A J S StickyBit - A1 AInverse J0 NoErrors T - B Radix [Failure] T0 Underflow - B1 BInverse J1 NoErrors T2 ThirtyTwo - B2 RadixD2 [SeriousDefect] T5 OneAndHalf - B9 BMinusU2 J2 NoErrors T7 TwentySeven - C [Defect] T8 TwoForty - C1 CInverse J3 NoErrors U OneUlp - D [Flaw] U0 UnderflowThreshold - D4 FourD K PageNo U1 - E0 L Milestone U2 - E1 M V - E2 Exp2 N V0 - E3 N1 V8 - E5 MinSqEr O Zero V9 - E6 SqEr O1 One W - E7 MaxSqEr O2 Two X - E8 O3 Three X1 - E9 O4 Four X8 - F1 MinusOne O5 Five X9 Random1 - F2 Half O8 Eight Y - F3 Third O9 Nine Y1 - F6 P Precision Y2 - F9 Q Y9 Random2 - G1 GMult Q8 Z - G2 GDiv Q9 Z0 PseudoZero - G3 GAddSub R Z1 - H R1 RMult Z2 - H1 HInverse R2 RDiv Z9 - I R3 RAddSub - IO NoTrials R4 RSqrt - I3 IEEE R9 Random9 - - SqRWrng - -All the variables in BASIC are true variables and in consequence, -the program is more difficult to follow since the "constants" must -be determined (the glossary is very helpful). The Pascal version -uses Real constants, but checks are added to ensure that the values -are correctly converted by the compiler. - -The major textual change to the Pascal version apart from the -identifiersis that named procedures are used, inserting parameters -wherehelpful. New procedures are also introduced. The -correspondence is as follows: - - -BASIC Pascal -lines - - 90- 140 Pause - 170- 250 Instructions - 380- 460 Heading - 480- 670 Characteristics - 690- 870 History -2940-2950 Random -3710-3740 NewD -4040-4080 DoesYequalX -4090-4110 PrintIfNPositive -4640-4850 TestPartialUnderflow - -=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*= - -Below is an "ed script" that splits para.c into 10 files -of the form part[1-8].c, subs.c, and msgs.c, plus a header -file, paranoia.h, that these files require. -r paranoia.c -$ -?SPLIT -+,$w msgs.c -.,$d -?SPLIT -.d -+d --,$w subs.c --,$d -?part8 -+d -?include -.,$w part8.c -.,$d --d -?part7 -+d -?include -.,$w part7.c -.,$d --d -?part6 -+d -?include -.,$w part6.c -.,$d --d -?part5 -+d -?include -.,$w part5.c -.,$d --d -?part4 -+d -?include -.,$w part4.c -.,$d --d -?part3 -+d -?include -.,$w part3.c -.,$d --d -?part2 -+d -?include -.,$w part2.c -.,$d -?SPLIT -.d -1,/^#include/-1d -1,$w part1.c -/Computed constants/,$d -1,$s/^int/extern &/ -1,$s/^FLOAT/extern &/ -1,$s! = .*!;! -/^Guard/,/^Round/s/^/extern / -/^jmp_buf/s/^/extern / -/^Sig_type/s/^/extern / -a -extern int sigfpe(); -. -w paranoia.h -q - -*/ - -#include <stdio.h> -#ifndef NOSIGNAL -#include <signal.h> -#endif -#include <setjmp.h> - -#define Ldouble -/*#define Single*/ - -#ifdef Single -#define NPRT 2 -extern double fabs(), floor(), log(), pow(), sqrt(); -#define FLOAT float -#define FABS(x) (float)fabs((double)(x)) -#define FLOOR(x) (float)floor((double)(x)) -#define LOG(x) (float)log((double)(x)) -#define POW(x,y) (float)pow((double)(x),(double)(y)) -#define SQRT(x) (float)sqrt((double)(x)) -#define FSETUP sprec -/*sprec() { }*/ -#else -#ifdef Ldouble -#define NPRT 6 -extern long double fabsl(), floorl(), logl(), powl(), sqrtl(); -#define FLOAT long double -#define FABS(x) fabsl(x) -#define FLOOR(x) floorl(x) -#define LOG(x) logl(x) -#define POW(x,y) powl(x,y) -#define SQRT(x) sqrtl(x) -#define FSETUP ldprec -#else -#define NPRT 4 -extern double fabs(), floor(), log(), pow(), sqrt(); -#define FLOAT double -#define FABS(x) fabs(x) -#define FLOOR(x) floor(x) -#define LOG(x) log(x) -#define POW(x,y) pow(x,y) -#define SQRT(x) sqrt(x) -/*double __sqrtdf2(); -#define SQRT(x) __sqrtdf2(x) -*/ -#define FSETUP dprec -/* dprec() { } */ -#endif -#endif - -jmp_buf ovfl_buf; -typedef int (*Sig_type)(); -Sig_type sigsave; - -#define KEYBOARD 0 - -FLOAT Radix, BInvrse, RadixD2, BMinusU2; -FLOAT Sign(), Random(); - -/*Small floating point constants.*/ -FLOAT Zero = 0.0; -FLOAT Half = 0.5; -FLOAT One = 1.0; -FLOAT Two = 2.0; -FLOAT Three = 3.0; -FLOAT Four = 4.0; -FLOAT Five = 5.0; -FLOAT Eight = 8.0; -FLOAT Nine = 9.0; -FLOAT TwentySeven = 27.0; -FLOAT ThirtyTwo = 32.0; -FLOAT TwoForty = 240.0; -FLOAT MinusOne = -1.0; -FLOAT OneAndHalf = 1.5; -/*Integer constants*/ -int NoTrials = 20; /*Number of tests for commutativity. */ -#define False 0 -#define True 1 - -/* Definitions for declared types - Guard == (Yes, No); - Rounding == (Chopped, Rounded, Other); - Message == packed array [1..40] of char; - Class == (Flaw, Defect, Serious, Failure); - */ -#define Yes 1 -#define No 0 -#define Chopped 2 -#define Rounded 1 -#define Other 0 -#define Flaw 3 -#define Defect 2 -#define Serious 1 -#define Failure 0 -typedef int Guard, Rounding, Class; -typedef char Message; - -/* Declarations of Variables */ -int Indx; -char ch[8]; -FLOAT AInvrse, A1; -FLOAT C, CInvrse; -FLOAT D, FourD; -static FLOAT E0, E1, Exp2, E3, MinSqEr; -FLOAT SqEr, MaxSqEr, E9; -FLOAT Third; -FLOAT F6, F9; -FLOAT H, HInvrse; -int I; -FLOAT StickyBit, J; -FLOAT MyZero; -FLOAT Precision; -FLOAT Q, Q9; -FLOAT R, Random9; -FLOAT T, Underflow, S; -FLOAT OneUlp, UfThold, U1, U2; -FLOAT V, V0, V9; -FLOAT W; -FLOAT X, X1, X2, X8, Random1; -static FLOAT Y, Y1, Y2, Random2; -FLOAT Z, PseudoZero, Z1, Z2, Z9; -int ErrCnt[4]; -int fpecount; -int Milestone; -int PageNo; -int M, N, N1; -Guard GMult, GDiv, GAddSub; -Rounding RMult, RDiv, RAddSub, RSqrt; -int Break, Done, NotMonot, Monot, Anomaly, IEEE, - SqRWrng, UfNGrad; -/* Computed constants. */ -/*U1 gap below 1.0, i.e, 1.0-U1 is next number below 1.0 */ -/*U2 gap above 1.0, i.e, 1.0+U2 is next number above 1.0 */ - -/* floating point exception receiver */ -sigfpe() -{ - fpecount++; - printf("\n* * * FLOATING-POINT ERROR * * *\n"); - fflush(stdout); - if (sigsave) { -#ifndef NOSIGNAL - signal(SIGFPE, sigsave); -#endif - sigsave = 0; - longjmp(ovfl_buf, 1); - } - abort(); -} - - -FLOAT Ptemp; - -pnum( x ) -FLOAT *x; -{ -char str[30]; -double d; -unsigned short *p; -int i; - -p = (unsigned short *)x; -for( i=0; i<NPRT; i++ ) - printf( "%04x ", *p++ & 0xffff ); -#ifdef Ldouble -e64toasc( x, str, 20 ); -#else -#ifdef Single -e24toasc( x, str, 20 ); -#else -e53toasc( x, str, 20 ); -#endif -#endif -printf( " = %s\n", str ); -/* -d = *x; -printf( " = %.16e\n", d ); -*/ -} - - - -main() -{ -/* noexcept(); */ - FSETUP(); - /* First two assignments use integer right-hand sides. */ - Zero = 0; - One = 1; - Two = One + One; - Three = Two + One; - Four = Three + One; - Five = Four + One; - Eight = Four + Four; - Nine = Three * Three; - TwentySeven = Nine * Three; - ThirtyTwo = Four * Eight; - TwoForty = Four * Five * Three * Four; - MinusOne = -One; - Half = One / Two; - OneAndHalf = One + Half; - ErrCnt[Failure] = 0; - ErrCnt[Serious] = 0; - ErrCnt[Defect] = 0; - ErrCnt[Flaw] = 0; - PageNo = 1; - /*=============================================*/ - Milestone = 0; - /*=============================================*/ -#ifndef NOSIGNAL - signal(SIGFPE, sigfpe); -#endif - Instructions(); - Pause(); - Heading(); - Pause(); - Characteristics(); - Pause(); - History(); - Pause(); - /*=============================================*/ - Milestone = 7; - /*=============================================*/ - printf("Program is now RUNNING tests on small integers:\n"); - - TstCond (Failure, (Zero + Zero == Zero) && (One - One == Zero) - && (One > Zero) && (One + One == Two), - "0+0 != 0, 1-1 != 0, 1 <= 0, or 1+1 != 2"); - Z = - Zero; - if (Z == 0.0) { - U1 = 0.001; - Radix = 1; - TstPtUf(); - } - else { - ErrCnt[Failure] = ErrCnt[Failure] + 1; - printf("Comparison alleges that -0.0 is Non-zero!\n"); - } - TstCond (Failure, (Three == Two + One) && (Four == Three + One) - && (Four + Two * (- Two) == Zero) - && (Four - Three - One == Zero), - "3 != 2+1, 4 != 3+1, 4+2*(-2) != 0, or 4-3-1 != 0"); - TstCond (Failure, (MinusOne == (0 - One)) - && (MinusOne + One == Zero ) && (One + MinusOne == Zero) - && (MinusOne + FABS(One) == Zero) - && (MinusOne + MinusOne * MinusOne == Zero), - "-1+1 != 0, (-1)+abs(1) != 0, or -1+(-1)*(-1) != 0"); - TstCond (Failure, Half + MinusOne + Half == Zero, - "1/2 + (-1) + 1/2 != 0"); - /*=============================================*/ - /*SPLIT - part2(); - part3(); - part4(); - part5(); - part6(); - part7(); - part8(); - } -#include "paranoia.h" -part2(){ -*/ - Milestone = 10; - /*=============================================*/ - TstCond (Failure, (Nine == Three * Three) - && (TwentySeven == Nine * Three) && (Eight == Four + Four) - && (ThirtyTwo == Eight * Four) - && (ThirtyTwo - TwentySeven - Four - One == Zero), - "9 != 3*3, 27 != 9*3, 32 != 8*4, or 32-27-4-1 != 0"); - TstCond (Failure, (Five == Four + One) && - (TwoForty == Four * Five * Three * Four) - && (TwoForty / Three - Four * Four * Five == Zero) - && ( TwoForty / Four - Five * Three * Four == Zero) - && ( TwoForty / Five - Four * Three * Four == Zero), - "5 != 4+1, 240/3 != 80, 240/4 != 60, or 240/5 != 48"); - if (ErrCnt[Failure] == 0) { - printf("-1, 0, 1/2, 1, 2, 3, 4, 5, 9, 27, 32 & 240 are O.K.\n"); - printf("\n"); - } - printf("Searching for Radix and Precision.\n"); - W = One; - do { - W = W + W; - Y = W + One; - Z = Y - W; - Y = Z - One; - } while (MinusOne + FABS(Y) < Zero); - /*.. now W is just big enough that |((W+1)-W)-1| >= 1 ...*/ - Precision = Zero; - Y = One; - do { - Radix = W + Y; - Y = Y + Y; - Radix = Radix - W; - } while ( Radix == Zero); - if (Radix < Two) Radix = One; - printf("Radix = " ); - pnum( &Radix ); - if (Radix != 1) { - W = One; - do { - Precision = Precision + One; - W = W * Radix; - Y = W + One; - } while ((Y - W) == One); - } - /*... now W == Radix^Precision is barely too big to satisfy (W+1)-W == 1 - ...*/ - U1 = One / W; - U2 = Radix * U1; - printf("Closest relative separation found is U1 = " ); - pnum( &U1 ); - printf("U2 = "); - pnum( &U2 ); - printf("Recalculating radix and precision."); - - /*save old values*/ - E0 = Radix; - E1 = U1; - E9 = U2; - E3 = Precision; - - X = Four / Three; - Third = X - One; - F6 = Half - Third; - X = F6 + F6; - X = FABS(X - Third); - if (X < U2) X = U2; - - /*... now X = (unknown no.) ulps of 1+...*/ - do { - U2 = X; - Y = Half * U2 + ThirtyTwo * U2 * U2; - Y = One + Y; - X = Y - One; - } while ( ! ((U2 <= X) || (X <= Zero))); - - /*... now U2 == 1 ulp of 1 + ... */ - X = Two / Three; - F6 = X - Half; - Third = F6 + F6; - X = Third - Half; - X = FABS(X + F6); - if (X < U1) X = U1; - - /*... now X == (unknown no.) ulps of 1 -... */ - do { - U1 = X; - Y = Half * U1 + ThirtyTwo * U1 * U1; - Y = Half - Y; - X = Half + Y; - Y = Half - X; - X = Half + Y; - } while ( ! ((U1 <= X) || (X <= Zero))); - /*... now U1 == 1 ulp of 1 - ... */ - if (U1 == E1) printf("confirms closest relative separation U1 .\n"); - else - { - printf("gets better closest relative separation U1 = " ); - pnum( &U1 ); - } - W = One / U1; - F9 = (Half - U1) + Half; - Radix = FLOOR(0.01 + U2 / U1); - if (Radix == E0) printf("Radix confirmed.\n"); - else - { - printf("MYSTERY: recalculated Radix = " ); - pnum( &Radix ); - } - TstCond (Defect, Radix <= Eight + Eight, - "Radix is too big: roundoff problems"); - TstCond (Flaw, (Radix == Two) || (Radix == 10) - || (Radix == One), "Radix is not as good as 2 or 10"); - /*=============================================*/ - Milestone = 20; - /*=============================================*/ - TstCond (Failure, F9 - Half < Half, - "(1-U1)-1/2 < 1/2 is FALSE, prog. fails?"); - X = F9; - I = 1; - Y = X - Half; - Z = Y - Half; - TstCond (Failure, (X != One) - || (Z == Zero), "Comparison is fuzzy,X=1 but X-1/2-1/2 != 0"); - X = One + U2; - I = 0; - /*=============================================*/ - Milestone = 25; - /*=============================================*/ - /*... BMinusU2 = nextafter(Radix, 0) */ - BMinusU2 = Radix - One; - BMinusU2 = (BMinusU2 - U2) + One; - /* Purify Integers */ - if (Radix != One) { - X = - TwoForty * LOG(U1) / LOG(Radix); - Y = FLOOR(Half + X); - if (FABS(X - Y) * Four < One) X = Y; - Precision = X / TwoForty; - Y = FLOOR(Half + Precision); - if (FABS(Precision - Y) * TwoForty < Half) Precision = Y; - } - if ((Precision != FLOOR(Precision)) || (Radix == One)) { - printf("Precision cannot be characterized by an Integer number\n"); - printf("of significant digits but, by itself, this is a minor flaw.\n"); - } - if (Radix == One) - printf("logarithmic encoding has precision characterized solely by U1.\n"); - else - { - printf("The number of significant digits of the Radix is " ); - pnum( &Precision ); - } - TstCond (Serious, U2 * Nine * Nine * TwoForty < One, - "Precision worse than 5 decimal figures "); - /*=============================================*/ - Milestone = 30; - /*=============================================*/ - /* Test for extra-precise subepressions */ - X = FABS(((Four / Three - One) - One / Four) * Three - One / Four); - do { - Z2 = X; - X = (One + (Half * Z2 + ThirtyTwo * Z2 * Z2)) - One; - } while ( ! ((Z2 <= X) || (X <= Zero))); - X = Y = Z = FABS((Three / Four - Two / Three) * Three - One / Four); - do { - Z1 = Z; - Z = (One / Two - ((One / Two - (Half * Z1 + ThirtyTwo * Z1 * Z1)) - + One / Two)) + One / Two; - } while ( ! ((Z1 <= Z) || (Z <= Zero))); - do { - do { - Y1 = Y; - Y = (Half - ((Half - (Half * Y1 + ThirtyTwo * Y1 * Y1)) + Half - )) + Half; - } while ( ! ((Y1 <= Y) || (Y <= Zero))); - X1 = X; - X = ((Half * X1 + ThirtyTwo * X1 * X1) - F9) + F9; - } while ( ! ((X1 <= X) || (X <= Zero))); - if ((X1 != Y1) || (X1 != Z1)) { - BadCond(Serious, "Disagreements among the values X1, Y1, Z1,\n"); - printf("respectively " ); - pnum( &X1 ); - pnum( &Y1 ); - pnum( &Z1 ); - printf("are symptoms of inconsistencies introduced\n"); - printf("by extra-precise evaluation of arithmetic subexpressions.\n"); - notify("Possibly some part of this"); - if ((X1 == U1) || (Y1 == U1) || (Z1 == U1)) printf( - "That feature is not tested further by this program.\n") ; - } - else { - if ((Z1 != U1) || (Z2 != U2)) { - if ((Z1 >= U1) || (Z2 >= U2)) { - BadCond(Failure, ""); - notify("Precision"); - printf("\tU1 = " ); - pnum( &U1 ); - printf( "Z1 - U1 = " ); - Ptemp = Z1-U1; - pnum( &Ptemp ); - printf("\tU2 = " ); - pnum( &U2 ); - Ptemp = Z2-U2; - printf( "Z2 - U2 = " ); - pnum( &Ptemp ); - } - else { - if ((Z1 <= Zero) || (Z2 <= Zero)) { - printf("Because of unusual Radix = "); - pnum( &Radix ); - printf(", or exact rational arithmetic a result\n"); - printf("Z1 = " ); - pnum( &Z1 ); - printf( "or Z2 = " ); - pnum( &Z2 ); - notify("of an\nextra-precision"); - } - if (Z1 != Z2 || Z1 > Zero) { - X = Z1 / U1; - Y = Z2 / U2; - if (Y > X) X = Y; - Q = - LOG(X); - printf("Some subexpressions appear to be calculated extra\n"); - printf("precisely with about" ); - Ptemp = Q / LOG(Radix); - pnum( &Ptemp ); - printf( "extra B-digits, i.e.\n" ); - Ptemp = Q / LOG(10.); - printf("roughly " ); - pnum( &Ptemp ); - printf( "extra significant decimals.\n"); - } - printf("That feature is not tested further by this program.\n"); - } - } - } - Pause(); - /*=============================================*/ - /*SPLIT - } -#include "paranoia.h" -part3(){ -*/ - Milestone = 35; - /*=============================================*/ - if (Radix >= Two) { - X = W / (Radix * Radix); - Y = X + One; - Z = Y - X; - T = Z + U2; - X = T - Z; - TstCond (Failure, X == U2, - "Subtraction is not normalized X=Y,X+Z != Y+Z!"); - if (X == U2) printf( - "Subtraction appears to be normalized, as it should be."); - } - printf("\nChecking for guard digit in *, /, and -.\n"); - Y = F9 * One; - Z = One * F9; - X = F9 - Half; - Y = (Y - Half) - X; - Z = (Z - Half) - X; - X = One + U2; - T = X * Radix; - R = Radix * X; - X = T - Radix; - X = X - Radix * U2; - T = R - Radix; - T = T - Radix * U2; - X = X * (Radix - One); - T = T * (Radix - One); - if ((X == Zero) && (Y == Zero) && (Z == Zero) && (T == Zero)) GMult = Yes; - else { - GMult = No; - TstCond (Serious, False, - "* lacks a Guard Digit, so 1*X != X"); - } - Z = Radix * U2; - X = One + Z; - Y = FABS((X + Z) - X * X) - U2; - X = One - U2; - Z = FABS((X - U2) - X * X) - U1; - TstCond (Failure, (Y <= Zero) - && (Z <= Zero), "* gets too many final digits wrong.\n"); - Y = One - U2; - X = One + U2; - Z = One / Y; - Y = Z - X; - X = One / Three; - Z = Three / Nine; - X = X - Z; - T = Nine / TwentySeven; - Z = Z - T; - TstCond(Defect, X == Zero && Y == Zero && Z == Zero, - "Division lacks a Guard Digit, so error can exceed 1 ulp\n\ -or 1/3 and 3/9 and 9/27 may disagree"); - Y = F9 / One; - X = F9 - Half; - Y = (Y - Half) - X; - X = One + U2; - T = X / One; - X = T - X; - if ((X == Zero) && (Y == Zero) && (Z == Zero)) GDiv = Yes; - else { - GDiv = No; - TstCond (Serious, False, - "Division lacks a Guard Digit, so X/1 != X"); - } - X = One / (One + U2); - Y = X - Half - Half; - TstCond (Serious, Y < Zero, - "Computed value of 1/1.000..1 >= 1"); - X = One - U2; - Y = One + Radix * U2; - Z = X * Radix; - T = Y * Radix; - R = Z / Radix; - StickyBit = T / Radix; - X = R - X; - Y = StickyBit - Y; - TstCond (Failure, X == Zero && Y == Zero, - "* and/or / gets too many last digits wrong"); - Y = One - U1; - X = One - F9; - Y = One - Y; - T = Radix - U2; - Z = Radix - BMinusU2; - T = Radix - T; - if ((X == U1) && (Y == U1) && (Z == U2) && (T == U2)) GAddSub = Yes; - else { - GAddSub = No; - TstCond (Serious, False, - "- lacks Guard Digit, so cancellation is obscured"); - } - if (F9 != One && F9 - One >= Zero) { - BadCond(Serious, "comparison alleges (1-U1) < 1 although\n"); - printf(" subtration yields (1-U1) - 1 = 0 , thereby vitiating\n"); - printf(" such precautions against division by zero as\n"); - printf(" ... if (X == 1.0) {.....} else {.../(X-1.0)...}\n"); - } - if (GMult == Yes && GDiv == Yes && GAddSub == Yes) printf( - " *, /, and - appear to have guard digits, as they should.\n"); - /*=============================================*/ - Milestone = 40; - /*=============================================*/ - Pause(); - printf("Checking rounding on multiply, divide and add/subtract.\n"); - RMult = Other; - RDiv = Other; - RAddSub = Other; - RadixD2 = Radix / Two; - A1 = Two; - Done = False; - do { - AInvrse = Radix; - do { - X = AInvrse; - AInvrse = AInvrse / A1; - } while ( ! (FLOOR(AInvrse) != AInvrse)); - Done = (X == One) || (A1 > Three); - if (! Done) A1 = Nine + One; - } while ( ! (Done)); - if (X == One) A1 = Radix; - AInvrse = One / A1; - X = A1; - Y = AInvrse; - Done = False; - do { - Z = X * Y - Half; - TstCond (Failure, Z == Half, - "X * (1/X) differs from 1"); - Done = X == Radix; - X = Radix; - Y = One / X; - } while ( ! (Done)); - Y2 = One + U2; - Y1 = One - U2; - X = OneAndHalf - U2; - Y = OneAndHalf + U2; - Z = (X - U2) * Y2; - T = Y * Y1; - Z = Z - X; - T = T - X; - X = X * Y2; - Y = (Y + U2) * Y1; - X = X - OneAndHalf; - Y = Y - OneAndHalf; - if ((X == Zero) && (Y == Zero) && (Z == Zero) && (T <= Zero)) { - printf("Y2 = "); - pnum( &Y2 ); - printf("Y1 = "); - pnum( &Y1 ); - printf("U2 = "); - pnum( &U2 ); - X = (OneAndHalf + U2) * Y2; - Y = OneAndHalf - U2 - U2; - Z = OneAndHalf + U2 + U2; - T = (OneAndHalf - U2) * Y1; - X = X - (Z + U2); - StickyBit = Y * Y1; - S = Z * Y2; - T = T - Y; - Y = (U2 - Y) + StickyBit; - Z = S - (Z + U2 + U2); - StickyBit = (Y2 + U2) * Y1; - Y1 = Y2 * Y1; - StickyBit = StickyBit - Y2; - Y1 = Y1 - Half; - if ((X == Zero) && (Y == Zero) && (Z == Zero) && (T == Zero) - && ( StickyBit == Zero) && (Y1 == Half)) { - RMult = Rounded; - printf("Multiplication appears to round correctly.\n"); - } - else if ((X + U2 == Zero) && (Y < Zero) && (Z + U2 == Zero) - && (T < Zero) && (StickyBit + U2 == Zero) - && (Y1 < Half)) { - RMult = Chopped; - printf("Multiplication appears to chop.\n"); - } - else printf("* is neither chopped nor correctly rounded.\n"); - if ((RMult == Rounded) && (GMult == No)) notify("Multiplication"); - } - else printf("* is neither chopped nor correctly rounded.\n"); - /*=============================================*/ - Milestone = 45; - /*=============================================*/ - Y2 = One + U2; - Y1 = One - U2; - Z = OneAndHalf + U2 + U2; - X = Z / Y2; - T = OneAndHalf - U2 - U2; - Y = (T - U2) / Y1; - Z = (Z + U2) / Y2; - X = X - OneAndHalf; - Y = Y - T; - T = T / Y1; - Z = Z - (OneAndHalf + U2); - T = (U2 - OneAndHalf) + T; - if (! ((X > Zero) || (Y > Zero) || (Z > Zero) || (T > Zero))) { - X = OneAndHalf / Y2; - Y = OneAndHalf - U2; - Z = OneAndHalf + U2; - X = X - Y; - T = OneAndHalf / Y1; - Y = Y / Y1; - T = T - (Z + U2); - Y = Y - Z; - Z = Z / Y2; - Y1 = (Y2 + U2) / Y2; - Z = Z - OneAndHalf; - Y2 = Y1 - Y2; - Y1 = (F9 - U1) / F9; - if ((X == Zero) && (Y == Zero) && (Z == Zero) && (T == Zero) - && (Y2 == Zero) && (Y2 == Zero) - && (Y1 - Half == F9 - Half )) { - RDiv = Rounded; - printf("Division appears to round correctly.\n"); - if (GDiv == No) notify("Division"); - } - else if ((X < Zero) && (Y < Zero) && (Z < Zero) && (T < Zero) - && (Y2 < Zero) && (Y1 - Half < F9 - Half)) { - RDiv = Chopped; - printf("Division appears to chop.\n"); - } - } - if (RDiv == Other) printf("/ is neither chopped nor correctly rounded.\n"); - BInvrse = One / Radix; - TstCond (Failure, (BInvrse * Radix - Half == Half), - "Radix * ( 1 / Radix ) differs from 1"); - /*=============================================*/ - /*SPLIT - } -#include "paranoia.h" -part4(){ -*/ - Milestone = 50; - /*=============================================*/ - TstCond (Failure, ((F9 + U1) - Half == Half) - && ((BMinusU2 + U2 ) - One == Radix - One), - "Incomplete carry-propagation in Addition"); - X = One - U1 * U1; - Y = One + U2 * (One - U2); - Z = F9 - Half; - X = (X - Half) - Z; - Y = Y - One; - if ((X == Zero) && (Y == Zero)) { - RAddSub = Chopped; - printf("Add/Subtract appears to be chopped.\n"); - } - if (GAddSub == Yes) { - X = (Half + U2) * U2; - Y = (Half - U2) * U2; - X = One + X; - Y = One + Y; - X = (One + U2) - X; - Y = One - Y; - if ((X == Zero) && (Y == Zero)) { - X = (Half + U2) * U1; - Y = (Half - U2) * U1; - X = One - X; - Y = One - Y; - X = F9 - X; - Y = One - Y; - if ((X == Zero) && (Y == Zero)) { - RAddSub = Rounded; - printf("Addition/Subtraction appears to round correctly.\n"); - if (GAddSub == No) notify("Add/Subtract"); - } - else printf("Addition/Subtraction neither rounds nor chops.\n"); - } - else printf("Addition/Subtraction neither rounds nor chops.\n"); - } - else printf("Addition/Subtraction neither rounds nor chops.\n"); - S = One; - X = One + Half * (One + Half); - Y = (One + U2) * Half; - Z = X - Y; - T = Y - X; - StickyBit = Z + T; - if (StickyBit != Zero) { - S = Zero; - BadCond(Flaw, "(X - Y) + (Y - X) is non zero!\n"); - } - StickyBit = Zero; - if ((GMult == Yes) && (GDiv == Yes) && (GAddSub == Yes) - && (RMult == Rounded) && (RDiv == Rounded) - && (RAddSub == Rounded) && (FLOOR(RadixD2) == RadixD2)) { - printf("Checking for sticky bit.\n"); - X = (Half + U1) * U2; - Y = Half * U2; - Z = One + Y; - T = One + X; - if ((Z - One <= Zero) && (T - One >= U2)) { - Z = T + Y; - Y = Z - X; - if ((Z - T >= U2) && (Y - T == Zero)) { - X = (Half + U1) * U1; - Y = Half * U1; - Z = One - Y; - T = One - X; - if ((Z - One == Zero) && (T - F9 == Zero)) { - Z = (Half - U1) * U1; - T = F9 - Z; - Q = F9 - Y; - if ((T - F9 == Zero) && (F9 - U1 - Q == Zero)) { - Z = (One + U2) * OneAndHalf; - T = (OneAndHalf + U2) - Z + U2; - X = One + Half / Radix; - Y = One + Radix * U2; - Z = X * Y; - if (T == Zero && X + Radix * U2 - Z == Zero) { - if (Radix != Two) { - X = Two + U2; - Y = X / Two; - if ((Y - One == Zero)) StickyBit = S; - } - else StickyBit = S; - } - } - } - } - } - } - if (StickyBit == One) printf("Sticky bit apparently used correctly.\n"); - else printf("Sticky bit used incorrectly or not at all.\n"); - TstCond (Flaw, !(GMult == No || GDiv == No || GAddSub == No || - RMult == Other || RDiv == Other || RAddSub == Other), - "lack(s) of guard digits or failure(s) to correctly round or chop\n\ -(noted above) count as one flaw in the final tally below"); - /*=============================================*/ - Milestone = 60; - /*=============================================*/ - printf("\n"); - printf("Does Multiplication commute? "); - printf("Testing on %d random pairs.\n", NoTrials); - Ptemp = 3.0; - Random9 = SQRT(Ptemp); - Random1 = Third; - I = 1; - do { - X = Random(); - Y = Random(); - Z9 = Y * X; - Z = X * Y; - Z9 = Z - Z9; - I = I + 1; - } while ( ! ((I > NoTrials) || (Z9 != Zero))); - if (I == NoTrials) { - Random1 = One + Half / Three; - Random2 = (U2 + U1) + One; - Z = Random1 * Random2; - Y = Random2 * Random1; - Z9 = (One + Half / Three) * ((U2 + U1) + One) - (One + Half / - Three) * ((U2 + U1) + One); - } - if (! ((I == NoTrials) || (Z9 == Zero))) - BadCond(Defect, "X * Y == Y * X trial fails.\n"); - else printf(" No failures found in %d integer pairs.\n", NoTrials); - /*=============================================*/ - Milestone = 70; - /*=============================================*/ - printf("\nRunning test of square root(x).\n"); - TstCond (Failure, (Zero == SQRT(Zero)) - && (- Zero == SQRT(- Zero)) - && (One == SQRT(One)), "Square root of 0.0, -0.0 or 1.0 wrong"); - MinSqEr = Zero; - MaxSqEr = Zero; - J = Zero; - X = Radix; - OneUlp = U2; - SqXMinX (Serious); - X = BInvrse; - OneUlp = BInvrse * U1; - SqXMinX (Serious); - X = U1; - OneUlp = U1 * U1; - SqXMinX (Serious); - if (J != Zero) Pause(); - printf("Testing if sqrt(X * X) == X for %d Integers X.\n", NoTrials); - J = Zero; - X = Two; - Y = Radix; - if ((Radix != One)) do { - X = Y; - Y = Radix * Y; - } while ( ! ((Y - X >= NoTrials))); - OneUlp = X * U2; - I = 1; - while (I < 10) { - X = X + One; - SqXMinX (Defect); - if (J > Zero) break; - I = I + 1; - } - printf("Test for sqrt monotonicity.\n"); - I = - 1; - X = BMinusU2; - Y = Radix; - Z = Radix + Radix * U2; - NotMonot = False; - Monot = False; - while ( ! (NotMonot || Monot)) { - I = I + 1; - X = SQRT(X); - Q = SQRT(Y); - Z = SQRT(Z); - if ((X > Q) || (Q > Z)) NotMonot = True; - else { - Q = FLOOR(Q + Half); - if ((I > 0) || (Radix == Q * Q)) Monot = True; - else if (I > 0) { - if (I > 1) Monot = True; - else { - Y = Y * BInvrse; - X = Y - U1; - Z = Y + U1; - } - } - else { - Y = Q; - X = Y - U2; - Z = Y + U2; - } - } - } - if (Monot) printf("sqrt has passed a test for Monotonicity.\n"); - else { - BadCond(Defect, ""); - printf("sqrt(X) is non-monotonic for X near " ); - pnum( &Y ); - } - /*=============================================*/ - /*SPLIT - } -#include "paranoia.h" -part5(){ -*/ - Milestone = 80; - /*=============================================*/ - MinSqEr = MinSqEr + Half; - MaxSqEr = MaxSqEr - Half; - Y = (SQRT(One + U2) - One) / U2; - SqEr = (Y - One) + U2 / Eight; - if (SqEr > MaxSqEr) MaxSqEr = SqEr; - SqEr = Y + U2 / Eight; - if (SqEr < MinSqEr) MinSqEr = SqEr; - Y = ((SQRT(F9) - U2) - (One - U2)) / U1; - SqEr = Y + U1 / Eight; - if (SqEr > MaxSqEr) MaxSqEr = SqEr; - SqEr = (Y + One) + U1 / Eight; - if (SqEr < MinSqEr) MinSqEr = SqEr; - OneUlp = U2; - X = OneUlp; - for( Indx = 1; Indx <= 3; ++Indx) { - Y = SQRT((X + U1 + X) + F9); - Y = ((Y - U2) - ((One - U2) + X)) / OneUlp; - Z = ((U1 - X) + F9) * Half * X * X / OneUlp; - SqEr = (Y + Half) + Z; - if (SqEr < MinSqEr) MinSqEr = SqEr; - SqEr = (Y - Half) + Z; - if (SqEr > MaxSqEr) MaxSqEr = SqEr; - if (((Indx == 1) || (Indx == 3))) - X = OneUlp * Sign (X) * FLOOR(Eight / (Nine * SQRT(OneUlp))); - else { - OneUlp = U1; - X = - OneUlp; - } - } - /*=============================================*/ - Milestone = 85; - /*=============================================*/ - SqRWrng = False; - Anomaly = False; - if (Radix != One) { - printf("Testing whether sqrt is rounded or chopped.\n"); - D = FLOOR(Half + POW(Radix, One + Precision - FLOOR(Precision))); - /* ... == Radix^(1 + fract) if (Precision == Integer + fract. */ - X = D / Radix; - Y = D / A1; - if ((X != FLOOR(X)) || (Y != FLOOR(Y))) { - Anomaly = True; - } - else { - X = Zero; - Z2 = X; - Y = One; - Y2 = Y; - Z1 = Radix - One; - FourD = Four * D; - do { - if (Y2 > Z2) { - Q = Radix; - Y1 = Y; - do { - X1 = FABS(Q + FLOOR(Half - Q / Y1) * Y1); - Q = Y1; - Y1 = X1; - } while ( ! (X1 <= Zero)); - if (Q <= One) { - Z2 = Y2; - Z = Y; - } - } - Y = Y + Two; - X = X + Eight; - Y2 = Y2 + X; - if (Y2 >= FourD) Y2 = Y2 - FourD; - } while ( ! (Y >= D)); - X8 = FourD - Z2; - Q = (X8 + Z * Z) / FourD; - X8 = X8 / Eight; - if (Q != FLOOR(Q)) Anomaly = True; - else { - Break = False; - do { - X = Z1 * Z; - X = X - FLOOR(X / Radix) * Radix; - if (X == One) - Break = True; - else - Z1 = Z1 - One; - } while ( ! (Break || (Z1 <= Zero))); - if ((Z1 <= Zero) && (! Break)) Anomaly = True; - else { - if (Z1 > RadixD2) Z1 = Z1 - Radix; - do { - NewD(); - } while ( ! (U2 * D >= F9)); - if (D * Radix - D != W - D) Anomaly = True; - else { - Z2 = D; - I = 0; - Y = D + (One + Z) * Half; - X = D + Z + Q; - SR3750(); - Y = D + (One - Z) * Half + D; - X = D - Z + D; - X = X + Q + X; - SR3750(); - NewD(); - if (D - Z2 != W - Z2) Anomaly = True; - else { - Y = (D - Z2) + (Z2 + (One - Z) * Half); - X = (D - Z2) + (Z2 - Z + Q); - SR3750(); - Y = (One + Z) * Half; - X = Q; - SR3750(); - if (I == 0) Anomaly = True; - } - } - } - } - } - if ((I == 0) || Anomaly) { - BadCond(Failure, "Anomalous arithmetic with Integer < "); - printf("Radix^Precision = " ); - pnum( &W ); - printf(" fails test whether sqrt rounds or chops.\n"); - SqRWrng = True; - } - } - if (! Anomaly) { - if (! ((MinSqEr < Zero) || (MaxSqEr > Zero))) { - RSqrt = Rounded; - printf("Square root appears to be correctly rounded.\n"); - } - else { - if ((MaxSqEr + U2 > U2 - Half) || (MinSqEr > Half) - || (MinSqEr + Radix < Half)) SqRWrng = True; - else { - RSqrt = Chopped; - printf("Square root appears to be chopped.\n"); - } - } - } - if (SqRWrng) { - printf("Square root is neither chopped nor correctly rounded.\n"); - printf("Observed errors run from " ); - Ptemp = MinSqEr - Half; - pnum( &Ptemp ); - printf("to %.7e ulps.\n"); - Ptemp = Half + MaxSqEr; - pnum( &Ptemp ); - TstCond (Serious, MaxSqEr - MinSqEr < Radix * Radix, - "sqrt gets too many last digits wrong"); - } - /*=============================================*/ - Milestone = 90; - /*=============================================*/ - Pause(); - printf("Testing powers Z^i for small Integers Z and i.\n"); - N = 0; - /* ... test powers of zero. */ - I = 0; - Z = -Zero; - M = 3.0; - Break = False; - do { - X = One; - SR3980(); - if (I <= 10) { - I = 1023; - SR3980(); - } - if (Z == MinusOne) Break = True; - else { - Z = MinusOne; - PrintIfNPositive(); - N = 0; - /* .. if(-1)^N is invalid, replace MinusOne by One. */ - I = - 4; - } - } while ( ! Break); - PrintIfNPositive(); - N1 = N; - N = 0; - Z = A1; - M = FLOOR(Two * LOG(W) / LOG(A1)); - Break = False; - do { - X = Z; - I = 1; - SR3980(); - if (Z == AInvrse) Break = True; - else Z = AInvrse; - } while ( ! (Break)); - /*=============================================*/ - Milestone = 100; - /*=============================================*/ - /* Powers of Radix have been tested, */ - /* next try a few primes */ - M = NoTrials; - Z = Three; - do { - X = Z; - I = 1; - SR3980(); - do { - Z = Z + Two; - } while ( Three * FLOOR(Z / Three) == Z ); - } while ( Z < Eight * Three ); - if (N > 0) { - printf("Errors like this may invalidate financial calculations\n"); - printf("\tinvolving interest rates.\n"); - } - PrintIfNPositive(); - N += N1; - if (N == 0) printf("... no discrepancis found.\n"); - if (N > 0) Pause(); - else printf("\n"); - /*=============================================*/ - /*SPLIT - } -#include "paranoia.h" -part6(){ -*/ - Milestone = 110; - /*=============================================*/ - printf("Seeking Underflow thresholds UfThold and E0.\n"); - D = U1; - if (Precision != FLOOR(Precision)) { - D = BInvrse; - X = Precision; - do { - D = D * BInvrse; - X = X - One; - } while ( X > Zero); - } - Y = One; - Z = D; - /* ... D is power of 1/Radix < 1. */ - do { - C = Y; - Y = Z; - Z = Y * Y; - } while ((Y > Z) && (Z + Z > Z)); - Y = C; - Z = Y * D; - do { - C = Y; - Y = Z; - Z = Y * D; - } while ((Y > Z) && (Z + Z > Z)); - if (Radix < Two) HInvrse = Two; - else HInvrse = Radix; - H = One / HInvrse; - /* ... 1/HInvrse == H == Min(1/Radix, 1/2) */ - CInvrse = One / C; - E0 = C; - Z = E0 * H; - /* ...1/Radix^(BIG Integer) << 1 << CInvrse == 1/C */ - do { - Y = E0; - E0 = Z; - Z = E0 * H; - } while ((E0 > Z) && (Z + Z > Z)); - UfThold = E0; - E1 = Zero; - Q = Zero; - E9 = U2; - S = One + E9; - D = C * S; - if (D <= C) { - E9 = Radix * U2; - S = One + E9; - D = C * S; - if (D <= C) { - BadCond(Failure, "multiplication gets too many last digits wrong.\n"); - Underflow = E0; - Y1 = Zero; - PseudoZero = Z; - Pause(); - } - } - else { - Underflow = D; - PseudoZero = Underflow * H; - UfThold = Zero; - do { - Y1 = Underflow; - Underflow = PseudoZero; - if (E1 + E1 <= E1) { - Y2 = Underflow * HInvrse; - E1 = FABS(Y1 - Y2); - Q = Y1; - if ((UfThold == Zero) && (Y1 != Y2)) UfThold = Y1; - } - PseudoZero = PseudoZero * H; - } while ((Underflow > PseudoZero) - && (PseudoZero + PseudoZero > PseudoZero)); - } - /* Comment line 4530 .. 4560 */ - if (PseudoZero != Zero) { - printf("\n"); - Z = PseudoZero; - /* ... Test PseudoZero for "phoney- zero" violates */ - /* ... PseudoZero < Underflow or PseudoZero < PseudoZero + PseudoZero - ... */ - if (PseudoZero <= Zero) { - BadCond(Failure, "Positive expressions can underflow to an\n"); - printf("allegedly negative value\n"); - printf("PseudoZero that prints out as: " ); - pnum( &PseudoZero ); - X = - PseudoZero; - if (X <= Zero) { - printf("But -PseudoZero, which should be\n"); - printf("positive, isn't; it prints out as " ); - pnum( &X ); - } - } - else { - BadCond(Flaw, "Underflow can stick at an allegedly positive\n"); - printf("value PseudoZero that prints out as "); - pnum( &PseudoZero ); - } - TstPtUf(); - } - /*=============================================*/ - Milestone = 120; - /*=============================================*/ - if (CInvrse * Y > CInvrse * Y1) { - S = H * S; - E0 = Underflow; - } - if (! ((E1 == Zero) || (E1 == E0))) { - BadCond(Defect, ""); - if (E1 < E0) { - printf("Products underflow at a higher"); - printf(" threshold than differences.\n"); - if (PseudoZero == Zero) - E0 = E1; - } - else { - printf("Difference underflows at a higher"); - printf(" threshold than products.\n"); - } - } - printf("Smallest strictly positive number found is E0 = "); - Pause(); - pnum( &E0 ); - Z = E0; - TstPtUf(); - Underflow = E0; - if (N == 1) Underflow = Y; - I = 4; - if (E1 == Zero) I = 3; - if (UfThold == Zero) I = I - 2; - UfNGrad = True; - switch (I) { - case 1: - UfThold = Underflow; - if ((CInvrse * Q) != ((CInvrse * Y) * S)) { - UfThold = Y; - BadCond(Failure, "Either accuracy deteriorates as numbers\n"); - printf("approach a threshold = "); - pnum( &UfThold ); - printf(" coming down from " ); - pnum( &C ); - printf(" or else multiplication gets too many last digits wrong.\n"); - } - Pause(); - break; - - case 2: - BadCond(Failure, "Underflow confuses Comparison which alleges that\n"); - printf("Q == Y while denying that |Q - Y| == 0; these values\n"); - printf("print out as Q = " ); - pnum( &Q ); - printf( "Y = " ); - pnum( &Y ); - printf ("|Q - Y| = " ); - Ptemp = FABS(Q - Y2); - pnum( &Ptemp ); - UfThold = Q; - break; - - case 3: - X = X; - break; - - case 4: - if ((Q == UfThold) && (E1 == E0) - && (FABS( UfThold - E1 / E9) <= E1)) { - UfNGrad = False; - printf("Underflow is gradual; it incurs Absolute Error =\n"); - printf("(roundoff in UfThold) < E0.\n"); - Y = E0 * CInvrse; - Y = Y * (OneAndHalf + U2); - X = CInvrse * (One + U2); - Y = Y / X; - IEEE = (Y == E0); - } - } - if (UfNGrad) { - printf("\n"); - R = SQRT(Underflow / UfThold); - if (R <= H) { - Z = R * UfThold; - X = Z * (One + R * H * (One + H)); - } - else { - Z = UfThold; - X = Z * (One + H * H * (One + H)); - } - if (! ((X == Z) || (X - Z != Zero))) { - BadCond(Flaw, ""); - printf("X = " ); - pnum( &X ); - printf( "is not equal to Z = "); - pnum( &Z ); - Z9 = X - Z; - printf("yet X - Z yields " ); - pnum( &Z9 ); - printf(" Should this NOT signal Underflow, "); - printf("this is a SERIOUS DEFECT\nthat causes "); - printf("confusion when innocent statements like\n");; - printf(" if (X == Z) ... else"); - printf(" ... (f(X) - f(Z)) / (X - Z) ...\n"); - printf("encounter Division by Zero although actually\n"); - printf("X / Z = 1 + "); - Ptemp = (X / Z - Half) - Half; - pnum( &Ptemp ); - } - } - printf("The Underflow threshold is "); - pnum( &UfThold ); - printf("below which calculation may suffer larger Relative error than "); - printf("merely roundoff.\n"); - Y2 = U1 * U1; - Y = Y2 * Y2; - Y2 = Y * U1; - if (Y2 <= UfThold) { - if (Y > E0) { - BadCond(Defect, ""); - I = 5; - } - else { - BadCond(Serious, ""); - I = 4; - } - printf("Range is too narrow; U1^%d Underflows.\n", I); - } - /*=============================================*/ - /*SPLIT - } -#include "paranoia.h" -part7(){ -*/ - Milestone = 130; - /*=============================================*/ - Y = - FLOOR(Half - TwoForty * LOG(UfThold) / LOG(HInvrse)) / TwoForty; - Y2 = Y - One; - printf("Since underflow occurs below the threshold\n"); - printf("UfThold = "); - pnum( &HInvrse ); - printf( ") ^ (Y=" ); - pnum( &Y ); - printf( ")\nonly underflow " ); - printf("should afflict the expression HInvrse^(Y+1).\n"); - pnum( &HInvrse ); - pnum( &Y2 ); - V9 = POW(HInvrse, Y2); - printf("actually calculating yields: "); - pnum( &V9 ); - if (! ((V9 >= Zero) && (V9 <= (Radix + Radix + E9) * UfThold))) { - BadCond(Serious, "this is not between 0 and underflow\n"); - printf(" threshold = "); - pnum( &UfThold ); - } - else if (! (V9 > UfThold * (One + E9))) - printf("This computed value is O.K.\n"); - else { - BadCond(Defect, "this is not between 0 and underflow\n"); - printf(" threshold = "); - pnum( &UfThold); - } - /*=============================================*/ - Milestone = 140; - /*=============================================*/ - printf("\n"); - /* ...calculate Exp2 == exp(2) == 7.389056099... */ - X = Zero; - I = 2; - Y = Two * Three; - Q = Zero; - N = 0; - do { - Z = X; - I = I + 1; - Y = Y / (I + I); - R = Y + Q; - X = Z + R; - Q = (Z - X) + R; - } while(X > Z); - Z = (OneAndHalf + One / Eight) + X / (OneAndHalf * ThirtyTwo); - X = Z * Z; - Exp2 = X * X; - X = F9; - Y = X - U1; - printf("Testing X^((X + 1) / (X - 1)) vs. exp(2) = "); - pnum( &Exp2 ); - printf( "as X -> 1.\n"); - for(I = 1;;) { - Z = X - BInvrse; - Z = (X + One) / (Z - (One - BInvrse)); - Q = POW(X, Z) - Exp2; - if (FABS(Q) > TwoForty * U2) { - N = 1; - V9 = (X - BInvrse) - (One - BInvrse); - BadCond(Defect, "Calculated"); - Ptemp = POW(X,Z); - pnum(&Ptemp); - printf("for (1 + (" ); - pnum( &V9 ); - printf( ") ^ (" ); - pnum( &Z ); - printf(") differs from correct value by "); - pnum( &Q ); - printf("\tThis much error may spoil financial\n"); - printf("\tcalculations involving tiny interest rates.\n"); - break; - } - else { - Z = (Y - X) * Two + Y; - X = Y; - Y = Z; - Z = One + (X - F9)*(X - F9); - if (Z > One && I < NoTrials) I++; - else { - if (X > One) { - if (N == 0) - printf("Accuracy seems adequate.\n"); - break; - } - else { - X = One + U2; - Y = U2 + U2; - Y += X; - I = 1; - } - } - } - } - /*=============================================*/ - Milestone = 150; - /*=============================================*/ - printf("Testing powers Z^Q at four nearly extreme values.\n"); - N = 0; - Z = A1; - Q = FLOOR(Half - LOG(C) / LOG(A1)); - Break = False; - do { - X = CInvrse; - Y = POW(Z, Q); - IsYeqX(); - Q = - Q; - X = C; - Y = POW(Z, Q); - IsYeqX(); - if (Z < One) Break = True; - else Z = AInvrse; - } while ( ! (Break)); - PrintIfNPositive(); - if (N == 0) printf(" ... no discrepancies found.\n"); - printf("\n"); - - /*=============================================*/ - Milestone = 160; - /*=============================================*/ - Pause(); - printf("Searching for Overflow threshold:\n"); - printf("This may generate an error.\n"); - sigsave = sigfpe; - I = 0; - Y = - CInvrse; - V9 = HInvrse * Y; - if (setjmp(ovfl_buf)) goto overflow; - do { - V = Y; - Y = V9; - V9 = HInvrse * Y; - } while(V9 < Y); - I = 1; -overflow: - Z = V9; - printf("Can `Z = -Y' overflow?\n"); - printf("Trying it on Y = " ); - pnum( &Y ); - V9 = - Y; - V0 = V9; - if (V - Y == V + V0) printf("Seems O.K.\n"); - else { - printf("finds a "); - BadCond(Flaw, "-(-Y) differs from Y.\n"); - } -#if 0 -/* this doesn't handle infinity. */ - if (Z != Y) { - BadCond(Serious, ""); - printf("overflow past " ); - pnum( &Y ); - printf( "shrinks to " ); - pnum( &Z ); - } -#endif - Y = V * (HInvrse * U2 - HInvrse); - Z = Y + ((One - HInvrse) * U2) * V; - if (Z < V0) Y = Z; - if (Y < V0) V = Y; - if (V0 - V < V0) V = V0; - printf("Overflow threshold is V = " ); - pnum( &V ); - if (I) - { - printf("Overflow saturates at V0 = " ); - pnum( &V0 ); - } - else printf("There is no saturation value because the system traps on overflow.\n"); - V9 = V * One; - printf("No Overflow should be signaled for V * 1 = " ); - pnum( &V9 ); - V9 = V / One; - printf(" nor for V / 1 = " ); - pnum( &V9 ); - printf("Any overflow signal separating this * from the one\n"); - printf("above is a DEFECT.\n"); - /*=============================================*/ - Milestone = 170; - /*=============================================*/ - if (!(-V < V && -V0 < V0 && -UfThold < V && UfThold < V)) { - BadCond(Failure, "Comparisons involving "); - printf("+-" ); - pnum( &V ); - printf( ", +- " ); - pnum( &V0 ); - printf( "and +- " ); - pnum( &UfThold ); - printf( "are confused by Overflow." ); - } - /*=============================================*/ - Milestone = 175; - /*=============================================*/ - printf("\n"); - for(Indx = 1; Indx <= 3; ++Indx) { - switch (Indx) { - case 1: Z = UfThold; break; - case 2: Z = E0; break; - case 3: Z = PseudoZero; break; - } - if (Z != Zero) { - V9 = SQRT(Z); - Y = V9 * V9; - if (Y / (One - Radix * E9) < Z - || Y > (One + Radix + E9) * Z) { - if (V9 > U1) BadCond(Serious, ""); - else BadCond(Defect, ""); - printf("Comparison alleges that what prints as Z =" ); - pnum( &Z ); - printf(" is too far from sqrt(Z) ^ 2 = "); - pnum( &Y ); - } - } - } - /*=============================================*/ - Milestone = 180; - /*=============================================*/ - for(Indx = 1; Indx <= 2; ++Indx) { - if (Indx == 1) Z = V; - else Z = V0; - V9 = SQRT(Z); - X = (One - Radix * E9) * V9; - V9 = V9 * X; - if (((V9 < (One - Two * Radix * E9) * Z) || (V9 > Z))) { - Y = V9; - if (X < W) BadCond(Serious, ""); - else BadCond(Defect, ""); - printf("Comparison alleges that Z = "); - pnum( &Z ); - printf(" is too far from sqrt(Z) ^ 2 " ); - pnum( &Y ); - } - } - /*=============================================*/ - /*SPLIT - } -#include "paranoia.h" -part8(){ -*/ - Milestone = 190; - /*=============================================*/ - Pause(); - X = UfThold * V; - Y = Radix * Radix; - if (X*Y < One || X > Y) { - if (X * Y < U1 || X > Y/U1) BadCond(Defect, "Badly"); - else BadCond(Flaw, ""); - - printf(" unbalanced range; UfThold * V = " ); - pnum( &X ); - printf( "is too far from 1.\n"); - } - /*=============================================*/ - Milestone = 200; - /*=============================================*/ - for (Indx = 1; Indx <= 5; ++Indx) { - X = F9; - switch (Indx) { - case 2: X = One + U2; break; - case 3: X = V; break; - case 4: X = UfThold; break; - case 5: X = Radix; - } - Y = X; - sigsave = sigfpe; - if (setjmp(ovfl_buf)) - { - printf(" X / X traps when X = "); - pnum( &X ); - } - else { - V9 = (Y / X - Half) - Half; - if (V9 == Zero) continue; - if (V9 == - U1 && Indx < 5) BadCond(Flaw, ""); - else BadCond(Serious, ""); - printf(" X / X differs from 1 when X ="); - pnum( &X ); - printf(" instead, X / X - 1/2 - 1/2 = "); - pnum( &V9 ); - } - } - /*=============================================*/ - Milestone = 210; - /*=============================================*/ - MyZero = Zero; - printf("\n"); - printf("What message and/or values does Division by Zero produce?\n") ; -#ifndef NOPAUSE - printf("This can interupt your program. You can "); - printf("skip this part if you wish.\n"); - printf("Do you wish to compute 1 / 0? "); - fflush(stdout); - read (KEYBOARD, ch, 8); - if ((ch[0] == 'Y') || (ch[0] == 'y')) { -#endif - sigsave = sigfpe; - printf(" Trying to compute 1 / 0 produces ..."); - if (!setjmp(ovfl_buf)) - { - Ptemp = One / MyZero; - pnum( &Ptemp ); - } -#ifndef NOPAUSE - } - else printf("O.K.\n"); - printf("\nDo you wish to compute 0 / 0? "); - fflush(stdout); - read (KEYBOARD, ch, 80); - if ((ch[0] == 'Y') || (ch[0] == 'y')) { -#endif - sigsave = sigfpe; - printf("\n Trying to compute 0 / 0 produces ..."); - if (!setjmp(ovfl_buf)) - { - Ptemp = Zero / MyZero; - pnum( &Ptemp ); - } -#ifndef NOPAUSE - } - else printf("O.K.\n"); -#endif - /*=============================================*/ - Milestone = 220; - /*=============================================*/ - Pause(); - printf("\n"); - { - static char *msg[] = { - "FAILUREs encountered =", - "SERIOUS DEFECTs discovered =", - "DEFECTs discovered =", - "FLAWs discovered =" }; - int i; - for(i = 0; i < 4; i++) if (ErrCnt[i]) - printf("The number of %-29s %d.\n", - msg[i], ErrCnt[i]); - } - printf("\n"); - if ((ErrCnt[Failure] + ErrCnt[Serious] + ErrCnt[Defect] - + ErrCnt[Flaw]) > 0) { - if ((ErrCnt[Failure] + ErrCnt[Serious] + ErrCnt[ - Defect] == 0) && (ErrCnt[Flaw] > 0)) { - printf("The arithmetic diagnosed seems "); - printf("satisfactory though flawed.\n"); - } - if ((ErrCnt[Failure] + ErrCnt[Serious] == 0) - && ( ErrCnt[Defect] > 0)) { - printf("The arithmetic diagnosed may be acceptable\n"); - printf("despite inconvenient Defects.\n"); - } - if ((ErrCnt[Failure] + ErrCnt[Serious]) > 0) { - printf("The arithmetic diagnosed has "); - printf("unacceptable serious defects.\n"); - } - if (ErrCnt[Failure] > 0) { - printf("Fatal FAILURE may have spoiled this"); - printf(" program's subsequent diagnoses.\n"); - } - } - else { - printf("No failures, defects nor flaws have been discovered.\n"); - if (! ((RMult == Rounded) && (RDiv == Rounded) - && (RAddSub == Rounded) && (RSqrt == Rounded))) - printf("The arithmetic diagnosed seems satisfactory.\n"); - else { - if (StickyBit >= One && - (Radix - Two) * (Radix - Nine - One) == Zero) { - printf("Rounding appears to conform to "); - printf("the proposed IEEE standard P"); - if ((Radix == Two) && - ((Precision - Four * Three * Two) * - ( Precision - TwentySeven - - TwentySeven + One) == Zero)) - printf("754"); - else printf("854"); - if (IEEE) printf(".\n"); - else { - printf(",\nexcept for possibly Double Rounding"); - printf(" during Gradual Underflow.\n"); - } - } - printf("The arithmetic diagnosed appears to be excellent!\n"); - } - } - if (fpecount) - printf("\nA total of %d floating point exceptions were registered.\n", - fpecount); - printf("END OF TEST.\n"); - } - -/*SPLIT subs.c -#include "paranoia.h" -*/ - -/* Sign */ - -FLOAT Sign (X) -FLOAT X; -{ return X >= 0. ? 1.0 : -1.0; } - -/* Pause */ - -Pause() -{ - char ch[8]; - -#ifndef NOPAUSE - printf("\nTo continue, press RETURN"); - fflush(stdout); - read(KEYBOARD, ch, 8); -#endif - printf("\nDiagnosis resumes after milestone Number %d", Milestone); - printf(" Page: %d\n\n", PageNo); - ++Milestone; - ++PageNo; - } - - /* TstCond */ - -TstCond (K, Valid, T) -int K, Valid; -char *T; -{ if (! Valid) { BadCond(K,T); printf(".\n"); } } - -BadCond(K, T) -int K; -char *T; -{ - static char *msg[] = { "FAILURE", "SERIOUS DEFECT", "DEFECT", "FLAW" }; - - ErrCnt [K] = ErrCnt [K] + 1; - printf("%s: %s", msg[K], T); - } - -/* Random */ -/* Random computes - X = (Random1 + Random9)^5 - Random1 = X - FLOOR(X) + 0.000005 * X; - and returns the new value of Random1 -*/ - -FLOAT Random() -{ - FLOAT X, Y; - - X = Random1 + Random9; - Y = X * X; - Y = Y * Y; - X = X * Y; - Y = X - FLOOR(X); - Random1 = Y + X * 0.000005; - return(Random1); - } - -/* SqXMinX */ - -SqXMinX (ErrKind) -int ErrKind; -{ - FLOAT XA, XB; - - XB = X * BInvrse; - XA = X - XB; - SqEr = ((SQRT(X * X) - XB) - XA) / OneUlp; - if (SqEr != Zero) { - if (SqEr < MinSqEr) MinSqEr = SqEr; - if (SqEr > MaxSqEr) MaxSqEr = SqEr; - J = J + 1.0; - BadCond(ErrKind, "\n"); - printf("sqrt( "); - Ptemp = X * X; - pnum( &Ptemp ); - printf( ") - " ); - pnum( &X ); - printf(" = " ); - Ptemp = OneUlp * SqEr; - pnum( &Ptemp ); - printf("\tinstead of correct value 0 .\n"); - } - } - -/* NewD */ - -NewD() -{ - X = Z1 * Q; - X = FLOOR(Half - X / Radix) * Radix + X; - Q = (Q - X * Z) / Radix + X * X * (D / Radix); - Z = Z - Two * X * D; - if (Z <= Zero) { - Z = - Z; - Z1 = - Z1; - } - D = Radix * D; - } - -/* SR3750 */ - -SR3750() -{ - if (! ((X - Radix < Z2 - Radix) || (X - Z2 > W - Z2))) { - I = I + 1; - X2 = SQRT(X * D); - Y2 = (X2 - Z2) - (Y - Z2); - X2 = X8 / (Y - Half); - X2 = X2 - Half * X2 * X2; - SqEr = (Y2 + Half) + (Half - X2); - if (SqEr < MinSqEr) MinSqEr = SqEr; - SqEr = Y2 - X2; - if (SqEr > MaxSqEr) MaxSqEr = SqEr; - } - } - -/* IsYeqX */ - -IsYeqX() -{ - if (Y != X) { - if (N <= 0) { - if (Z == Zero && Q <= Zero) - printf("WARNING: computing\n"); - else BadCond(Defect, "computing\n"); - printf("\t("); - pnum( &Z ); - printf( ") ^ (" ); - pnum( &Q ); - printf("\tyielded " ); - pnum( &Y ); - printf("\twhich compared unequal to correct " ); - pnum( &X ); - printf("\t\tthey differ by " ); - Ptemp = Y - X; - pnum( &Ptemp ); - } - N = N + 1; /* ... count discrepancies. */ - } - } - -/* SR3980 */ - -SR3980() -{ - do { - Q = (FLOAT) I; - Y = POW(Z, Q); - IsYeqX(); - if (++I > M) break; - X = Z * X; - } while ( X < W ); - } - -/* PrintIfNPositive */ - -PrintIfNPositive() -{ - if (N > 0) printf("Similar discrepancies have occurred %d times.\n", N); - } - -/* TstPtUf */ - -TstPtUf() -{ - N = 0; - if (Z != Zero) { - printf("Since comparison denies Z = 0, evaluating "); - printf("(Z + Z) / Z should be safe.\n"); - sigsave = sigfpe; - if (setjmp(ovfl_buf)) goto very_serious; - Q9 = (Z + Z) / Z; - printf("What the machine gets for (Z + Z) / Z is " ); - pnum( &Q9 ); - if (FABS(Q9 - Two) < Radix * U2) { - printf("This is O.K., provided Over/Underflow"); - printf(" has NOT just been signaled.\n"); - } - else { - if ((Q9 < One) || (Q9 > Two)) { -very_serious: - N = 1; - ErrCnt [Serious] = ErrCnt [Serious] + 1; - printf("This is a VERY SERIOUS DEFECT!\n"); - } - else { - N = 1; - ErrCnt [Defect] = ErrCnt [Defect] + 1; - printf("This is a DEFECT!\n"); - } - } - V9 = Z * One; - Random1 = V9; - V9 = One * Z; - Random2 = V9; - V9 = Z / One; - if ((Z == Random1) && (Z == Random2) && (Z == V9)) { - if (N > 0) Pause(); - } - else { - N = 1; - BadCond(Defect, "What prints as Z = "); - pnum( &Z ); - printf("\tcompares different from "); - if (Z != Random1) - { - printf("Z * 1 = " ); - pnum( &Random1 ); - } - if (! ((Z == Random2) - || (Random2 == Random1))) - { - printf("1 * Z == " ); - pnum( &Random2 ); - } - if (! (Z == V9)) - { - printf("Z / 1 = "); - pnum( &V9 ); - } - if (Random2 != Random1) { - ErrCnt [Defect] = ErrCnt [Defect] + 1; - BadCond(Defect, "Multiplication does not commute!\n"); - printf("\tComparison alleges that 1 * Z = "); - pnum( &Random2 ); - printf("\tdiffers from Z * 1 = "); - pnum( &Random1 ); - } - Pause(); - } - } - } - -notify(s) -char *s; -{ - printf("%s test appears to be inconsistent...\n", s); - printf(" PLEASE NOTIFY KARPINKSI!\n"); - } - -/*SPLIT msgs.c */ - -/* Instructions */ - -msglist(s) -char **s; -{ while(*s) printf("%s\n", *s++); } - -Instructions() -{ - static char *instr[] = { - "Lest this program stop prematurely, i.e. before displaying\n", - " `END OF TEST',\n", - "try to persuade the computer NOT to terminate execution when an", - "error like Over/Underflow or Division by Zero occurs, but rather", - "to persevere with a surrogate value after, perhaps, displaying some", - "warning. If persuasion avails naught, don't despair but run this", - "program anyway to see how many milestones it passes, and then", - "amend it to make further progress.\n", - "Answer questions with Y, y, N or n (unless otherwise indicated).\n", - 0}; - - msglist(instr); - } - -/* Heading */ - -Heading() -{ - static char *head[] = { - "Users are invited to help debug and augment this program so it will", - "cope with unanticipated and newly uncovered arithmetic pathologies.\n", - "Please send suggestions and interesting results to", - "\tRichard Karpinski", - "\tComputer Center U-76", - "\tUniversity of California", - "\tSan Francisco, CA 94143-0704, USA\n", - "In doing so, please include the following information:", -#ifdef Single - "\tPrecision:\tsingle;", -#else - "\tPrecision:\tdouble;", -#endif - "\tVersion:\t27 January 1986;", - "\tComputer:\n", - "\tCompiler:\n", - "\tOptimization level:\n", - "\tOther relevant compiler options:", - 0}; - - msglist(head); - } - -/* Characteristics */ - -Characteristics() -{ - static char *chars[] = { - "Running this program should reveal these characteristics:", - " Radix = 1, 2, 4, 8, 10, 16, 100, 256 ...", - " Precision = number of significant digits carried.", - " U2 = Radix/Radix^Precision = One Ulp", - "\t(OneUlpnit in the Last Place) of 1.000xxx .", - " U1 = 1/Radix^Precision = One Ulp of numbers a little less than 1.0 .", - " Adequacy of guard digits for Mult., Div. and Subt.", - " Whether arithmetic is chopped, correctly rounded, or something else", - "\tfor Mult., Div., Add/Subt. and Sqrt.", - " Whether a Sticky Bit used correctly for rounding.", - " UnderflowThreshold = an underflow threshold.", - " E0 and PseudoZero tell whether underflow is abrupt, gradual, or fuzzy.", - " V = an overflow threshold, roughly.", - " V0 tells, roughly, whether Infinity is represented.", - " Comparisions are checked for consistency with subtraction", - "\tand for contamination with pseudo-zeros.", - " Sqrt is tested. Y^X is not tested.", - " Extra-precise subexpressions are revealed but NOT YET tested.", - " Decimal-Binary conversion is NOT YET tested for accuracy.", - 0}; - - msglist(chars); - } - -History() - -{ /* History */ - /* Converted from Brian Wichmann's Pascal version to C by Thos Sumner, - with further massaging by David M. Gay. */ - - static char *hist[] = { - "The program attempts to discriminate among", - " FLAWs, like lack of a sticky bit,", - " Serious DEFECTs, like lack of a guard digit, and", - " FAILUREs, like 2+2 == 5 .", - "Failures may confound subsequent diagnoses.\n", - "The diagnostic capabilities of this program go beyond an earlier", - "program called `MACHAR', which can be found at the end of the", - "book `Software Manual for the Elementary Functions' (1980) by", - "W. J. Cody and W. Waite. Although both programs try to discover", - "the Radix, Precision and range (over/underflow thresholds)", - "of the arithmetic, this program tries to cope with a wider variety", - "of pathologies, and to say how well the arithmetic is implemented.", - "\nThe program is based upon a conventional radix representation for", - "floating-point numbers, but also allows logarithmic encoding", - "as used by certain early WANG machines.\n", - "BASIC version of this program (C) 1983 by Prof. W. M. Kahan;", - "see source comments for more history.", - 0}; - - msglist(hist); - } diff --git a/libm/ldouble/monotl.c b/libm/ldouble/monotl.c deleted file mode 100644 index 86b85eca1..000000000 --- a/libm/ldouble/monotl.c +++ /dev/null @@ -1,307 +0,0 @@ - -/* monot.c - Floating point function test vectors. - - Arguments and function values are synthesized for NPTS points in - the vicinity of each given tabulated test point. The points are - chosen to be near and on either side of the likely function algorithm - domain boundaries. Since the function programs change their methods - at these points, major coding errors or monotonicity failures might be - detected. - - August, 1998 - S. L. Moshier */ - - -#include <stdio.h> - -/* Avoid including math.h. */ -long double frexpl (long double, int *); -long double ldexpl (long double, int); - -/* Number of test points to generate on each side of tabulated point. */ -#define NPTS 100 - -/* Functions of one variable. */ -long double expl (long double); -long double logl (long double); -long double sinl (long double); -long double cosl (long double); -long double tanl (long double); -long double atanl (long double); -long double asinl (long double); -long double acosl (long double); -long double sinhl (long double); -long double coshl (long double); -long double tanhl (long double); -long double asinhl (long double); -long double acoshl (long double); -long double atanhl (long double); -long double gammal (long double); -long double fabsl (long double); -long double floorl (long double); - -struct oneargument - { - char *name; /* Name of the function. */ - long double (*func) (long double); - long double arg1; /* Function argument, assumed exact. */ - long double answer1; /* Exact, close to function value. */ - long double answer2; /* answer1 + answer2 has extended precision. */ - long double derivative; /* dy/dx evaluated at x = arg1. */ - int thresh; /* Error report threshold. 2 = 1 ULP approx. */ - }; - -/* Add this to error threshold test[i].thresh. */ -#define OKERROR 2 - -/* Unit of relative error in test[i].thresh. */ -static long double MACHEPL = 5.42101086242752217003726400434970855712890625E-20L; - -/* extern double MACHEP; */ - - -struct oneargument test1[] = -{ - {"exp", expl, 1.0L, 2.7182769775390625L, - 4.85091998273536028747e-6L, 2.71828182845904523536L, 1}, - {"exp", expl, -1.0L, 3.678741455078125e-1L, - 5.29566362982159552377e-6L, 3.678794411714423215955e-1L, 1}, - {"exp", expl, 0.5L, 1.648712158203125L, - 9.1124970031468486507878e-6L, 1.64872127070012814684865L, 1}, - {"exp", expl, -0.5L, 6.065216064453125e-1L, - 9.0532673209236037995e-6L, 6.0653065971263342360e-1L, 1}, - {"exp", expl, 2.0L, 7.3890533447265625L, - 2.75420408772723042746e-6L, 7.38905609893065022723L, 1}, - {"exp", expl, -2.0L, 1.353302001953125e-1L, - 5.08304130019189399949e-6L, 1.3533528323661269189e-1L, 1}, - {"log", logl, 1.41421356237309492343L, 3.465728759765625e-1L, - 7.1430341006605745676897e-7L, 7.0710678118654758708668e-1L, 1}, - {"log", logl, 7.07106781186547461715e-1L, -3.46588134765625e-1L, - 1.45444856522566402246e-5L, 1.41421356237309517417L, 1}, - {"sin", sinl, 7.85398163397448278999e-1L, 7.0709228515625e-1L, - 1.4496030297502751942956e-5L, 7.071067811865475460497e-1L, 1}, - {"sin", sinl, -7.85398163397448501044e-1L, -7.071075439453125e-1L, - 7.62758764840238811175e-7L, 7.07106781186547389040e-1L, 1}, - {"sin", sinl, 1.570796326794896558L, 9.999847412109375e-1L, - 1.52587890625e-5L, 6.12323399573676588613e-17L, 1}, - {"sin", sinl, -1.57079632679489678004L, -1.0L, - 1.29302922820150306903e-32L, -1.60812264967663649223e-16L, 1}, - {"sin", sinl, 4.712388980384689674L, -1.0L, - 1.68722975549458979398e-32L, -1.83697019872102976584e-16L, 1}, - {"sin", sinl, -4.71238898038468989604L, 9.999847412109375e-1L, - 1.52587890625e-5L, 3.83475850529283315008e-17L, 1}, - {"cos", cosl, 3.92699081698724139500E-1L, 9.23873901367187500000E-1L, - 5.63114409926198633370E-6L, -3.82683432365089757586E-1L, 1}, - {"cos", cosl, 7.85398163397448278999E-1L, 7.07092285156250000000E-1L, - 1.44960302975460497458E-5L, -7.07106781186547502752E-1L, 1}, - {"cos", cosl, 1.17809724509617241850E0L, 3.82675170898437500000E-1L, - 8.26146665231415693919E-6L, -9.23879532511286738554E-1L, 1}, - {"cos", cosl, 1.96349540849362069750E0L, -3.82690429687500000000E-1L, - 6.99732241029898567203E-6L, -9.23879532511286785419E-1L, 1}, - {"cos", cosl, 2.35619449019234483700E0L, -7.07107543945312500000E-1L, - 7.62758765040545859856E-7L, -7.07106781186547589348E-1L, 1}, - {"cos", cosl, 2.74889357189106897650E0L, -9.23889160156250000000E-1L, - 9.62764496328487887036E-6L, -3.82683432365089870728E-1L, 1}, - {"cos", cosl, 3.14159265358979311600E0L, -1.00000000000000000000E0L, - 7.49879891330928797323E-33L, -1.22464679914735317723E-16L, 1}, - {"tan", tanl, 7.85398163397448278999E-1L, 9.999847412109375e-1L, - 1.52587890624387676600E-5L, 1.99999999999999987754E0L, 1}, - {"tan", tanl, 1.17809724509617241850E0L, 2.41419982910156250000E0L, - 1.37332715322352112604E-5L, 6.82842712474618858345E0L, 1}, - {"tan", tanl, 1.96349540849362069750E0L, -2.41421508789062500000E0L, - 1.52551752942854759743E-6L, 6.82842712474619262118E0L, 1}, - {"tan", tanl, 2.35619449019234483700E0L, -1.00001525878906250000E0L, - 1.52587890623163029801E-5L, 2.00000000000000036739E0L, 1}, - {"tan", tanl, 2.74889357189106897650E0L, -4.14215087890625000000E-1L, - 1.52551752982565655126E-6L, 1.17157287525381000640E0L, 1}, - {"atan", atanl, 4.14213562373094923430E-1L, 3.92684936523437500000E-1L, - 1.41451752865477964149E-5L, 8.53553390593273837869E-1L, 1}, - {"atan", atanl, 1.0L, 7.85385131835937500000E-1L, - 1.30315615108096156608E-5L, 0.5L, 1}, - {"atan", atanl, 2.41421356237309492343E0L, 1.17808532714843750000E0L, - 1.19179477349460632350E-5L, 1.46446609406726250782E-1L, 1}, - {"atan", atanl, -2.41421356237309514547E0L, -1.17810058593750000000E0L, - 3.34084132752141908545E-6L, 1.46446609406726227789E-1L, 1}, - {"atan", atanl, -1.0L, -7.85400390625000000000E-1L, - 2.22722755169038433915E-6L, 0.5L, 1}, - {"atan", atanl, -4.14213562373095145475E-1L, -3.92700195312500000000E-1L, - 1.11361377576267665972E-6L, 8.53553390593273703853E-1L, 1}, - {"asin", asinl, 3.82683432365089615246E-1L, 3.92684936523437500000E-1L, - 1.41451752864854321970E-5L, 1.08239220029239389286E0L, 1}, - {"asin", asinl, 0.5L, 5.23590087890625000000E-1L, - 8.68770767387307710723E-6L, 1.15470053837925152902E0L, 1}, - {"asin", asinl, 7.07106781186547461715E-1L, 7.85385131835937500000E-1L, - 1.30315615107209645016E-5L, 1.41421356237309492343E0L, 1}, - {"asin", asinl, 9.23879532511286738483E-1L, 1.17808532714843750000E0L, - 1.19179477349183147612E-5L, 2.61312592975275276483E0L, 1}, - {"asin", asinl, -0.5L, -5.23605346679687500000E-1L, - 6.57108138862692289277E-6L, 1.15470053837925152902E0L, 1}, - {"acos", acosl, 1.95090322016128192573E-1L, 1.37443542480468750000E0L, - 1.13611408471185777914E-5L, -1.01959115820831832232E0L, 1}, - {"acos", acosl, 3.82683432365089615246E-1L, 1.17808532714843750000E0L, - 1.19179477351337991247E-5L, -1.08239220029239389286E0L, 1}, - {"acos", acosl, 0.5L, 1.04719543457031250000E0L, - 2.11662628524615421446E-6L, -1.15470053837925152902E0L, 1}, - {"acos", acosl, 7.07106781186547461715E-1L, 7.85385131835937500000E-1L, - 1.30315615108982668201E-5L, -1.41421356237309492343E0L, 1}, - {"acos", acosl, 9.23879532511286738483E-1L, 3.92684936523437500000E-1L, - 1.41451752867009165605E-5L, -2.61312592975275276483E0L, 1}, - {"acos", acosl, 9.80785280403230430579E-1L, 1.96334838867187500000E-1L, - 1.47019821746724723933E-5L, -5.12583089548300990774E0L, 1}, - {"acos", acosl, -0.5L, 2.09439086914062500000E0L, - 4.23325257049230842892E-6L, -1.15470053837925152902E0L, 1}, - {"sinh", sinhl, 1.0L, 1.17518615722656250000E0L, - 1.50364172389568823819E-5L, 1.54308063481524377848E0L, 1}, - {"sinh", sinhl, 7.09089565712818057364E2L, 4.49423283712885057274E307L, - 4.25947714184369757620E208L, 4.49423283712885057274E307L, 1}, - {"sinh", sinhl, 2.22044604925031308085E-16L, 0.00000000000000000000E0L, - 2.22044604925031308085E-16L, 1.00000000000000000000E0L, 1}, - {"cosh", coshl, 7.09089565712818057364E2L, 4.49423283712885057274E307L, - 4.25947714184369757620E208L, 4.49423283712885057274E307L, 1}, - {"cosh", coshl, 1.0L, 1.54307556152343750000E0L, - 5.07329180627847790562E-6L, 1.17520119364380145688E0L, 1}, - {"cosh", coshl, 0.5L, 1.12762451171875000000E0L, - 1.45348763078522622516E-6L, 5.21095305493747361622E-1L, 1}, - {"tanh", tanhl, 0.5L, 4.62112426757812500000E-1L, - 4.73050219725850231848E-6L, 7.86447732965927410150E-1L, 1}, - {"tanh", tanhl, 5.49306144334054780032E-1L, 4.99984741210937500000E-1L, - 1.52587890624507506378E-5L, 7.50000000000000049249E-1L, 1}, - {"tanh", tanhl, 0.625L, 5.54595947265625000000E-1L, - 3.77508375729399903910E-6L, 6.92419147969988069631E-1L, 1}, - {"asinh", asinhl, 0.5L, 4.81201171875000000000E-1L, - 1.06531846034474977589E-5L, 8.94427190999915878564E-1L, 1}, - {"asinh", asinhl, 1.0L, 8.81362915039062500000E-1L, - 1.06719804805252326093E-5L, 7.07106781186547524401E-1L, 1}, - {"asinh", asinhl, 2.0L, 1.44363403320312500000E0L, - 1.44197568534249327674E-6L, 4.47213595499957939282E-1L, 1}, - {"acosh", acoshl, 2.0L, 1.31695556640625000000E0L, - 2.33051856670862504635E-6L, 5.77350269189625764509E-1L, 1}, - {"acosh", acoshl, 1.5L, 9.62417602539062500000E-1L, - 6.04758014439499551783E-6L, 8.94427190999915878564E-1L, 1}, - {"acosh", acoshl, 1.03125L, 2.49343872070312500000E-1L, - 9.62177257298785143908E-6L, 3.96911150685467059809E0L, 1}, - {"atanh", atanhl, 0.5L, 5.49301147460937500000E-1L, - 4.99687311734569762262E-6L, 1.33333333333333333333E0L, 1}, -#if 0 - {"gamma", gammal, 1.0L, 1.0L, - 0.0L, -5.772156649015328606e-1L, 1}, - {"gamma", gammal, 2.0L, 1.0L, - 0.0L, 4.2278433509846713939e-1L, 1}, - {"gamma", gammal, 3.0L, 2.0L, - 0.0L, 1.845568670196934279L, 1}, - {"gamma", gammal, 4.0L, 6.0L, - 0.0L, 7.536706010590802836L, 1}, -#endif - {"null", NULL, 0.0L, 0.0L, 0.0L, 1}, -}; - -/* These take care of extra-precise floating point register problems. */ -volatile long double volat1; -volatile long double volat2; - - -/* Return the next nearest floating point value to X - in the direction of UPDOWN (+1 or -1). - (Fails if X is denormalized.) */ - -long double -nextval (x, updown) - long double x; - int updown; -{ - long double m; - int i; - - volat1 = x; - m = 0.25L * MACHEPL * volat1 * updown; - volat2 = volat1 + m; - if (volat2 != volat1) - printf ("successor failed\n"); - - for (i = 2; i < 10; i++) - { - volat2 = volat1 + i * m; - if (volat1 != volat2) - return volat2; - } - - printf ("nextval failed\n"); - return volat1; -} - - - - -int -main () -{ - long double (*fun1) (long double); - int i, j, errs, tests; - long double x, x0, y, dy, err; - - errs = 0; - tests = 0; - i = 0; - - for (;;) - { - fun1 = test1[i].func; - if (fun1 == NULL) - break; - volat1 = test1[i].arg1; - x0 = volat1; - x = volat1; - for (j = 0; j <= NPTS; j++) - { - volat1 = x - x0; - dy = volat1 * test1[i].derivative; - dy = test1[i].answer2 + dy; - volat1 = test1[i].answer1 + dy; - volat2 = (*(fun1)) (x); - if (volat2 != volat1) - { - /* Report difference between program result - and extended precision function value. */ - err = volat2 - test1[i].answer1; - err = err - dy; - err = err / volat1; - if (fabsl (err) > ((OKERROR + test1[i].thresh) * MACHEPL)) - { - printf ("%d %s(%.19Le) = %.19Le, rel err = %.3Le\n", - j, test1[i].name, x, volat2, err); - errs += 1; - } - } - x = nextval (x, 1); - tests += 1; - } - - x = x0; - x = nextval (x, -1); - for (j = 1; j < NPTS; j++) - { - volat1 = x - x0; - dy = volat1 * test1[i].derivative; - dy = test1[i].answer2 + dy; - volat1 = test1[i].answer1 + dy; - volat2 = (*(fun1)) (x); - if (volat2 != volat1) - { - err = volat2 - test1[i].answer1; - err = err - dy; - err = err / volat1; - if (fabsl (err) > ((OKERROR + test1[i].thresh) * MACHEPL)) - { - printf ("%d %s(%.19Le) = %.19Le, rel err = %.3Le\n", - j, test1[i].name, x, volat2, err); - errs += 1; - } - } - x = nextval (x, -1); - tests += 1; - } - i += 1; - } - printf ("%d errors in %d tests\n", errs, tests); -} diff --git a/libm/ldouble/mtherr.c b/libm/ldouble/mtherr.c deleted file mode 100644 index 17d0485d2..000000000 --- a/libm/ldouble/mtherr.c +++ /dev/null @@ -1,102 +0,0 @@ -/* mtherr.c - * - * Library common error handling routine - * - * - * - * SYNOPSIS: - * - * char *fctnam; - * int code; - * int mtherr(); - * - * mtherr( fctnam, code ); - * - * - * - * DESCRIPTION: - * - * This routine may be called to report one of the following - * error conditions (in the include file mconf.h). - * - * Mnemonic Value Significance - * - * DOMAIN 1 argument domain error - * SING 2 function singularity - * OVERFLOW 3 overflow range error - * UNDERFLOW 4 underflow range error - * TLOSS 5 total loss of precision - * PLOSS 6 partial loss of precision - * EDOM 33 Unix domain error code - * ERANGE 34 Unix range error code - * - * The default version of the file prints the function name, - * passed to it by the pointer fctnam, followed by the - * error condition. The display is directed to the standard - * output device. The routine then returns to the calling - * program. Users may wish to modify the program to abort by - * calling exit() under severe error conditions such as domain - * errors. - * - * Since all error conditions pass control to this function, - * the display may be easily changed, eliminated, or directed - * to an error logging device. - * - * SEE ALSO: - * - * mconf.h - * - */ - -/* -Cephes Math Library Release 2.0: April, 1987 -Copyright 1984, 1987 by Stephen L. Moshier -Direct inquiries to 30 Frost Street, Cambridge, MA 02140 -*/ - -#include <stdio.h> -#include <math.h> - -int merror = 0; - -/* Notice: the order of appearance of the following - * messages is bound to the error codes defined - * in mconf.h. - */ -static char *ermsg[7] = { -"unknown", /* error code 0 */ -"domain", /* error code 1 */ -"singularity", /* et seq. */ -"overflow", -"underflow", -"total loss of precision", -"partial loss of precision" -}; - - -int mtherr( name, code ) -char *name; -int code; -{ - -/* Display string passed by calling program, - * which is supposed to be the name of the - * function in which the error occurred: - */ -printf( "\n%s ", name ); - -/* Set global error message word */ -merror = code; - -/* Display error message defined - * by the code argument. - */ -if( (code <= 0) || (code >= 7) ) - code = 0; -printf( "%s error\n", ermsg[code] ); - -/* Return to calling - * program - */ -return( 0 ); -} diff --git a/libm/ldouble/mtstl.c b/libm/ldouble/mtstl.c deleted file mode 100644 index 0cd6eed16..000000000 --- a/libm/ldouble/mtstl.c +++ /dev/null @@ -1,521 +0,0 @@ -/* mtst.c - Consistency tests for math functions. - - With NTRIALS=10000, the following are typical results for - an alleged IEEE long double precision arithmetic: - -Consistency test of math functions. -Max and rms errors for 10000 random arguments. -A = absolute error criterion (but relative if >1): -Otherwise, estimate is of relative error -x = cbrt( cube(x) ): max = 7.65E-20 rms = 4.39E-21 -x = atan( tan(x) ): max = 2.01E-19 rms = 3.96E-20 -x = sin( asin(x) ): max = 2.15E-19 rms = 3.00E-20 -x = sqrt( square(x) ): max = 0.00E+00 rms = 0.00E+00 -x = log( exp(x) ): max = 5.42E-20 A rms = 1.87E-21 A -x = log2( exp2(x) ): max = 1.08E-19 A rms = 3.37E-21 A -x = log10( exp10(x) ): max = 2.71E-20 A rms = 6.76E-22 A -x = acosh( cosh(x) ): max = 3.13E-18 A rms = 3.21E-20 A -x = pow( pow(x,a),1/a ): max = 1.25E-17 rms = 1.70E-19 -x = tanh( atanh(x) ): max = 1.08E-19 rms = 1.16E-20 -x = asinh( sinh(x) ): max = 1.03E-19 rms = 2.94E-21 -x = cos( acos(x) ): max = 1.63E-19 A rms = 4.37E-20 A -lgam(x) = log(gamma(x)): max = 2.31E-19 A rms = 5.93E-20 A -x = ndtri( ndtr(x) ): max = 5.07E-17 rms = 7.03E-19 -Legendre ellpk, ellpe: max = 7.59E-19 A rms = 1.72E-19 A -Absolute error and only 2000 trials: -Wronksian of Yn, Jn: max = 6.40E-18 A rms = 1.49E-19 A -Relative error and only 100 trials: -x = stdtri(stdtr(k,x) ): max = 6.73E-19 rms = 2.46E-19 -*/ - -/* -Cephes Math Library Release 2.3: November, 1995 -Copyright 1984, 1987, 1988, 1995 by Stephen L. Moshier -*/ - -#include <math.h> - -/* C9X spells lgam lgamma. */ -#define GLIBC2 0 - -#define NTRIALS 10000 -#define WTRIALS (NTRIALS/5) -#define STRTST 0 - -/* Note, fabsl may be an intrinsic function. */ -#ifdef ANSIPROT -extern long double fabsl ( long double ); -extern long double sqrtl ( long double ); -extern long double cbrtl ( long double ); -extern long double expl ( long double ); -extern long double logl ( long double ); -extern long double tanl ( long double ); -extern long double atanl ( long double ); -extern long double sinl ( long double ); -extern long double asinl ( long double ); -extern long double cosl ( long double ); -extern long double acosl ( long double ); -extern long double powl ( long double, long double ); -extern long double tanhl ( long double ); -extern long double atanhl ( long double ); -extern long double sinhl ( long double ); -extern long double asinhl ( long double ); -extern long double coshl ( long double ); -extern long double acoshl ( long double ); -extern long double exp2l ( long double ); -extern long double log2l ( long double ); -extern long double exp10l ( long double ); -extern long double log10l ( long double ); -extern long double gammal ( long double ); -extern long double lgaml ( long double ); -extern long double jnl ( int, long double ); -extern long double ynl ( int, long double ); -extern long double ndtrl ( long double ); -extern long double ndtril ( long double ); -extern long double stdtrl ( int, long double ); -extern long double stdtril ( int, long double ); -extern long double ellpel ( long double ); -extern long double ellpkl ( long double ); -extern void exit (int); -#else -long double fabsl(), sqrtl(); -long double cbrtl(), expl(), logl(), tanl(), atanl(); -long double sinl(), asinl(), cosl(), acosl(), powl(); -long double tanhl(), atanhl(), sinhl(), asinhl(), coshl(), acoshl(); -long double exp2l(), log2l(), exp10l(), log10l(); -long double gammal(), lgaml(), jnl(), ynl(), ndtrl(), ndtril(); -long double stdtrl(), stdtril(), ellpel(), ellpkl(); -void exit (); -#endif -extern int merror; -#if GLIBC2 -long double lgammal(long double); -#endif -/* -NYI: -double iv(), kn(); -*/ - -/* Provide inverses for square root and cube root: */ -long double squarel(x) -long double x; -{ -return( x * x ); -} - -long double cubel(x) -long double x; -{ -return( x * x * x ); -} - -/* lookup table for each function */ -struct fundef - { - char *nam1; /* the function */ - long double (*name )(); - char *nam2; /* its inverse */ - long double (*inv )(); - int nargs; /* number of function arguments */ - int tstyp; /* type code of the function */ - long ctrl; /* relative error flag */ - long double arg1w; /* width of domain for 1st arg */ - long double arg1l; /* lower bound domain 1st arg */ - long arg1f; /* flags, e.g. integer arg */ - long double arg2w; /* same info for args 2, 3, 4 */ - long double arg2l; - long arg2f; -/* - double arg3w; - double arg3l; - long arg3f; - double arg4w; - double arg4l; - long arg4f; -*/ - }; - - -/* fundef.ctrl bits: */ -#define RELERR 1 -#define EXPSCAL 4 - -/* fundef.tstyp test types: */ -#define POWER 1 -#define ELLIP 2 -#define GAMMA 3 -#define WRONK1 4 -#define WRONK2 5 -#define WRONK3 6 -#define STDTR 7 - -/* fundef.argNf argument flag bits: */ -#define INT 2 - -extern long double MINLOGL; -extern long double MAXLOGL; -extern long double PIL; -extern long double PIO2L; -/* -define MINLOG -170.0 -define MAXLOG +170.0 -define PI 3.14159265358979323846 -define PIO2 1.570796326794896619 -*/ - -#define NTESTS 17 -struct fundef defs[NTESTS] = { -{" cube", cubel, " cbrt", cbrtl, 1, 0, 1, 2000.0L, -1000.0L, 0, -0.0, 0.0, 0}, -{" tan", tanl, " atan", atanl, 1, 0, 1, 0.0L, 0.0L, 0, -0.0, 0.0, 0}, -{" asin", asinl, " sin", sinl, 1, 0, 1, 2.0L, -1.0L, 0, -0.0, 0.0, 0}, -{"square", squarel, " sqrt", sqrtl, 1, 0, 1, 170.0L, -85.0L, EXPSCAL, -0.0, 0.0, 0}, -{" exp", expl, " log", logl, 1, 0, 0, 340.0L, -170.0L, 0, -0.0, 0.0, 0}, -{" exp2", exp2l, " log2", log2l, 1, 0, 0, 340.0L, -170.0L, 0, -0.0, 0.0, 0}, -{" exp10", exp10l, " log10", log10l, 1, 0, 0, 340.0L, -170.0L, 0, -0.0, 0.0, 0}, -{" cosh", coshl, " acosh", acoshl, 1, 0, 0, 340.0L, 0.0L, 0, -0.0, 0.0, 0}, -{"pow", powl, "pow", powl, 2, POWER, 1, 25.0L, 0.0L, 0, -50.0, -25.0, 0}, -{" atanh", atanhl, " tanh", tanhl, 1, 0, 1, 2.0L, -1.0L, 0, -0.0, 0.0, 0}, -{" sinh", sinhl, " asinh", asinhl, 1, 0, 1, 340.0L, 0.0L, 0, -0.0, 0.0, 0}, -{" acos", acosl, " cos", cosl, 1, 0, 0, 2.0L, -1.0L, 0, -0.0, 0.0, 0}, -#if GLIBC2 - /* -{ "gamma", gammal, "lgammal", lgammal, 1, GAMMA, 0, 34.0, 0.0, 0, -0.0, 0.0, 0}, -*/ -#else -{ "gamma", gammal, "lgam", lgaml, 1, GAMMA, 0, 34.0, 0.0, 0, -0.0, 0.0, 0}, -{ " ndtr", ndtrl, " ndtri", ndtril, 1, 0, 1, 10.0L, -10.0L, 0, -0.0, 0.0, 0}, -{" ellpe", ellpel, " ellpk", ellpkl, 1, ELLIP, 0, 1.0L, 0.0L, 0, -0.0, 0.0, 0}, -{ "stdtr", stdtrl, "stdtri", stdtril, 2, STDTR, 1, 4.0L, -2.0L, 0, -30.0, 1.0, INT}, -{ " Jn", jnl, " Yn", ynl, 2, WRONK1, 0, 30.0, 0.1, 0, -40.0, -20.0, INT}, -#endif -}; - -static char *headrs[] = { -"x = %s( %s(x) ): ", -"x = %s( %s(x,a),1/a ): ", /* power */ -"Legendre %s, %s: ", /* ellip */ -"%s(x) = log(%s(x)): ", /* gamma */ -"Wronksian of %s, %s: ", /* wronk1 */ -"Wronksian of %s, %s: ", /* wronk2 */ -"Wronksian of %s, %s: ", /* wronk3 */ -"x = %s(%s(k,x) ): ", /* stdtr */ -}; - -static long double y1 = 0.0; -static long double y2 = 0.0; -static long double y3 = 0.0; -static long double y4 = 0.0; -static long double a = 0.0; -static long double x = 0.0; -static long double y = 0.0; -static long double z = 0.0; -static long double e = 0.0; -static long double max = 0.0; -static long double rmsa = 0.0; -static long double rms = 0.0; -static long double ave = 0.0; -static double da, db, dc, dd; - -int ldrand(); -int printf(); - -int -main() -{ -long double (*fun )(); -long double (*ifun )(); -struct fundef *d; -int i, k, itst; -int m, ntr; - -ntr = NTRIALS; -printf( "Consistency test of math functions.\n" ); -printf( "Max and rms errors for %d random arguments.\n", - ntr ); -printf( "A = absolute error criterion (but relative if >1):\n" ); -printf( "Otherwise, estimate is of relative error\n" ); - -/* Initialize machine dependent parameters to test near the - * largest an smallest possible arguments. To compare different - * machines, use the same test intervals for all systems. - */ -defs[1].arg1w = PIL; -defs[1].arg1l = -PIL/2.0; -/* -defs[3].arg1w = MAXLOGL; -defs[3].arg1l = -MAXLOGL/2.0; -defs[4].arg1w = 2.0*MAXLOGL; -defs[4].arg1l = -MAXLOGL; -defs[6].arg1w = 2.0*MAXLOGL; -defs[6].arg1l = -MAXLOGL; -defs[7].arg1w = MAXLOGL; -defs[7].arg1l = 0.0; -*/ - -/* Outer loop, on the test number: */ - -for( itst=STRTST; itst<NTESTS; itst++ ) -{ -d = &defs[itst]; -m = 0; -max = 0.0L; -rmsa = 0.0L; -ave = 0.0L; -fun = d->name; -ifun = d->inv; - -/* Smaller number of trials for Wronksians - * (put them at end of list) - */ -if( d->tstyp == WRONK1 ) - { - ntr = WTRIALS; - printf( "Absolute error and only %d trials:\n", ntr ); - } -else if( d->tstyp == STDTR ) - { - ntr = NTRIALS/100; - printf( "Relative error and only %d trials:\n", ntr ); - } -/* -y1 = d->arg1l; -y2 = d->arg1w; -da = y1; -db = y2; -printf( "arg1l = %.4e, arg1w = %.4e\n", da, db ); -*/ -printf( headrs[d->tstyp], d->nam2, d->nam1 ); - -for( i=0; i<ntr; i++ ) -{ -m++; -k = 0; -/* make random number(s) in desired range(s) */ -switch( d->nargs ) -{ - -default: -goto illegn; - -case 2: -ldrand( &a ); -a = d->arg2w * ( a - 1.0L ) + d->arg2l; -if( d->arg2f & EXPSCAL ) - { - a = expl(a); - ldrand( &y2 ); - a -= 1.0e-13L * a * (y2 - 1.0L); - } -if( d->arg2f & INT ) - { - k = a + 0.25L; - a = k; - } - -case 1: -ldrand( &x ); -y1 = d->arg1l; -y2 = d->arg1w; -x = y2 * ( x - 1.0L ) + y1; -if( x < y1 ) - x = y1; -y1 += y2; -if( x > y1 ) - x = y1; -if( d->arg1f & EXPSCAL ) - { - x = expl(x); - ldrand( &y2 ); - x += 1.0e-13L * x * (y2 - 1.0L); - } -} - -/* compute function under test */ -switch( d->nargs ) - { - case 1: - switch( d->tstyp ) - { - case ELLIP: - y1 = ( *(fun) )(x); - y2 = ( *(fun) )(1.0L-x); - y3 = ( *(ifun) )(x); - y4 = ( *(ifun) )(1.0L-x); - break; -#if 1 - case GAMMA: - y = lgaml(x); - x = logl( gammal(x) ); - break; -#endif - default: - z = ( *(fun) )(x); - y = ( *(ifun) )(z); - } -/* -if( merror ) - { - printf( "error: x = %.15e, z = %.15e, y = %.15e\n", - (double )x, (double )z, (double )y ); - } -*/ - break; - - case 2: - if( d->arg2f & INT ) - { - switch( d->tstyp ) - { - case WRONK1: - y1 = (*fun)( k, x ); /* jn */ - y2 = (*fun)( k+1, x ); - y3 = (*ifun)( k, x ); /* yn */ - y4 = (*ifun)( k+1, x ); - break; - - case WRONK2: - y1 = (*fun)( a, x ); /* iv */ - y2 = (*fun)( a+1.0L, x ); - y3 = (*ifun)( k, x ); /* kn */ - y4 = (*ifun)( k+1, x ); - break; - - default: - z = (*fun)( k, x ); - y = (*ifun)( k, z ); - } - } - else - { - if( d->tstyp == POWER ) - { - z = (*fun)( x, a ); - y = (*ifun)( z, 1.0L/a ); - } - else - { - z = (*fun)( a, x ); - y = (*ifun)( a, z ); - } - } - break; - - - default: -illegn: - printf( "Illegal nargs= %d", d->nargs ); - exit(1); - } - -switch( d->tstyp ) - { - case WRONK1: - /* Jn, Yn */ -/* e = (y2*y3 - y1*y4) - 2.0L/(PIL*x);*/ - e = x*(y2*y3 - y1*y4) - 2.0L/PIL; - break; - - case WRONK2: -/* In, Kn */ -/* e = (y2*y3 + y1*y4) - 1.0L/x; */ - e = x*(y2*y3 + y1*y4) - 1.0L; - break; - - case ELLIP: - e = (y1-y3)*y4 + y3*y2 - PIO2L; - break; - - default: - e = y - x; - break; - } - -if( d->ctrl & RELERR ) - { - if( x != 0.0L ) - e /= x; - else - printf( "warning, x == 0\n" ); - } -else - { - if( fabsl(x) > 1.0L ) - e /= x; - } - -ave += e; -/* absolute value of error */ -if( e < 0 ) - e = -e; - -/* peak detect the error */ -if( e > max ) - { - max = e; - - if( e > 1.0e-10L ) - { -da = x; -db = z; -dc = y; -dd = max; - printf("x %.6E z %.6E y %.6E max %.4E\n", - da, db, dc, dd ); -/* - if( d->tstyp >= WRONK1 ) - { - printf( "y1 %.4E y2 %.4E y3 %.4E y4 %.4E k %d x %.4E\n", - (double )y1, (double )y2, (double )y3, - (double )y4, k, (double )x ); - } -*/ - } - -/* - printf("%.8E %.8E %.4E %6ld \n", x, y, max, n); - printf("%d %.8E %.8E %.4E %6ld \n", k, x, y, max, n); - printf("%.6E %.6E %.6E %.4E %6ld \n", a, x, y, max, n); - printf("%.6E %.6E %.6E %.6E %.4E %6ld \n", a, b, x, y, max, n); - printf("%.4E %.4E %.4E %.4E %.4E %.4E %6ld \n", - a, b, c, x, y, max, n); -*/ - } - -/* accumulate rms error */ -e *= 1.0e16L; /* adjust range */ -rmsa += e * e; /* accumulate the square of the error */ -} - -/* report after NTRIALS trials */ -rms = 1.0e-16L * sqrtl( rmsa/m ); -da = max; -db = rms; -if(d->ctrl & RELERR) - printf(" max = %.2E rms = %.2E\n", da, db ); -else - printf(" max = %.2E A rms = %.2E A\n", da, db ); -} /* loop on itst */ - -exit (0); -return 0; -} - diff --git a/libm/ldouble/nantst.c b/libm/ldouble/nantst.c deleted file mode 100644 index 855a43b5a..000000000 --- a/libm/ldouble/nantst.c +++ /dev/null @@ -1,61 +0,0 @@ -#include <stdio.h> -long double inf = 1.0f/0.0f; -long double nnn = 1.0f/0.0f - 1.0f/0.0f; -long double fin = 1.0f; -long double neg = -1.0f; -long double nn2; - -int isnanl(), isfinitel(), signbitl(); -void abort (void); -void exit (int); - -void pvalue (char *str, long double x) -{ -union - { - long double f; - unsigned int i[3]; - }u; -int k; - -printf("%s ", str); -u.f = x; -for (k = 0; k < 3; k++) - printf("%08x ", u.i[k]); -printf ("\n"); -} - - -int -main() -{ - -if (!isnanl(nnn)) - abort(); -pvalue("nnn", nnn); -pvalue("inf", inf); -nn2 = inf - inf; -pvalue("inf - inf", nn2); -if (isnanl(fin)) - abort(); -if (isnanl(inf)) - abort(); -if (!isfinitel(fin)) - abort(); -if (isfinitel(nnn)) - abort(); -if (isfinitel(inf)) - abort(); -if (!signbitl(neg)) - abort(); -if (signbitl(fin)) - abort(); -if (signbitl(inf)) - abort(); -/* -if (signbitf(nnn)) - abort(); - */ -exit (0); -return 0; -} diff --git a/libm/ldouble/nbdtrl.c b/libm/ldouble/nbdtrl.c deleted file mode 100644 index 91593f544..000000000 --- a/libm/ldouble/nbdtrl.c +++ /dev/null @@ -1,197 +0,0 @@ -/* nbdtrl.c - * - * Negative binomial distribution - * - * - * - * SYNOPSIS: - * - * int k, n; - * long double p, y, nbdtrl(); - * - * y = nbdtrl( k, n, p ); - * - * - * - * DESCRIPTION: - * - * Returns the sum of the terms 0 through k of the negative - * binomial distribution: - * - * k - * -- ( n+j-1 ) n j - * > ( ) p (1-p) - * -- ( j ) - * j=0 - * - * In a sequence of Bernoulli trials, this is the probability - * that k or fewer failures precede the nth success. - * - * The terms are not computed individually; instead the incomplete - * beta integral is employed, according to the formula - * - * y = nbdtr( k, n, p ) = incbet( n, k+1, p ). - * - * The arguments must be positive, with p ranging from 0 to 1. - * - * - * - * ACCURACY: - * - * Tested at random points (k,n,p) with k and n between 1 and 10,000 - * and p between 0 and 1. - * - * arithmetic domain # trials peak rms - * Absolute error: - * IEEE 0,10000 10000 9.8e-15 2.1e-16 - * - */ - /* nbdtrcl.c - * - * Complemented negative binomial distribution - * - * - * - * SYNOPSIS: - * - * int k, n; - * long double p, y, nbdtrcl(); - * - * y = nbdtrcl( k, n, p ); - * - * - * - * DESCRIPTION: - * - * Returns the sum of the terms k+1 to infinity of the negative - * binomial distribution: - * - * inf - * -- ( n+j-1 ) n j - * > ( ) p (1-p) - * -- ( j ) - * j=k+1 - * - * The terms are not computed individually; instead the incomplete - * beta integral is employed, according to the formula - * - * y = nbdtrc( k, n, p ) = incbet( k+1, n, 1-p ). - * - * The arguments must be positive, with p ranging from 0 to 1. - * - * - * - * ACCURACY: - * - * See incbetl.c. - * - */ - /* nbdtril - * - * Functional inverse of negative binomial distribution - * - * - * - * SYNOPSIS: - * - * int k, n; - * long double p, y, nbdtril(); - * - * p = nbdtril( k, n, y ); - * - * - * - * DESCRIPTION: - * - * Finds the argument p such that nbdtr(k,n,p) is equal to y. - * - * ACCURACY: - * - * Tested at random points (a,b,y), with y between 0 and 1. - * - * a,b Relative error: - * arithmetic domain # trials peak rms - * IEEE 0,100 - * See also incbil.c. - */ - -/* -Cephes Math Library Release 2.3: January,1995 -Copyright 1984, 1995 by Stephen L. Moshier -*/ - -#include <math.h> -#ifdef ANSIPROT -extern long double incbetl ( long double, long double, long double ); -extern long double powl ( long double, long double ); -extern long double incbil ( long double, long double, long double ); -#else -long double incbetl(), powl(), incbil(); -#endif - -long double nbdtrcl( k, n, p ) -int k, n; -long double p; -{ -long double dk, dn; - -if( (p < 0.0L) || (p > 1.0L) ) - goto domerr; -if( k < 0 ) - { -domerr: - mtherr( "nbdtrl", DOMAIN ); - return( 0.0L ); - } -dn = n; -if( k == 0 ) - return( 1.0L - powl( p, dn ) ); - -dk = k+1; -return( incbetl( dk, dn, 1.0L - p ) ); -} - - - -long double nbdtrl( k, n, p ) -int k, n; -long double p; -{ -long double dk, dn; - -if( (p < 0.0L) || (p > 1.0L) ) - goto domerr; -if( k < 0 ) - { -domerr: - mtherr( "nbdtrl", DOMAIN ); - return( 0.0L ); - } -dn = n; -if( k == 0 ) - return( powl( p, dn ) ); - -dk = k+1; -return( incbetl( dn, dk, p ) ); -} - - -long double nbdtril( k, n, p ) -int k, n; -long double p; -{ -long double dk, dn, w; - -if( (p < 0.0L) || (p > 1.0L) ) - goto domerr; -if( k < 0 ) - { -domerr: - mtherr( "nbdtrl", DOMAIN ); - return( 0.0L ); - } -dk = k+1; -dn = n; -w = incbil( dn, dk, p ); -return( w ); -} diff --git a/libm/ldouble/ndtril.c b/libm/ldouble/ndtril.c deleted file mode 100644 index b1a15cedf..000000000 --- a/libm/ldouble/ndtril.c +++ /dev/null @@ -1,416 +0,0 @@ -/* ndtril.c - * - * Inverse of Normal distribution function - * - * - * - * SYNOPSIS: - * - * long double x, y, ndtril(); - * - * x = ndtril( y ); - * - * - * - * DESCRIPTION: - * - * Returns the argument, x, for which the area under the - * Gaussian probability density function (integrated from - * minus infinity to x) is equal to y. - * - * - * For small arguments 0 < y < exp(-2), the program computes - * z = sqrt( -2 log(y) ); then the approximation is - * x = z - log(z)/z - (1/z) P(1/z) / Q(1/z) . - * For larger arguments, x/sqrt(2 pi) = w + w^3 R(w^2)/S(w^2)) , - * where w = y - 0.5 . - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * Arguments uniformly distributed: - * IEEE 0, 1 5000 7.8e-19 9.9e-20 - * Arguments exponentially distributed: - * IEEE exp(-11355),-1 30000 1.7e-19 4.3e-20 - * - * - * ERROR MESSAGES: - * - * message condition value returned - * ndtril domain x <= 0 -MAXNUML - * ndtril domain x >= 1 MAXNUML - * - */ - - -/* -Cephes Math Library Release 2.3: January, 1995 -Copyright 1984, 1995 by Stephen L. Moshier -*/ - -#include <math.h> -extern long double MAXNUML; - -/* ndtri(y+0.5)/sqrt(2 pi) = y + y^3 R(y^2) - 0 <= y <= 3/8 - Peak relative error 6.8e-21. */ -#if UNK -/* sqrt(2pi) */ -static long double s2pi = 2.506628274631000502416E0L; -static long double P0[8] = { - 8.779679420055069160496E-3L, --7.649544967784380691785E-1L, - 2.971493676711545292135E0L, --4.144980036933753828858E0L, - 2.765359913000830285937E0L, --9.570456817794268907847E-1L, - 1.659219375097958322098E-1L, --1.140013969885358273307E-2L, -}; -static long double Q0[7] = { -/* 1.000000000000000000000E0L, */ --5.303846964603721860329E0L, - 9.908875375256718220854E0L, --9.031318655459381388888E0L, - 4.496118508523213950686E0L, --1.250016921424819972516E0L, - 1.823840725000038842075E-1L, --1.088633151006419263153E-2L, -}; -#endif -#if IBMPC -static unsigned short s2p[] = { -0x2cb3,0xb138,0x98ff,0xa06c,0x4000, XPD -}; -#define s2pi *(long double *)s2p -static short P0[] = { -0xb006,0x9fc1,0xa4fe,0x8fd8,0x3ff8, XPD -0x6f8a,0x976e,0x0ed2,0xc3d4,0xbffe, XPD -0xf1f1,0x6fcc,0xf3d0,0xbe2c,0x4000, XPD -0xccfb,0xa681,0xad2c,0x84a3,0xc001, XPD -0x9a0d,0x0082,0xa825,0xb0fb,0x4000, XPD -0x13d1,0x054a,0xf220,0xf500,0xbffe, XPD -0xcee9,0x2c92,0x70bd,0xa9e7,0x3ffc, XPD -0x5fee,0x4a42,0xa6cb,0xbac7,0xbff8, XPD -}; -static short Q0[] = { -/* 0x0000,0x0000,0x0000,0x8000,0x3fff, XPD */ -0x841e,0xfec7,0x1d44,0xa9b9,0xc001, XPD -0x97e6,0xcde0,0xc0e7,0x9e8a,0x4002, XPD -0x66f9,0x8f3e,0x47fd,0x9080,0xc002, XPD -0x212f,0x2185,0x33ec,0x8fe0,0x4001, XPD -0x8e73,0x7bac,0x8df2,0xa000,0xbfff, XPD -0xc143,0xcb94,0xe3ea,0xbac2,0x3ffc, XPD -0x25d9,0xc8f3,0x9573,0xb25c,0xbff8, XPD -}; -#endif -#if MIEEE -static unsigned long s2p[] = { -0x40000000,0xa06c98ff,0xb1382cb3, -}; -#define s2pi *(long double *)s2p -static long P0[24] = { -0x3ff80000,0x8fd8a4fe,0x9fc1b006, -0xbffe0000,0xc3d40ed2,0x976e6f8a, -0x40000000,0xbe2cf3d0,0x6fccf1f1, -0xc0010000,0x84a3ad2c,0xa681ccfb, -0x40000000,0xb0fba825,0x00829a0d, -0xbffe0000,0xf500f220,0x054a13d1, -0x3ffc0000,0xa9e770bd,0x2c92cee9, -0xbff80000,0xbac7a6cb,0x4a425fee, -}; -static long Q0[21] = { -/* 0x3fff0000,0x80000000,0x00000000, */ -0xc0010000,0xa9b91d44,0xfec7841e, -0x40020000,0x9e8ac0e7,0xcde097e6, -0xc0020000,0x908047fd,0x8f3e66f9, -0x40010000,0x8fe033ec,0x2185212f, -0xbfff0000,0xa0008df2,0x7bac8e73, -0x3ffc0000,0xbac2e3ea,0xcb94c143, -0xbff80000,0xb25c9573,0xc8f325d9, -}; -#endif - -/* Approximation for interval z = sqrt(-2 log y ) between 2 and 8 - */ -/* ndtri(p) = z - ln(z)/z - 1/z P1(1/z)/Q1(1/z) - z = sqrt(-2 ln(p)) - 2 <= z <= 8, i.e., y between exp(-2) = .135 and exp(-32) = 1.27e-14. - Peak relative error 5.3e-21 */ -#if UNK -static long double P1[10] = { - 4.302849750435552180717E0L, - 4.360209451837096682600E1L, - 9.454613328844768318162E1L, - 9.336735653151873871756E1L, - 5.305046472191852391737E1L, - 1.775851836288460008093E1L, - 3.640308340137013109859E0L, - 3.691354900171224122390E-1L, - 1.403530274998072987187E-2L, - 1.377145111380960566197E-4L, -}; -static long double Q1[9] = { -/* 1.000000000000000000000E0L, */ - 2.001425109170530136741E1L, - 7.079893963891488254284E1L, - 8.033277265194672063478E1L, - 5.034715121553662712917E1L, - 1.779820137342627204153E1L, - 3.845554944954699547539E0L, - 3.993627390181238962857E-1L, - 1.526870689522191191380E-2L, - 1.498700676286675466900E-4L, -}; -#endif -#if IBMPC -static short P1[] = { -0x6105,0xb71e,0xf1f5,0x89b0,0x4001, XPD -0x461d,0x2604,0x8b77,0xae68,0x4004, XPD -0x8b33,0x4a47,0x9ec8,0xbd17,0x4005, XPD -0xa0b2,0xc1b0,0x1627,0xbabc,0x4005, XPD -0x9901,0x28f7,0xad06,0xd433,0x4004, XPD -0xddcb,0x5009,0x7213,0x8e11,0x4003, XPD -0x2432,0x0fa6,0xcfd5,0xe8fa,0x4000, XPD -0x3e24,0xd53c,0x53b2,0xbcff,0x3ffd, XPD -0x4058,0x3d75,0x5393,0xe5f4,0x3ff8, XPD -0x1789,0xf50a,0x7524,0x9067,0x3ff2, XPD -}; -static short Q1[] = { -/* 0x0000,0x0000,0x0000,0x8000,0x3fff, XPD */ -0xd901,0x2673,0x2fad,0xa01d,0x4003, XPD -0x24f5,0xc93c,0x0e9d,0x8d99,0x4005, XPD -0x8cda,0x523a,0x612d,0xa0aa,0x4005, XPD -0x602c,0xb5fc,0x7b9b,0xc963,0x4004, XPD -0xac72,0xd3e7,0xb766,0x8e62,0x4003, XPD -0x048e,0xe34c,0x927c,0xf61d,0x4000, XPD -0x6d88,0xa5cc,0x45de,0xcc79,0x3ffd, XPD -0xe6d1,0x199a,0x9931,0xfa29,0x3ff8, XPD -0x4c7d,0x3675,0x70a0,0x9d26,0x3ff2, XPD -}; -#endif -#if MIEEE -static long P1[30] = { -0x40010000,0x89b0f1f5,0xb71e6105, -0x40040000,0xae688b77,0x2604461d, -0x40050000,0xbd179ec8,0x4a478b33, -0x40050000,0xbabc1627,0xc1b0a0b2, -0x40040000,0xd433ad06,0x28f79901, -0x40030000,0x8e117213,0x5009ddcb, -0x40000000,0xe8facfd5,0x0fa62432, -0x3ffd0000,0xbcff53b2,0xd53c3e24, -0x3ff80000,0xe5f45393,0x3d754058, -0x3ff20000,0x90677524,0xf50a1789, -}; -static long Q1[27] = { -/* 0x3fff0000,0x80000000,0x00000000, */ -0x40030000,0xa01d2fad,0x2673d901, -0x40050000,0x8d990e9d,0xc93c24f5, -0x40050000,0xa0aa612d,0x523a8cda, -0x40040000,0xc9637b9b,0xb5fc602c, -0x40030000,0x8e62b766,0xd3e7ac72, -0x40000000,0xf61d927c,0xe34c048e, -0x3ffd0000,0xcc7945de,0xa5cc6d88, -0x3ff80000,0xfa299931,0x199ae6d1, -0x3ff20000,0x9d2670a0,0x36754c7d, -}; -#endif - -/* ndtri(x) = z - ln(z)/z - 1/z P2(1/z)/Q2(1/z) - z = sqrt(-2 ln(y)) - 8 <= z <= 32 - i.e., y between exp(-32) = 1.27e-14 and exp(-512) = 4.38e-223 - Peak relative error 1.0e-21 */ -#if UNK -static long double P2[8] = { - 3.244525725312906932464E0L, - 6.856256488128415760904E0L, - 3.765479340423144482796E0L, - 1.240893301734538935324E0L, - 1.740282292791367834724E-1L, - 9.082834200993107441750E-3L, - 1.617870121822776093899E-4L, - 7.377405643054504178605E-7L, -}; -static long double Q2[7] = { -/* 1.000000000000000000000E0L, */ - 6.021509481727510630722E0L, - 3.528463857156936773982E0L, - 1.289185315656302878699E0L, - 1.874290142615703609510E-1L, - 9.867655920899636109122E-3L, - 1.760452434084258930442E-4L, - 8.028288500688538331773E-7L, -}; -#endif -#if IBMPC -static short P2[] = { -0xafb1,0x4ff9,0x4f3a,0xcfa6,0x4000, XPD -0xbd81,0xaffa,0x7401,0xdb66,0x4001, XPD -0x3a32,0x3863,0x9d0f,0xf0fd,0x4000, XPD -0x300e,0x633d,0x977a,0x9ed5,0x3fff, XPD -0xea3a,0x56b6,0x74c5,0xb234,0x3ffc, XPD -0x38c6,0x49d2,0x2af6,0x94d0,0x3ff8, XPD -0xc85d,0xe17d,0x5ed1,0xa9a5,0x3ff2, XPD -0x536c,0x808b,0x2542,0xc609,0x3fea, XPD -}; -static short Q2[] = { -/* 0x0000,0x0000,0x0000,0x8000,0x3fff, XPD */ -0xaabd,0x125a,0x34a7,0xc0b0,0x4001, XPD -0x0ded,0xe6da,0x5a11,0xe1d2,0x4000, XPD -0xc742,0x9d16,0x0640,0xa504,0x3fff, XPD -0xea1e,0x4cc2,0x643a,0xbfed,0x3ffc, XPD -0x7a9b,0xfaff,0xf2dd,0xa1ab,0x3ff8, XPD -0xfd90,0x4688,0xc902,0xb898,0x3ff2, XPD -0xf003,0x032a,0xfa7e,0xd781,0x3fea, XPD -}; -#endif -#if MIEEE -static long P2[24] = { -0x40000000,0xcfa64f3a,0x4ff9afb1, -0x40010000,0xdb667401,0xaffabd81, -0x40000000,0xf0fd9d0f,0x38633a32, -0x3fff0000,0x9ed5977a,0x633d300e, -0x3ffc0000,0xb23474c5,0x56b6ea3a, -0x3ff80000,0x94d02af6,0x49d238c6, -0x3ff20000,0xa9a55ed1,0xe17dc85d, -0x3fea0000,0xc6092542,0x808b536c, -}; -static long Q2[21] = { -/* 0x3fff0000,0x80000000,0x00000000, */ -0x40010000,0xc0b034a7,0x125aaabd, -0x40000000,0xe1d25a11,0xe6da0ded, -0x3fff0000,0xa5040640,0x9d16c742, -0x3ffc0000,0xbfed643a,0x4cc2ea1e, -0x3ff80000,0xa1abf2dd,0xfaff7a9b, -0x3ff20000,0xb898c902,0x4688fd90, -0x3fea0000,0xd781fa7e,0x032af003, -}; -#endif - -/* ndtri(x) = z - ln(z)/z - 1/z P3(1/z)/Q3(1/z) - 32 < z < 2048/13 - Peak relative error 1.4e-20 */ -#if UNK -static long double P3[8] = { - 2.020331091302772535752E0L, - 2.133020661587413053144E0L, - 2.114822217898707063183E-1L, --6.500909615246067985872E-3L, --7.279315200737344309241E-4L, --1.275404675610280787619E-5L, --6.433966387613344714022E-8L, --7.772828380948163386917E-11L, -}; -static long double Q3[7] = { -/* 1.000000000000000000000E0L, */ - 2.278210997153449199574E0L, - 2.345321838870438196534E-1L, --6.916708899719964982855E-3L, --7.908542088737858288849E-4L, --1.387652389480217178984E-5L, --7.001476867559193780666E-8L, --8.458494263787680376729E-11L, -}; -#endif -#if IBMPC -static short P3[] = { -0x87b2,0x0f31,0x1ac7,0x814d,0x4000, XPD -0x491c,0xcd74,0x6917,0x8883,0x4000, XPD -0x935e,0x1776,0xcba9,0xd88e,0x3ffc, XPD -0xbafd,0x8abb,0x9518,0xd505,0xbff7, XPD -0xc87e,0x2ed3,0xa84a,0xbed2,0xbff4, XPD -0x0094,0xa402,0x36b5,0xd5fa,0xbfee, XPD -0xbc53,0x0fc3,0x1ab2,0x8a2b,0xbfe7, XPD -0x30b4,0x71c0,0x223d,0xaaed,0xbfdd, XPD -}; -static short Q3[] = { -/* 0x0000,0x0000,0x0000,0x8000,0x3fff, XPD */ -0xdfc1,0x8a57,0x357f,0x91ce,0x4000, XPD -0xcc4f,0x9e03,0x346e,0xf029,0x3ffc, XPD -0x38b1,0x9788,0x8f42,0xe2a5,0xbff7, XPD -0xb281,0x2117,0x53da,0xcf51,0xbff4, XPD -0xf2ab,0x1d42,0x3760,0xe8cf,0xbfee, XPD -0x741b,0xf14f,0x06b0,0x965b,0xbfe7, XPD -0x37c2,0xa91f,0x16ea,0xba01,0xbfdd, XPD -}; -#endif -#if MIEEE -static long P3[24] = { -0x40000000,0x814d1ac7,0x0f3187b2, -0x40000000,0x88836917,0xcd74491c, -0x3ffc0000,0xd88ecba9,0x1776935e, -0xbff70000,0xd5059518,0x8abbbafd, -0xbff40000,0xbed2a84a,0x2ed3c87e, -0xbfee0000,0xd5fa36b5,0xa4020094, -0xbfe70000,0x8a2b1ab2,0x0fc3bc53, -0xbfdd0000,0xaaed223d,0x71c030b4, -}; -static long Q3[21] = { -/* 0x3fff0000,0x80000000,0x00000000, */ -0x40000000,0x91ce357f,0x8a57dfc1, -0x3ffc0000,0xf029346e,0x9e03cc4f, -0xbff70000,0xe2a58f42,0x978838b1, -0xbff40000,0xcf5153da,0x2117b281, -0xbfee0000,0xe8cf3760,0x1d42f2ab, -0xbfe70000,0x965b06b0,0xf14f741b, -0xbfdd0000,0xba0116ea,0xa91f37c2, -}; -#endif -#ifdef ANSIPROT -extern long double polevll ( long double, void *, int ); -extern long double p1evll ( long double, void *, int ); -extern long double logl ( long double ); -extern long double sqrtl ( long double ); -#else -long double polevll(), p1evll(), logl(), sqrtl(); -#endif - -long double ndtril(y0) -long double y0; -{ -long double x, y, z, y2, x0, x1; -int code; - -if( y0 <= 0.0L ) - { - mtherr( "ndtril", DOMAIN ); - return( -MAXNUML ); - } -if( y0 >= 1.0L ) - { - mtherr( "ndtri", DOMAIN ); - return( MAXNUML ); - } -code = 1; -y = y0; -if( y > (1.0L - 0.13533528323661269189L) ) /* 0.135... = exp(-2) */ - { - y = 1.0L - y; - code = 0; - } - -if( y > 0.13533528323661269189L ) - { - y = y - 0.5L; - y2 = y * y; - x = y + y * (y2 * polevll( y2, P0, 7 )/p1evll( y2, Q0, 7 )); - x = x * s2pi; - return(x); - } - -x = sqrtl( -2.0L * logl(y) ); -x0 = x - logl(x)/x; -z = 1.0L/x; -if( x < 8.0L ) - x1 = z * polevll( z, P1, 9 )/p1evll( z, Q1, 9 ); -else if( x < 32.0L ) - x1 = z * polevll( z, P2, 7 )/p1evll( z, Q2, 7 ); -else - x1 = z * polevll( z, P3, 7 )/p1evll( z, Q3, 7 ); -x = x0 - x1; -if( code != 0 ) - x = -x; -return( x ); -} diff --git a/libm/ldouble/ndtrl.c b/libm/ldouble/ndtrl.c deleted file mode 100644 index 2c53314a5..000000000 --- a/libm/ldouble/ndtrl.c +++ /dev/null @@ -1,473 +0,0 @@ -/* ndtrl.c - * - * Normal distribution function - * - * - * - * SYNOPSIS: - * - * long double x, y, ndtrl(); - * - * y = ndtrl( x ); - * - * - * - * DESCRIPTION: - * - * Returns the area under the Gaussian probability density - * function, integrated from minus infinity to x: - * - * x - * - - * 1 | | 2 - * ndtr(x) = --------- | exp( - t /2 ) dt - * sqrt(2pi) | | - * - - * -inf. - * - * = ( 1 + erf(z) ) / 2 - * = erfc(z) / 2 - * - * where z = x/sqrt(2). Computation is via the functions - * erf and erfc. - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -13,0 30000 1.6e-17 2.9e-18 - * IEEE -150.7,0 2000 1.6e-15 3.8e-16 - * Accuracy is limited by error amplification in computing exp(-x^2). - * - * - * ERROR MESSAGES: - * - * message condition value returned - * erfcl underflow x^2 / 2 > MAXLOGL 0.0 - * - */ - /* erfl.c - * - * Error function - * - * - * - * SYNOPSIS: - * - * long double x, y, erfl(); - * - * y = erfl( x ); - * - * - * - * DESCRIPTION: - * - * The integral is - * - * x - * - - * 2 | | 2 - * erf(x) = -------- | exp( - t ) dt. - * sqrt(pi) | | - * - - * 0 - * - * The magnitude of x is limited to about 106.56 for IEEE - * arithmetic; 1 or -1 is returned outside this range. - * - * For 0 <= |x| < 1, erf(x) = x * P6(x^2)/Q6(x^2); otherwise - * erf(x) = 1 - erfc(x). - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 0,1 50000 2.0e-19 5.7e-20 - * - */ - /* erfcl.c - * - * Complementary error function - * - * - * - * SYNOPSIS: - * - * long double x, y, erfcl(); - * - * y = erfcl( x ); - * - * - * - * DESCRIPTION: - * - * - * 1 - erf(x) = - * - * inf. - * - - * 2 | | 2 - * erfc(x) = -------- | exp( - t ) dt - * sqrt(pi) | | - * - - * x - * - * - * For small x, erfc(x) = 1 - erf(x); otherwise rational - * approximations are computed. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 0,13 20000 7.0e-18 1.8e-18 - * IEEE 0,106.56 10000 4.4e-16 1.2e-16 - * Accuracy is limited by error amplification in computing exp(-x^2). - * - * - * ERROR MESSAGES: - * - * message condition value returned - * erfcl underflow x^2 > MAXLOGL 0.0 - * - * - */ - - -/* -Cephes Math Library Release 2.3: January, 1995 -Copyright 1984, 1995 by Stephen L. Moshier -*/ - - -#include <math.h> - -extern long double MAXLOGL; -static long double SQRTHL = 7.071067811865475244008e-1L; - -/* erfc(x) = exp(-x^2) P(1/x)/Q(1/x) - 1/8 <= 1/x <= 1 - Peak relative error 5.8e-21 */ -#if UNK -static long double P[10] = { - 1.130609921802431462353E9L, - 2.290171954844785638925E9L, - 2.295563412811856278515E9L, - 1.448651275892911637208E9L, - 6.234814405521647580919E8L, - 1.870095071120436715930E8L, - 3.833161455208142870198E7L, - 4.964439504376477951135E6L, - 3.198859502299390825278E5L, --9.085943037416544232472E-6L, -}; -static long double Q[10] = { -/* 1.000000000000000000000E0L, */ - 1.130609910594093747762E9L, - 3.565928696567031388910E9L, - 5.188672873106859049556E9L, - 4.588018188918609726890E9L, - 2.729005809811924550999E9L, - 1.138778654945478547049E9L, - 3.358653716579278063988E8L, - 6.822450775590265689648E7L, - 8.799239977351261077610E6L, - 5.669830829076399819566E5L, -}; -#endif -#if IBMPC -static short P[] = { -0x4bf0,0x9ad8,0x7a03,0x86c7,0x401d, XPD -0xdf23,0xd843,0x4032,0x8881,0x401e, XPD -0xd025,0xcfd5,0x8494,0x88d3,0x401e, XPD -0xb6d0,0xc92b,0x5417,0xacb1,0x401d, XPD -0xada8,0x356a,0x4982,0x94a6,0x401c, XPD -0x4e13,0xcaee,0x9e31,0xb258,0x401a, XPD -0x5840,0x554d,0x37a3,0x9239,0x4018, XPD -0x3b58,0x3da2,0xaf02,0x9780,0x4015, XPD -0x0144,0x489e,0xbe68,0x9c31,0x4011, XPD -0x333b,0xd9e6,0xd404,0x986f,0xbfee, XPD -}; -static short Q[] = { -/* 0x0000,0x0000,0x0000,0x8000,0x3fff, XPD */ -0x0e43,0x302d,0x79ed,0x86c7,0x401d, XPD -0xf817,0x9128,0xc0f8,0xd48b,0x401e, XPD -0x8eae,0x8dad,0x6eb4,0x9aa2,0x401f, XPD -0x00e7,0x7595,0xcd06,0x88bb,0x401f, XPD -0x4991,0xcfda,0x52f1,0xa2a9,0x401e, XPD -0xc39d,0xe415,0xc43d,0x87c0,0x401d, XPD -0xa75d,0x436f,0x30dd,0xa027,0x401b, XPD -0xc4cb,0x305a,0xbf78,0x8220,0x4019, XPD -0x3708,0x33b1,0x07fa,0x8644,0x4016, XPD -0x24fa,0x96f6,0x7153,0x8a6c,0x4012, XPD -}; -#endif -#if MIEEE -static long P[30] = { -0x401d0000,0x86c77a03,0x9ad84bf0, -0x401e0000,0x88814032,0xd843df23, -0x401e0000,0x88d38494,0xcfd5d025, -0x401d0000,0xacb15417,0xc92bb6d0, -0x401c0000,0x94a64982,0x356aada8, -0x401a0000,0xb2589e31,0xcaee4e13, -0x40180000,0x923937a3,0x554d5840, -0x40150000,0x9780af02,0x3da23b58, -0x40110000,0x9c31be68,0x489e0144, -0xbfee0000,0x986fd404,0xd9e6333b, -}; -static long Q[30] = { -/* 0x3fff0000,0x80000000,0x00000000, */ -0x401d0000,0x86c779ed,0x302d0e43, -0x401e0000,0xd48bc0f8,0x9128f817, -0x401f0000,0x9aa26eb4,0x8dad8eae, -0x401f0000,0x88bbcd06,0x759500e7, -0x401e0000,0xa2a952f1,0xcfda4991, -0x401d0000,0x87c0c43d,0xe415c39d, -0x401b0000,0xa02730dd,0x436fa75d, -0x40190000,0x8220bf78,0x305ac4cb, -0x40160000,0x864407fa,0x33b13708, -0x40120000,0x8a6c7153,0x96f624fa, -}; -#endif - -/* erfc(x) = exp(-x^2) 1/x R(1/x^2) / S(1/x^2) - 1/128 <= 1/x < 1/8 - Peak relative error 1.9e-21 */ -#if UNK -static long double R[5] = { - 3.621349282255624026891E0L, - 7.173690522797138522298E0L, - 3.445028155383625172464E0L, - 5.537445669807799246891E-1L, - 2.697535671015506686136E-2L, -}; -static long double S[5] = { -/* 1.000000000000000000000E0L, */ - 1.072884067182663823072E1L, - 1.533713447609627196926E1L, - 6.572990478128949439509E0L, - 1.005392977603322982436E0L, - 4.781257488046430019872E-2L, -}; -#endif -#if IBMPC -static short R[] = { -0x260a,0xab95,0x2fc7,0xe7c4,0x4000, XPD -0x4761,0x613e,0xdf6d,0xe58e,0x4001, XPD -0x0615,0x4b00,0x575f,0xdc7b,0x4000, XPD -0x521d,0x8527,0x3435,0x8dc2,0x3ffe, XPD -0x22cf,0xc711,0x6c5b,0xdcfb,0x3ff9, XPD -}; -static short S[] = { -/* 0x0000,0x0000,0x0000,0x8000,0x3fff, XPD */ -0x5de6,0x17d7,0x54d6,0xaba9,0x4002, XPD -0x55d5,0xd300,0xe71e,0xf564,0x4002, XPD -0xb611,0x8f76,0xf020,0xd255,0x4001, XPD -0x3684,0x3798,0xb793,0x80b0,0x3fff, XPD -0xf5af,0x2fb2,0x1e57,0xc3d7,0x3ffa, XPD -}; -#endif -#if MIEEE -static long R[15] = { -0x40000000,0xe7c42fc7,0xab95260a, -0x40010000,0xe58edf6d,0x613e4761, -0x40000000,0xdc7b575f,0x4b000615, -0x3ffe0000,0x8dc23435,0x8527521d, -0x3ff90000,0xdcfb6c5b,0xc71122cf, -}; -static long S[15] = { -/* 0x3fff0000,0x80000000,0x00000000, */ -0x40020000,0xaba954d6,0x17d75de6, -0x40020000,0xf564e71e,0xd30055d5, -0x40010000,0xd255f020,0x8f76b611, -0x3fff0000,0x80b0b793,0x37983684, -0x3ffa0000,0xc3d71e57,0x2fb2f5af, -}; -#endif - -/* erf(x) = x P(x^2)/Q(x^2) - 0 <= x <= 1 - Peak relative error 7.6e-23 */ -#if UNK -static long double T[7] = { - 1.097496774521124996496E-1L, - 5.402980370004774841217E0L, - 2.871822526820825849235E2L, - 2.677472796799053019985E3L, - 4.825977363071025440855E4L, - 1.549905740900882313773E5L, - 1.104385395713178565288E6L, -}; -static long double U[6] = { -/* 1.000000000000000000000E0L, */ - 4.525777638142203713736E1L, - 9.715333124857259246107E2L, - 1.245905812306219011252E4L, - 9.942956272177178491525E4L, - 4.636021778692893773576E5L, - 9.787360737578177599571E5L, -}; -#endif -#if IBMPC -static short T[] = { -0xfd7a,0x3a1a,0x705b,0xe0c4,0x3ffb, XPD -0x3128,0xc337,0x3716,0xace5,0x4001, XPD -0x9517,0x4e93,0x540e,0x8f97,0x4007, XPD -0x6118,0x6059,0x9093,0xa757,0x400a, XPD -0xb954,0xa987,0xc60c,0xbc83,0x400e, XPD -0x7a56,0xe45a,0xa4bd,0x975b,0x4010, XPD -0xc446,0x6bab,0x0b2a,0x86d0,0x4013, XPD -}; -static short U[] = { -/* 0x0000,0x0000,0x0000,0x8000,0x3fff, XPD */ -0x3453,0x1f8e,0xf688,0xb507,0x4004, XPD -0x71ac,0xb12f,0x21ca,0xf2e2,0x4008, XPD -0xffe8,0x9cac,0x3b84,0xc2ac,0x400c, XPD -0x481d,0x445b,0xc807,0xc232,0x400f, XPD -0x9ad5,0x1aef,0x45b1,0xe25e,0x4011, XPD -0x71a7,0x1cad,0x012e,0xeef3,0x4012, XPD -}; -#endif -#if MIEEE -static long T[21] = { -0x3ffb0000,0xe0c4705b,0x3a1afd7a, -0x40010000,0xace53716,0xc3373128, -0x40070000,0x8f97540e,0x4e939517, -0x400a0000,0xa7579093,0x60596118, -0x400e0000,0xbc83c60c,0xa987b954, -0x40100000,0x975ba4bd,0xe45a7a56, -0x40130000,0x86d00b2a,0x6babc446, -}; -static long U[18] = { -/* 0x3fff0000,0x80000000,0x00000000, */ -0x40040000,0xb507f688,0x1f8e3453, -0x40080000,0xf2e221ca,0xb12f71ac, -0x400c0000,0xc2ac3b84,0x9cacffe8, -0x400f0000,0xc232c807,0x445b481d, -0x40110000,0xe25e45b1,0x1aef9ad5, -0x40120000,0xeef3012e,0x1cad71a7, -}; -#endif -#ifdef ANSIPROT -extern long double polevll ( long double, void *, int ); -extern long double p1evll ( long double, void *, int ); -extern long double expl ( long double ); -extern long double logl ( long double ); -extern long double erfl ( long double ); -extern long double erfcl ( long double ); -extern long double fabsl ( long double ); -#else -long double polevll(), p1evll(), expl(), logl(), erfl(), erfcl(), fabsl(); -#endif -#ifdef INFINITIES -extern long double INFINITYL; -#endif - -long double ndtrl(a) -long double a; -{ -long double x, y, z; - -x = a * SQRTHL; -z = fabsl(x); - -if( z < SQRTHL ) - y = 0.5L + 0.5L * erfl(x); - -else - { - y = 0.5L * erfcl(z); - - if( x > 0.0L ) - y = 1.0L - y; - } - -return(y); -} - - -long double erfcl(a) -long double a; -{ -long double p,q,x,y,z; - -#ifdef INFINITIES -if( a == INFINITYL ) - return(0.0L); -if( a == -INFINITYL ) - return(2.0L); -#endif -if( a < 0.0L ) - x = -a; -else - x = a; - -if( x < 1.0L ) - return( 1.0L - erfl(a) ); - -z = -a * a; - -if( z < -MAXLOGL ) - { -under: - mtherr( "erfcl", UNDERFLOW ); - if( a < 0 ) - return( 2.0L ); - else - return( 0.0L ); - } - -z = expl(z); -y = 1.0L/x; - -if( x < 8.0L ) - { - p = polevll( y, P, 9 ); - q = p1evll( y, Q, 10 ); - } -else - { - q = y * y; - p = y * polevll( q, R, 4 ); - q = p1evll( q, S, 5 ); - } -y = (z * p)/q; - -if( a < 0.0L ) - y = 2.0L - y; - -if( y == 0.0L ) - goto under; - -return(y); -} - - - -long double erfl(x) -long double x; -{ -long double y, z; - -#if MINUSZERO -if( x == 0.0L ) - return(x); -#endif -#ifdef INFINITIES -if( x == -INFINITYL ) - return(-1.0L); -if( x == INFINITYL ) - return(1.0L); -#endif -if( fabsl(x) > 1.0L ) - return( 1.0L - erfcl(x) ); - -z = x * x; -y = x * polevll( z, T, 6 ) / p1evll( z, U, 6 ); -return( y ); -} diff --git a/libm/ldouble/pdtrl.c b/libm/ldouble/pdtrl.c deleted file mode 100644 index 861b1d9ae..000000000 --- a/libm/ldouble/pdtrl.c +++ /dev/null @@ -1,184 +0,0 @@ -/* pdtrl.c - * - * Poisson distribution - * - * - * - * SYNOPSIS: - * - * int k; - * long double m, y, pdtrl(); - * - * y = pdtrl( k, m ); - * - * - * - * DESCRIPTION: - * - * Returns the sum of the first k terms of the Poisson - * distribution: - * - * k j - * -- -m m - * > e -- - * -- j! - * j=0 - * - * The terms are not summed directly; instead the incomplete - * gamma integral is employed, according to the relation - * - * y = pdtr( k, m ) = igamc( k+1, m ). - * - * The arguments must both be positive. - * - * - * - * ACCURACY: - * - * See igamc(). - * - */ - /* pdtrcl() - * - * Complemented poisson distribution - * - * - * - * SYNOPSIS: - * - * int k; - * long double m, y, pdtrcl(); - * - * y = pdtrcl( k, m ); - * - * - * - * DESCRIPTION: - * - * Returns the sum of the terms k+1 to infinity of the Poisson - * distribution: - * - * inf. j - * -- -m m - * > e -- - * -- j! - * j=k+1 - * - * The terms are not summed directly; instead the incomplete - * gamma integral is employed, according to the formula - * - * y = pdtrc( k, m ) = igam( k+1, m ). - * - * The arguments must both be positive. - * - * - * - * ACCURACY: - * - * See igam.c. - * - */ - /* pdtril() - * - * Inverse Poisson distribution - * - * - * - * SYNOPSIS: - * - * int k; - * long double m, y, pdtrl(); - * - * m = pdtril( k, y ); - * - * - * - * - * DESCRIPTION: - * - * Finds the Poisson variable x such that the integral - * from 0 to x of the Poisson density is equal to the - * given probability y. - * - * This is accomplished using the inverse gamma integral - * function and the relation - * - * m = igami( k+1, y ). - * - * - * - * - * ACCURACY: - * - * See igami.c. - * - * ERROR MESSAGES: - * - * message condition value returned - * pdtri domain y < 0 or y >= 1 0.0 - * k < 0 - * - */ - -/* -Cephes Math Library Release 2.3: March, 1995 -Copyright 1984, 1995 by Stephen L. Moshier -*/ - -#include <math.h> -#ifdef ANSIPROT -extern long double igaml ( long double, long double ); -extern long double igamcl ( long double, long double ); -extern long double igamil ( long double, long double ); -#else -long double igaml(), igamcl(), igamil(); -#endif - -long double pdtrcl( k, m ) -int k; -long double m; -{ -long double v; - -if( (k < 0) || (m <= 0.0L) ) - { - mtherr( "pdtrcl", DOMAIN ); - return( 0.0L ); - } -v = k+1; -return( igaml( v, m ) ); -} - - - -long double pdtrl( k, m ) -int k; -long double m; -{ -long double v; - -if( (k < 0) || (m <= 0.0L) ) - { - mtherr( "pdtrl", DOMAIN ); - return( 0.0L ); - } -v = k+1; -return( igamcl( v, m ) ); -} - - -long double pdtril( k, y ) -int k; -long double y; -{ -long double v; - -if( (k < 0) || (y < 0.0L) || (y >= 1.0L) ) - { - mtherr( "pdtril", DOMAIN ); - return( 0.0L ); - } -v = k+1; -v = igamil( v, y ); -return( v ); -} diff --git a/libm/ldouble/polevll.c b/libm/ldouble/polevll.c deleted file mode 100644 index ce37c6d9d..000000000 --- a/libm/ldouble/polevll.c +++ /dev/null @@ -1,182 +0,0 @@ -/* polevll.c - * p1evll.c - * - * Evaluate polynomial - * - * - * - * SYNOPSIS: - * - * int N; - * long double x, y, coef[N+1], polevl[]; - * - * y = polevll( x, coef, N ); - * - * - * - * DESCRIPTION: - * - * Evaluates polynomial of degree N: - * - * 2 N - * y = C + C x + C x +...+ C x - * 0 1 2 N - * - * Coefficients are stored in reverse order: - * - * coef[0] = C , ..., coef[N] = C . - * N 0 - * - * The function p1evll() assumes that coef[N] = 1.0 and is - * omitted from the array. Its calling arguments are - * otherwise the same as polevll(). - * - * This module also contains the following globally declared constants: - * MAXNUML = 1.189731495357231765021263853E4932L; - * MACHEPL = 5.42101086242752217003726400434970855712890625E-20L; - * MAXLOGL = 1.1356523406294143949492E4L; - * MINLOGL = -1.1355137111933024058873E4L; - * LOGE2L = 6.9314718055994530941723E-1L; - * LOG2EL = 1.4426950408889634073599E0L; - * PIL = 3.1415926535897932384626L; - * PIO2L = 1.5707963267948966192313L; - * PIO4L = 7.8539816339744830961566E-1L; - * - * SPEED: - * - * In the interest of speed, there are no checks for out - * of bounds arithmetic. This routine is used by most of - * the functions in the library. Depending on available - * equipment features, the user may wish to rewrite the - * program in microcode or assembly language. - * - */ - - -/* -Cephes Math Library Release 2.2: July, 1992 -Copyright 1984, 1987, 1988, 1992 by Stephen L. Moshier -Direct inquiries to 30 Frost Street, Cambridge, MA 02140 -*/ -#include <math.h> - -#if UNK -/* almost 2^16384 */ -long double MAXNUML = 1.189731495357231765021263853E4932L; -/* 2^-64 */ -long double MACHEPL = 5.42101086242752217003726400434970855712890625E-20L; -/* log( MAXNUML ) */ -long double MAXLOGL = 1.1356523406294143949492E4L; -#ifdef DENORMAL -/* log(smallest denormal number = 2^-16446) */ -long double MINLOGL = -1.13994985314888605586758E4L; -#else -/* log( underflow threshold = 2^(-16382) ) */ -long double MINLOGL = -1.1355137111933024058873E4L; -#endif -long double LOGE2L = 6.9314718055994530941723E-1L; -long double LOG2EL = 1.4426950408889634073599E0L; -long double PIL = 3.1415926535897932384626L; -long double PIO2L = 1.5707963267948966192313L; -long double PIO4L = 7.8539816339744830961566E-1L; -#ifdef INFINITIES -long double NANL = 0.0L / 0.0L; -long double INFINITYL = 1.0L / 0.0L; -#else -long double INFINITYL = 1.189731495357231765021263853E4932L; -long double NANL = 0.0L; -#endif -#endif -#if IBMPC -short MAXNUML[] = {0xffff,0xffff,0xffff,0xffff,0x7ffe, XPD}; -short MAXLOGL[] = {0x79ab,0xd1cf,0x17f7,0xb172,0x400c, XPD}; -#ifdef INFINITIES -short INFINITYL[] = {0,0,0,0x8000,0x7fff, XPD}; -short NANL[] = {0,0,0,0xc000,0x7fff, XPD}; -#else -short INFINITYL[] = {0xffff,0xffff,0xffff,0xffff,0x7ffe, XPD}; -long double NANL = 0.0L; -#endif -#ifdef DENORMAL -short MINLOGL[] = {0xbaaa,0x09e2,0xfe7f,0xb21d,0xc00c, XPD}; -#else -short MINLOGL[] = {0xeb2f,0x1210,0x8c67,0xb16c,0xc00c, XPD}; -#endif -short MACHEPL[] = {0x0000,0x0000,0x0000,0x8000,0x3fbf, XPD}; -short LOGE2L[] = {0x79ac,0xd1cf,0x17f7,0xb172,0x3ffe, XPD}; -short LOG2EL[] = {0xf0bc,0x5c17,0x3b29,0xb8aa,0x3fff, XPD}; -short PIL[] = {0xc235,0x2168,0xdaa2,0xc90f,0x4000, XPD}; -short PIO2L[] = {0xc235,0x2168,0xdaa2,0xc90f,0x3fff, XPD}; -short PIO4L[] = {0xc235,0x2168,0xdaa2,0xc90f,0x3ffe, XPD}; -#endif -#if MIEEE -long MAXNUML[] = {0x7ffe0000,0xffffffff,0xffffffff}; -long MAXLOGL[] = {0x400c0000,0xb17217f7,0xd1cf79ab}; -#ifdef INFINITIES -long INFINITY[] = {0x7fff0000,0x80000000,0x00000000}; -long NANL[] = {0x7fff0000,0xffffffff,0xffffffff}; -#else -long INFINITYL[] = {0x7ffe0000,0xffffffff,0xffffffff}; -long double NANL = 0.0L; -#endif -#ifdef DENORMAL -long MINLOGL[] = {0xc00c0000,0xb21dfe7f,0x09e2baaa}; -#else -long MINLOGL[] = {0xc00c0000,0xb16c8c67,0x1210eb2f}; -#endif -long MACHEPL[] = {0x3fbf0000,0x80000000,0x00000000}; -long LOGE2L[] = {0x3ffe0000,0xb17217f7,0xd1cf79ac}; -long LOG2EL[] = {0x3fff0000,0xb8aa3b29,0x5c17f0bc}; -long PIL[] = {0x40000000,0xc90fdaa2,0x2168c235}; -long PIO2L[] = {0x3fff0000,0xc90fdaa2,0x2168c235}; -long PIO4L[] = {0x3ffe0000,0xc90fdaa2,0x2168c235}; -#endif - -#ifdef MINUSZERO -long double NEGZEROL = -0.0L; -#else -long double NEGZEROL = 0.0L; -#endif - -/* Polynomial evaluator: - * P[0] x^n + P[1] x^(n-1) + ... + P[n] - */ -long double polevll( x, p, n ) -long double x; -void *p; -int n; -{ -register long double y; -register long double *P = (long double *)p; - -y = *P++; -do - { - y = y * x + *P++; - } -while( --n ); -return(y); -} - - - -/* Polynomial evaluator: - * x^n + P[0] x^(n-1) + P[1] x^(n-2) + ... + P[n] - */ -long double p1evll( x, p, n ) -long double x; -void *p; -int n; -{ -register long double y; -register long double *P = (long double *)p; - -n -= 1; -y = x + *P++; -do - { - y = y * x + *P++; - } -while( --n ); -return( y ); -} diff --git a/libm/ldouble/powil.c b/libm/ldouble/powil.c deleted file mode 100644 index d36c7854e..000000000 --- a/libm/ldouble/powil.c +++ /dev/null @@ -1,164 +0,0 @@ -/* powil.c - * - * Real raised to integer power, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, powil(); - * int n; - * - * y = powil( x, n ); - * - * - * - * DESCRIPTION: - * - * Returns argument x raised to the nth power. - * The routine efficiently decomposes n as a sum of powers of - * two. The desired power is a product of two-to-the-kth - * powers of x. Thus to compute the 32767 power of x requires - * 28 multiplications instead of 32767 multiplications. - * - * - * - * ACCURACY: - * - * - * Relative error: - * arithmetic x domain n domain # trials peak rms - * IEEE .001,1000 -1022,1023 50000 4.3e-17 7.8e-18 - * IEEE 1,2 -1022,1023 20000 3.9e-17 7.6e-18 - * IEEE .99,1.01 0,8700 10000 3.6e-16 7.2e-17 - * - * Returns MAXNUM on overflow, zero on underflow. - * - */ - -/* powil.c */ - -/* -Cephes Math Library Release 2.2: December, 1990 -Copyright 1984, 1990 by Stephen L. Moshier -Direct inquiries to 30 Frost Street, Cambridge, MA 02140 -*/ - -#include <math.h> -extern long double MAXNUML, MAXLOGL, MINLOGL; -extern long double LOGE2L; -#ifdef ANSIPROT -extern long double frexpl ( long double, int * ); -#else -long double frexpl(); -#endif - -long double powil( x, nn ) -long double x; -int nn; -{ -long double w, y; -long double s; -int n, e, sign, asign, lx; - -if( x == 0.0L ) - { - if( nn == 0 ) - return( 1.0L ); - else if( nn < 0 ) - return( MAXNUML ); - else - return( 0.0L ); - } - -if( nn == 0 ) - return( 1.0L ); - - -if( x < 0.0L ) - { - asign = -1; - x = -x; - } -else - asign = 0; - - -if( nn < 0 ) - { - sign = -1; - n = -nn; - } -else - { - sign = 1; - n = nn; - } - -/* Overflow detection */ - -/* Calculate approximate logarithm of answer */ -s = x; -s = frexpl( s, &lx ); -e = (lx - 1)*n; -if( (e == 0) || (e > 64) || (e < -64) ) - { - s = (s - 7.0710678118654752e-1L) / (s + 7.0710678118654752e-1L); - s = (2.9142135623730950L * s - 0.5L + lx) * nn * LOGE2L; - } -else - { - s = LOGE2L * e; - } - -if( s > MAXLOGL ) - { - mtherr( "powil", OVERFLOW ); - y = MAXNUML; - goto done; - } - -if( s < MINLOGL ) - { - mtherr( "powil", UNDERFLOW ); - return(0.0L); - } -/* Handle tiny denormal answer, but with less accuracy - * since roundoff error in 1.0/x will be amplified. - * The precise demarcation should be the gradual underflow threshold. - */ -if( s < (-MAXLOGL+2.0L) ) - { - x = 1.0L/x; - sign = -sign; - } - -/* First bit of the power */ -if( n & 1 ) - y = x; - -else - { - y = 1.0L; - asign = 0; - } - -w = x; -n >>= 1; -while( n ) - { - w = w * w; /* arg to the 2-to-the-kth power */ - if( n & 1 ) /* if that bit is set, then include in product */ - y *= w; - n >>= 1; - } - - -done: - -if( asign ) - y = -y; /* odd power of negative number */ -if( sign < 0 ) - y = 1.0L/y; -return(y); -} diff --git a/libm/ldouble/powl.c b/libm/ldouble/powl.c deleted file mode 100644 index bad380696..000000000 --- a/libm/ldouble/powl.c +++ /dev/null @@ -1,739 +0,0 @@ -/* powl.c - * - * Power function, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, z, powl(); - * - * z = powl( x, y ); - * - * - * - * DESCRIPTION: - * - * Computes x raised to the yth power. Analytically, - * - * x**y = exp( y log(x) ). - * - * Following Cody and Waite, this program uses a lookup table - * of 2**-i/32 and pseudo extended precision arithmetic to - * obtain several extra bits of accuracy in both the logarithm - * and the exponential. - * - * - * - * ACCURACY: - * - * The relative error of pow(x,y) can be estimated - * by y dl ln(2), where dl is the absolute error of - * the internally computed base 2 logarithm. At the ends - * of the approximation interval the logarithm equal 1/32 - * and its relative error is about 1 lsb = 1.1e-19. Hence - * the predicted relative error in the result is 2.3e-21 y . - * - * Relative error: - * arithmetic domain # trials peak rms - * - * IEEE +-1000 40000 2.8e-18 3.7e-19 - * .001 < x < 1000, with log(x) uniformly distributed. - * -1000 < y < 1000, y uniformly distributed. - * - * IEEE 0,8700 60000 6.5e-18 1.0e-18 - * 0.99 < x < 1.01, 0 < y < 8700, uniformly distributed. - * - * - * ERROR MESSAGES: - * - * message condition value returned - * pow overflow x**y > MAXNUM INFINITY - * pow underflow x**y < 1/MAXNUM 0.0 - * pow domain x<0 and y noninteger 0.0 - * - */ - -/* -Cephes Math Library Release 2.7: May, 1998 -Copyright 1984, 1991, 1998 by Stephen L. Moshier -*/ - - -#include <math.h> - -static char fname[] = {"powl"}; - -/* Table size */ -#define NXT 32 -/* log2(Table size) */ -#define LNXT 5 - -#ifdef UNK -/* log(1+x) = x - .5x^2 + x^3 * P(z)/Q(z) - * on the domain 2^(-1/32) - 1 <= x <= 2^(1/32) - 1 - */ -static long double P[] = { - 8.3319510773868690346226E-4L, - 4.9000050881978028599627E-1L, - 1.7500123722550302671919E0L, - 1.4000100839971580279335E0L, -}; -static long double Q[] = { -/* 1.0000000000000000000000E0L,*/ - 5.2500282295834889175431E0L, - 8.4000598057587009834666E0L, - 4.2000302519914740834728E0L, -}; -/* A[i] = 2^(-i/32), rounded to IEEE long double precision. - * If i is even, A[i] + B[i/2] gives additional accuracy. - */ -static long double A[33] = { - 1.0000000000000000000000E0L, - 9.7857206208770013448287E-1L, - 9.5760328069857364691013E-1L, - 9.3708381705514995065011E-1L, - 9.1700404320467123175367E-1L, - 8.9735453750155359320742E-1L, - 8.7812608018664974155474E-1L, - 8.5930964906123895780165E-1L, - 8.4089641525371454301892E-1L, - 8.2287773907698242225554E-1L, - 8.0524516597462715409607E-1L, - 7.8799042255394324325455E-1L, - 7.7110541270397041179298E-1L, - 7.5458221379671136985669E-1L, - 7.3841307296974965571198E-1L, - 7.2259040348852331001267E-1L, - 7.0710678118654752438189E-1L, - 6.9195494098191597746178E-1L, - 6.7712777346844636413344E-1L, - 6.6261832157987064729696E-1L, - 6.4841977732550483296079E-1L, - 6.3452547859586661129850E-1L, - 6.2092890603674202431705E-1L, - 6.0762367999023443907803E-1L, - 5.9460355750136053334378E-1L, - 5.8186242938878875689693E-1L, - 5.6939431737834582684856E-1L, - 5.5719337129794626814472E-1L, - 5.4525386633262882960438E-1L, - 5.3357020033841180906486E-1L, - 5.2213689121370692017331E-1L, - 5.1094857432705833910408E-1L, - 5.0000000000000000000000E-1L, -}; -static long double B[17] = { - 0.0000000000000000000000E0L, - 2.6176170809902549338711E-20L, --1.0126791927256478897086E-20L, - 1.3438228172316276937655E-21L, - 1.2207982955417546912101E-20L, --6.3084814358060867200133E-21L, - 1.3164426894366316434230E-20L, --1.8527916071632873716786E-20L, - 1.8950325588932570796551E-20L, - 1.5564775779538780478155E-20L, - 6.0859793637556860974380E-21L, --2.0208749253662532228949E-20L, - 1.4966292219224761844552E-20L, - 3.3540909728056476875639E-21L, --8.6987564101742849540743E-22L, --1.2327176863327626135542E-20L, - 0.0000000000000000000000E0L, -}; - -/* 2^x = 1 + x P(x), - * on the interval -1/32 <= x <= 0 - */ -static long double R[] = { - 1.5089970579127659901157E-5L, - 1.5402715328927013076125E-4L, - 1.3333556028915671091390E-3L, - 9.6181291046036762031786E-3L, - 5.5504108664798463044015E-2L, - 2.4022650695910062854352E-1L, - 6.9314718055994530931447E-1L, -}; - -#define douba(k) A[k] -#define doubb(k) B[k] -#define MEXP (NXT*16384.0L) -/* The following if denormal numbers are supported, else -MEXP: */ -#ifdef DENORMAL -#define MNEXP (-NXT*(16384.0L+64.0L)) -#else -#define MNEXP (-NXT*16384.0L) -#endif -/* log2(e) - 1 */ -#define LOG2EA 0.44269504088896340735992L -#endif - - -#ifdef IBMPC -static short P[] = { -0xb804,0xa8b7,0xc6f4,0xda6a,0x3ff4, XPD -0x7de9,0xcf02,0x58c0,0xfae1,0x3ffd, XPD -0x405a,0x3722,0x67c9,0xe000,0x3fff, XPD -0xcd99,0x6b43,0x87ca,0xb333,0x3fff, XPD -}; -static short Q[] = { -/* 0x0000,0x0000,0x0000,0x8000,0x3fff, */ -0x6307,0xa469,0x3b33,0xa800,0x4001, XPD -0xfec2,0x62d7,0xa51c,0x8666,0x4002, XPD -0xda32,0xd072,0xa5d7,0x8666,0x4001, XPD -}; -static short A[] = { -0x0000,0x0000,0x0000,0x8000,0x3fff, XPD -0x033a,0x722a,0xb2db,0xfa83,0x3ffe, XPD -0xcc2c,0x2486,0x7d15,0xf525,0x3ffe, XPD -0xf5cb,0xdcda,0xb99b,0xefe4,0x3ffe, XPD -0x392f,0xdd24,0xc6e7,0xeac0,0x3ffe, XPD -0x48a8,0x7c83,0x06e7,0xe5b9,0x3ffe, XPD -0xe111,0x2a94,0xdeec,0xe0cc,0x3ffe, XPD -0x3755,0xdaf2,0xb797,0xdbfb,0x3ffe, XPD -0x6af4,0xd69d,0xfcca,0xd744,0x3ffe, XPD -0xe45a,0xf12a,0x1d91,0xd2a8,0x3ffe, XPD -0x80e4,0x1f84,0x8c15,0xce24,0x3ffe, XPD -0x27a3,0x6e2f,0xbd86,0xc9b9,0x3ffe, XPD -0xdadd,0x5506,0x2a11,0xc567,0x3ffe, XPD -0x9456,0x6670,0x4cca,0xc12c,0x3ffe, XPD -0x36bf,0x580c,0xa39f,0xbd08,0x3ffe, XPD -0x9ee9,0x62fb,0xaf47,0xb8fb,0x3ffe, XPD -0x6484,0xf9de,0xf333,0xb504,0x3ffe, XPD -0x2590,0xd2ac,0xf581,0xb123,0x3ffe, XPD -0x4ac6,0x42a1,0x3eea,0xad58,0x3ffe, XPD -0x0ef8,0xea7c,0x5ab4,0xa9a1,0x3ffe, XPD -0x38ea,0xb151,0xd6a9,0xa5fe,0x3ffe, XPD -0x6819,0x0c49,0x4303,0xa270,0x3ffe, XPD -0x11ae,0x91a1,0x3260,0x9ef5,0x3ffe, XPD -0x5539,0xd54e,0x39b9,0x9b8d,0x3ffe, XPD -0xa96f,0x8db8,0xf051,0x9837,0x3ffe, XPD -0x0961,0xfef7,0xefa8,0x94f4,0x3ffe, XPD -0xc336,0xab11,0xd373,0x91c3,0x3ffe, XPD -0x53c0,0x45cd,0x398b,0x8ea4,0x3ffe, XPD -0xd6e7,0xea8b,0xc1e3,0x8b95,0x3ffe, XPD -0x8527,0x92da,0x0e80,0x8898,0x3ffe, XPD -0x7b15,0xcc48,0xc367,0x85aa,0x3ffe, XPD -0xa1d7,0xac2b,0x8698,0x82cd,0x3ffe, XPD -0x0000,0x0000,0x0000,0x8000,0x3ffe, XPD -}; -static short B[] = { -0x0000,0x0000,0x0000,0x0000,0x0000, XPD -0x1f87,0xdb30,0x18f5,0xf73a,0x3fbd, XPD -0xac15,0x3e46,0x2932,0xbf4a,0xbfbc, XPD -0x7944,0xba66,0xa091,0xcb12,0x3fb9, XPD -0xff78,0x40b4,0x2ee6,0xe69a,0x3fbc, XPD -0xc895,0x5069,0xe383,0xee53,0xbfbb, XPD -0x7cde,0x9376,0x4325,0xf8ab,0x3fbc, XPD -0xa10c,0x25e0,0xc093,0xaefd,0xbfbd, XPD -0x7d3e,0xea95,0x1366,0xb2fb,0x3fbd, XPD -0x5d89,0xeb34,0x5191,0x9301,0x3fbd, XPD -0x80d9,0xb883,0xfb10,0xe5eb,0x3fbb, XPD -0x045d,0x288c,0xc1ec,0xbedd,0xbfbd, XPD -0xeded,0x5c85,0x4630,0x8d5a,0x3fbd, XPD -0x9d82,0xe5ac,0x8e0a,0xfd6d,0x3fba, XPD -0x6dfd,0xeb58,0xaf14,0x8373,0xbfb9, XPD -0xf938,0x7aac,0x91cf,0xe8da,0xbfbc, XPD -0x0000,0x0000,0x0000,0x0000,0x0000, XPD -}; -static short R[] = { -0xa69b,0x530e,0xee1d,0xfd2a,0x3fee, XPD -0xc746,0x8e7e,0x5960,0xa182,0x3ff2, XPD -0x63b6,0xadda,0xfd6a,0xaec3,0x3ff5, XPD -0xc104,0xfd99,0x5b7c,0x9d95,0x3ff8, XPD -0xe05e,0x249d,0x46b8,0xe358,0x3ffa, XPD -0x5d1d,0x162c,0xeffc,0xf5fd,0x3ffc, XPD -0x79aa,0xd1cf,0x17f7,0xb172,0x3ffe, XPD -}; - -/* 10 byte sizes versus 12 byte */ -#define douba(k) (*(long double *)(&A[(sizeof( long double )/2)*(k)])) -#define doubb(k) (*(long double *)(&B[(sizeof( long double )/2)*(k)])) -#define MEXP (NXT*16384.0L) -#ifdef DENORMAL -#define MNEXP (-NXT*(16384.0L+64.0L)) -#else -#define MNEXP (-NXT*16384.0L) -#endif -static short L[] = {0xc2ef,0x705f,0xeca5,0xe2a8,0x3ffd, XPD}; -#define LOG2EA (*(long double *)(&L[0])) -#endif - -#ifdef MIEEE -static long P[] = { -0x3ff40000,0xda6ac6f4,0xa8b7b804, -0x3ffd0000,0xfae158c0,0xcf027de9, -0x3fff0000,0xe00067c9,0x3722405a, -0x3fff0000,0xb33387ca,0x6b43cd99, -}; -static long Q[] = { -/* 0x3fff0000,0x80000000,0x00000000, */ -0x40010000,0xa8003b33,0xa4696307, -0x40020000,0x8666a51c,0x62d7fec2, -0x40010000,0x8666a5d7,0xd072da32, -}; -static long A[] = { -0x3fff0000,0x80000000,0x00000000, -0x3ffe0000,0xfa83b2db,0x722a033a, -0x3ffe0000,0xf5257d15,0x2486cc2c, -0x3ffe0000,0xefe4b99b,0xdcdaf5cb, -0x3ffe0000,0xeac0c6e7,0xdd24392f, -0x3ffe0000,0xe5b906e7,0x7c8348a8, -0x3ffe0000,0xe0ccdeec,0x2a94e111, -0x3ffe0000,0xdbfbb797,0xdaf23755, -0x3ffe0000,0xd744fcca,0xd69d6af4, -0x3ffe0000,0xd2a81d91,0xf12ae45a, -0x3ffe0000,0xce248c15,0x1f8480e4, -0x3ffe0000,0xc9b9bd86,0x6e2f27a3, -0x3ffe0000,0xc5672a11,0x5506dadd, -0x3ffe0000,0xc12c4cca,0x66709456, -0x3ffe0000,0xbd08a39f,0x580c36bf, -0x3ffe0000,0xb8fbaf47,0x62fb9ee9, -0x3ffe0000,0xb504f333,0xf9de6484, -0x3ffe0000,0xb123f581,0xd2ac2590, -0x3ffe0000,0xad583eea,0x42a14ac6, -0x3ffe0000,0xa9a15ab4,0xea7c0ef8, -0x3ffe0000,0xa5fed6a9,0xb15138ea, -0x3ffe0000,0xa2704303,0x0c496819, -0x3ffe0000,0x9ef53260,0x91a111ae, -0x3ffe0000,0x9b8d39b9,0xd54e5539, -0x3ffe0000,0x9837f051,0x8db8a96f, -0x3ffe0000,0x94f4efa8,0xfef70961, -0x3ffe0000,0x91c3d373,0xab11c336, -0x3ffe0000,0x8ea4398b,0x45cd53c0, -0x3ffe0000,0x8b95c1e3,0xea8bd6e7, -0x3ffe0000,0x88980e80,0x92da8527, -0x3ffe0000,0x85aac367,0xcc487b15, -0x3ffe0000,0x82cd8698,0xac2ba1d7, -0x3ffe0000,0x80000000,0x00000000, -}; -static long B[51] = { -0x00000000,0x00000000,0x00000000, -0x3fbd0000,0xf73a18f5,0xdb301f87, -0xbfbc0000,0xbf4a2932,0x3e46ac15, -0x3fb90000,0xcb12a091,0xba667944, -0x3fbc0000,0xe69a2ee6,0x40b4ff78, -0xbfbb0000,0xee53e383,0x5069c895, -0x3fbc0000,0xf8ab4325,0x93767cde, -0xbfbd0000,0xaefdc093,0x25e0a10c, -0x3fbd0000,0xb2fb1366,0xea957d3e, -0x3fbd0000,0x93015191,0xeb345d89, -0x3fbb0000,0xe5ebfb10,0xb88380d9, -0xbfbd0000,0xbeddc1ec,0x288c045d, -0x3fbd0000,0x8d5a4630,0x5c85eded, -0x3fba0000,0xfd6d8e0a,0xe5ac9d82, -0xbfb90000,0x8373af14,0xeb586dfd, -0xbfbc0000,0xe8da91cf,0x7aacf938, -0x00000000,0x00000000,0x00000000, -}; -static long R[] = { -0x3fee0000,0xfd2aee1d,0x530ea69b, -0x3ff20000,0xa1825960,0x8e7ec746, -0x3ff50000,0xaec3fd6a,0xadda63b6, -0x3ff80000,0x9d955b7c,0xfd99c104, -0x3ffa0000,0xe35846b8,0x249de05e, -0x3ffc0000,0xf5fdeffc,0x162c5d1d, -0x3ffe0000,0xb17217f7,0xd1cf79aa, -}; - -#define douba(k) (*(long double *)&A[3*(k)]) -#define doubb(k) (*(long double *)&B[3*(k)]) -#define MEXP (NXT*16384.0L) -#ifdef DENORMAL -#define MNEXP (-NXT*(16384.0L+64.0L)) -#else -#define MNEXP (-NXT*16382.0L) -#endif -static long L[3] = {0x3ffd0000,0xe2a8eca5,0x705fc2ef}; -#define LOG2EA (*(long double *)(&L[0])) -#endif - - -#define F W -#define Fa Wa -#define Fb Wb -#define G W -#define Ga Wa -#define Gb u -#define H W -#define Ha Wb -#define Hb Wb - -extern long double MAXNUML; -static VOLATILE long double z; -static long double w, W, Wa, Wb, ya, yb, u; -#ifdef ANSIPROT -extern long double floorl ( long double ); -extern long double fabsl ( long double ); -extern long double frexpl ( long double, int * ); -extern long double ldexpl ( long double, int ); -extern long double polevll ( long double, void *, int ); -extern long double p1evll ( long double, void *, int ); -extern long double powil ( long double, int ); -extern int isnanl ( long double ); -extern int isfinitel ( long double ); -static long double reducl( long double ); -extern int signbitl ( long double ); -#else -long double floorl(), fabsl(), frexpl(), ldexpl(); -long double polevll(), p1evll(), powil(); -static long double reducl(); -int isnanl(), isfinitel(), signbitl(); -#endif - -#ifdef INFINITIES -extern long double INFINITYL; -#else -#define INFINITYL MAXNUML -#endif - -#ifdef NANS -extern long double NANL; -#endif -#ifdef MINUSZERO -extern long double NEGZEROL; -#endif - -long double powl( x, y ) -long double x, y; -{ -/* double F, Fa, Fb, G, Ga, Gb, H, Ha, Hb */ -int i, nflg, iyflg, yoddint; -long e; - -if( y == 0.0L ) - return( 1.0L ); - -#ifdef NANS -if( isnanl(x) ) - return( x ); -if( isnanl(y) ) - return( y ); -#endif - -if( y == 1.0L ) - return( x ); - -#ifdef INFINITIES -if( !isfinitel(y) && (x == -1.0L || x == 1.0L) ) - { - mtherr( "powl", DOMAIN ); -#ifdef NANS - return( NANL ); -#else - return( INFINITYL ); -#endif - } -#endif - -if( x == 1.0L ) - return( 1.0L ); - -if( y >= MAXNUML ) - { -#ifdef INFINITIES - if( x > 1.0L ) - return( INFINITYL ); -#else - if( x > 1.0L ) - return( MAXNUML ); -#endif - if( x > 0.0L && x < 1.0L ) - return( 0.0L ); -#ifdef INFINITIES - if( x < -1.0L ) - return( INFINITYL ); -#else - if( x < -1.0L ) - return( MAXNUML ); -#endif - if( x > -1.0L && x < 0.0L ) - return( 0.0L ); - } -if( y <= -MAXNUML ) - { - if( x > 1.0L ) - return( 0.0L ); -#ifdef INFINITIES - if( x > 0.0L && x < 1.0L ) - return( INFINITYL ); -#else - if( x > 0.0L && x < 1.0L ) - return( MAXNUML ); -#endif - if( x < -1.0L ) - return( 0.0L ); -#ifdef INFINITIES - if( x > -1.0L && x < 0.0L ) - return( INFINITYL ); -#else - if( x > -1.0L && x < 0.0L ) - return( MAXNUML ); -#endif - } -if( x >= MAXNUML ) - { -#if INFINITIES - if( y > 0.0L ) - return( INFINITYL ); -#else - if( y > 0.0L ) - return( MAXNUML ); -#endif - return( 0.0L ); - } - -w = floorl(y); -/* Set iyflg to 1 if y is an integer. */ -iyflg = 0; -if( w == y ) - iyflg = 1; - -/* Test for odd integer y. */ -yoddint = 0; -if( iyflg ) - { - ya = fabsl(y); - ya = floorl(0.5L * ya); - yb = 0.5L * fabsl(w); - if( ya != yb ) - yoddint = 1; - } - -if( x <= -MAXNUML ) - { - if( y > 0.0L ) - { -#ifdef INFINITIES - if( yoddint ) - return( -INFINITYL ); - return( INFINITYL ); -#else - if( yoddint ) - return( -MAXNUML ); - return( MAXNUML ); -#endif - } - if( y < 0.0L ) - { -#ifdef MINUSZERO - if( yoddint ) - return( NEGZEROL ); -#endif - return( 0.0 ); - } - } - - -nflg = 0; /* flag = 1 if x<0 raised to integer power */ -if( x <= 0.0L ) - { - if( x == 0.0L ) - { - if( y < 0.0 ) - { -#ifdef MINUSZERO - if( signbitl(x) && yoddint ) - return( -INFINITYL ); -#endif -#ifdef INFINITIES - return( INFINITYL ); -#else - return( MAXNUML ); -#endif - } - if( y > 0.0 ) - { -#ifdef MINUSZERO - if( signbitl(x) && yoddint ) - return( NEGZEROL ); -#endif - return( 0.0 ); - } - if( y == 0.0L ) - return( 1.0L ); /* 0**0 */ - else - return( 0.0L ); /* 0**y */ - } - else - { - if( iyflg == 0 ) - { /* noninteger power of negative number */ - mtherr( fname, DOMAIN ); -#ifdef NANS - return(NANL); -#else - return(0.0L); -#endif - } - nflg = 1; - } - } - -/* Integer power of an integer. */ - -if( iyflg ) - { - i = w; - w = floorl(x); - if( (w == x) && (fabsl(y) < 32768.0) ) - { - w = powil( x, (int) y ); - return( w ); - } - } - - -if( nflg ) - x = fabsl(x); - -/* separate significand from exponent */ -x = frexpl( x, &i ); -e = i; - -/* find significand in antilog table A[] */ -i = 1; -if( x <= douba(17) ) - i = 17; -if( x <= douba(i+8) ) - i += 8; -if( x <= douba(i+4) ) - i += 4; -if( x <= douba(i+2) ) - i += 2; -if( x >= douba(1) ) - i = -1; -i += 1; - - -/* Find (x - A[i])/A[i] - * in order to compute log(x/A[i]): - * - * log(x) = log( a x/a ) = log(a) + log(x/a) - * - * log(x/a) = log(1+v), v = x/a - 1 = (x-a)/a - */ -x -= douba(i); -x -= doubb(i/2); -x /= douba(i); - - -/* rational approximation for log(1+v): - * - * log(1+v) = v - v**2/2 + v**3 P(v) / Q(v) - */ -z = x*x; -w = x * ( z * polevll( x, P, 3 ) / p1evll( x, Q, 3 ) ); -w = w - ldexpl( z, -1 ); /* w - 0.5 * z */ - -/* Convert to base 2 logarithm: - * multiply by log2(e) = 1 + LOG2EA - */ -z = LOG2EA * w; -z += w; -z += LOG2EA * x; -z += x; - -/* Compute exponent term of the base 2 logarithm. */ -w = -i; -w = ldexpl( w, -LNXT ); /* divide by NXT */ -w += e; -/* Now base 2 log of x is w + z. */ - -/* Multiply base 2 log by y, in extended precision. */ - -/* separate y into large part ya - * and small part yb less than 1/NXT - */ -ya = reducl(y); -yb = y - ya; - -/* (w+z)(ya+yb) - * = w*ya + w*yb + z*y - */ -F = z * y + w * yb; -Fa = reducl(F); -Fb = F - Fa; - -G = Fa + w * ya; -Ga = reducl(G); -Gb = G - Ga; - -H = Fb + Gb; -Ha = reducl(H); -w = ldexpl( Ga+Ha, LNXT ); - -/* Test the power of 2 for overflow */ -if( w > MEXP ) - { -/* printf( "w = %.4Le ", w ); */ - mtherr( fname, OVERFLOW ); - return( MAXNUML ); - } - -if( w < MNEXP ) - { -/* printf( "w = %.4Le ", w ); */ - mtherr( fname, UNDERFLOW ); - return( 0.0L ); - } - -e = w; -Hb = H - Ha; - -if( Hb > 0.0L ) - { - e += 1; - Hb -= (1.0L/NXT); /*0.0625L;*/ - } - -/* Now the product y * log2(x) = Hb + e/NXT. - * - * Compute base 2 exponential of Hb, - * where -0.0625 <= Hb <= 0. - */ -z = Hb * polevll( Hb, R, 6 ); /* z = 2**Hb - 1 */ - -/* Express e/NXT as an integer plus a negative number of (1/NXT)ths. - * Find lookup table entry for the fractional power of 2. - */ -if( e < 0 ) - i = 0; -else - i = 1; -i = e/NXT + i; -e = NXT*i - e; -w = douba( e ); -z = w * z; /* 2**-e * ( 1 + (2**Hb-1) ) */ -z = z + w; -z = ldexpl( z, i ); /* multiply by integer power of 2 */ - -if( nflg ) - { -/* For negative x, - * find out if the integer exponent - * is odd or even. - */ - w = ldexpl( y, -1 ); - w = floorl(w); - w = ldexpl( w, 1 ); - if( w != y ) - z = -z; /* odd exponent */ - } - -return( z ); -} - - -/* Find a multiple of 1/NXT that is within 1/NXT of x. */ -static long double reducl(x) -long double x; -{ -long double t; - -t = ldexpl( x, LNXT ); -t = floorl( t ); -t = ldexpl( t, -LNXT ); -return(t); -} diff --git a/libm/ldouble/sinhl.c b/libm/ldouble/sinhl.c deleted file mode 100644 index 0533a1c7a..000000000 --- a/libm/ldouble/sinhl.c +++ /dev/null @@ -1,150 +0,0 @@ -/* sinhl.c - * - * Hyperbolic sine, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, sinhl(); - * - * y = sinhl( x ); - * - * - * - * DESCRIPTION: - * - * Returns hyperbolic sine of argument in the range MINLOGL to - * MAXLOGL. - * - * The range is partitioned into two segments. If |x| <= 1, a - * rational function of the form x + x**3 P(x)/Q(x) is employed. - * Otherwise the calculation is sinh(x) = ( exp(x) - exp(-x) )/2. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -2,2 10000 1.5e-19 3.9e-20 - * IEEE +-10000 30000 1.1e-19 2.8e-20 - * - */ - -/* -Cephes Math Library Release 2.7: January, 1998 -Copyright 1984, 1991, 1998 by Stephen L. Moshier -*/ - -#include <math.h> - -#ifdef UNK -static long double P[] = { - 1.7550769032975377032681E-6L, - 4.1680702175874268714539E-4L, - 3.0993532520425419002409E-2L, - 9.9999999999999999998002E-1L, -}; -static long double Q[] = { - 1.7453965448620151484660E-8L, --5.9116673682651952419571E-6L, - 1.0599252315677389339530E-3L, --1.1403880487744749056675E-1L, - 6.0000000000000000000200E0L, -}; -#endif - -#ifdef IBMPC -static short P[] = { -0xec6a,0xd942,0xfbb3,0xeb8f,0x3feb, XPD -0x365e,0xb30a,0xe437,0xda86,0x3ff3, XPD -0x8890,0x01f6,0x2612,0xfde6,0x3ff9, XPD -0x0000,0x0000,0x0000,0x8000,0x3fff, XPD -}; -static short Q[] = { -0x4edd,0x4c21,0xad09,0x95ed,0x3fe5, XPD -0x4376,0x9b70,0xd605,0xc65c,0xbfed, XPD -0xc8ad,0x5d21,0x3069,0x8aed,0x3ff5, XPD -0x9c32,0x6374,0x2d4b,0xe98d,0xbffb, XPD -0x0000,0x0000,0x0000,0xc000,0x4001, XPD -}; -#endif - -#ifdef MIEEE -static long P[] = { -0x3feb0000,0xeb8ffbb3,0xd942ec6a, -0x3ff30000,0xda86e437,0xb30a365e, -0x3ff90000,0xfde62612,0x01f68890, -0x3fff0000,0x80000000,0x00000000, -}; -static long Q[] = { -0x3fe50000,0x95edad09,0x4c214edd, -0xbfed0000,0xc65cd605,0x9b704376, -0x3ff50000,0x8aed3069,0x5d21c8ad, -0xbffb0000,0xe98d2d4b,0x63749c32, -0x40010000,0xc0000000,0x00000000, -}; -#endif - -extern long double MAXNUML, MAXLOGL, MINLOGL, LOGE2L; -#ifdef ANSIPROT -extern long double fabsl ( long double ); -extern long double expl ( long double ); -extern long double polevll ( long double, void *, int ); -extern long double p1evll ( long double, void *, int ); -#else -long double fabsl(), expl(), polevll(), p1evll(); -#endif -#ifdef INFINITIES -extern long double INFINITYL; -#endif -#ifdef NANS -extern long double NANL; -#endif - -long double sinhl(x) -long double x; -{ -long double a; - -#ifdef MINUSZERO -if( x == 0.0 ) - return(x); -#endif -a = fabsl(x); -if( (x > (MAXLOGL + LOGE2L)) || (x > -(MINLOGL-LOGE2L) ) ) - { - mtherr( "sinhl", DOMAIN ); -#ifdef INFINITIES - if( x > 0.0L ) - return( INFINITYL ); - else - return( -INFINITYL ); -#else - if( x > 0.0L ) - return( MAXNUML ); - else - return( -MAXNUML ); -#endif - } -if( a > 1.0L ) - { - if( a >= (MAXLOGL - LOGE2L) ) - { - a = expl(0.5L*a); - a = (0.5L * a) * a; - if( x < 0.0L ) - a = -a; - return(a); - } - a = expl(a); - a = 0.5L*a - (0.5L/a); - if( x < 0.0L ) - a = -a; - return(a); - } - -a *= a; -return( x + x * a * (polevll(a,P,3)/polevll(a,Q,4)) ); -} diff --git a/libm/ldouble/sinl.c b/libm/ldouble/sinl.c deleted file mode 100644 index dc7d739f9..000000000 --- a/libm/ldouble/sinl.c +++ /dev/null @@ -1,342 +0,0 @@ -/* sinl.c - * - * Circular sine, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, sinl(); - * - * y = sinl( x ); - * - * - * - * DESCRIPTION: - * - * Range reduction is into intervals of pi/4. The reduction - * error is nearly eliminated by contriving an extended precision - * modular arithmetic. - * - * Two polynomial approximating functions are employed. - * Between 0 and pi/4 the sine is approximated by the Cody - * and Waite polynomial form - * x + x**3 P(x**2) . - * Between pi/4 and pi/2 the cosine is represented as - * 1 - .5 x**2 + x**4 Q(x**2) . - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE +-5.5e11 200,000 1.2e-19 2.9e-20 - * - * ERROR MESSAGES: - * - * message condition value returned - * sin total loss x > 2**39 0.0 - * - * Loss of precision occurs for x > 2**39 = 5.49755813888e11. - * The routine as implemented flags a TLOSS error for - * x > 2**39 and returns 0.0. - */ - /* cosl.c - * - * Circular cosine, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, cosl(); - * - * y = cosl( x ); - * - * - * - * DESCRIPTION: - * - * Range reduction is into intervals of pi/4. The reduction - * error is nearly eliminated by contriving an extended precision - * modular arithmetic. - * - * Two polynomial approximating functions are employed. - * Between 0 and pi/4 the cosine is approximated by - * 1 - .5 x**2 + x**4 Q(x**2) . - * Between pi/4 and pi/2 the sine is represented by the Cody - * and Waite polynomial form - * x + x**3 P(x**2) . - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE +-5.5e11 50000 1.2e-19 2.9e-20 - */ - -/* sin.c */ - -/* -Cephes Math Library Release 2.7: May, 1998 -Copyright 1985, 1990, 1998 by Stephen L. Moshier -*/ - -#include <math.h> - -#ifdef UNK -static long double sincof[7] = { --7.5785404094842805756289E-13L, - 1.6058363167320443249231E-10L, --2.5052104881870868784055E-8L, - 2.7557319214064922217861E-6L, --1.9841269841254799668344E-4L, - 8.3333333333333225058715E-3L, --1.6666666666666666640255E-1L, -}; -static long double coscof[7] = { - 4.7377507964246204691685E-14L, --1.1470284843425359765671E-11L, - 2.0876754287081521758361E-9L, --2.7557319214999787979814E-7L, - 2.4801587301570552304991E-5L, --1.3888888888888872993737E-3L, - 4.1666666666666666609054E-2L, -}; -static long double DP1 = 7.853981554508209228515625E-1L; -static long double DP2 = 7.946627356147928367136046290398E-9L; -static long double DP3 = 3.061616997868382943065164830688E-17L; -#endif - -#ifdef IBMPC -static short sincof[] = { -0x4e27,0xe1d6,0x2389,0xd551,0xbfd6, XPD -0x64d7,0xe706,0x4623,0xb090,0x3fde, XPD -0x01b1,0xbf34,0x2946,0xd732,0xbfe5, XPD -0xc8f7,0x9845,0x1d29,0xb8ef,0x3fec, XPD -0x6514,0x0c53,0x00d0,0xd00d,0xbff2, XPD -0x569a,0x8888,0x8888,0x8888,0x3ff8, XPD -0xaa97,0xaaaa,0xaaaa,0xaaaa,0xbffc, XPD -}; -static short coscof[] = { -0x7436,0x6f99,0x8c3a,0xd55e,0x3fd2, XPD -0x2f37,0x58f4,0x920f,0xc9c9,0xbfda, XPD -0x5350,0x659e,0xc648,0x8f76,0x3fe2, XPD -0x4d2b,0xf5c6,0x7dba,0x93f2,0xbfe9, XPD -0x53ed,0x0c66,0x00d0,0xd00d,0x3fef, XPD -0x7b67,0x0b60,0x60b6,0xb60b,0xbff5, XPD -0xaa9a,0xaaaa,0xaaaa,0xaaaa,0x3ffa, XPD -}; -static short P1[] = {0x0000,0x0000,0xda80,0xc90f,0x3ffe, XPD}; -static short P2[] = {0x0000,0x0000,0xa300,0x8885,0x3fe4, XPD}; -static short P3[] = {0x3707,0xa2e0,0x3198,0x8d31,0x3fc8, XPD}; -#define DP1 *(long double *)P1 -#define DP2 *(long double *)P2 -#define DP3 *(long double *)P3 -#endif - -#ifdef MIEEE -static long sincof[] = { -0xbfd60000,0xd5512389,0xe1d64e27, -0x3fde0000,0xb0904623,0xe70664d7, -0xbfe50000,0xd7322946,0xbf3401b1, -0x3fec0000,0xb8ef1d29,0x9845c8f7, -0xbff20000,0xd00d00d0,0x0c536514, -0x3ff80000,0x88888888,0x8888569a, -0xbffc0000,0xaaaaaaaa,0xaaaaaa97, -}; -static long coscof[] = { -0x3fd20000,0xd55e8c3a,0x6f997436, -0xbfda0000,0xc9c9920f,0x58f42f37, -0x3fe20000,0x8f76c648,0x659e5350, -0xbfe90000,0x93f27dba,0xf5c64d2b, -0x3fef0000,0xd00d00d0,0x0c6653ed, -0xbff50000,0xb60b60b6,0x0b607b67, -0x3ffa0000,0xaaaaaaaa,0xaaaaaa9a, -}; -static long P1[] = {0x3ffe0000,0xc90fda80,0x00000000}; -static long P2[] = {0x3fe40000,0x8885a300,0x00000000}; -static long P3[] = {0x3fc80000,0x8d313198,0xa2e03707}; -#define DP1 *(long double *)P1 -#define DP2 *(long double *)P2 -#define DP3 *(long double *)P3 -#endif - -static long double lossth = 5.49755813888e11L; /* 2^39 */ -extern long double PIO4L; -#ifdef ANSIPROT -extern long double polevll ( long double, void *, int ); -extern long double floorl ( long double ); -extern long double ldexpl ( long double, int ); -extern int isnanl ( long double ); -extern int isfinitel ( long double ); -#else -long double polevll(), floorl(), ldexpl(), isnanl(), isfinitel(); -#endif -#ifdef INFINITIES -extern long double INFINITYL; -#endif -#ifdef NANS -extern long double NANL; -#endif - -long double sinl(x) -long double x; -{ -long double y, z, zz; -int j, sign; - -#ifdef NANS -if( isnanl(x) ) - return(x); -#endif -#ifdef MINUSZERO -if( x == 0.0L ) - return(x); -#endif -#ifdef NANS -if( !isfinitel(x) ) - { - mtherr( "sinl", DOMAIN ); -#ifdef NANS - return(NANL); -#else - return(0.0L); -#endif - } -#endif -/* make argument positive but save the sign */ -sign = 1; -if( x < 0 ) - { - x = -x; - sign = -1; - } - -if( x > lossth ) - { - mtherr( "sinl", TLOSS ); - return(0.0L); - } - -y = floorl( x/PIO4L ); /* integer part of x/PIO4 */ - -/* strip high bits of integer part to prevent integer overflow */ -z = ldexpl( y, -4 ); -z = floorl(z); /* integer part of y/8 */ -z = y - ldexpl( z, 4 ); /* y - 16 * (y/16) */ - -j = z; /* convert to integer for tests on the phase angle */ -/* map zeros to origin */ -if( j & 1 ) - { - j += 1; - y += 1.0L; - } -j = j & 07; /* octant modulo 360 degrees */ -/* reflect in x axis */ -if( j > 3) - { - sign = -sign; - j -= 4; - } - -/* Extended precision modular arithmetic */ -z = ((x - y * DP1) - y * DP2) - y * DP3; - -zz = z * z; -if( (j==1) || (j==2) ) - { - y = 1.0L - ldexpl(zz,-1) + zz * zz * polevll( zz, coscof, 6 ); - } -else - { - y = z + z * (zz * polevll( zz, sincof, 6 )); - } - -if(sign < 0) - y = -y; - -return(y); -} - - - - - -long double cosl(x) -long double x; -{ -long double y, z, zz; -long i; -int j, sign; - - -#ifdef NANS -if( isnanl(x) ) - return(x); -#endif -#ifdef INFINITIES -if( !isfinitel(x) ) - { - mtherr( "cosl", DOMAIN ); -#ifdef NANS - return(NANL); -#else - return(0.0L); -#endif - } -#endif - -/* make argument positive */ -sign = 1; -if( x < 0 ) - x = -x; - -if( x > lossth ) - { - mtherr( "cosl", TLOSS ); - return(0.0L); - } - -y = floorl( x/PIO4L ); -z = ldexpl( y, -4 ); -z = floorl(z); /* integer part of y/8 */ -z = y - ldexpl( z, 4 ); /* y - 16 * (y/16) */ - -/* integer and fractional part modulo one octant */ -i = z; -if( i & 1 ) /* map zeros to origin */ - { - i += 1; - y += 1.0L; - } -j = i & 07; -if( j > 3) - { - j -=4; - sign = -sign; - } - -if( j > 1 ) - sign = -sign; - -/* Extended precision modular arithmetic */ -z = ((x - y * DP1) - y * DP2) - y * DP3; - -zz = z * z; -if( (j==1) || (j==2) ) - { - y = z + z * (zz * polevll( zz, sincof, 6 )); - } -else - { - y = 1.0L - ldexpl(zz,-1) + zz * zz * polevll( zz, coscof, 6 ); - } - -if(sign < 0) - y = -y; - -return(y); -} diff --git a/libm/ldouble/sqrtl.c b/libm/ldouble/sqrtl.c deleted file mode 100644 index a3b17175f..000000000 --- a/libm/ldouble/sqrtl.c +++ /dev/null @@ -1,172 +0,0 @@ -/* sqrtl.c - * - * Square root, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, sqrtl(); - * - * y = sqrtl( x ); - * - * - * - * DESCRIPTION: - * - * Returns the square root of x. - * - * Range reduction involves isolating the power of two of the - * argument and using a polynomial approximation to obtain - * a rough value for the square root. Then Heron's iteration - * is used three times to converge to an accurate value. - * - * Note, some arithmetic coprocessors such as the 8087 and - * 68881 produce correctly rounded square roots, which this - * routine will not. - * - * ACCURACY: - * - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 0,10 30000 8.1e-20 3.1e-20 - * - * - * ERROR MESSAGES: - * - * message condition value returned - * sqrt domain x < 0 0.0 - * - */ - -/* -Cephes Math Library Release 2.2: December, 1990 -Copyright 1984, 1990 by Stephen L. Moshier -Direct inquiries to 30 Frost Street, Cambridge, MA 02140 -*/ - - -#include <math.h> - -#define SQRT2 1.4142135623730950488017E0L -#ifdef ANSIPROT -extern long double frexpl ( long double, int * ); -extern long double ldexpl ( long double, int ); -#else -long double frexpl(), ldexpl(); -#endif - -long double sqrtl(x) -long double x; -{ -int e; -long double z, w; -#ifndef UNK -short *q; -#endif - -if( x <= 0.0 ) - { - if( x < 0.0 ) - mtherr( "sqrtl", DOMAIN ); - return( 0.0 ); - } -w = x; -/* separate exponent and significand */ -#ifdef UNK -z = frexpl( x, &e ); -#endif - -/* Note, frexp and ldexp are used in order to - * handle denormal numbers properly. - */ -#ifdef IBMPC -z = frexpl( x, &e ); -q = (short *)&x; /* point to the exponent word */ -q += 4; -/* -e = ((*q >> 4) & 0x0fff) - 0x3fe; -*q &= 0x000f; -*q |= 0x3fe0; -z = x; -*/ -#endif -#ifdef MIEEE -z = frexpl( x, &e ); -q = (short *)&x; -/* -e = ((*q >> 4) & 0x0fff) - 0x3fe; -*q &= 0x000f; -*q |= 0x3fe0; -z = x; -*/ -#endif - -/* approximate square root of number between 0.5 and 1 - * relative error of linear approximation = 7.47e-3 - */ -/* -x = 0.4173075996388649989089L + 0.59016206709064458299663L * z; -*/ - -/* quadratic approximation, relative error 6.45e-4 */ -x = ( -0.20440583154734771959904L * z - + 0.89019407351052789754347L) * z - + 0.31356706742295303132394L; - -/* adjust for odd powers of 2 */ -if( (e & 1) != 0 ) - x *= SQRT2; - -/* re-insert exponent */ -#ifdef UNK -x = ldexpl( x, (e >> 1) ); -#endif -#ifdef IBMPC -x = ldexpl( x, (e >> 1) ); -/* -*q += ((e >>1) & 0x7ff) << 4; -*q &= 077777; -*/ -#endif -#ifdef MIEEE -x = ldexpl( x, (e >> 1) ); -/* -*q += ((e >>1) & 0x7ff) << 4; -*q &= 077777; -*/ -#endif - -/* Newton iterations: */ -#ifdef UNK -x += w/x; -x = ldexpl( x, -1 ); /* divide by 2 */ -x += w/x; -x = ldexpl( x, -1 ); -x += w/x; -x = ldexpl( x, -1 ); -#endif - -/* Note, assume the square root cannot be denormal, - * so it is safe to use integer exponent operations here. - */ -#ifdef IBMPC -x += w/x; -*q -= 1; -x += w/x; -*q -= 1; -x += w/x; -*q -= 1; -#endif -#ifdef MIEEE -x += w/x; -*q -= 1; -x += w/x; -*q -= 1; -x += w/x; -*q -= 1; -#endif - -return(x); -} diff --git a/libm/ldouble/stdtrl.c b/libm/ldouble/stdtrl.c deleted file mode 100644 index 4218d4133..000000000 --- a/libm/ldouble/stdtrl.c +++ /dev/null @@ -1,225 +0,0 @@ -/* stdtrl.c - * - * Student's t distribution - * - * - * - * SYNOPSIS: - * - * long double p, t, stdtrl(); - * int k; - * - * p = stdtrl( k, t ); - * - * - * DESCRIPTION: - * - * Computes the integral from minus infinity to t of the Student - * t distribution with integer k > 0 degrees of freedom: - * - * t - * - - * | | - * - | 2 -(k+1)/2 - * | ( (k+1)/2 ) | ( x ) - * ---------------------- | ( 1 + --- ) dx - * - | ( k ) - * sqrt( k pi ) | ( k/2 ) | - * | | - * - - * -inf. - * - * Relation to incomplete beta integral: - * - * 1 - stdtr(k,t) = 0.5 * incbet( k/2, 1/2, z ) - * where - * z = k/(k + t**2). - * - * For t < -1.6, this is the method of computation. For higher t, - * a direct method is derived from integration by parts. - * Since the function is symmetric about t=0, the area under the - * right tail of the density is found by calling the function - * with -t instead of t. - * - * ACCURACY: - * - * Tested at random 1 <= k <= 100. The "domain" refers to t. - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -100,-1.6 10000 5.7e-18 9.8e-19 - * IEEE -1.6,100 10000 3.8e-18 1.0e-19 - */ - -/* stdtril.c - * - * Functional inverse of Student's t distribution - * - * - * - * SYNOPSIS: - * - * long double p, t, stdtril(); - * int k; - * - * t = stdtril( k, p ); - * - * - * DESCRIPTION: - * - * Given probability p, finds the argument t such that stdtrl(k,t) - * is equal to p. - * - * ACCURACY: - * - * Tested at random 1 <= k <= 100. The "domain" refers to p: - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 0,1 3500 4.2e-17 4.1e-18 - */ - - -/* -Cephes Math Library Release 2.3: January, 1995 -Copyright 1984, 1995 by Stephen L. Moshier -*/ - -#include <math.h> - -extern long double PIL, MACHEPL, MAXNUML; -#ifdef ANSIPROT -extern long double sqrtl ( long double ); -extern long double atanl ( long double ); -extern long double incbetl ( long double, long double, long double ); -extern long double incbil ( long double, long double, long double ); -extern long double fabsl ( long double ); -#else -long double sqrtl(), atanl(), incbetl(), incbil(), fabsl(); -#endif - -long double stdtrl( k, t ) -int k; -long double t; -{ -long double x, rk, z, f, tz, p, xsqk; -int j; - -if( k <= 0 ) - { - mtherr( "stdtrl", DOMAIN ); - return(0.0L); - } - -if( t == 0.0L ) - return( 0.5L ); - -if( t < -1.6L ) - { - rk = k; - z = rk / (rk + t * t); - p = 0.5L * incbetl( 0.5L*rk, 0.5L, z ); - return( p ); - } - -/* compute integral from -t to + t */ - -if( t < 0.0L ) - x = -t; -else - x = t; - -rk = k; /* degrees of freedom */ -z = 1.0L + ( x * x )/rk; - -/* test if k is odd or even */ -if( (k & 1) != 0) - { - - /* computation for odd k */ - - xsqk = x/sqrtl(rk); - p = atanl( xsqk ); - if( k > 1 ) - { - f = 1.0L; - tz = 1.0L; - j = 3; - while( (j<=(k-2)) && ( (tz/f) > MACHEPL ) ) - { - tz *= (j-1)/( z * j ); - f += tz; - j += 2; - } - p += f * xsqk/z; - } - p *= 2.0L/PIL; - } - - -else - { - - /* computation for even k */ - - f = 1.0L; - tz = 1.0L; - j = 2; - - while( ( j <= (k-2) ) && ( (tz/f) > MACHEPL ) ) - { - tz *= (j - 1)/( z * j ); - f += tz; - j += 2; - } - p = f * x/sqrtl(z*rk); - } - -/* common exit */ - - -if( t < 0.0L ) - p = -p; /* note destruction of relative accuracy */ - - p = 0.5L + 0.5L * p; -return(p); -} - - -long double stdtril( k, p ) -int k; -long double p; -{ -long double t, rk, z; -int rflg; - -if( k <= 0 || p <= 0.0L || p >= 1.0L ) - { - mtherr( "stdtril", DOMAIN ); - return(0.0L); - } - -rk = k; - -if( p > 0.25L && p < 0.75L ) - { - if( p == 0.5L ) - return( 0.0L ); - z = 1.0L - 2.0L * p; - z = incbil( 0.5L, 0.5L*rk, fabsl(z) ); - t = sqrtl( rk*z/(1.0L-z) ); - if( p < 0.5L ) - t = -t; - return( t ); - } -rflg = -1; -if( p >= 0.5L) - { - p = 1.0L - p; - rflg = 1; - } -z = incbil( 0.5L*rk, 0.5L, 2.0L*p ); - -if( MAXNUML * z < rk ) - return(rflg* MAXNUML); -t = sqrtl( rk/z - rk ); -return( rflg * t ); -} diff --git a/libm/ldouble/tanhl.c b/libm/ldouble/tanhl.c deleted file mode 100644 index 42c7133c3..000000000 --- a/libm/ldouble/tanhl.c +++ /dev/null @@ -1,129 +0,0 @@ -/* tanhl.c - * - * Hyperbolic tangent, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, tanhl(); - * - * y = tanhl( x ); - * - * - * - * DESCRIPTION: - * - * Returns hyperbolic tangent of argument in the range MINLOGL to - * MAXLOGL. - * - * A rational function is used for |x| < 0.625. The form - * x + x**3 P(x)/Q(x) of Cody _& Waite is employed. - * Otherwise, - * tanh(x) = sinh(x)/cosh(x) = 1 - 2/(exp(2x) + 1). - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE -2,2 30000 1.3e-19 2.4e-20 - * - */ - -/* -Cephes Math Library Release 2.7: May, 1998 -Copyright 1984, 1987, 1989, 1998 by Stephen L. Moshier -*/ - -#include <math.h> - -#ifdef UNK -static long double P[] = { --6.8473739392677100872869E-5L, --9.5658283111794641589011E-1L, --8.4053568599672284488465E1L, --1.3080425704712825945553E3L, -}; -static long double Q[] = { -/* 1.0000000000000000000000E0L,*/ - 9.6259501838840336946872E1L, - 1.8218117903645559060232E3L, - 3.9241277114138477845780E3L, -}; -#endif - -#ifdef IBMPC -static short P[] = { -0xd2a4,0x1b0c,0x8f15,0x8f99,0xbff1, XPD -0x5959,0x9111,0x9cc7,0xf4e2,0xbffe, XPD -0xb576,0xef5e,0x6d57,0xa81b,0xc005, XPD -0xe3be,0xbfbd,0x5cbc,0xa381,0xc009, XPD -}; -static short Q[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ -0x687f,0xce24,0xdd6c,0xc084,0x4005, XPD -0x3793,0xc95f,0xfa2f,0xe3b9,0x4009, XPD -0xd5a2,0x1f9c,0x0b1b,0xf542,0x400a, XPD -}; -#endif - -#ifdef MIEEE -static long P[] = { -0xbff10000,0x8f998f15,0x1b0cd2a4, -0xbffe0000,0xf4e29cc7,0x91115959, -0xc0050000,0xa81b6d57,0xef5eb576, -0xc0090000,0xa3815cbc,0xbfbde3be, -}; -static long Q[] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0x40050000,0xc084dd6c,0xce24687f, -0x40090000,0xe3b9fa2f,0xc95f3793, -0x400a0000,0xf5420b1b,0x1f9cd5a2, -}; -#endif - -extern long double MAXLOGL; -#ifdef ANSIPROT -extern long double fabsl ( long double ); -extern long double expl ( long double ); -extern long double polevll ( long double, void *, int ); -extern long double p1evll ( long double, void *, int ); -#else -long double fabsl(), expl(), polevll(), p1evll(); -#endif - -long double tanhl(x) -long double x; -{ -long double s, z; - -#ifdef MINUSZERO -if( x == 0.0L ) - return(x); -#endif -z = fabsl(x); -if( z > 0.5L * MAXLOGL ) - { - if( x > 0 ) - return( 1.0L ); - else - return( -1.0L ); - } -if( z >= 0.625L ) - { - s = expl(2.0*z); - z = 1.0L - 2.0/(s + 1.0L); - if( x < 0 ) - z = -z; - } -else - { - s = x * x; - z = polevll( s, P, 3 )/p1evll(s, Q, 3); - z = x * s * z; - z = x + z; - } -return( z ); -} diff --git a/libm/ldouble/tanl.c b/libm/ldouble/tanl.c deleted file mode 100644 index e546dd664..000000000 --- a/libm/ldouble/tanl.c +++ /dev/null @@ -1,279 +0,0 @@ -/* tanl.c - * - * Circular tangent, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, tanl(); - * - * y = tanl( x ); - * - * - * - * DESCRIPTION: - * - * Returns the circular tangent of the radian argument x. - * - * Range reduction is modulo pi/4. A rational function - * x + x**3 P(x**2)/Q(x**2) - * is employed in the basic interval [0, pi/4]. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE +-1.07e9 30000 1.9e-19 4.8e-20 - * - * ERROR MESSAGES: - * - * message condition value returned - * tan total loss x > 2^39 0.0 - * - */ - /* cotl.c - * - * Circular cotangent, long double precision - * - * - * - * SYNOPSIS: - * - * long double x, y, cotl(); - * - * y = cotl( x ); - * - * - * - * DESCRIPTION: - * - * Returns the circular cotangent of the radian argument x. - * - * Range reduction is modulo pi/4. A rational function - * x + x**3 P(x**2)/Q(x**2) - * is employed in the basic interval [0, pi/4]. - * - * - * - * ACCURACY: - * - * Relative error: - * arithmetic domain # trials peak rms - * IEEE +-1.07e9 30000 1.9e-19 5.1e-20 - * - * - * ERROR MESSAGES: - * - * message condition value returned - * cot total loss x > 2^39 0.0 - * cot singularity x = 0 INFINITYL - * - */ - -/* -Cephes Math Library Release 2.7: May, 1998 -Copyright 1984, 1990, 1998 by Stephen L. Moshier -*/ - -#include <math.h> - -#ifdef UNK -static long double P[] = { --1.3093693918138377764608E4L, - 1.1535166483858741613983E6L, --1.7956525197648487798769E7L, -}; -static long double Q[] = { -/* 1.0000000000000000000000E0L,*/ - 1.3681296347069295467845E4L, --1.3208923444021096744731E6L, - 2.5008380182335791583922E7L, --5.3869575592945462988123E7L, -}; -static long double DP1 = 7.853981554508209228515625E-1L; -static long double DP2 = 7.946627356147928367136046290398E-9L; -static long double DP3 = 3.061616997868382943065164830688E-17L; -#endif - - -#ifdef IBMPC -static short P[] = { -0xbc1c,0x79f9,0xc692,0xcc96,0xc00c, XPD -0xe5b1,0xe4ee,0x652f,0x8ccf,0x4013, XPD -0xaf9a,0x4c8b,0x5699,0x88ff,0xc017, XPD -}; -static short Q[] = { -/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ -0x8ed4,0x9b2b,0x2f75,0xd5c5,0x400c, XPD -0xadcd,0x55e4,0xe2c1,0xa13d,0xc013, XPD -0x7adf,0x56c7,0x7e17,0xbecc,0x4017, XPD -0x86f6,0xf2d1,0x01e5,0xcd7f,0xc018, XPD -}; -static short P1[] = {0x0000,0x0000,0xda80,0xc90f,0x3ffe, XPD}; -static short P2[] = {0x0000,0x0000,0xa300,0x8885,0x3fe4, XPD}; -static short P3[] = {0x3707,0xa2e0,0x3198,0x8d31,0x3fc8, XPD}; -#define DP1 *(long double *)P1 -#define DP2 *(long double *)P2 -#define DP3 *(long double *)P3 -#endif - -#ifdef MIEEE -static long P[] = { -0xc00c0000,0xcc96c692,0x79f9bc1c, -0x40130000,0x8ccf652f,0xe4eee5b1, -0xc0170000,0x88ff5699,0x4c8baf9a, -}; -static long Q[] = { -/*0x3fff0000,0x80000000,0x00000000,*/ -0x400c0000,0xd5c52f75,0x9b2b8ed4, -0xc0130000,0xa13de2c1,0x55e4adcd, -0x40170000,0xbecc7e17,0x56c77adf, -0xc0180000,0xcd7f01e5,0xf2d186f6, -}; -static long P1[] = {0x3ffe0000,0xc90fda80,0x00000000}; -static long P2[] = {0x3fe40000,0x8885a300,0x00000000}; -static long P3[] = {0x3fc80000,0x8d313198,0xa2e03707}; -#define DP1 *(long double *)P1 -#define DP2 *(long double *)P2 -#define DP3 *(long double *)P3 -#endif - -static long double lossth = 5.49755813888e11L; /* 2^39 */ -extern long double PIO4L; -extern long double MAXNUML; - -#ifdef ANSIPROT -extern long double polevll ( long double, void *, int ); -extern long double p1evll ( long double, void *, int ); -extern long double floorl ( long double ); -extern long double ldexpl ( long double, int ); -extern int isnanl ( long double ); -extern int isfinitel ( long double ); -static long double tancotl( long double, int ); -#else -long double polevll(), p1evll(), floorl(), ldexpl(), isnanl(), isfinitel(); -static long double tancotl(); -#endif -#ifdef INFINITIES -extern long double INFINITYL; -#endif -#ifdef NANS -extern long double NANL; -#endif - -long double tanl(x) -long double x; -{ - -#ifdef NANS -if( isnanl(x) ) - return(x); -#endif -#ifdef MINUSZERO -if( x == 0.0L ) - return(x); -#endif -#ifdef NANS -if( !isfinitel(x) ) - { - mtherr( "tanl", DOMAIN ); - return(NANL); - } -#endif -return( tancotl(x,0) ); -} - - -long double cotl(x) -long double x; -{ - -if( x == 0.0L ) - { - mtherr( "cotl", SING ); -#ifdef INFINITIES - return( INFINITYL ); -#else - return( MAXNUML ); -#endif - } -return( tancotl(x,1) ); -} - - -static long double tancotl( xx, cotflg ) -long double xx; -int cotflg; -{ -long double x, y, z, zz; -int j, sign; - -/* make argument positive but save the sign */ -if( xx < 0.0L ) - { - x = -xx; - sign = -1; - } -else - { - x = xx; - sign = 1; - } - -if( x > lossth ) - { - if( cotflg ) - mtherr( "cotl", TLOSS ); - else - mtherr( "tanl", TLOSS ); - return(0.0L); - } - -/* compute x mod PIO4 */ -y = floorl( x/PIO4L ); - -/* strip high bits of integer part */ -z = ldexpl( y, -4 ); -z = floorl(z); /* integer part of y/16 */ -z = y - ldexpl( z, 4 ); /* y - 16 * (y/16) */ - -/* integer and fractional part modulo one octant */ -j = z; - -/* map zeros and singularities to origin */ -if( j & 1 ) - { - j += 1; - y += 1.0L; - } - -z = ((x - y * DP1) - y * DP2) - y * DP3; - -zz = z * z; - -if( zz > 1.0e-20L ) - y = z + z * (zz * polevll( zz, P, 2 )/p1evll(zz, Q, 4)); -else - y = z; - -if( j & 2 ) - { - if( cotflg ) - y = -y; - else - y = -1.0L/y; - } -else - { - if( cotflg ) - y = 1.0L/y; - } - -if( sign < 0 ) - y = -y; - -return( y ); -} diff --git a/libm/ldouble/testvect.c b/libm/ldouble/testvect.c deleted file mode 100644 index 1c3ffcb91..000000000 --- a/libm/ldouble/testvect.c +++ /dev/null @@ -1,497 +0,0 @@ - -/* Test vectors for math functions. - See C9X section F.9. - - On some systems it may be necessary to modify the default exception - settings of the floating point arithmetic unit. */ - -/* -Cephes Math Library Release 2.7: May, 1998 -Copyright 1998 by Stephen L. Moshier -*/ - -#include <stdio.h> -int isfinitel (long double); - -/* Some compilers will not accept these expressions. */ - -#define ZINF 1 -#define ZMINF 2 -#define ZNANL 3 -#define ZPIL 4 -#define ZPIO2L 4 - -extern long double INFINITYL, NANL, NEGZEROL; -long double MINFL; -extern long double PIL, PIO2L, PIO4L, MACHEPL; -long double MPIL; -long double MPIO2L; -long double MPIO4L; -long double THPIO4L = 2.35619449019234492884698L; -long double MTHPIO4L = -2.35619449019234492884698L; -long double SQRT2L = 1.414213562373095048802E0L; -long double SQRTHL = 7.071067811865475244008E-1L; -long double ZEROL = 0.0L; -long double HALFL = 0.5L; -long double MHALFL = -0.5L; -long double ONEL = 1.0L; -long double MONEL = -1.0L; -long double TWOL = 2.0L; -long double MTWOL = -2.0L; -long double THREEL = 3.0L; -long double MTHREEL = -3.0L; - -/* Functions of one variable. */ -long double logl (long double); -long double expl (long double); -long double atanl (long double); -long double sinl (long double); -long double cosl (long double); -long double tanl (long double); -long double acosl (long double); -long double asinl (long double); -long double acoshl (long double); -long double asinhl (long double); -long double atanhl (long double); -long double sinhl (long double); -long double coshl (long double); -long double tanhl (long double); -long double exp2l (long double); -long double expm1l (long double); -long double log10l (long double); -long double log1pl (long double); -long double log2l (long double); -long double fabsl (long double); -long double erfl (long double); -long double erfcl (long double); -long double gammal (long double); -long double lgaml (long double); -long double floorl (long double); -long double ceill (long double); -long double cbrtl (long double); - -struct oneargument - { - char *name; /* Name of the function. */ - long double (*func) (long double); - long double *arg1; - long double *answer; - int thresh; /* Error report threshold. */ - }; - -#if 0 - {"sinl", sinl, 32767.L, 1.8750655394138942394239E-1L, 0}, - {"cosl", cosl, 32767.L, 9.8226335176928229845654E-1L, 0}, - {"tanl", tanl, 32767.L, 1.9089234430221485740826E-1L, 0}, - {"sinl", sinl, 8388607.L, 9.9234509376961249835628E-1L, 0}, - {"cosl", cosl, 8388607.L, -1.2349580912475928183718E-1L, 0}, - {"tanl", tanl, 8388607.L, -8.0354556223613614748329E0L, 0}, - {"sinl", sinl, 2147483647.L, -7.2491655514455639054829E-1L, 0}, - {"cosl", cosl, 2147483647.L, -6.8883669187794383467976E-1L, 0}, - {"tanl", tanl, 2147483647.L, 1.0523779637351339136698E0L, 0}, - {"sinl", sinl, PIO4L, 7.0710678118654752440084E-1L, 0}, - {"cosl", cosl, PIO2L, -2.50827880633416613471e-20L, 0}, -#endif - -struct oneargument test1[] = -{ - {"atanl", atanl, &ONEL, &PIO4L, 0}, - {"sinl", sinl, &PIO2L, &ONEL, 0}, - {"cosl", cosl, &PIO4L, &SQRTHL, 0}, - {"acosl", acosl, &NANL, &NANL, 0}, - {"acosl", acosl, &ONEL, &ZEROL, 0}, - {"acosl", acosl, &TWOL, &NANL, 0}, - {"acosl", acosl, &MTWOL, &NANL, 0}, - {"asinl", asinl, &NANL, &NANL, 0}, - {"asinl", asinl, &ZEROL, &ZEROL, 0}, - {"asinl", asinl, &NEGZEROL, &NEGZEROL, 0}, - {"asinl", asinl, &TWOL, &NANL, 0}, - {"asinl", asinl, &MTWOL, &NANL, 0}, - {"atanl", atanl, &NANL, &NANL, 0}, - {"atanl", atanl, &ZEROL, &ZEROL, 0}, - {"atanl", atanl, &NEGZEROL, &NEGZEROL, 0}, - {"atanl", atanl, &INFINITYL, &PIO2L, 0}, - {"atanl", atanl, &MINFL, &MPIO2L, 0}, - {"cosl", cosl, &NANL, &NANL, 0}, - {"cosl", cosl, &ZEROL, &ONEL, 0}, - {"cosl", cosl, &NEGZEROL, &ONEL, 0}, - {"cosl", cosl, &INFINITYL, &NANL, 0}, - {"cosl", cosl, &MINFL, &NANL, 0}, - {"sinl", sinl, &NANL, &NANL, 0}, - {"sinl", sinl, &NEGZEROL, &NEGZEROL, 0}, - {"sinl", sinl, &ZEROL, &ZEROL, 0}, - {"sinl", sinl, &INFINITYL, &NANL, 0}, - {"sinl", sinl, &MINFL, &NANL, 0}, - {"tanl", tanl, &NANL, &NANL, 0}, - {"tanl", tanl, &ZEROL, &ZEROL, 0}, - {"tanl", tanl, &NEGZEROL, &NEGZEROL, 0}, - {"tanl", tanl, &INFINITYL, &NANL, 0}, - {"tanl", tanl, &MINFL, &NANL, 0}, - {"acoshl", acoshl, &NANL, &NANL, 0}, - {"acoshl", acoshl, &ONEL, &ZEROL, 0}, - {"acoshl", acoshl, &INFINITYL, &INFINITYL, 0}, - {"acoshl", acoshl, &HALFL, &NANL, 0}, - {"acoshl", acoshl, &MONEL, &NANL, 0}, - {"asinhl", asinhl, &NANL, &NANL, 0}, - {"asinhl", asinhl, &ZEROL, &ZEROL, 0}, - {"asinhl", asinhl, &NEGZEROL, &NEGZEROL, 0}, - {"asinhl", asinhl, &INFINITYL, &INFINITYL, 0}, - {"asinhl", asinhl, &MINFL, &MINFL, 0}, - {"atanhl", atanhl, &NANL, &NANL, 0}, - {"atanhl", atanhl, &ZEROL, &ZEROL, 0}, - {"atanhl", atanhl, &NEGZEROL, &NEGZEROL, 0}, - {"atanhl", atanhl, &ONEL, &INFINITYL, 0}, - {"atanhl", atanhl, &MONEL, &MINFL, 0}, - {"atanhl", atanhl, &TWOL, &NANL, 0}, - {"atanhl", atanhl, &MTWOL, &NANL, 0}, - {"coshl", coshl, &NANL, &NANL, 0}, - {"coshl", coshl, &ZEROL, &ONEL, 0}, - {"coshl", coshl, &NEGZEROL, &ONEL, 0}, - {"coshl", coshl, &INFINITYL, &INFINITYL, 0}, - {"coshl", coshl, &MINFL, &INFINITYL, 0}, - {"sinhl", sinhl, &NANL, &NANL, 0}, - {"sinhl", sinhl, &ZEROL, &ZEROL, 0}, - {"sinhl", sinhl, &NEGZEROL, &NEGZEROL, 0}, - {"sinhl", sinhl, &INFINITYL, &INFINITYL, 0}, - {"sinhl", sinhl, &MINFL, &MINFL, 0}, - {"tanhl", tanhl, &NANL, &NANL, 0}, - {"tanhl", tanhl, &ZEROL, &ZEROL, 0}, - {"tanhl", tanhl, &NEGZEROL, &NEGZEROL, 0}, - {"tanhl", tanhl, &INFINITYL, &ONEL, 0}, - {"tanhl", tanhl, &MINFL, &MONEL, 0}, - {"expl", expl, &NANL, &NANL, 0}, - {"expl", expl, &ZEROL, &ONEL, 0}, - {"expl", expl, &NEGZEROL, &ONEL, 0}, - {"expl", expl, &INFINITYL, &INFINITYL, 0}, - {"expl", expl, &MINFL, &ZEROL, 0}, - {"exp2l", exp2l, &NANL, &NANL, 0}, - {"exp2l", exp2l, &ZEROL, &ONEL, 0}, - {"exp2l", exp2l, &NEGZEROL, &ONEL, 0}, - {"exp2l", exp2l, &INFINITYL, &INFINITYL, 0}, - {"exp2l", exp2l, &MINFL, &ZEROL, 0}, - {"expm1l", expm1l, &NANL, &NANL, 0}, - {"expm1l", expm1l, &ZEROL, &ZEROL, 0}, - {"expm1l", expm1l, &NEGZEROL, &NEGZEROL, 0}, - {"expm1l", expm1l, &INFINITYL, &INFINITYL, 0}, - {"expm1l", expm1l, &MINFL, &MONEL, 0}, - {"logl", logl, &NANL, &NANL, 0}, - {"logl", logl, &ZEROL, &MINFL, 0}, - {"logl", logl, &NEGZEROL, &MINFL, 0}, - {"logl", logl, &ONEL, &ZEROL, 0}, - {"logl", logl, &MONEL, &NANL, 0}, - {"logl", logl, &INFINITYL, &INFINITYL, 0}, - {"log10l", log10l, &NANL, &NANL, 0}, - {"log10l", log10l, &ZEROL, &MINFL, 0}, - {"log10l", log10l, &NEGZEROL, &MINFL, 0}, - {"log10l", log10l, &ONEL, &ZEROL, 0}, - {"log10l", log10l, &MONEL, &NANL, 0}, - {"log10l", log10l, &INFINITYL, &INFINITYL, 0}, - {"log1pl", log1pl, &NANL, &NANL, 0}, - {"log1pl", log1pl, &ZEROL, &ZEROL, 0}, - {"log1pl", log1pl, &NEGZEROL, &NEGZEROL, 0}, - {"log1pl", log1pl, &MONEL, &MINFL, 0}, - {"log1pl", log1pl, &MTWOL, &NANL, 0}, - {"log1pl", log1pl, &INFINITYL, &INFINITYL, 0}, - {"log2l", log2l, &NANL, &NANL, 0}, - {"log2l", log2l, &ZEROL, &MINFL, 0}, - {"log2l", log2l, &NEGZEROL, &MINFL, 0}, - {"log2l", log2l, &MONEL, &NANL, 0}, - {"log2l", log2l, &INFINITYL, &INFINITYL, 0}, - /* {"fabsl", fabsl, &NANL, &NANL, 0}, */ - {"fabsl", fabsl, &ONEL, &ONEL, 0}, - {"fabsl", fabsl, &MONEL, &ONEL, 0}, - {"fabsl", fabsl, &ZEROL, &ZEROL, 0}, - {"fabsl", fabsl, &NEGZEROL, &ZEROL, 0}, - {"fabsl", fabsl, &INFINITYL, &INFINITYL, 0}, - {"fabsl", fabsl, &MINFL, &INFINITYL, 0}, - {"cbrtl", cbrtl, &NANL, &NANL, 0}, - {"cbrtl", cbrtl, &ZEROL, &ZEROL, 0}, - {"cbrtl", cbrtl, &NEGZEROL, &NEGZEROL, 0}, - {"cbrtl", cbrtl, &INFINITYL, &INFINITYL, 0}, - {"cbrtl", cbrtl, &MINFL, &MINFL, 0}, - {"erfl", erfl, &NANL, &NANL, 0}, - {"erfl", erfl, &ZEROL, &ZEROL, 0}, - {"erfl", erfl, &NEGZEROL, &NEGZEROL, 0}, - {"erfl", erfl, &INFINITYL, &ONEL, 0}, - {"erfl", erfl, &MINFL, &MONEL, 0}, - {"erfcl", erfcl, &NANL, &NANL, 0}, - {"erfcl", erfcl, &INFINITYL, &ZEROL, 0}, - {"erfcl", erfcl, &MINFL, &TWOL, 0}, - {"gammal", gammal, &NANL, &NANL, 0}, - {"gammal", gammal, &INFINITYL, &INFINITYL, 0}, - {"gammal", gammal, &MONEL, &NANL, 0}, - {"gammal", gammal, &ZEROL, &NANL, 0}, - {"gammal", gammal, &MINFL, &NANL, 0}, - {"lgaml", lgaml, &NANL, &NANL, 0}, - {"lgaml", lgaml, &INFINITYL, &INFINITYL, 0}, - {"lgaml", lgaml, &MONEL, &INFINITYL, 0}, - {"lgaml", lgaml, &ZEROL, &INFINITYL, 0}, - {"lgaml", lgaml, &MINFL, &INFINITYL, 0}, - {"ceill", ceill, &NANL, &NANL, 0}, - {"ceill", ceill, &ZEROL, &ZEROL, 0}, - {"ceill", ceill, &NEGZEROL, &NEGZEROL, 0}, - {"ceill", ceill, &INFINITYL, &INFINITYL, 0}, - {"ceill", ceill, &MINFL, &MINFL, 0}, - {"floorl", floorl, &NANL, &NANL, 0}, - {"floorl", floorl, &ZEROL, &ZEROL, 0}, - {"floorl", floorl, &NEGZEROL, &NEGZEROL, 0}, - {"floorl", floorl, &INFINITYL, &INFINITYL, 0}, - {"floorl", floorl, &MINFL, &MINFL, 0}, - {"null", NULL, &ZEROL, &ZEROL, 0}, -}; - -/* Functions of two variables. */ -long double atan2l (long double, long double); -long double powl (long double, long double); - -struct twoarguments - { - char *name; /* Name of the function. */ - long double (*func) (long double, long double); - long double *arg1; - long double *arg2; - long double *answer; - int thresh; - }; - -struct twoarguments test2[] = -{ - {"atan2l", atan2l, &ZEROL, &ONEL, &ZEROL, 0}, - {"atan2l", atan2l, &NEGZEROL, &ONEL,&NEGZEROL, 0}, - {"atan2l", atan2l, &ZEROL, &ZEROL, &ZEROL, 0}, - {"atan2l", atan2l, &NEGZEROL, &ZEROL, &NEGZEROL, 0}, - {"atan2l", atan2l, &ZEROL, &MONEL, &PIL, 0}, - {"atan2l", atan2l, &NEGZEROL, &MONEL, &MPIL, 0}, - {"atan2l", atan2l, &ZEROL, &NEGZEROL, &PIL, 0}, - {"atan2l", atan2l, &NEGZEROL, &NEGZEROL, &MPIL, 0}, - {"atan2l", atan2l, &ONEL, &ZEROL, &PIO2L, 0}, - {"atan2l", atan2l, &ONEL, &NEGZEROL, &PIO2L, 0}, - {"atan2l", atan2l, &MONEL, &ZEROL, &MPIO2L, 0}, - {"atan2l", atan2l, &MONEL, &NEGZEROL, &MPIO2L, 0}, - {"atan2l", atan2l, &ONEL, &INFINITYL, &ZEROL, 0}, - {"atan2l", atan2l, &MONEL, &INFINITYL, &NEGZEROL, 0}, - {"atan2l", atan2l, &INFINITYL, &ONEL, &PIO2L, 0}, - {"atan2l", atan2l, &INFINITYL, &MONEL, &PIO2L, 0}, - {"atan2l", atan2l, &MINFL, &ONEL, &MPIO2L, 0}, - {"atan2l", atan2l, &MINFL, &MONEL, &MPIO2L, 0}, - {"atan2l", atan2l, &ONEL, &MINFL, &PIL, 0}, - {"atan2l", atan2l, &MONEL, &MINFL, &MPIL, 0}, - {"atan2l", atan2l, &INFINITYL, &INFINITYL, &PIO4L, 0}, - {"atan2l", atan2l, &MINFL, &INFINITYL, &MPIO4L, 0}, - {"atan2l", atan2l, &INFINITYL, &MINFL, &THPIO4L, 0}, - {"atan2l", atan2l, &MINFL, &MINFL, &MTHPIO4L, 0}, - {"atan2l", atan2l, &ONEL, &ONEL, &PIO4L, 0}, - {"atan2l", atan2l, &NANL, &ONEL, &NANL, 0}, - {"atan2l", atan2l, &ONEL, &NANL, &NANL, 0}, - {"atan2l", atan2l, &NANL, &NANL, &NANL, 0}, - {"powl", powl, &ONEL, &ZEROL, &ONEL, 0}, - {"powl", powl, &ONEL, &NEGZEROL, &ONEL, 0}, - {"powl", powl, &MONEL, &ZEROL, &ONEL, 0}, - {"powl", powl, &MONEL, &NEGZEROL, &ONEL, 0}, - {"powl", powl, &INFINITYL, &ZEROL, &ONEL, 0}, - {"powl", powl, &INFINITYL, &NEGZEROL, &ONEL, 0}, - {"powl", powl, &NANL, &ZEROL, &ONEL, 0}, - {"powl", powl, &NANL, &NEGZEROL, &ONEL, 0}, - {"powl", powl, &TWOL, &INFINITYL, &INFINITYL, 0}, - {"powl", powl, &MTWOL, &INFINITYL, &INFINITYL, 0}, - {"powl", powl, &HALFL, &INFINITYL, &ZEROL, 0}, - {"powl", powl, &MHALFL, &INFINITYL, &ZEROL, 0}, - {"powl", powl, &TWOL, &MINFL, &ZEROL, 0}, - {"powl", powl, &MTWOL, &MINFL, &ZEROL, 0}, - {"powl", powl, &HALFL, &MINFL, &INFINITYL, 0}, - {"powl", powl, &MHALFL, &MINFL, &INFINITYL, 0}, - {"powl", powl, &INFINITYL, &HALFL, &INFINITYL, 0}, - {"powl", powl, &INFINITYL, &TWOL, &INFINITYL, 0}, - {"powl", powl, &INFINITYL, &MHALFL, &ZEROL, 0}, - {"powl", powl, &INFINITYL, &MTWOL, &ZEROL, 0}, - {"powl", powl, &MINFL, &THREEL, &MINFL, 0}, - {"powl", powl, &MINFL, &TWOL, &INFINITYL, 0}, - {"powl", powl, &MINFL, &MTHREEL, &NEGZEROL, 0}, - {"powl", powl, &MINFL, &MTWOL, &ZEROL, 0}, - {"powl", powl, &NANL, &ONEL, &NANL, 0}, - {"powl", powl, &ONEL, &NANL, &NANL, 0}, - {"powl", powl, &NANL, &NANL, &NANL, 0}, - {"powl", powl, &ONEL, &INFINITYL, &NANL, 0}, - {"powl", powl, &MONEL, &INFINITYL, &NANL, 0}, - {"powl", powl, &ONEL, &MINFL, &NANL, 0}, - {"powl", powl, &MONEL, &MINFL, &NANL, 0}, - {"powl", powl, &MTWOL, &HALFL, &NANL, 0}, - {"powl", powl, &ZEROL, &MTHREEL, &INFINITYL, 0}, - {"powl", powl, &NEGZEROL, &MTHREEL, &MINFL, 0}, - {"powl", powl, &ZEROL, &MHALFL, &INFINITYL, 0}, - {"powl", powl, &NEGZEROL, &MHALFL, &INFINITYL, 0}, - {"powl", powl, &ZEROL, &THREEL, &ZEROL, 0}, - {"powl", powl, &NEGZEROL, &THREEL, &NEGZEROL, 0}, - {"powl", powl, &ZEROL, &HALFL, &ZEROL, 0}, - {"powl", powl, &NEGZEROL, &HALFL, &ZEROL, 0}, - {"null", NULL, &ZEROL, &ZEROL, &ZEROL, 0}, -}; - -/* Integer functions of one variable. */ - -int isnanl (long double); -int signbitl (long double); - -struct intans - { - char *name; /* Name of the function. */ - int (*func) (long double); - long double *arg1; - int ianswer; - }; - -struct intans test3[] = -{ - {"isfinitel", isfinitel, &ZEROL, 1}, - {"isfinitel", isfinitel, &INFINITYL, 0}, - {"isfinitel", isfinitel, &MINFL, 0}, - {"isnanl", isnanl, &NANL, 1}, - {"isnanl", isnanl, &INFINITYL, 0}, - {"isnanl", isnanl, &ZEROL, 0}, - {"isnanl", isnanl, &NEGZEROL, 0}, - {"signbitl", signbitl, &NEGZEROL, 1}, - {"signbitl", signbitl, &MONEL, 1}, - {"signbitl", signbitl, &ZEROL, 0}, - {"signbitl", signbitl, &ONEL, 0}, - {"signbitl", signbitl, &MINFL, 1}, - {"signbitl", signbitl, &INFINITYL, 0}, - {"null", NULL, &ZEROL, 0}, -}; - -static volatile long double x1; -static volatile long double x2; -static volatile long double y; -static volatile long double answer; - -int -main () -{ - int i, nerrors, k, ianswer, ntests; - long double (*fun1) (long double); - long double (*fun2) (long double, long double); - int (*fun3) (long double); - long double e; - union - { - long double d; - char c[12]; - } u, v; - - /* This masks off fpu exceptions on i386. */ - /* setfpu(0x137f); */ - nerrors = 0; - ntests = 0; - MINFL = -INFINITYL; - MPIL = -PIL; - MPIO2L = -PIO2L; - MPIO4L = -PIO4L; - i = 0; - for (;;) - { - fun1 = test1[i].func; - if (fun1 == NULL) - break; - x1 = *(test1[i].arg1); - y = (*(fun1)) (x1); - answer = *(test1[i].answer); - if (test1[i].thresh == 0) - { - v.d = answer; - u.d = y; - if (memcmp(u.c, v.c, 10) != 0) - { - /* O.K. if both are NaNs of some sort. */ - if (isnanl(v.d) && isnanl(u.d)) - goto nxttest1; - goto wrongone; - } - else - goto nxttest1; - } - if (y != answer) - { - e = y - answer; - if (answer != 0.0L) - e = e / answer; - if (e < 0) - e = -e; - if (e > test1[i].thresh * MACHEPL) - { -wrongone: - printf ("%s (%.20Le) = %.20Le\n should be %.20Le\n", - test1[i].name, x1, y, answer); - nerrors += 1; - } - } -nxttest1: - ntests += 1; - i += 1; - } - - i = 0; - for (;;) - { - fun2 = test2[i].func; - if (fun2 == NULL) - break; - x1 = *(test2[i].arg1); - x2 = *(test2[i].arg2); - y = (*(fun2)) (x1, x2); - answer = *(test2[i].answer); - if (test2[i].thresh == 0) - { - v.d = answer; - u.d = y; - if (memcmp(u.c, v.c, 10) != 0) - { - /* O.K. if both are NaNs of some sort. */ - if (isnanl(v.d) && isnanl(u.d)) - goto nxttest2; - goto wrongtwo; - } - else - goto nxttest2; - } - if (y != answer) - { - e = y - answer; - if (answer != 0.0L) - e = e / answer; - if (e < 0) - e = -e; - if (e > test2[i].thresh * MACHEPL) - { -wrongtwo: - printf ("%s (%.20Le, %.20Le) = %.20Le\n should be %.20Le\n", - test2[i].name, x1, x2, y, answer); - nerrors += 1; - } - } -nxttest2: - ntests += 1; - i += 1; - } - - - i = 0; - for (;;) - { - fun3 = test3[i].func; - if (fun3 == NULL) - break; - x1 = *(test3[i].arg1); - k = (*(fun3)) (x1); - ianswer = test3[i].ianswer; - if (k != ianswer) - { - printf ("%s (%.20Le) = %d\n should be. %d\n", - test3[i].name, x1, k, ianswer); - nerrors += 1; - } - ntests += 1; - i += 1; - } - - printf ("testvect: %d errors in %d tests\n", nerrors, ntests); - exit (0); -} diff --git a/libm/ldouble/unityl.c b/libm/ldouble/unityl.c deleted file mode 100644 index 10670ce3a..000000000 --- a/libm/ldouble/unityl.c +++ /dev/null @@ -1,128 +0,0 @@ -/* unityl.c - * - * Relative error approximations for function arguments near - * unity. - * - * log1p(x) = log(1+x) - * expm1(x) = exp(x) - 1 - * cosm1(x) = cos(x) - 1 - * - */ - - -/* log1p(x) = log(1 + x) - * Relative error: - * arithmetic domain # trials peak rms - * IEEE 0.5, 2 30000 1.4e-19 4.1e-20 - * - */ - -#include <math.h> -/* Coefficients for log(1+x) = x - x**2/2 + x**3 P(x)/Q(x) - * 1/sqrt(2) <= x < sqrt(2) - * Theoretical peak relative error = 2.32e-20 - */ -static long double LP[] = { - 4.5270000862445199635215E-5L, - 4.9854102823193375972212E-1L, - 6.5787325942061044846969E0L, - 2.9911919328553073277375E1L, - 6.0949667980987787057556E1L, - 5.7112963590585538103336E1L, - 2.0039553499201281259648E1L, -}; -static long double LQ[] = { -/* 1.0000000000000000000000E0L,*/ - 1.5062909083469192043167E1L, - 8.3047565967967209469434E1L, - 2.2176239823732856465394E2L, - 3.0909872225312059774938E2L, - 2.1642788614495947685003E2L, - 6.0118660497603843919306E1L, -}; - -#define SQRTH 0.70710678118654752440L -#define SQRT2 1.41421356237309504880L -#ifdef ANSIPROT -extern long double logl ( long double ); -extern long double expl ( long double ); -extern long double cosl ( long double ); -extern long double polevll ( long double, void *, int ); -extern long double p1evll ( long double, void *, int ); -#else -long double logl(), expl(), cosl(), polevll(), p1evll(); -#endif - -long double log1pl(x) -long double x; -{ -long double z; - -z = 1.0L + x; -if( (z < SQRTH) || (z > SQRT2) ) - return( logl(z) ); -z = x*x; -z = -0.5L * z + x * ( z * polevll( x, LP, 6 ) / p1evll( x, LQ, 6 ) ); -return (x + z); -} - - - -/* expm1(x) = exp(x) - 1 */ - -/* e^x = 1 + 2x P(x^2)/( Q(x^2) - P(x^2) ) - * -0.5 <= x <= 0.5 - */ - -static long double EP[3] = { - 1.2617719307481059087798E-4L, - 3.0299440770744196129956E-2L, - 9.9999999999999999991025E-1L, -}; -static long double EQ[4] = { - 3.0019850513866445504159E-6L, - 2.5244834034968410419224E-3L, - 2.2726554820815502876593E-1L, - 2.0000000000000000000897E0L, -}; - -long double expm1l(x) -long double x; -{ -long double r, xx; - -if( (x < -0.5L) || (x > 0.5L) ) - return( expl(x) - 1.0L ); -xx = x * x; -r = x * polevll( xx, EP, 2 ); -r = r/( polevll( xx, EQ, 3 ) - r ); -return (r + r); -} - - - -/* cosm1(x) = cos(x) - 1 */ - -static long double coscof[7] = { - 4.7377507964246204691685E-14L, --1.1470284843425359765671E-11L, - 2.0876754287081521758361E-9L, --2.7557319214999787979814E-7L, - 2.4801587301570552304991E-5L, --1.3888888888888872993737E-3L, - 4.1666666666666666609054E-2L, -}; - -extern long double PIO4L; - -long double cosm1l(x) -long double x; -{ -long double xx; - -if( (x < -PIO4L) || (x > PIO4L) ) - return( cosl(x) - 1.0L ); -xx = x * x; -xx = -0.5L*xx + xx * xx * polevll( xx, coscof, 6 ); -return xx; -} diff --git a/libm/ldouble/wronkl.c b/libm/ldouble/wronkl.c deleted file mode 100644 index bec958f01..000000000 --- a/libm/ldouble/wronkl.c +++ /dev/null @@ -1,67 +0,0 @@ -/* Wronksian test for Bessel functions. */ - -long double jnl (), ynl (), floorl (); -#define PI 3.14159265358979323846L - -long double y, Jn, Jnp1, Jmn, Jmnp1, Yn, Ynp1; -long double w1, w2, err1, max1, err2, max2; -void wronk (); - -main () -{ - long double x, delta; - int n, i, j; - - max1 = 0.0L; - max2 = 0.0L; - delta = 0.6 / PI; - for (n = -30; n <= 30; n++) - { - x = -30.0; - while (x < 30.0) - { - wronk (n, x); - x += delta; - } - delta += .00123456; - } -} - -void -wronk (n, x) - int n; - long double x; -{ - - Jnp1 = jnl (n + 1, x); - Jmn = jnl (-n, x); - Jn = jnl (n, x); - Jmnp1 = jnl (-(n + 1), x); - /* This should be trivially zero. */ - err1 = Jnp1 * Jmn + Jn * Jmnp1; - if (err1 < 0.0) - err1 = -err1; - if (err1 > max1) - { - max1 = err1; - printf ("1 %3d %.5Le %.3Le\n", n, x, max1); - } - if (x < 0.0) - { - x = -x; - Jn = jnl (n, x); - Jnp1 = jnl (n + 1, x); - } - Yn = ynl (n, x); - Ynp1 = ynl (n + 1, x); - /* The Wronksian. */ - w1 = Jnp1 * Yn - Jn * Ynp1; - /* What the Wronksian should be. */ - w2 = 2.0 / (PI * x); - err2 = w1 - w2; - if (err2 > max2) - { - max2 = err2; - printf ("2 %3d %.5Le %.3Le\n", n, x, max2); - } -} diff --git a/libm/ldouble/ynl.c b/libm/ldouble/ynl.c deleted file mode 100644 index 444792850..000000000 --- a/libm/ldouble/ynl.c +++ /dev/null @@ -1,113 +0,0 @@ -/* ynl.c - * - * Bessel function of second kind of integer order - * - * - * - * SYNOPSIS: - * - * long double x, y, ynl(); - * int n; - * - * y = ynl( n, x ); - * - * - * - * DESCRIPTION: - * - * Returns Bessel function of order n, where n is a - * (possibly negative) integer. - * - * The function is evaluated by forward recurrence on - * n, starting with values computed by the routines - * y0l() and y1l(). - * - * If n = 0 or 1 the routine for y0l or y1l is called - * directly. - * - * - * - * ACCURACY: - * - * - * Absolute error, except relative error when y > 1. - * x >= 0, -30 <= n <= +30. - * arithmetic domain # trials peak rms - * IEEE -30, 30 10000 1.3e-18 1.8e-19 - * - * - * ERROR MESSAGES: - * - * message condition value returned - * ynl singularity x = 0 MAXNUML - * ynl overflow MAXNUML - * - * Spot checked against tables for x, n between 0 and 100. - * - */ - -/* -Cephes Math Library Release 2.1: December, 1988 -Copyright 1984, 1987 by Stephen L. Moshier -Direct inquiries to 30 Frost Street, Cambridge, MA 02140 -*/ - -#include <math.h> -extern long double MAXNUML; -#ifdef ANSIPROT -extern long double y0l ( long double ); -extern long double y1l ( long double ); -#else -long double y0l(), y1l(); -#endif - -long double ynl( n, x ) -int n; -long double x; -{ -long double an, anm1, anm2, r; -int k, sign; - -if( n < 0 ) - { - n = -n; - if( (n & 1) == 0 ) /* -1**n */ - sign = 1; - else - sign = -1; - } -else - sign = 1; - - -if( n == 0 ) - return( sign * y0l(x) ); -if( n == 1 ) - return( sign * y1l(x) ); - -/* test for overflow */ -if( x <= 0.0L ) - { - mtherr( "ynl", SING ); - return( -MAXNUML ); - } - -/* forward recurrence on n */ - -anm2 = y0l(x); -anm1 = y1l(x); -k = 1; -r = 2 * k; -do - { - an = r * anm1 / x - anm2; - anm2 = anm1; - anm1 = an; - r += 2.0L; - ++k; - } -while( k < n ); - - -return( sign * an ); -} |