|
|
1.1 ! root 1: /* ! 2: * Copyright (c) 1985 Regents of the University of California. ! 3: * All rights reserved. ! 4: * ! 5: * Redistribution and use in source and binary forms are permitted ! 6: * provided that: (1) source distributions retain this entire copyright ! 7: * notice and comment, and (2) distributions including binaries display ! 8: * the following acknowledgement: ``This product includes software ! 9: * developed by the University of California, Berkeley and its contributors'' ! 10: * in the documentation or other materials provided with the distribution ! 11: * and in all advertising materials mentioning features or use of this ! 12: * software. Neither the name of the University nor the names of its ! 13: * contributors may be used to endorse or promote products derived ! 14: * from this software without specific prior written permission. ! 15: * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR ! 16: * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED ! 17: * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. ! 18: * ! 19: * All recipients should regard themselves as participants in an ongoing ! 20: * research project and hence should feel obligated to report their ! 21: * experiences (good or bad) with these elementary function codes, using ! 22: * the sendbug(8) program, to the authors. ! 23: */ ! 24: ! 25: #ifndef lint ! 26: static char sccsid[] = "@(#)log1p.c 5.5 (Berkeley) 6/1/90"; ! 27: #endif /* not lint */ ! 28: ! 29: /* LOG1P(x) ! 30: * RETURN THE LOGARITHM OF 1+x ! 31: * DOUBLE PRECISION (VAX D FORMAT 56 bits, IEEE DOUBLE 53 BITS) ! 32: * CODED IN C BY K.C. NG, 1/19/85; ! 33: * REVISED BY K.C. NG on 2/6/85, 3/7/85, 3/24/85, 4/16/85. ! 34: * ! 35: * Required system supported functions: ! 36: * scalb(x,n) ! 37: * copysign(x,y) ! 38: * logb(x) ! 39: * finite(x) ! 40: * ! 41: * Required kernel function: ! 42: * log__L(z) ! 43: * ! 44: * Method : ! 45: * 1. Argument Reduction: find k and f such that ! 46: * 1+x = 2^k * (1+f), ! 47: * where sqrt(2)/2 < 1+f < sqrt(2) . ! 48: * ! 49: * 2. Let s = f/(2+f) ; based on log(1+f) = log(1+s) - log(1-s) ! 50: * = 2s + 2/3 s**3 + 2/5 s**5 + ....., ! 51: * log(1+f) is computed by ! 52: * ! 53: * log(1+f) = 2s + s*log__L(s*s) ! 54: * where ! 55: * log__L(z) = z*(L1 + z*(L2 + z*(... (L6 + z*L7)...))) ! 56: * ! 57: * See log__L() for the values of the coefficients. ! 58: * ! 59: * 3. Finally, log(1+x) = k*ln2 + log(1+f). ! 60: * ! 61: * Remarks 1. In step 3 n*ln2 will be stored in two floating point numbers ! 62: * n*ln2hi + n*ln2lo, where ln2hi is chosen such that the last ! 63: * 20 bits (for VAX D format), or the last 21 bits ( for IEEE ! 64: * double) is 0. This ensures n*ln2hi is exactly representable. ! 65: * 2. In step 1, f may not be representable. A correction term c ! 66: * for f is computed. It follows that the correction term for ! 67: * f - t (the leading term of log(1+f) in step 2) is c-c*x. We ! 68: * add this correction term to n*ln2lo to attenuate the error. ! 69: * ! 70: * ! 71: * Special cases: ! 72: * log1p(x) is NaN with signal if x < -1; log1p(NaN) is NaN with no signal; ! 73: * log1p(INF) is +INF; log1p(-1) is -INF with signal; ! 74: * only log1p(0)=0 is exact for finite argument. ! 75: * ! 76: * Accuracy: ! 77: * log1p(x) returns the exact log(1+x) nearly rounded. In a test run ! 78: * with 1,536,000 random arguments on a VAX, the maximum observed ! 79: * error was .846 ulps (units in the last place). ! 80: * ! 81: * Constants: ! 82: * The hexadecimal values are the intended ones for the following constants. ! 83: * The decimal values may be used, provided that the compiler will convert ! 84: * from decimal to binary accurately enough to produce the hexadecimal values ! 85: * shown. ! 86: */ ! 87: ! 88: #include <errno.h> ! 89: #include "mathimpl.h" ! 90: ! 91: vc(ln2hi, 6.9314718055829871446E-1 ,7217,4031,0000,f7d0, 0, .B17217F7D00000) ! 92: vc(ln2lo, 1.6465949582897081279E-12 ,bcd5,2ce7,d9cc,e4f1, -39, .E7BCD5E4F1D9CC) ! 93: vc(sqrt2, 1.4142135623730950622E0 ,04f3,40b5,de65,33f9, 1, .B504F333F9DE65) ! 94: ! 95: ic(ln2hi, 6.9314718036912381649E-1, -1, 1.62E42FEE00000) ! 96: ic(ln2lo, 1.9082149292705877000E-10, -33, 1.A39EF35793C76) ! 97: ic(sqrt2, 1.4142135623730951455E0, 0, 1.6A09E667F3BCD) ! 98: ! 99: #ifdef vccast ! 100: #define ln2hi vccast(ln2hi) ! 101: #define ln2lo vccast(ln2lo) ! 102: #define sqrt2 vccast(sqrt2) ! 103: #endif ! 104: ! 105: double log1p(x) ! 106: double x; ! 107: { ! 108: const static double zero=0.0, negone= -1.0, one=1.0, ! 109: half=1.0/2.0, small=1.0E-20; /* 1+small == 1 */ ! 110: double z,s,t,c; ! 111: int k; ! 112: ! 113: #if !defined(vax)&&!defined(tahoe) ! 114: if(x!=x) return(x); /* x is NaN */ ! 115: #endif /* !defined(vax)&&!defined(tahoe) */ ! 116: ! 117: if(finite(x)) { ! 118: if( x > negone ) { ! 119: ! 120: /* argument reduction */ ! 121: if(copysign(x,one)<small) return(x); ! 122: k=logb(one+x); z=scalb(x,-k); t=scalb(one,-k); ! 123: if(z+t >= sqrt2 ) ! 124: { k += 1 ; z *= half; t *= half; } ! 125: t += negone; x = z + t; ! 126: c = (t-x)+z ; /* correction term for x */ ! 127: ! 128: /* compute log(1+x) */ ! 129: s = x/(2+x); t = x*x*half; ! 130: c += (k*ln2lo-c*x); ! 131: z = c+s*(t+log__L(s*s)); ! 132: x += (z - t) ; ! 133: ! 134: return(k*ln2hi+x); ! 135: } ! 136: /* end of if (x > negone) */ ! 137: ! 138: else { ! 139: #if defined(vax)||defined(tahoe) ! 140: if ( x == negone ) ! 141: return (infnan(-ERANGE)); /* -INF */ ! 142: else ! 143: return (infnan(EDOM)); /* NaN */ ! 144: #else /* defined(vax)||defined(tahoe) */ ! 145: /* x = -1, return -INF with signal */ ! 146: if ( x == negone ) return( negone/zero ); ! 147: ! 148: /* negative argument for log, return NaN with signal */ ! 149: else return ( zero / zero ); ! 150: #endif /* defined(vax)||defined(tahoe) */ ! 151: } ! 152: } ! 153: /* end of if (finite(x)) */ ! 154: ! 155: /* log(-INF) is NaN */ ! 156: else if(x<0) ! 157: return(zero/zero); ! 158: ! 159: /* log(+INF) is INF */ ! 160: else return(x); ! 161: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.