1 ------------------------------------------------------------------------------
3 -- GNAT RUNTIME COMPONENTS --
5 -- ADA.NUMERICS.GENERIC_COMPLEX_ELEMENTARY_FUNCTIONS --
9 -- Copyright (C) 1992-2001 Free Software Foundation, Inc.
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with Ada.Numerics.Generic_Elementary_Functions;
36 package body Ada.Numerics.Generic_Complex_Elementary_Functions is
38 package Elementary_Functions is new
39 Ada.Numerics.Generic_Elementary_Functions (Real'Base);
40 use Elementary_Functions;
42 PI : constant := 3.14159_26535_89793_23846_26433_83279_50288_41971;
43 PI_2 : constant := PI / 2.0;
44 Sqrt_Two : constant := 1.41421_35623_73095_04880_16887_24209_69807_85696;
45 Log_Two : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755;
47 subtype T is Real'Base;
49 Epsilon : constant T := 2.0 ** (1 - T'Model_Mantissa);
50 Square_Root_Epsilon : constant T := Sqrt_Two ** (1 - T'Model_Mantissa);
51 Inv_Square_Root_Epsilon : constant T := Sqrt_Two ** (T'Model_Mantissa - 1);
52 Root_Root_Epsilon : constant T := Sqrt_Two **
53 ((1 - T'Model_Mantissa) / 2);
54 Log_Inverse_Epsilon_2 : constant T := T (T'Model_Mantissa - 1) / 2.0;
56 Complex_Zero : constant Complex := (0.0, 0.0);
57 Complex_One : constant Complex := (1.0, 0.0);
58 Complex_I : constant Complex := (0.0, 1.0);
59 Half_Pi : constant Complex := (PI_2, 0.0);
65 function "**" (Left : Complex; Right : Complex) return Complex is
68 and then Im (Right) = 0.0
69 and then Re (Left) = 0.0
70 and then Im (Left) = 0.0
75 and then Im (Left) = 0.0
76 and then Re (Right) < 0.0
78 raise Constraint_Error;
80 elsif Re (Left) = 0.0 and then Im (Left) = 0.0 then
83 elsif Right = (0.0, 0.0) then
86 elsif Re (Right) = 0.0 and then Im (Right) = 0.0 then
89 elsif Re (Right) = 1.0 and then Im (Right) = 0.0 then
93 return Exp (Right * Log (Left));
97 function "**" (Left : Real'Base; Right : Complex) return Complex is
99 if Re (Right) = 0.0 and then Im (Right) = 0.0 and then Left = 0.0 then
100 raise Argument_Error;
102 elsif Left = 0.0 and then Re (Right) < 0.0 then
103 raise Constraint_Error;
105 elsif Left = 0.0 then
106 return Compose_From_Cartesian (Left, 0.0);
108 elsif Re (Right) = 0.0 and then Im (Right) = 0.0 then
111 elsif Re (Right) = 1.0 and then Im (Right) = 0.0 then
112 return Compose_From_Cartesian (Left, 0.0);
115 return Exp (Log (Left) * Right);
119 function "**" (Left : Complex; Right : Real'Base) return Complex is
122 and then Re (Left) = 0.0
123 and then Im (Left) = 0.0
125 raise Argument_Error;
127 elsif Re (Left) = 0.0
128 and then Im (Left) = 0.0
131 raise Constraint_Error;
133 elsif Re (Left) = 0.0 and then Im (Left) = 0.0 then
136 elsif Right = 0.0 then
139 elsif Right = 1.0 then
143 return Exp (Right * Log (Left));
151 function Arccos (X : Complex) return Complex is
155 if X = Complex_One then
158 elsif abs Re (X) < Square_Root_Epsilon and then
159 abs Im (X) < Square_Root_Epsilon
163 elsif abs Re (X) > Inv_Square_Root_Epsilon or else
164 abs Im (X) > Inv_Square_Root_Epsilon
166 return -2.0 * Complex_I * Log (Sqrt ((1.0 + X) / 2.0) +
167 Complex_I * Sqrt ((1.0 - X) / 2.0));
170 Result := -Complex_I * Log (X + Complex_I * Sqrt (1.0 - X * X));
173 and then abs Re (X) <= 1.00
175 Set_Im (Result, Im (X));
185 function Arccosh (X : Complex) return Complex is
189 if X = Complex_One then
192 elsif abs Re (X) < Square_Root_Epsilon and then
193 abs Im (X) < Square_Root_Epsilon
195 Result := Compose_From_Cartesian (-Im (X), -PI_2 + Re (X));
197 elsif abs Re (X) > Inv_Square_Root_Epsilon or else
198 abs Im (X) > Inv_Square_Root_Epsilon
200 Result := Log_Two + Log (X);
203 Result := 2.0 * Log (Sqrt ((1.0 + X) / 2.0) +
204 Sqrt ((X - 1.0) / 2.0));
207 if Re (Result) <= 0.0 then
218 function Arccot (X : Complex) return Complex is
222 if abs Re (X) < Square_Root_Epsilon and then
223 abs Im (X) < Square_Root_Epsilon
227 elsif abs Re (X) > 1.0 / Epsilon or else
228 abs Im (X) > 1.0 / Epsilon
230 Xt := Complex_One / X;
233 Set_Re (Xt, PI - Re (Xt));
240 Xt := Complex_I * Log ((X - Complex_I) / (X + Complex_I)) / 2.0;
242 if Re (Xt) < 0.0 then
253 function Arccoth (X : Complex) return Complex is
257 if X = (0.0, 0.0) then
258 return Compose_From_Cartesian (0.0, PI_2);
260 elsif abs Re (X) < Square_Root_Epsilon
261 and then abs Im (X) < Square_Root_Epsilon
263 return PI_2 * Complex_I + X;
265 elsif abs Re (X) > 1.0 / Epsilon or else
266 abs Im (X) > 1.0 / Epsilon
271 return PI * Complex_I;
274 elsif Im (X) = 0.0 and then Re (X) = 1.0 then
275 raise Constraint_Error;
277 elsif Im (X) = 0.0 and then Re (X) = -1.0 then
278 raise Constraint_Error;
282 R := Log ((1.0 + X) / (X - 1.0)) / 2.0;
285 when Constraint_Error =>
286 R := (Log (1.0 + X) - Log (X - 1.0)) / 2.0;
290 Set_Im (R, PI + Im (R));
304 function Arcsin (X : Complex) return Complex is
308 if abs Re (X) < Square_Root_Epsilon and then
309 abs Im (X) < Square_Root_Epsilon
313 elsif abs Re (X) > Inv_Square_Root_Epsilon or else
314 abs Im (X) > Inv_Square_Root_Epsilon
316 Result := -Complex_I * (Log (Complex_I * X) + Log (2.0 * Complex_I));
318 if Im (Result) > PI_2 then
319 Set_Im (Result, PI - Im (X));
321 elsif Im (Result) < -PI_2 then
322 Set_Im (Result, -(PI + Im (X)));
326 Result := -Complex_I * Log (Complex_I * X + Sqrt (1.0 - X * X));
329 Set_Re (Result, Re (X));
332 and then abs Re (X) <= 1.00
334 Set_Im (Result, Im (X));
344 function Arcsinh (X : Complex) return Complex is
348 if abs Re (X) < Square_Root_Epsilon and then
349 abs Im (X) < Square_Root_Epsilon
353 elsif abs Re (X) > Inv_Square_Root_Epsilon or else
354 abs Im (X) > Inv_Square_Root_Epsilon
356 Result := Log_Two + Log (X); -- may have wrong sign
358 if (Re (X) < 0.0 and Re (Result) > 0.0)
359 or else (Re (X) > 0.0 and Re (Result) < 0.0)
361 Set_Re (Result, -Re (Result));
367 Result := Log (X + Sqrt (1.0 + X * X));
370 Set_Re (Result, Re (X));
371 elsif Im (X) = 0.0 then
372 Set_Im (Result, Im (X));
382 function Arctan (X : Complex) return Complex is
384 if abs Re (X) < Square_Root_Epsilon and then
385 abs Im (X) < Square_Root_Epsilon
390 return -Complex_I * (Log (1.0 + Complex_I * X)
391 - Log (1.0 - Complex_I * X)) / 2.0;
399 function Arctanh (X : Complex) return Complex is
401 if abs Re (X) < Square_Root_Epsilon and then
402 abs Im (X) < Square_Root_Epsilon
406 return (Log (1.0 + X) - Log (1.0 - X)) / 2.0;
414 function Cos (X : Complex) return Complex is
417 Compose_From_Cartesian
418 (Cos (Re (X)) * Cosh (Im (X)),
419 -Sin (Re (X)) * Sinh (Im (X)));
426 function Cosh (X : Complex) return Complex is
429 Compose_From_Cartesian
430 (Cosh (Re (X)) * Cos (Im (X)),
431 Sinh (Re (X)) * Sin (Im (X)));
438 function Cot (X : Complex) return Complex is
440 if abs Re (X) < Square_Root_Epsilon and then
441 abs Im (X) < Square_Root_Epsilon
443 return Complex_One / X;
445 elsif Im (X) > Log_Inverse_Epsilon_2 then
448 elsif Im (X) < -Log_Inverse_Epsilon_2 then
452 return Cos (X) / Sin (X);
459 function Coth (X : Complex) return Complex is
461 if abs Re (X) < Square_Root_Epsilon and then
462 abs Im (X) < Square_Root_Epsilon
464 return Complex_One / X;
466 elsif Re (X) > Log_Inverse_Epsilon_2 then
469 elsif Re (X) < -Log_Inverse_Epsilon_2 then
473 return Cosh (X) / Sinh (X);
481 function Exp (X : Complex) return Complex is
482 EXP_RE_X : Real'Base := Exp (Re (X));
485 return Compose_From_Cartesian (EXP_RE_X * Cos (Im (X)),
486 EXP_RE_X * Sin (Im (X)));
490 function Exp (X : Imaginary) return Complex is
491 ImX : Real'Base := Im (X);
494 return Compose_From_Cartesian (Cos (ImX), Sin (ImX));
501 function Log (X : Complex) return Complex is
507 if Re (X) = 0.0 and then Im (X) = 0.0 then
508 raise Constraint_Error;
510 elsif abs (1.0 - Re (X)) < Root_Root_Epsilon
511 and then abs Im (X) < Root_Root_Epsilon
514 Set_Re (Z, Re (Z) - 1.0);
516 return (1.0 - (1.0 / 2.0 -
517 (1.0 / 3.0 - (1.0 / 4.0) * Z) * Z) * Z) * Z;
521 ReX := Log (Modulus (X));
524 when Constraint_Error =>
525 ReX := Log (Modulus (X / 2.0)) - Log_Two;
528 ImX := Arctan (Im (X), Re (X));
531 ImX := ImX - 2.0 * PI;
534 return Compose_From_Cartesian (ReX, ImX);
541 function Sin (X : Complex) return Complex is
543 if abs Re (X) < Square_Root_Epsilon and then
544 abs Im (X) < Square_Root_Epsilon then
549 Compose_From_Cartesian
550 (Sin (Re (X)) * Cosh (Im (X)),
551 Cos (Re (X)) * Sinh (Im (X)));
558 function Sinh (X : Complex) return Complex is
560 if abs Re (X) < Square_Root_Epsilon and then
561 abs Im (X) < Square_Root_Epsilon
566 return Compose_From_Cartesian (Sinh (Re (X)) * Cos (Im (X)),
567 Cosh (Re (X)) * Sin (Im (X)));
575 function Sqrt (X : Complex) return Complex is
576 ReX : constant Real'Base := Re (X);
577 ImX : constant Real'Base := Im (X);
578 XR : constant Real'Base := abs Re (X);
579 YR : constant Real'Base := abs Im (X);
585 -- Deal with pure real case, see (RM G.1.2(39))
590 Compose_From_Cartesian
598 Compose_From_Cartesian
599 (0.0, Real'Copy_Sign (Sqrt (-ReX), ImX));
603 R_X := Sqrt (YR / 2.0);
606 return Compose_From_Cartesian (R_X, R_X);
608 return Compose_From_Cartesian (R_X, -R_X);
612 R := Sqrt (XR ** 2 + YR ** 2);
614 -- If the square of the modulus overflows, try rescaling the
615 -- real and imaginary parts. We cannot depend on an exception
616 -- being raised on all targets.
618 if R > Real'Base'Last then
619 raise Constraint_Error;
622 -- We are solving the system
624 -- XR = R_X ** 2 - Y_R ** 2 (1)
625 -- YR = 2.0 * R_X * R_Y (2)
627 -- The symmetric solution involves square roots for both R_X and
628 -- R_Y, but it is more accurate to use the square root with the
629 -- larger argument for either R_X or R_Y, and equation (2) for the
633 R_Y := Sqrt (0.5 * (R - ReX));
634 R_X := YR / (2.0 * R_Y);
637 R_X := Sqrt (0.5 * (R + ReX));
638 R_Y := YR / (2.0 * R_X);
642 if Im (X) < 0.0 then -- halve angle, Sqrt of magnitude
645 return Compose_From_Cartesian (R_X, R_Y);
648 when Constraint_Error =>
650 -- Rescale and try again.
652 R := Modulus (Compose_From_Cartesian (Re (X / 4.0), Im (X / 4.0)));
653 R_X := 2.0 * Sqrt (0.5 * R + 0.5 * Re (X / 4.0));
654 R_Y := 2.0 * Sqrt (0.5 * R - 0.5 * Re (X / 4.0));
656 if Im (X) < 0.0 then -- halve angle, Sqrt of magnitude
660 return Compose_From_Cartesian (R_X, R_Y);
667 function Tan (X : Complex) return Complex is
669 if abs Re (X) < Square_Root_Epsilon and then
670 abs Im (X) < Square_Root_Epsilon
674 elsif Im (X) > Log_Inverse_Epsilon_2 then
677 elsif Im (X) < -Log_Inverse_Epsilon_2 then
681 return Sin (X) / Cos (X);
689 function Tanh (X : Complex) return Complex is
691 if abs Re (X) < Square_Root_Epsilon and then
692 abs Im (X) < Square_Root_Epsilon
696 elsif Re (X) > Log_Inverse_Epsilon_2 then
699 elsif Re (X) < -Log_Inverse_Epsilon_2 then
703 return Sinh (X) / Cosh (X);
707 end Ada.Numerics.Generic_Complex_Elementary_Functions;