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 the above copyright notice and this paragraph are 7 * duplicated in all such forms and that any documentation, 8 * advertising materials, and other materials related to such 9 * distribution and use acknowledge that the software was developed 10 * by the University of California, Berkeley. The name of the 11 * University may not be used to endorse or promote products derived 12 * from this software without specific prior written permission. 13 * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR 14 * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED 15 * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. 16 * 17 * All recipients should regard themselves as participants in an ongoing 18 * research project and hence should feel obligated to report their 19 * experiences (good or bad) with these elementary function codes, using 20 * the sendbug(8) program, to the authors. 21 */ 22 23 #ifndef lint 24 static char sccsid[] = "@(#)cabs.c 5.4 (Berkeley) 09/22/88"; 25 #endif /* not lint */ 26 27 /* HYPOT(X,Y) 28 * RETURN THE SQUARE ROOT OF X^2 + Y^2 WHERE Z=X+iY 29 * DOUBLE PRECISION (VAX D format 56 bits, IEEE DOUBLE 53 BITS) 30 * CODED IN C BY K.C. NG, 11/28/84; 31 * REVISED BY K.C. NG, 7/12/85. 32 * 33 * Required system supported functions : 34 * copysign(x,y) 35 * finite(x) 36 * scalb(x,N) 37 * sqrt(x) 38 * 39 * Method : 40 * 1. replace x by |x| and y by |y|, and swap x and 41 * y if y > x (hence x is never smaller than y). 42 * 2. Hypot(x,y) is computed by: 43 * Case I, x/y > 2 44 * 45 * y 46 * hypot = x + ----------------------------- 47 * 2 48 * sqrt ( 1 + [x/y] ) + x/y 49 * 50 * Case II, x/y <= 2 51 * y 52 * hypot = x + -------------------------------------------------- 53 * 2 54 * [x/y] - 2 55 * (sqrt(2)+1) + (x-y)/y + ----------------------------- 56 * 2 57 * sqrt ( 1 + [x/y] ) + sqrt(2) 58 * 59 * 60 * 61 * Special cases: 62 * hypot(x,y) is INF if x or y is +INF or -INF; else 63 * hypot(x,y) is NAN if x or y is NAN. 64 * 65 * Accuracy: 66 * hypot(x,y) returns the sqrt(x^2+y^2) with error less than 1 ulps (units 67 * in the last place). See Kahan's "Interval Arithmetic Options in the 68 * Proposed IEEE Floating Point Arithmetic Standard", Interval Mathematics 69 * 1980, Edited by Karl L.E. Nickel, pp 99-128. (A faster but less accurate 70 * code follows in comments.) In a test run with 500,000 random arguments 71 * on a VAX, the maximum observed error was .959 ulps. 72 * 73 * Constants: 74 * The hexadecimal values are the intended ones for the following constants. 75 * The decimal values may be used, provided that the compiler will convert 76 * from decimal to binary accurately enough to produce the hexadecimal values 77 * shown. 78 */ 79 #include "mathimpl.h" 80 81 vc(r2p1hi, 2.4142135623730950345E0 ,8279,411a,ef32,99fc, 2, .9A827999FCEF32) 82 vc(r2p1lo, 1.4349369327986523769E-17 ,597d,2484,754b,89b3, -55, .84597D89B3754B) 83 vc(sqrt2, 1.4142135623730950622E0 ,04f3,40b5,de65,33f9, 1, .B504F333F9DE65) 84 85 ic(r2p1hi, 2.4142135623730949234E0 , 1, 1.3504F333F9DE6) 86 ic(r2p1lo, 1.2537167179050217666E-16 , -53, 1.21165F626CDD5) 87 ic(sqrt2, 1.4142135623730951455E0 , 0, 1.6A09E667F3BCD) 88 89 #ifdef vccast 90 #define r2p1hi vccast(r2p1hi) 91 #define r2p1lo vccast(r2p1lo) 92 #define sqrt2 vccast(sqrt2) 93 #endif 94 95 double 96 hypot(x,y) 97 double x, y; 98 { 99 static const double zero=0, one=1, 100 small=1.0E-18; /* fl(1+small)==1 */ 101 static const ibig=30; /* fl(1+2**(2*ibig))==1 */ 102 double t,r; 103 int exp; 104 105 if(finite(x)) 106 if(finite(y)) 107 { 108 x=copysign(x,one); 109 y=copysign(y,one); 110 if(y > x) 111 { t=x; x=y; y=t; } 112 if(x == zero) return(zero); 113 if(y == zero) return(x); 114 exp= logb(x); 115 if(exp-(int)logb(y) > ibig ) 116 /* raise inexact flag and return |x| */ 117 { one+small; return(x); } 118 119 /* start computing sqrt(x^2 + y^2) */ 120 r=x-y; 121 if(r>y) { /* x/y > 2 */ 122 r=x/y; 123 r=r+sqrt(one+r*r); } 124 else { /* 1 <= x/y <= 2 */ 125 r/=y; t=r*(r+2.0); 126 r+=t/(sqrt2+sqrt(2.0+t)); 127 r+=r2p1lo; r+=r2p1hi; } 128 129 r=y/r; 130 return(x+r); 131 132 } 133 134 else if(y==y) /* y is +-INF */ 135 return(copysign(y,one)); 136 else 137 return(y); /* y is NaN and x is finite */ 138 139 else if(x==x) /* x is +-INF */ 140 return (copysign(x,one)); 141 else if(finite(y)) 142 return(x); /* x is NaN, y is finite */ 143 #if !defined(vax)&&!defined(tahoe) 144 else if(y!=y) return(y); /* x and y is NaN */ 145 #endif /* !defined(vax)&&!defined(tahoe) */ 146 else return(copysign(y,one)); /* y is INF */ 147 } 148 149 /* CABS(Z) 150 * RETURN THE ABSOLUTE VALUE OF THE COMPLEX NUMBER Z = X + iY 151 * DOUBLE PRECISION (VAX D format 56 bits, IEEE DOUBLE 53 BITS) 152 * CODED IN C BY K.C. NG, 11/28/84. 153 * REVISED BY K.C. NG, 7/12/85. 154 * 155 * Required kernel function : 156 * hypot(x,y) 157 * 158 * Method : 159 * cabs(z) = hypot(x,y) . 160 */ 161 162 double 163 cabs(z) 164 struct { double x, y;} z; 165 { 166 return hypot(z.x,z.y); 167 } 168 169 double 170 z_abs(z) 171 struct { double x,y;} *z; 172 { 173 return hypot(z->x,z->y); 174 } 175 176 /* A faster but less accurate version of cabs(x,y) */ 177 #if 0 178 double hypot(x,y) 179 double x, y; 180 { 181 static const double zero=0, one=1; 182 small=1.0E-18; /* fl(1+small)==1 */ 183 static const ibig=30; /* fl(1+2**(2*ibig))==1 */ 184 double temp; 185 int exp; 186 187 if(finite(x)) 188 if(finite(y)) 189 { 190 x=copysign(x,one); 191 y=copysign(y,one); 192 if(y > x) 193 { temp=x; x=y; y=temp; } 194 if(x == zero) return(zero); 195 if(y == zero) return(x); 196 exp= logb(x); 197 x=scalb(x,-exp); 198 if(exp-(int)logb(y) > ibig ) 199 /* raise inexact flag and return |x| */ 200 { one+small; return(scalb(x,exp)); } 201 else y=scalb(y,-exp); 202 return(scalb(sqrt(x*x+y*y),exp)); 203 } 204 205 else if(y==y) /* y is +-INF */ 206 return(copysign(y,one)); 207 else 208 return(y); /* y is NaN and x is finite */ 209 210 else if(x==x) /* x is +-INF */ 211 return (copysign(x,one)); 212 else if(finite(y)) 213 return(x); /* x is NaN, y is finite */ 214 else if(y!=y) return(y); /* x and y is NaN */ 215 else return(copysign(y,one)); /* y is INF */ 216 } 217 #endif 218