mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-18 00:09:23 +02:00
* Replaced fpc_ln_real with modern port from fdlibm/uclibc, it has even better accuracy than damath library.
git-svn-id: trunk@27172 -
This commit is contained in:
sergei
parent
9801288cdc
commit
5f985602fb
@ -60,16 +60,9 @@ type
|
|||||||
|
|
||||||
|
|
||||||
const
|
const
|
||||||
PIO2 = 1.57079632679489661923; { pi/2 }
|
|
||||||
PIO4 = 7.85398163397448309616E-1; { pi/4 }
|
PIO4 = 7.85398163397448309616E-1; { pi/4 }
|
||||||
SQRT2 = 1.41421356237309504880; { sqrt(2) }
|
SQRT2 = 1.41421356237309504880; { sqrt(2) }
|
||||||
SQRTH = 7.07106781186547524401E-1; { sqrt(2)/2 }
|
|
||||||
LOG2E = 1.4426950408889634073599; { 1/log(2) }
|
LOG2E = 1.4426950408889634073599; { 1/log(2) }
|
||||||
SQ2OPI = 7.9788456080286535587989E-1; { sqrt( 2/pi )}
|
|
||||||
LOGE2 = 6.93147180559945309417E-1; { log(2) }
|
|
||||||
LOGSQ2 = 3.46573590279972654709E-1; { log(2)/2 }
|
|
||||||
THPIO4 = 2.35619449019234492885; { 3*pi/4 }
|
|
||||||
TWOOPI = 6.36619772367581343075535E-1; { 2/pi }
|
|
||||||
lossth = 1.073741824e9;
|
lossth = 1.073741824e9;
|
||||||
MAXLOG = 8.8029691931113054295988E1; { log(2**127) }
|
MAXLOG = 8.8029691931113054295988E1; { log(2**127) }
|
||||||
MINLOG = -8.872283911167299960540E1; { log(2**-128) }
|
MINLOG = -8.872283911167299960540E1; { log(2**-128) }
|
||||||
@ -1341,124 +1334,162 @@ type
|
|||||||
|
|
||||||
{$ifndef FPC_SYSTEM_HAS_LN}
|
{$ifndef FPC_SYSTEM_HAS_LN}
|
||||||
function fpc_ln_real(d:ValReal):ValReal;compilerproc;
|
function fpc_ln_real(d:ValReal):ValReal;compilerproc;
|
||||||
|
{
|
||||||
|
This code was translated from uclib code, the original code
|
||||||
|
had the following copyright notice:
|
||||||
|
|
||||||
|
*
|
||||||
|
* ====================================================
|
||||||
|
* Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved.
|
||||||
|
*
|
||||||
|
* Developed at SunPro, a Sun Microsystems, Inc. business.
|
||||||
|
* Permission to use, copy, modify, and distribute this
|
||||||
|
* software is freely granted, provided that this notice
|
||||||
|
* is preserved.
|
||||||
|
* ====================================================
|
||||||
|
*}
|
||||||
|
|
||||||
{*****************************************************************}
|
{*****************************************************************}
|
||||||
{ Natural Logarithm }
|
{ Natural Logarithm }
|
||||||
{*****************************************************************}
|
{*****************************************************************}
|
||||||
{ }
|
{*
|
||||||
{ SYNOPSIS: }
|
* SYNOPSIS:
|
||||||
{ }
|
*
|
||||||
{ double x, y, log(); }
|
* double x, y, log();
|
||||||
{ }
|
*
|
||||||
{ y = ln( x ); }
|
* y = ln( x );
|
||||||
{ }
|
*
|
||||||
{ DESCRIPTION: }
|
* DESCRIPTION:
|
||||||
{ }
|
*
|
||||||
{ Returns the base e (2.718...) logarithm of x. }
|
* Returns the base e (2.718...) logarithm of x.
|
||||||
{ }
|
*
|
||||||
{ The argument is separated into its exponent and fractional }
|
* Method :
|
||||||
{ parts. If the exponent is between -1 and +1, the logarithm }
|
* 1. Argument Reduction: find k and f such that
|
||||||
{ of the fraction is approximated by }
|
* x = 2^k * (1+f),
|
||||||
{ }
|
* where sqrt(2)/2 < 1+f < sqrt(2) .
|
||||||
{ log(1+x) = x - 0.5 x**2 + x**3 P(x)/Q(x). }
|
*
|
||||||
{ }
|
* 2. Approximation of log(1+f).
|
||||||
{ Otherwise, setting z = 2(x-1)/x+1), }
|
* Let s = f/(2+f) ; based on log(1+f) = log(1+s) - log(1-s)
|
||||||
{ }
|
* = 2s + 2/3 s**3 + 2/5 s**5 + .....,
|
||||||
{ log(x) = z + z**3 P(z)/Q(z). }
|
* = 2s + s*R
|
||||||
{ }
|
* We use a special Reme algorithm on [0,0.1716] to generate
|
||||||
{*****************************************************************}
|
* a polynomial of degree 14 to approximate R The maximum error
|
||||||
const P : array[0..6] of Real = (
|
* of this polynomial approximation is bounded by 2**-58.45. In
|
||||||
{ Coefficients for log(1+x) = x - x**2/2 + x**3 P(x)/Q(x)
|
* other words,
|
||||||
1/sqrt(2) <= x < sqrt(2) }
|
* 2 4 6 8 10 12 14
|
||||||
|
* R(z) ~ Lg1*s +Lg2*s +Lg3*s +Lg4*s +Lg5*s +Lg6*s +Lg7*s
|
||||||
|
* (the values of Lg1 to Lg7 are listed in the program)
|
||||||
|
* and
|
||||||
|
* | 2 14 | -58.45
|
||||||
|
* | Lg1*s +...+Lg7*s - R(z) | <= 2
|
||||||
|
* | |
|
||||||
|
* Note that 2s = f - s*f = f - hfsq + s*hfsq, where hfsq = f*f/2.
|
||||||
|
* In order to guarantee error in log below 1ulp, we compute log
|
||||||
|
* by
|
||||||
|
* log(1+f) = f - s*(f - R) (if f is not too large)
|
||||||
|
* log(1+f) = f - (hfsq - s*(hfsq+R)). (better accuracy)
|
||||||
|
*
|
||||||
|
* 3. Finally, log(x) = k*ln2 + log(1+f).
|
||||||
|
* = k*ln2_hi+(f-(hfsq-(s*(hfsq+R)+k*ln2_lo)))
|
||||||
|
* Here ln2 is split into two floating point number:
|
||||||
|
* ln2_hi + ln2_lo,
|
||||||
|
* where n*ln2_hi is always exact for |n| < 2000.
|
||||||
|
*
|
||||||
|
* Special cases:
|
||||||
|
* log(x) is NaN with signal if x < 0 (including -INF) ;
|
||||||
|
* log(+INF) is +INF; log(0) is -INF with signal;
|
||||||
|
* log(NaN) is that NaN with no signal.
|
||||||
|
*
|
||||||
|
* Accuracy:
|
||||||
|
* according to an error analysis, the error is always less than
|
||||||
|
* 1 ulp (unit in the last place).
|
||||||
|
*}
|
||||||
|
const
|
||||||
|
ln2_hi: double = 6.93147180369123816490e-01; { 3fe62e42 fee00000 }
|
||||||
|
ln2_lo: double = 1.90821492927058770002e-10; { 3dea39ef 35793c76 }
|
||||||
|
two54: double = 1.80143985094819840000e+16; { 43500000 00000000 }
|
||||||
|
Lg1: double = 6.666666666666735130e-01; { 3FE55555 55555593 }
|
||||||
|
Lg2: double = 3.999999999940941908e-01; { 3FD99999 9997FA04 }
|
||||||
|
Lg3: double = 2.857142874366239149e-01; { 3FD24924 94229359 }
|
||||||
|
Lg4: double = 2.222219843214978396e-01; { 3FCC71C5 1D8E78AF }
|
||||||
|
Lg5: double = 1.818357216161805012e-01; { 3FC74664 96CB03DE }
|
||||||
|
Lg6: double = 1.531383769920937332e-01; { 3FC39A09 D078C69F }
|
||||||
|
Lg7: double = 1.479819860511658591e-01; { 3FC2F112 DF3E5244 }
|
||||||
|
|
||||||
4.58482948458143443514E-5,
|
zero: double = 0.0;
|
||||||
4.98531067254050724270E-1,
|
|
||||||
6.56312093769992875930E0,
|
|
||||||
2.97877425097986925891E1,
|
|
||||||
6.06127134467767258030E1,
|
|
||||||
5.67349287391754285487E1,
|
|
||||||
1.98892446572874072159E1);
|
|
||||||
Q : array[0..5] of Real = (
|
|
||||||
1.50314182634250003249E1,
|
|
||||||
8.27410449222435217021E1,
|
|
||||||
2.20664384982121929218E2,
|
|
||||||
3.07254189979530058263E2,
|
|
||||||
2.14955586696422947765E2,
|
|
||||||
5.96677339718622216300E1);
|
|
||||||
|
|
||||||
{ Coefficients for log(x) = z + z**3 P(z)/Q(z),
|
|
||||||
where z = 2(x-1)/(x+1)
|
|
||||||
1/sqrt(2) <= x < sqrt(2) }
|
|
||||||
|
|
||||||
R : array[0..2] of Real = (
|
|
||||||
-7.89580278884799154124E-1,
|
|
||||||
1.63866645699558079767E1,
|
|
||||||
-6.41409952958715622951E1);
|
|
||||||
S : array[0..2] of Real = (
|
|
||||||
-3.56722798256324312549E1,
|
|
||||||
3.12093766372244180303E2,
|
|
||||||
-7.69691943550460008604E2);
|
|
||||||
|
|
||||||
var e : Integer;
|
|
||||||
z, y : Real;
|
|
||||||
|
|
||||||
|
var
|
||||||
|
hfsq,f,s,z,R,w,t1,t2,dk: double;
|
||||||
|
k,hx,i,j: longint;
|
||||||
|
lx: longword;
|
||||||
begin
|
begin
|
||||||
if( d <= 0.0 ) then
|
hx := float64high(d);
|
||||||
begin
|
lx := float64low(d);
|
||||||
float_raise(float_flag_invalid);
|
|
||||||
exit;
|
|
||||||
end;
|
|
||||||
d := frexp( d, e );
|
|
||||||
|
|
||||||
{ logarithm using log(x) = z + z**3 P(z)/Q(z),
|
k := 0;
|
||||||
where z = 2(x-1)/x+1) }
|
if (hx < $00100000) then { x < 2**-1022 }
|
||||||
|
begin
|
||||||
if( (e > 2) or (e < -2) ) then
|
if (((hx and $7fffffff) or lx)=0) then
|
||||||
begin
|
exit(-two54/zero); { log(+-0)=-inf }
|
||||||
if( d < SQRTH ) then
|
if (hx<0) then
|
||||||
begin
|
exit((d-d)/zero); { log(-#) = NaN }
|
||||||
{ 2( 2x-1 )/( 2x+1 ) }
|
dec(k, 54); d := d * two54; { subnormal number, scale up x }
|
||||||
Dec(e, 1);
|
hx := float64high(d);
|
||||||
z := d - 0.5;
|
end;
|
||||||
y := 0.5 * z + 0.5;
|
if (hx >= $7ff00000) then
|
||||||
end
|
exit(d+d);
|
||||||
else
|
inc(k, (hx shr 20)-1023);
|
||||||
begin
|
hx := hx and $000fffff;
|
||||||
{ 2 (x-1)/(x+1) }
|
i := (hx + $95f64) and $100000;
|
||||||
z := d - 0.5;
|
float64sethigh(d,hx or (i xor $3ff00000)); { normalize x or x/2 }
|
||||||
z := z - 0.5;
|
inc(k, (i shr 20));
|
||||||
y := 0.5 * d + 0.5;
|
f := d-1.0;
|
||||||
end;
|
if (($000fffff and (2+hx))<3) then { |f| < 2**-20 }
|
||||||
d := z / y;
|
begin
|
||||||
{ /* rational form */ }
|
if (f=zero) then
|
||||||
z := d*d;
|
begin
|
||||||
z := d + d * ( z * polevl( z, R, 2 ) / p1evl( z, S, 3 ) );
|
if (k=0) then
|
||||||
end
|
exit(zero)
|
||||||
else
|
else
|
||||||
begin
|
begin
|
||||||
{ logarithm using log(1+x) = x - .5x**2 + x**3 P(x)/Q(x) }
|
dk := k;
|
||||||
if( d < SQRTH ) then
|
exit(dk*ln2_hi+dk*ln2_lo);
|
||||||
begin
|
end;
|
||||||
Dec(e, 1);
|
end;
|
||||||
d := ldexp( d, 1 ) - 1.0; { 2x - 1 }
|
R := f*f*(0.5-0.33333333333333333*f);
|
||||||
end
|
if (k=0) then
|
||||||
else
|
exit(f-R)
|
||||||
d := d - 1.0;
|
else
|
||||||
|
begin
|
||||||
{ rational form }
|
dk := k;
|
||||||
z := d*d;
|
exit(dk*ln2_hi-((R-dk*ln2_lo)-f));
|
||||||
y := d * ( z * polevl( d, P, 6 ) / p1evl( d, Q, 6 ) );
|
end;
|
||||||
y := y - ldexp( z, -1 ); { y - 0.5 * z }
|
end;
|
||||||
z := d + y;
|
s := f/(2.0+f);
|
||||||
end;
|
dk := k;
|
||||||
{ recombine with exponent term }
|
z := s*s;
|
||||||
if( e <> 0 ) then
|
i := hx-$6147a;
|
||||||
begin
|
w := z*z;
|
||||||
y := e;
|
j := $6b851-hx;
|
||||||
z := z - y * 2.121944400546905827679e-4;
|
t1 := w*(Lg2+w*(Lg4+w*Lg6));
|
||||||
z := z + y * 0.693359375;
|
t2 := z*(Lg1+w*(Lg3+w*(Lg5+w*Lg7)));
|
||||||
end;
|
i := i or j;
|
||||||
|
R := t2+t1;
|
||||||
result:= z;
|
if (i>0) then
|
||||||
|
begin
|
||||||
|
hfsq := 0.5*f*f;
|
||||||
|
if (k=0) then
|
||||||
|
result := f-(hfsq-s*(hfsq+R))
|
||||||
|
else
|
||||||
|
result := dk*ln2_hi-((hfsq-(s*(hfsq+R)+dk*ln2_lo))-f);
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
if (k=0) then
|
||||||
|
result := f-s*(f-R)
|
||||||
|
else
|
||||||
|
result := dk*ln2_hi-((s*(f-R)-dk*ln2_lo)-f);
|
||||||
|
end;
|
||||||
end;
|
end;
|
||||||
{$endif}
|
{$endif}
|
||||||
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user