1 1.3 rillig /* $NetBSD: catrig.c,v 1.3 2022/04/19 20:32:16 rillig Exp $ */ 2 1.1 christos /*- 3 1.1 christos * Copyright (c) 2012 Stephen Montgomery-Smith <stephen (at) FreeBSD.ORG> 4 1.1 christos * All rights reserved. 5 1.1 christos * 6 1.1 christos * Redistribution and use in source and binary forms, with or without 7 1.1 christos * modification, are permitted provided that the following conditions 8 1.1 christos * are met: 9 1.1 christos * 1. Redistributions of source code must retain the above copyright 10 1.1 christos * notice, this list of conditions and the following disclaimer. 11 1.1 christos * 2. Redistributions in binary form must reproduce the above copyright 12 1.1 christos * notice, this list of conditions and the following disclaimer in the 13 1.1 christos * documentation and/or other materials provided with the distribution. 14 1.1 christos * 15 1.1 christos * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 16 1.1 christos * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 17 1.1 christos * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 18 1.1 christos * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 19 1.1 christos * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 1.1 christos * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 21 1.1 christos * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 22 1.1 christos * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 23 1.1 christos * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 24 1.1 christos * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 25 1.1 christos * SUCH DAMAGE. 26 1.1 christos */ 27 1.1 christos 28 1.1 christos #include <sys/cdefs.h> 29 1.1 christos #if 0 30 1.1 christos __FBSDID("$FreeBSD: head/lib/msun/src/catrig.c 275819 2014-12-16 09:21:56Z ed $"); 31 1.1 christos #endif 32 1.3 rillig __RCSID("$NetBSD: catrig.c,v 1.3 2022/04/19 20:32:16 rillig Exp $"); 33 1.1 christos 34 1.1 christos #include "namespace.h" 35 1.1 christos #ifdef __weak_alias 36 1.1 christos __weak_alias(casin, _casin) 37 1.1 christos #endif 38 1.1 christos #ifdef __weak_alias 39 1.1 christos __weak_alias(catan, _catan) 40 1.1 christos #endif 41 1.1 christos 42 1.1 christos #include <complex.h> 43 1.1 christos #include <float.h> 44 1.1 christos 45 1.1 christos #include "math.h" 46 1.1 christos #include "math_private.h" 47 1.1 christos 48 1.1 christos 49 1.1 christos 50 1.1 christos #undef isinf 51 1.1 christos #define isinf(x) (fabs(x) == INFINITY) 52 1.1 christos #undef isnan 53 1.1 christos #define isnan(x) ((x) != (x)) 54 1.3 rillig #define raise_inexact() do { volatile float junk __unused = /*LINTED*/1 + tiny; } while (0) 55 1.1 christos #undef signbit 56 1.1 christos #define signbit(x) (__builtin_signbit(x)) 57 1.1 christos 58 1.1 christos /* We need that DBL_EPSILON^2/128 is larger than FOUR_SQRT_MIN. */ 59 1.1 christos static const double 60 1.1 christos A_crossover = 10, /* Hull et al suggest 1.5, but 10 works better */ 61 1.1 christos B_crossover = 0.6417, /* suggested by Hull et al */ 62 1.1 christos m_e = 2.7182818284590452e0, /* 0x15bf0a8b145769.0p-51 */ 63 1.1 christos m_ln2 = 6.9314718055994531e-1, /* 0x162e42fefa39ef.0p-53 */ 64 1.1 christos pio2_hi = 1.5707963267948966e0, /* 0x1921fb54442d18.0p-52 */ 65 1.1 christos RECIP_EPSILON = 1 / DBL_EPSILON, 66 1.1 christos SQRT_3_EPSILON = 2.5809568279517849e-8, /* 0x1bb67ae8584caa.0p-78 */ 67 1.1 christos SQRT_6_EPSILON = 3.6500241499888571e-8, /* 0x13988e1409212e.0p-77 */ 68 1.2 christos #if DBL_MAX_EXP == 1024 /* IEEE */ 69 1.2 christos FOUR_SQRT_MIN = 0x1p-509, /* >= 4 * sqrt(DBL_MIN) */ 70 1.2 christos QUARTER_SQRT_MAX = 0x1p509, /* <= sqrt(DBL_MAX) / 4 */ 71 1.1 christos SQRT_MIN = 0x1p-511; /* >= sqrt(DBL_MIN) */ 72 1.2 christos #elif DBL_MAX_EXP == 127 /* VAX */ 73 1.2 christos FOUR_SQRT_MIN = 0x1p-62, /* >= 4 * sqrt(DBL_MIN) */ 74 1.2 christos QUARTER_SQRT_MAX = 0x1p62, /* <= sqrt(DBL_MAX) / 4 */ 75 1.2 christos SQRT_MIN = 0x1p-64; /* >= sqrt(DBL_MIN) */ 76 1.2 christos #else 77 1.2 christos #error "unsupported floating point format" 78 1.2 christos #endif 79 1.2 christos 80 1.1 christos 81 1.1 christos static const volatile double 82 1.1 christos pio2_lo = 6.1232339957367659e-17; /* 0x11a62633145c07.0p-106 */ 83 1.1 christos static const volatile float 84 1.1 christos tiny = 0x1p-100; 85 1.1 christos 86 1.1 christos static double complex clog_for_large_values(double complex z); 87 1.1 christos 88 1.1 christos /* 89 1.1 christos * Testing indicates that all these functions are accurate up to 4 ULP. 90 1.1 christos * The functions casin(h) and cacos(h) are about 2.5 times slower than asinh. 91 1.1 christos * The functions catan(h) are a little under 2 times slower than atanh. 92 1.1 christos * 93 1.1 christos * The code for casinh, casin, cacos, and cacosh comes first. The code is 94 1.1 christos * rather complicated, and the four functions are highly interdependent. 95 1.1 christos * 96 1.1 christos * The code for catanh and catan comes at the end. It is much simpler than 97 1.1 christos * the other functions, and the code for these can be disconnected from the 98 1.1 christos * rest of the code. 99 1.1 christos */ 100 1.1 christos 101 1.1 christos /* 102 1.1 christos * ================================ 103 1.1 christos * | casinh, casin, cacos, cacosh | 104 1.1 christos * ================================ 105 1.1 christos */ 106 1.1 christos 107 1.1 christos /* 108 1.1 christos * The algorithm is very close to that in "Implementing the complex arcsine 109 1.1 christos * and arccosine functions using exception handling" by T. E. Hull, Thomas F. 110 1.1 christos * Fairgrieve, and Ping Tak Peter Tang, published in ACM Transactions on 111 1.1 christos * Mathematical Software, Volume 23 Issue 3, 1997, Pages 299-335, 112 1.1 christos * http://dl.acm.org/citation.cfm?id=275324. 113 1.1 christos * 114 1.1 christos * Throughout we use the convention z = x + I*y. 115 1.1 christos * 116 1.1 christos * casinh(z) = sign(x)*log(A+sqrt(A*A-1)) + I*asin(B) 117 1.1 christos * where 118 1.1 christos * A = (|z+I| + |z-I|) / 2 119 1.1 christos * B = (|z+I| - |z-I|) / 2 = y/A 120 1.1 christos * 121 1.1 christos * These formulas become numerically unstable: 122 1.1 christos * (a) for Re(casinh(z)) when z is close to the line segment [-I, I] (that 123 1.1 christos * is, Re(casinh(z)) is close to 0); 124 1.1 christos * (b) for Im(casinh(z)) when z is close to either of the intervals 125 1.1 christos * [I, I*infinity) or (-I*infinity, -I] (that is, |Im(casinh(z))| is 126 1.1 christos * close to PI/2). 127 1.1 christos * 128 1.1 christos * These numerical problems are overcome by defining 129 1.1 christos * f(a, b) = (hypot(a, b) - b) / 2 = a*a / (hypot(a, b) + b) / 2 130 1.1 christos * Then if A < A_crossover, we use 131 1.1 christos * log(A + sqrt(A*A-1)) = log1p((A-1) + sqrt((A-1)*(A+1))) 132 1.1 christos * A-1 = f(x, 1+y) + f(x, 1-y) 133 1.1 christos * and if B > B_crossover, we use 134 1.1 christos * asin(B) = atan2(y, sqrt(A*A - y*y)) = atan2(y, sqrt((A+y)*(A-y))) 135 1.1 christos * A-y = f(x, y+1) + f(x, y-1) 136 1.1 christos * where without loss of generality we have assumed that x and y are 137 1.1 christos * non-negative. 138 1.1 christos * 139 1.1 christos * Much of the difficulty comes because the intermediate computations may 140 1.1 christos * produce overflows or underflows. This is dealt with in the paper by Hull 141 1.1 christos * et al by using exception handling. We do this by detecting when 142 1.1 christos * computations risk underflow or overflow. The hardest part is handling the 143 1.1 christos * underflows when computing f(a, b). 144 1.1 christos * 145 1.1 christos * Note that the function f(a, b) does not appear explicitly in the paper by 146 1.1 christos * Hull et al, but the idea may be found on pages 308 and 309. Introducing the 147 1.1 christos * function f(a, b) allows us to concentrate many of the clever tricks in this 148 1.1 christos * paper into one function. 149 1.1 christos */ 150 1.1 christos 151 1.1 christos /* 152 1.1 christos * Function f(a, b, hypot_a_b) = (hypot(a, b) - b) / 2. 153 1.1 christos * Pass hypot(a, b) as the third argument. 154 1.1 christos */ 155 1.1 christos static inline double 156 1.1 christos f(double a, double b, double hypot_a_b) 157 1.1 christos { 158 1.1 christos if (b < 0) 159 1.1 christos return ((hypot_a_b - b) / 2); 160 1.1 christos if (b == 0) 161 1.1 christos return (a / 2); 162 1.1 christos return (a * a / (hypot_a_b + b) / 2); 163 1.1 christos } 164 1.1 christos 165 1.1 christos /* 166 1.1 christos * All the hard work is contained in this function. 167 1.1 christos * x and y are assumed positive or zero, and less than RECIP_EPSILON. 168 1.1 christos * Upon return: 169 1.1 christos * rx = Re(casinh(z)) = -Im(cacos(y + I*x)). 170 1.1 christos * B_is_usable is set to 1 if the value of B is usable. 171 1.1 christos * If B_is_usable is set to 0, sqrt_A2my2 = sqrt(A*A - y*y), and new_y = y. 172 1.1 christos * If returning sqrt_A2my2 has potential to result in an underflow, it is 173 1.1 christos * rescaled, and new_y is similarly rescaled. 174 1.1 christos */ 175 1.1 christos static inline void 176 1.1 christos do_hard_work(double x, double y, double *rx, int *B_is_usable, double *B, 177 1.1 christos double *sqrt_A2my2, double *new_y) 178 1.1 christos { 179 1.1 christos double R, S, A; /* A, B, R, and S are as in Hull et al. */ 180 1.1 christos double Am1, Amy; /* A-1, A-y. */ 181 1.1 christos 182 1.1 christos R = hypot(x, y + 1); /* |z+I| */ 183 1.1 christos S = hypot(x, y - 1); /* |z-I| */ 184 1.1 christos 185 1.1 christos /* A = (|z+I| + |z-I|) / 2 */ 186 1.1 christos A = (R + S) / 2; 187 1.1 christos /* 188 1.1 christos * Mathematically A >= 1. There is a small chance that this will not 189 1.1 christos * be so because of rounding errors. So we will make certain it is 190 1.1 christos * so. 191 1.1 christos */ 192 1.1 christos if (A < 1) 193 1.1 christos A = 1; 194 1.1 christos 195 1.1 christos if (A < A_crossover) { 196 1.1 christos /* 197 1.1 christos * Am1 = fp + fm, where fp = f(x, 1+y), and fm = f(x, 1-y). 198 1.1 christos * rx = log1p(Am1 + sqrt(Am1*(A+1))) 199 1.1 christos */ 200 1.1 christos if (y == 1 && x < DBL_EPSILON * DBL_EPSILON / 128) { 201 1.1 christos /* 202 1.1 christos * fp is of order x^2, and fm = x/2. 203 1.1 christos * A = 1 (inexactly). 204 1.1 christos */ 205 1.1 christos *rx = sqrt(x); 206 1.1 christos } else if (x >= DBL_EPSILON * fabs(y - 1)) { 207 1.1 christos /* 208 1.1 christos * Underflow will not occur because 209 1.1 christos * x >= DBL_EPSILON^2/128 >= FOUR_SQRT_MIN 210 1.1 christos */ 211 1.1 christos Am1 = f(x, 1 + y, R) + f(x, 1 - y, S); 212 1.1 christos *rx = log1p(Am1 + sqrt(Am1 * (A + 1))); 213 1.1 christos } else if (y < 1) { 214 1.1 christos /* 215 1.1 christos * fp = x*x/(1+y)/4, fm = x*x/(1-y)/4, and 216 1.1 christos * A = 1 (inexactly). 217 1.1 christos */ 218 1.1 christos *rx = x / sqrt((1 - y) * (1 + y)); 219 1.1 christos } else { /* if (y > 1) */ 220 1.1 christos /* 221 1.1 christos * A-1 = y-1 (inexactly). 222 1.1 christos */ 223 1.1 christos *rx = log1p((y - 1) + sqrt((y - 1) * (y + 1))); 224 1.1 christos } 225 1.1 christos } else { 226 1.1 christos *rx = log(A + sqrt(A * A - 1)); 227 1.1 christos } 228 1.1 christos 229 1.1 christos *new_y = y; 230 1.1 christos 231 1.1 christos if (y < FOUR_SQRT_MIN) { 232 1.1 christos /* 233 1.1 christos * Avoid a possible underflow caused by y/A. For casinh this 234 1.1 christos * would be legitimate, but will be picked up by invoking atan2 235 1.1 christos * later on. For cacos this would not be legitimate. 236 1.1 christos */ 237 1.1 christos *B_is_usable = 0; 238 1.1 christos *sqrt_A2my2 = A * (2 / DBL_EPSILON); 239 1.1 christos *new_y = y * (2 / DBL_EPSILON); 240 1.1 christos return; 241 1.1 christos } 242 1.1 christos 243 1.1 christos /* B = (|z+I| - |z-I|) / 2 = y/A */ 244 1.1 christos *B = y / A; 245 1.1 christos *B_is_usable = 1; 246 1.1 christos 247 1.1 christos if (*B > B_crossover) { 248 1.1 christos *B_is_usable = 0; 249 1.1 christos /* 250 1.1 christos * Amy = fp + fm, where fp = f(x, y+1), and fm = f(x, y-1). 251 1.1 christos * sqrt_A2my2 = sqrt(Amy*(A+y)) 252 1.1 christos */ 253 1.1 christos if (y == 1 && x < DBL_EPSILON / 128) { 254 1.1 christos /* 255 1.1 christos * fp is of order x^2, and fm = x/2. 256 1.1 christos * A = 1 (inexactly). 257 1.1 christos */ 258 1.1 christos *sqrt_A2my2 = sqrt(x) * sqrt((A + y) / 2); 259 1.1 christos } else if (x >= DBL_EPSILON * fabs(y - 1)) { 260 1.1 christos /* 261 1.1 christos * Underflow will not occur because 262 1.1 christos * x >= DBL_EPSILON/128 >= FOUR_SQRT_MIN 263 1.1 christos * and 264 1.1 christos * x >= DBL_EPSILON^2 >= FOUR_SQRT_MIN 265 1.1 christos */ 266 1.1 christos Amy = f(x, y + 1, R) + f(x, y - 1, S); 267 1.1 christos *sqrt_A2my2 = sqrt(Amy * (A + y)); 268 1.1 christos } else if (y > 1) { 269 1.1 christos /* 270 1.1 christos * fp = x*x/(y+1)/4, fm = x*x/(y-1)/4, and 271 1.1 christos * A = y (inexactly). 272 1.1 christos * 273 1.1 christos * y < RECIP_EPSILON. So the following 274 1.1 christos * scaling should avoid any underflow problems. 275 1.1 christos */ 276 1.1 christos *sqrt_A2my2 = x * (4 / DBL_EPSILON / DBL_EPSILON) * y / 277 1.1 christos sqrt((y + 1) * (y - 1)); 278 1.1 christos *new_y = y * (4 / DBL_EPSILON / DBL_EPSILON); 279 1.1 christos } else { /* if (y < 1) */ 280 1.1 christos /* 281 1.1 christos * fm = 1-y >= DBL_EPSILON, fp is of order x^2, and 282 1.1 christos * A = 1 (inexactly). 283 1.1 christos */ 284 1.1 christos *sqrt_A2my2 = sqrt((1 - y) * (1 + y)); 285 1.1 christos } 286 1.1 christos } 287 1.1 christos } 288 1.1 christos 289 1.1 christos /* 290 1.1 christos * casinh(z) = z + O(z^3) as z -> 0 291 1.1 christos * 292 1.1 christos * casinh(z) = sign(x)*clog(sign(x)*z) + O(1/z^2) as z -> infinity 293 1.1 christos * The above formula works for the imaginary part as well, because 294 1.1 christos * Im(casinh(z)) = sign(x)*atan2(sign(x)*y, fabs(x)) + O(y/z^3) 295 1.1 christos * as z -> infinity, uniformly in y 296 1.1 christos */ 297 1.1 christos double complex 298 1.1 christos casinh(double complex z) 299 1.1 christos { 300 1.1 christos double x, y, ax, ay, rx, ry, B, sqrt_A2my2, new_y; 301 1.1 christos int B_is_usable; 302 1.1 christos double complex w; 303 1.1 christos 304 1.1 christos x = creal(z); 305 1.1 christos y = cimag(z); 306 1.1 christos ax = fabs(x); 307 1.1 christos ay = fabs(y); 308 1.1 christos 309 1.1 christos if (isnan(x) || isnan(y)) { 310 1.1 christos /* casinh(+-Inf + I*NaN) = +-Inf + I*NaN */ 311 1.1 christos if (isinf(x)) 312 1.1 christos return (CMPLX(x, y + y)); 313 1.1 christos /* casinh(NaN + I*+-Inf) = opt(+-)Inf + I*NaN */ 314 1.1 christos if (isinf(y)) 315 1.1 christos return (CMPLX(y, x + x)); 316 1.1 christos /* casinh(NaN + I*0) = NaN + I*0 */ 317 1.1 christos if (y == 0) 318 1.1 christos return (CMPLX(x + x, y)); 319 1.1 christos /* 320 1.1 christos * All other cases involving NaN return NaN + I*NaN. 321 1.1 christos * C99 leaves it optional whether to raise invalid if one of 322 1.1 christos * the arguments is not NaN, so we opt not to raise it. 323 1.1 christos */ 324 1.1 christos return (CMPLX(x + 0.0L + (y + 0), x + 0.0L + (y + 0))); 325 1.1 christos } 326 1.1 christos 327 1.1 christos if (ax > RECIP_EPSILON || ay > RECIP_EPSILON) { 328 1.1 christos /* clog...() will raise inexact unless x or y is infinite. */ 329 1.1 christos if (signbit(x) == 0) 330 1.1 christos w = clog_for_large_values(z) + m_ln2; 331 1.1 christos else 332 1.1 christos w = clog_for_large_values(-z) + m_ln2; 333 1.1 christos return (CMPLX(copysign(creal(w), x), copysign(cimag(w), y))); 334 1.1 christos } 335 1.1 christos 336 1.1 christos /* Avoid spuriously raising inexact for z = 0. */ 337 1.1 christos if (x == 0 && y == 0) 338 1.1 christos return (z); 339 1.1 christos 340 1.1 christos /* All remaining cases are inexact. */ 341 1.1 christos raise_inexact(); 342 1.1 christos 343 1.1 christos if (ax < SQRT_6_EPSILON / 4 && ay < SQRT_6_EPSILON / 4) 344 1.1 christos return (z); 345 1.1 christos 346 1.1 christos do_hard_work(ax, ay, &rx, &B_is_usable, &B, &sqrt_A2my2, &new_y); 347 1.1 christos if (B_is_usable) 348 1.1 christos ry = asin(B); 349 1.1 christos else 350 1.1 christos ry = atan2(new_y, sqrt_A2my2); 351 1.1 christos return (CMPLX(copysign(rx, x), copysign(ry, y))); 352 1.1 christos } 353 1.1 christos 354 1.1 christos /* 355 1.1 christos * casin(z) = reverse(casinh(reverse(z))) 356 1.1 christos * where reverse(x + I*y) = y + I*x = I*conj(z). 357 1.1 christos */ 358 1.1 christos double complex 359 1.1 christos casin(double complex z) 360 1.1 christos { 361 1.1 christos double complex w = casinh(CMPLX(cimag(z), creal(z))); 362 1.1 christos 363 1.1 christos return (CMPLX(cimag(w), creal(w))); 364 1.1 christos } 365 1.1 christos 366 1.1 christos /* 367 1.1 christos * cacos(z) = PI/2 - casin(z) 368 1.1 christos * but do the computation carefully so cacos(z) is accurate when z is 369 1.1 christos * close to 1. 370 1.1 christos * 371 1.1 christos * cacos(z) = PI/2 - z + O(z^3) as z -> 0 372 1.1 christos * 373 1.1 christos * cacos(z) = -sign(y)*I*clog(z) + O(1/z^2) as z -> infinity 374 1.1 christos * The above formula works for the real part as well, because 375 1.1 christos * Re(cacos(z)) = atan2(fabs(y), x) + O(y/z^3) 376 1.1 christos * as z -> infinity, uniformly in y 377 1.1 christos */ 378 1.1 christos double complex 379 1.1 christos cacos(double complex z) 380 1.1 christos { 381 1.1 christos double x, y, ax, ay, rx, ry, B, sqrt_A2mx2, new_x; 382 1.1 christos int sx, sy; 383 1.1 christos int B_is_usable; 384 1.1 christos double complex w; 385 1.1 christos 386 1.1 christos x = creal(z); 387 1.1 christos y = cimag(z); 388 1.1 christos sx = signbit(x); 389 1.1 christos sy = signbit(y); 390 1.1 christos ax = fabs(x); 391 1.1 christos ay = fabs(y); 392 1.1 christos 393 1.1 christos if (isnan(x) || isnan(y)) { 394 1.1 christos /* cacos(+-Inf + I*NaN) = NaN + I*opt(-)Inf */ 395 1.1 christos if (isinf(x)) 396 1.1 christos return (CMPLX(y + y, -INFINITY)); 397 1.1 christos /* cacos(NaN + I*+-Inf) = NaN + I*-+Inf */ 398 1.1 christos if (isinf(y)) 399 1.1 christos return (CMPLX(x + x, -y)); 400 1.1 christos /* cacos(0 + I*NaN) = PI/2 + I*NaN with inexact */ 401 1.1 christos if (x == 0) 402 1.1 christos return (CMPLX(pio2_hi + pio2_lo, y + y)); 403 1.1 christos /* 404 1.1 christos * All other cases involving NaN return NaN + I*NaN. 405 1.1 christos * C99 leaves it optional whether to raise invalid if one of 406 1.1 christos * the arguments is not NaN, so we opt not to raise it. 407 1.1 christos */ 408 1.1 christos return (CMPLX(x + 0.0L + (y + 0), x + 0.0L + (y + 0))); 409 1.1 christos } 410 1.1 christos 411 1.1 christos if (ax > RECIP_EPSILON || ay > RECIP_EPSILON) { 412 1.1 christos /* clog...() will raise inexact unless x or y is infinite. */ 413 1.1 christos w = clog_for_large_values(z); 414 1.1 christos rx = fabs(cimag(w)); 415 1.1 christos ry = creal(w) + m_ln2; 416 1.1 christos if (sy == 0) 417 1.1 christos ry = -ry; 418 1.1 christos return (CMPLX(rx, ry)); 419 1.1 christos } 420 1.1 christos 421 1.1 christos /* Avoid spuriously raising inexact for z = 1. */ 422 1.1 christos if (x == 1 && y == 0) 423 1.1 christos return (CMPLX(0, -y)); 424 1.1 christos 425 1.1 christos /* All remaining cases are inexact. */ 426 1.1 christos raise_inexact(); 427 1.1 christos 428 1.1 christos if (ax < SQRT_6_EPSILON / 4 && ay < SQRT_6_EPSILON / 4) 429 1.1 christos return (CMPLX(pio2_hi - (x - pio2_lo), -y)); 430 1.1 christos 431 1.1 christos do_hard_work(ay, ax, &ry, &B_is_usable, &B, &sqrt_A2mx2, &new_x); 432 1.1 christos if (B_is_usable) { 433 1.1 christos if (sx == 0) 434 1.1 christos rx = acos(B); 435 1.1 christos else 436 1.1 christos rx = acos(-B); 437 1.1 christos } else { 438 1.1 christos if (sx == 0) 439 1.1 christos rx = atan2(sqrt_A2mx2, new_x); 440 1.1 christos else 441 1.1 christos rx = atan2(sqrt_A2mx2, -new_x); 442 1.1 christos } 443 1.1 christos if (sy == 0) 444 1.1 christos ry = -ry; 445 1.1 christos return (CMPLX(rx, ry)); 446 1.1 christos } 447 1.1 christos 448 1.1 christos /* 449 1.1 christos * cacosh(z) = I*cacos(z) or -I*cacos(z) 450 1.1 christos * where the sign is chosen so Re(cacosh(z)) >= 0. 451 1.1 christos */ 452 1.1 christos double complex 453 1.1 christos cacosh(double complex z) 454 1.1 christos { 455 1.1 christos double complex w; 456 1.1 christos double rx, ry; 457 1.1 christos 458 1.1 christos w = cacos(z); 459 1.1 christos rx = creal(w); 460 1.1 christos ry = cimag(w); 461 1.1 christos /* cacosh(NaN + I*NaN) = NaN + I*NaN */ 462 1.1 christos if (isnan(rx) && isnan(ry)) 463 1.1 christos return (CMPLX(ry, rx)); 464 1.1 christos /* cacosh(NaN + I*+-Inf) = +Inf + I*NaN */ 465 1.1 christos /* cacosh(+-Inf + I*NaN) = +Inf + I*NaN */ 466 1.1 christos if (isnan(rx)) 467 1.1 christos return (CMPLX(fabs(ry), rx)); 468 1.1 christos /* cacosh(0 + I*NaN) = NaN + I*NaN */ 469 1.1 christos if (isnan(ry)) 470 1.1 christos return (CMPLX(ry, ry)); 471 1.1 christos return (CMPLX(fabs(ry), copysign(rx, cimag(z)))); 472 1.1 christos } 473 1.1 christos 474 1.1 christos /* 475 1.1 christos * Optimized version of clog() for |z| finite and larger than ~RECIP_EPSILON. 476 1.1 christos */ 477 1.1 christos static double complex 478 1.1 christos clog_for_large_values(double complex z) 479 1.1 christos { 480 1.1 christos double x, y; 481 1.1 christos double ax, ay, t; 482 1.1 christos 483 1.1 christos x = creal(z); 484 1.1 christos y = cimag(z); 485 1.1 christos ax = fabs(x); 486 1.1 christos ay = fabs(y); 487 1.1 christos if (ax < ay) { 488 1.1 christos t = ax; 489 1.1 christos ax = ay; 490 1.1 christos ay = t; 491 1.1 christos } 492 1.1 christos 493 1.1 christos /* 494 1.1 christos * Avoid overflow in hypot() when x and y are both very large. 495 1.1 christos * Divide x and y by E, and then add 1 to the logarithm. This depends 496 1.1 christos * on E being larger than sqrt(2). 497 1.1 christos * Dividing by E causes an insignificant loss of accuracy; however 498 1.1 christos * this method is still poor since it is uneccessarily slow. 499 1.1 christos */ 500 1.1 christos if (ax > DBL_MAX / 2) 501 1.1 christos return (CMPLX(log(hypot(x / m_e, y / m_e)) + 1, atan2(y, x))); 502 1.1 christos 503 1.1 christos /* 504 1.1 christos * Avoid overflow when x or y is large. Avoid underflow when x or 505 1.1 christos * y is small. 506 1.1 christos */ 507 1.1 christos if (ax > QUARTER_SQRT_MAX || ay < SQRT_MIN) 508 1.1 christos return (CMPLX(log(hypot(x, y)), atan2(y, x))); 509 1.1 christos 510 1.1 christos return (CMPLX(log(ax * ax + ay * ay) / 2, atan2(y, x))); 511 1.1 christos } 512 1.1 christos 513 1.1 christos /* 514 1.1 christos * ================= 515 1.1 christos * | catanh, catan | 516 1.1 christos * ================= 517 1.1 christos */ 518 1.1 christos 519 1.1 christos /* 520 1.1 christos * sum_squares(x,y) = x*x + y*y (or just x*x if y*y would underflow). 521 1.1 christos * Assumes x*x and y*y will not overflow. 522 1.1 christos * Assumes x and y are finite. 523 1.1 christos * Assumes y is non-negative. 524 1.1 christos * Assumes fabs(x) >= DBL_EPSILON. 525 1.1 christos */ 526 1.1 christos static inline double 527 1.1 christos sum_squares(double x, double y) 528 1.1 christos { 529 1.1 christos 530 1.1 christos /* Avoid underflow when y is small. */ 531 1.1 christos if (y < SQRT_MIN) 532 1.1 christos return (x * x); 533 1.1 christos 534 1.1 christos return (x * x + y * y); 535 1.1 christos } 536 1.1 christos 537 1.1 christos /* 538 1.1 christos * real_part_reciprocal(x, y) = Re(1/(x+I*y)) = x/(x*x + y*y). 539 1.1 christos * Assumes x and y are not NaN, and one of x and y is larger than 540 1.1 christos * RECIP_EPSILON. We avoid unwarranted underflow. It is important to not use 541 1.1 christos * the code creal(1/z), because the imaginary part may produce an unwanted 542 1.1 christos * underflow. 543 1.1 christos * This is only called in a context where inexact is always raised before 544 1.1 christos * the call, so no effort is made to avoid or force inexact. 545 1.1 christos */ 546 1.1 christos static inline double 547 1.1 christos real_part_reciprocal(double x, double y) 548 1.1 christos { 549 1.1 christos double scale; 550 1.1 christos uint32_t hx, hy; 551 1.1 christos int32_t ix, iy; 552 1.1 christos 553 1.1 christos /* 554 1.1 christos * This code is inspired by the C99 document n1124.pdf, Section G.5.1, 555 1.1 christos * example 2. 556 1.1 christos */ 557 1.1 christos GET_HIGH_WORD(hx, x); 558 1.1 christos ix = hx & 0x7ff00000; 559 1.1 christos GET_HIGH_WORD(hy, y); 560 1.1 christos iy = hy & 0x7ff00000; 561 1.1 christos #define BIAS (DBL_MAX_EXP - 1) 562 1.1 christos /* XXX more guard digits are useful iff there is extra precision. */ 563 1.1 christos #define CUTOFF (DBL_MANT_DIG / 2 + 1) /* just half or 1 guard digit */ 564 1.1 christos if (ix - iy >= CUTOFF << 20 || isinf(x)) 565 1.1 christos return (1 / x); /* +-Inf -> +-0 is special */ 566 1.1 christos if (iy - ix >= CUTOFF << 20) 567 1.1 christos return (x / y / y); /* should avoid double div, but hard */ 568 1.1 christos if (ix <= (BIAS + DBL_MAX_EXP / 2 - CUTOFF) << 20) 569 1.1 christos return (x / (x * x + y * y)); 570 1.1 christos scale = 1; 571 1.1 christos SET_HIGH_WORD(scale, 0x7ff00000 - ix); /* 2**(1-ilogb(x)) */ 572 1.1 christos x *= scale; 573 1.1 christos y *= scale; 574 1.1 christos return (x / (x * x + y * y) * scale); 575 1.1 christos } 576 1.1 christos 577 1.1 christos /* 578 1.1 christos * catanh(z) = log((1+z)/(1-z)) / 2 579 1.1 christos * = log1p(4*x / |z-1|^2) / 4 580 1.1 christos * + I * atan2(2*y, (1-x)*(1+x)-y*y) / 2 581 1.1 christos * 582 1.1 christos * catanh(z) = z + O(z^3) as z -> 0 583 1.1 christos * 584 1.1 christos * catanh(z) = 1/z + sign(y)*I*PI/2 + O(1/z^3) as z -> infinity 585 1.1 christos * The above formula works for the real part as well, because 586 1.1 christos * Re(catanh(z)) = x/|z|^2 + O(x/z^4) 587 1.1 christos * as z -> infinity, uniformly in x 588 1.1 christos */ 589 1.1 christos double complex 590 1.1 christos catanh(double complex z) 591 1.1 christos { 592 1.1 christos double x, y, ax, ay, rx, ry; 593 1.1 christos 594 1.1 christos x = creal(z); 595 1.1 christos y = cimag(z); 596 1.1 christos ax = fabs(x); 597 1.1 christos ay = fabs(y); 598 1.1 christos 599 1.1 christos /* This helps handle many cases. */ 600 1.1 christos if (y == 0 && ax <= 1) 601 1.1 christos return (CMPLX(atanh(x), y)); 602 1.1 christos 603 1.1 christos /* To ensure the same accuracy as atan(), and to filter out z = 0. */ 604 1.1 christos if (x == 0) 605 1.1 christos return (CMPLX(x, atan(y))); 606 1.1 christos 607 1.1 christos if (isnan(x) || isnan(y)) { 608 1.1 christos /* catanh(+-Inf + I*NaN) = +-0 + I*NaN */ 609 1.1 christos if (isinf(x)) 610 1.1 christos return (CMPLX(copysign(0, x), y + y)); 611 1.1 christos /* catanh(NaN + I*+-Inf) = sign(NaN)0 + I*+-PI/2 */ 612 1.1 christos if (isinf(y)) 613 1.1 christos return (CMPLX(copysign(0, x), 614 1.1 christos copysign(pio2_hi + pio2_lo, y))); 615 1.1 christos /* 616 1.1 christos * All other cases involving NaN return NaN + I*NaN. 617 1.1 christos * C99 leaves it optional whether to raise invalid if one of 618 1.1 christos * the arguments is not NaN, so we opt not to raise it. 619 1.1 christos */ 620 1.1 christos return (CMPLX(x + 0.0L + (y + 0), x + 0.0L + (y + 0))); 621 1.1 christos } 622 1.1 christos 623 1.1 christos if (ax > RECIP_EPSILON || ay > RECIP_EPSILON) 624 1.1 christos return (CMPLX(real_part_reciprocal(x, y), 625 1.1 christos copysign(pio2_hi + pio2_lo, y))); 626 1.1 christos 627 1.1 christos if (ax < SQRT_3_EPSILON / 2 && ay < SQRT_3_EPSILON / 2) { 628 1.1 christos /* 629 1.1 christos * z = 0 was filtered out above. All other cases must raise 630 1.1 christos * inexact, but this is the only only that needs to do it 631 1.1 christos * explicitly. 632 1.1 christos */ 633 1.1 christos raise_inexact(); 634 1.1 christos return (z); 635 1.1 christos } 636 1.1 christos 637 1.1 christos if (ax == 1 && ay < DBL_EPSILON) 638 1.1 christos rx = (m_ln2 - log(ay)) / 2; 639 1.1 christos else 640 1.1 christos rx = log1p(4 * ax / sum_squares(ax - 1, ay)) / 4; 641 1.1 christos 642 1.1 christos if (ax == 1) 643 1.1 christos ry = atan2(2, -ay) / 2; 644 1.1 christos else if (ay < DBL_EPSILON) 645 1.1 christos ry = atan2(2 * ay, (1 - ax) * (1 + ax)) / 2; 646 1.1 christos else 647 1.1 christos ry = atan2(2 * ay, (1 - ax) * (1 + ax) - ay * ay) / 2; 648 1.1 christos 649 1.1 christos return (CMPLX(copysign(rx, x), copysign(ry, y))); 650 1.1 christos } 651 1.1 christos 652 1.1 christos /* 653 1.1 christos * catan(z) = reverse(catanh(reverse(z))) 654 1.1 christos * where reverse(x + I*y) = y + I*x = I*conj(z). 655 1.1 christos */ 656 1.1 christos double complex 657 1.1 christos catan(double complex z) 658 1.1 christos { 659 1.1 christos double complex w = catanh(CMPLX(cimag(z), creal(z))); 660 1.1 christos 661 1.1 christos return (CMPLX(cimag(w), creal(w))); 662 1.1 christos } 663