1 ------------------------------------------------------------------------------
3 -- GNAT RUNTIME COMPONENTS --
5 -- ADA.NUMERICS.GENERIC_COMPLEX_ELEMENTARY_FUNCTIONS --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc.
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNAT was originally developed by the GNAT team at New York University. --
32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
34 ------------------------------------------------------------------------------
36 with Ada
.Numerics
.Generic_Elementary_Functions
;
38 package body Ada
.Numerics
.Generic_Complex_Elementary_Functions
is
40 package Elementary_Functions
is new
41 Ada
.Numerics
.Generic_Elementary_Functions
(Real
'Base);
42 use Elementary_Functions
;
44 PI
: constant := 3.14159_26535_89793_23846_26433_83279_50288_41971
;
45 PI_2
: constant := PI
/ 2.0;
46 Sqrt_Two
: constant := 1.41421_35623_73095_04880_16887_24209_69807_85696
;
47 Log_Two
: constant := 0.69314_71805_59945_30941_72321_21458_17656_80755
;
49 subtype T
is Real
'Base;
51 Epsilon
: constant T
:= 2.0 ** (1 - T
'Model_Mantissa);
52 Square_Root_Epsilon
: constant T
:= Sqrt_Two
** (1 - T
'Model_Mantissa);
53 Inv_Square_Root_Epsilon
: constant T
:= Sqrt_Two
** (T
'Model_Mantissa - 1);
54 Root_Root_Epsilon
: constant T
:= Sqrt_Two
**
55 ((1 - T
'Model_Mantissa) / 2);
56 Log_Inverse_Epsilon_2
: constant T
:= T
(T
'Model_Mantissa - 1) / 2.0;
58 Complex_Zero
: constant Complex
:= (0.0, 0.0);
59 Complex_One
: constant Complex
:= (1.0, 0.0);
60 Complex_I
: constant Complex
:= (0.0, 1.0);
61 Half_Pi
: constant Complex
:= (PI_2
, 0.0);
67 function "**" (Left
: Complex
; Right
: Complex
) return Complex
is
70 and then Im
(Right
) = 0.0
71 and then Re
(Left
) = 0.0
72 and then Im
(Left
) = 0.0
77 and then Im
(Left
) = 0.0
78 and then Re
(Right
) < 0.0
80 raise Constraint_Error
;
82 elsif Re
(Left
) = 0.0 and then Im
(Left
) = 0.0 then
85 elsif Right
= (0.0, 0.0) then
88 elsif Re
(Right
) = 0.0 and then Im
(Right
) = 0.0 then
91 elsif Re
(Right
) = 1.0 and then Im
(Right
) = 0.0 then
95 return Exp
(Right
* Log
(Left
));
99 function "**" (Left
: Real
'Base; Right
: Complex
) return Complex
is
101 if Re
(Right
) = 0.0 and then Im
(Right
) = 0.0 and then Left
= 0.0 then
102 raise Argument_Error
;
104 elsif Left
= 0.0 and then Re
(Right
) < 0.0 then
105 raise Constraint_Error
;
107 elsif Left
= 0.0 then
108 return Compose_From_Cartesian
(Left
, 0.0);
110 elsif Re
(Right
) = 0.0 and then Im
(Right
) = 0.0 then
113 elsif Re
(Right
) = 1.0 and then Im
(Right
) = 0.0 then
114 return Compose_From_Cartesian
(Left
, 0.0);
117 return Exp
(Log
(Left
) * Right
);
121 function "**" (Left
: Complex
; Right
: Real
'Base) return Complex
is
124 and then Re
(Left
) = 0.0
125 and then Im
(Left
) = 0.0
127 raise Argument_Error
;
129 elsif Re
(Left
) = 0.0
130 and then Im
(Left
) = 0.0
133 raise Constraint_Error
;
135 elsif Re
(Left
) = 0.0 and then Im
(Left
) = 0.0 then
138 elsif Right
= 0.0 then
141 elsif Right
= 1.0 then
145 return Exp
(Right
* Log
(Left
));
153 function Arccos
(X
: Complex
) return Complex
is
157 if X
= Complex_One
then
160 elsif abs Re
(X
) < Square_Root_Epsilon
and then
161 abs Im
(X
) < Square_Root_Epsilon
165 elsif abs Re
(X
) > Inv_Square_Root_Epsilon
or else
166 abs Im
(X
) > Inv_Square_Root_Epsilon
168 return -2.0 * Complex_I
* Log
(Sqrt
((1.0 + X
) / 2.0) +
169 Complex_I
* Sqrt
((1.0 - X
) / 2.0));
172 Result
:= -Complex_I
* Log
(X
+ Complex_I
* Sqrt
(1.0 - X
* X
));
175 and then abs Re
(X
) <= 1.00
177 Set_Im
(Result
, Im
(X
));
187 function Arccosh
(X
: Complex
) return Complex
is
191 if X
= Complex_One
then
194 elsif abs Re
(X
) < Square_Root_Epsilon
and then
195 abs Im
(X
) < Square_Root_Epsilon
197 Result
:= Compose_From_Cartesian
(-Im
(X
), -PI_2
+ Re
(X
));
199 elsif abs Re
(X
) > Inv_Square_Root_Epsilon
or else
200 abs Im
(X
) > Inv_Square_Root_Epsilon
202 Result
:= Log_Two
+ Log
(X
);
205 Result
:= 2.0 * Log
(Sqrt
((1.0 + X
) / 2.0) +
206 Sqrt
((X
- 1.0) / 2.0));
209 if Re
(Result
) <= 0.0 then
220 function Arccot
(X
: Complex
) return Complex
is
224 if abs Re
(X
) < Square_Root_Epsilon
and then
225 abs Im
(X
) < Square_Root_Epsilon
229 elsif abs Re
(X
) > 1.0 / Epsilon
or else
230 abs Im
(X
) > 1.0 / Epsilon
232 Xt
:= Complex_One
/ X
;
235 Set_Re
(Xt
, PI
- Re
(Xt
));
242 Xt
:= Complex_I
* Log
((X
- Complex_I
) / (X
+ Complex_I
)) / 2.0;
244 if Re
(Xt
) < 0.0 then
255 function Arccoth
(X
: Complex
) return Complex
is
259 if X
= (0.0, 0.0) then
260 return Compose_From_Cartesian
(0.0, PI_2
);
262 elsif abs Re
(X
) < Square_Root_Epsilon
263 and then abs Im
(X
) < Square_Root_Epsilon
265 return PI_2
* Complex_I
+ X
;
267 elsif abs Re
(X
) > 1.0 / Epsilon
or else
268 abs Im
(X
) > 1.0 / Epsilon
273 return PI
* Complex_I
;
276 elsif Im
(X
) = 0.0 and then Re
(X
) = 1.0 then
277 raise Constraint_Error
;
279 elsif Im
(X
) = 0.0 and then Re
(X
) = -1.0 then
280 raise Constraint_Error
;
284 R
:= Log
((1.0 + X
) / (X
- 1.0)) / 2.0;
287 when Constraint_Error
=>
288 R
:= (Log
(1.0 + X
) - Log
(X
- 1.0)) / 2.0;
292 Set_Im
(R
, PI
+ Im
(R
));
306 function Arcsin
(X
: Complex
) return Complex
is
310 if abs Re
(X
) < Square_Root_Epsilon
and then
311 abs Im
(X
) < Square_Root_Epsilon
315 elsif abs Re
(X
) > Inv_Square_Root_Epsilon
or else
316 abs Im
(X
) > Inv_Square_Root_Epsilon
318 Result
:= -Complex_I
* (Log
(Complex_I
* X
) + Log
(2.0 * Complex_I
));
320 if Im
(Result
) > PI_2
then
321 Set_Im
(Result
, PI
- Im
(X
));
323 elsif Im
(Result
) < -PI_2
then
324 Set_Im
(Result
, -(PI
+ Im
(X
)));
328 Result
:= -Complex_I
* Log
(Complex_I
* X
+ Sqrt
(1.0 - X
* X
));
331 Set_Re
(Result
, Re
(X
));
334 and then abs Re
(X
) <= 1.00
336 Set_Im
(Result
, Im
(X
));
346 function Arcsinh
(X
: Complex
) return Complex
is
350 if abs Re
(X
) < Square_Root_Epsilon
and then
351 abs Im
(X
) < Square_Root_Epsilon
355 elsif abs Re
(X
) > Inv_Square_Root_Epsilon
or else
356 abs Im
(X
) > Inv_Square_Root_Epsilon
358 Result
:= Log_Two
+ Log
(X
); -- may have wrong sign
360 if (Re
(X
) < 0.0 and Re
(Result
) > 0.0)
361 or else (Re
(X
) > 0.0 and Re
(Result
) < 0.0)
363 Set_Re
(Result
, -Re
(Result
));
369 Result
:= Log
(X
+ Sqrt
(1.0 + X
* X
));
372 Set_Re
(Result
, Re
(X
));
373 elsif Im
(X
) = 0.0 then
374 Set_Im
(Result
, Im
(X
));
384 function Arctan
(X
: Complex
) return Complex
is
386 if abs Re
(X
) < Square_Root_Epsilon
and then
387 abs Im
(X
) < Square_Root_Epsilon
392 return -Complex_I
* (Log
(1.0 + Complex_I
* X
)
393 - Log
(1.0 - Complex_I
* X
)) / 2.0;
401 function Arctanh
(X
: Complex
) return Complex
is
403 if abs Re
(X
) < Square_Root_Epsilon
and then
404 abs Im
(X
) < Square_Root_Epsilon
408 return (Log
(1.0 + X
) - Log
(1.0 - X
)) / 2.0;
416 function Cos
(X
: Complex
) return Complex
is
419 Compose_From_Cartesian
420 (Cos
(Re
(X
)) * Cosh
(Im
(X
)),
421 -Sin
(Re
(X
)) * Sinh
(Im
(X
)));
428 function Cosh
(X
: Complex
) return Complex
is
431 Compose_From_Cartesian
432 (Cosh
(Re
(X
)) * Cos
(Im
(X
)),
433 Sinh
(Re
(X
)) * Sin
(Im
(X
)));
440 function Cot
(X
: Complex
) return Complex
is
442 if abs Re
(X
) < Square_Root_Epsilon
and then
443 abs Im
(X
) < Square_Root_Epsilon
445 return Complex_One
/ X
;
447 elsif Im
(X
) > Log_Inverse_Epsilon_2
then
450 elsif Im
(X
) < -Log_Inverse_Epsilon_2
then
454 return Cos
(X
) / Sin
(X
);
461 function Coth
(X
: Complex
) return Complex
is
463 if abs Re
(X
) < Square_Root_Epsilon
and then
464 abs Im
(X
) < Square_Root_Epsilon
466 return Complex_One
/ X
;
468 elsif Re
(X
) > Log_Inverse_Epsilon_2
then
471 elsif Re
(X
) < -Log_Inverse_Epsilon_2
then
475 return Cosh
(X
) / Sinh
(X
);
483 function Exp
(X
: Complex
) return Complex
is
484 EXP_RE_X
: Real
'Base := Exp
(Re
(X
));
487 return Compose_From_Cartesian
(EXP_RE_X
* Cos
(Im
(X
)),
488 EXP_RE_X
* Sin
(Im
(X
)));
492 function Exp
(X
: Imaginary
) return Complex
is
493 ImX
: Real
'Base := Im
(X
);
496 return Compose_From_Cartesian
(Cos
(ImX
), Sin
(ImX
));
503 function Log
(X
: Complex
) return Complex
is
509 if Re
(X
) = 0.0 and then Im
(X
) = 0.0 then
510 raise Constraint_Error
;
512 elsif abs (1.0 - Re
(X
)) < Root_Root_Epsilon
513 and then abs Im
(X
) < Root_Root_Epsilon
516 Set_Re
(Z
, Re
(Z
) - 1.0);
518 return (1.0 - (1.0 / 2.0 -
519 (1.0 / 3.0 - (1.0 / 4.0) * Z
) * Z
) * Z
) * Z
;
523 ReX
:= Log
(Modulus
(X
));
526 when Constraint_Error
=>
527 ReX
:= Log
(Modulus
(X
/ 2.0)) - Log_Two
;
530 ImX
:= Arctan
(Im
(X
), Re
(X
));
533 ImX
:= ImX
- 2.0 * PI
;
536 return Compose_From_Cartesian
(ReX
, ImX
);
543 function Sin
(X
: Complex
) return Complex
is
545 if abs Re
(X
) < Square_Root_Epsilon
and then
546 abs Im
(X
) < Square_Root_Epsilon
then
551 Compose_From_Cartesian
552 (Sin
(Re
(X
)) * Cosh
(Im
(X
)),
553 Cos
(Re
(X
)) * Sinh
(Im
(X
)));
560 function Sinh
(X
: Complex
) return Complex
is
562 if abs Re
(X
) < Square_Root_Epsilon
and then
563 abs Im
(X
) < Square_Root_Epsilon
568 return Compose_From_Cartesian
(Sinh
(Re
(X
)) * Cos
(Im
(X
)),
569 Cosh
(Re
(X
)) * Sin
(Im
(X
)));
577 function Sqrt
(X
: Complex
) return Complex
is
578 ReX
: constant Real
'Base := Re
(X
);
579 ImX
: constant Real
'Base := Im
(X
);
580 XR
: constant Real
'Base := abs Re
(X
);
581 YR
: constant Real
'Base := abs Im
(X
);
587 -- Deal with pure real case, see (RM G.1.2(39))
592 Compose_From_Cartesian
600 Compose_From_Cartesian
601 (0.0, Real
'Copy_Sign (Sqrt
(-ReX
), ImX
));
605 R_X
:= Sqrt
(YR
/ 2.0);
608 return Compose_From_Cartesian
(R_X
, R_X
);
610 return Compose_From_Cartesian
(R_X
, -R_X
);
614 R
:= Sqrt
(XR
** 2 + YR
** 2);
616 -- If the square of the modulus overflows, try rescaling the
617 -- real and imaginary parts. We cannot depend on an exception
618 -- being raised on all targets.
620 if R
> Real
'Base'Last then
621 raise Constraint_Error;
624 -- We are solving the system
626 -- XR = R_X ** 2 - Y_R ** 2 (1)
627 -- YR = 2.0 * R_X * R_Y (2)
629 -- The symmetric solution involves square roots for both R_X and
630 -- R_Y, but it is more accurate to use the square root with the
631 -- larger argument for either R_X or R_Y, and equation (2) for the
635 R_Y := Sqrt (0.5 * (R - ReX));
636 R_X := YR / (2.0 * R_Y);
639 R_X := Sqrt (0.5 * (R + ReX));
640 R_Y := YR / (2.0 * R_X);
644 if Im (X) < 0.0 then -- halve angle, Sqrt of magnitude
647 return Compose_From_Cartesian (R_X, R_Y);
650 when Constraint_Error =>
652 -- Rescale and try again.
654 R := Modulus (Compose_From_Cartesian (Re (X / 4.0), Im (X / 4.0)));
655 R_X := 2.0 * Sqrt (0.5 * R + 0.5 * Re (X / 4.0));
656 R_Y := 2.0 * Sqrt (0.5 * R - 0.5 * Re (X / 4.0));
658 if Im (X) < 0.0 then -- halve angle, Sqrt of magnitude
662 return Compose_From_Cartesian (R_X, R_Y);
669 function Tan (X : Complex) return Complex is
671 if abs Re (X) < Square_Root_Epsilon and then
672 abs Im (X) < Square_Root_Epsilon
676 elsif Im (X) > Log_Inverse_Epsilon_2 then
679 elsif Im (X) < -Log_Inverse_Epsilon_2 then
683 return Sin (X) / Cos (X);
691 function Tanh (X : Complex) return Complex is
693 if abs Re (X) < Square_Root_Epsilon and then
694 abs Im (X) < Square_Root_Epsilon
698 elsif Re (X) > Log_Inverse_Epsilon_2 then
701 elsif Re (X) < -Log_Inverse_Epsilon_2 then
705 return Sinh (X) / Cosh (X);
709 end Ada.Numerics.Generic_Complex_Elementary_Functions;