?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2014-02-20 Richard Biener <rguenther@suse.de>
[official-gcc.git] / gcc / ada / a-ngcoar.adb
blobca0c58c36f222808e679f3b91761c7b1fd68eb0b
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- ADA.NUMERICS.GENERIC_COMPLEX_ARRAYS --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2006-2012, Free Software Foundation, Inc. --
10 -- --
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 3, 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. --
17 -- --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 with System.Generic_Array_Operations; use System.Generic_Array_Operations;
33 with Ada.Numerics; use Ada.Numerics;
34
35 package body Ada.Numerics.Generic_Complex_Arrays is
36
37 -- Operations that are defined in terms of operations on the type Real,
38 -- such as addition, subtraction and scaling, are computed in the canonical
39 -- way looping over all elements.
40
41 package Ops renames System.Generic_Array_Operations;
42
43 subtype Real is Real_Arrays.Real;
44 -- Work around visibility bug ???
45
46 function Is_Non_Zero (X : Complex) return Boolean is (X /= (0.0, 0.0));
47 -- Needed by Back_Substitute
48
49 procedure Back_Substitute is new Ops.Back_Substitute
50 (Scalar => Complex,
51 Matrix => Complex_Matrix,
52 Is_Non_Zero => Is_Non_Zero);
53
54 procedure Forward_Eliminate is new Ops.Forward_Eliminate
55 (Scalar => Complex,
56 Real => Real'Base,
57 Matrix => Complex_Matrix,
58 Zero => (0.0, 0.0),
59 One => (1.0, 0.0));
60
61 procedure Transpose is new Ops.Transpose
62 (Scalar => Complex,
63 Matrix => Complex_Matrix);
64
65 -- Helper function that raises a Constraint_Error is the argument is
66 -- not a square matrix, and otherwise returns its length.
67
68 function Length is new Square_Matrix_Length (Complex, Complex_Matrix);
69
70 -- Instant a generic square root implementation here, in order to avoid
71 -- instantiating a complete copy of Generic_Elementary_Functions.
72 -- Speed of the square root is not a big concern here.
73
74 function Sqrt is new Ops.Sqrt (Real'Base);
75
76 -- Instantiating the following subprograms directly would lead to
77 -- name clashes, so use a local package.
78
79 package Instantiations is
80
81 ---------
82 -- "*" --
83 ---------
84
85 function "*" is new Vector_Scalar_Elementwise_Operation
86 (Left_Scalar => Complex,
87 Right_Scalar => Complex,
88 Result_Scalar => Complex,
89 Left_Vector => Complex_Vector,
90 Result_Vector => Complex_Vector,
91 Operation => "*");
92
93 function "*" is new Vector_Scalar_Elementwise_Operation
94 (Left_Scalar => Complex,
95 Right_Scalar => Real'Base,
96 Result_Scalar => Complex,
97 Left_Vector => Complex_Vector,
98 Result_Vector => Complex_Vector,
99 Operation => "*");
100
101 function "*" is new Scalar_Vector_Elementwise_Operation
102 (Left_Scalar => Complex,
103 Right_Scalar => Complex,
104 Result_Scalar => Complex,
105 Right_Vector => Complex_Vector,
106 Result_Vector => Complex_Vector,
107 Operation => "*");
108
109 function "*" is new Scalar_Vector_Elementwise_Operation
110 (Left_Scalar => Real'Base,
111 Right_Scalar => Complex,
112 Result_Scalar => Complex,
113 Right_Vector => Complex_Vector,
114 Result_Vector => Complex_Vector,
115 Operation => "*");
116
117 function "*" is new Inner_Product
118 (Left_Scalar => Complex,
119 Right_Scalar => Real'Base,
120 Result_Scalar => Complex,
121 Left_Vector => Complex_Vector,
122 Right_Vector => Real_Vector,
123 Zero => (0.0, 0.0));
124
125 function "*" is new Inner_Product
126 (Left_Scalar => Real'Base,
127 Right_Scalar => Complex,
128 Result_Scalar => Complex,
129 Left_Vector => Real_Vector,
130 Right_Vector => Complex_Vector,
131 Zero => (0.0, 0.0));
132
133 function "*" is new Inner_Product
134 (Left_Scalar => Complex,
135 Right_Scalar => Complex,
136 Result_Scalar => Complex,
137 Left_Vector => Complex_Vector,
138 Right_Vector => Complex_Vector,
139 Zero => (0.0, 0.0));
140
141 function "*" is new Outer_Product
142 (Left_Scalar => Complex,
143 Right_Scalar => Complex,
144 Result_Scalar => Complex,
145 Left_Vector => Complex_Vector,
146 Right_Vector => Complex_Vector,
147 Matrix => Complex_Matrix);
148
149 function "*" is new Outer_Product
150 (Left_Scalar => Real'Base,
151 Right_Scalar => Complex,
152 Result_Scalar => Complex,
153 Left_Vector => Real_Vector,
154 Right_Vector => Complex_Vector,
155 Matrix => Complex_Matrix);
156
157 function "*" is new Outer_Product
158 (Left_Scalar => Complex,
159 Right_Scalar => Real'Base,
160 Result_Scalar => Complex,
161 Left_Vector => Complex_Vector,
162 Right_Vector => Real_Vector,
163 Matrix => Complex_Matrix);
164
165 function "*" is new Matrix_Scalar_Elementwise_Operation
166 (Left_Scalar => Complex,
167 Right_Scalar => Complex,
168 Result_Scalar => Complex,
169 Left_Matrix => Complex_Matrix,
170 Result_Matrix => Complex_Matrix,
171 Operation => "*");
172
173 function "*" is new Matrix_Scalar_Elementwise_Operation
174 (Left_Scalar => Complex,
175 Right_Scalar => Real'Base,
176 Result_Scalar => Complex,
177 Left_Matrix => Complex_Matrix,
178 Result_Matrix => Complex_Matrix,
179 Operation => "*");
180
181 function "*" is new Scalar_Matrix_Elementwise_Operation
182 (Left_Scalar => Complex,
183 Right_Scalar => Complex,
184 Result_Scalar => Complex,
185 Right_Matrix => Complex_Matrix,
186 Result_Matrix => Complex_Matrix,
187 Operation => "*");
188
189 function "*" is new Scalar_Matrix_Elementwise_Operation
190 (Left_Scalar => Real'Base,
191 Right_Scalar => Complex,
192 Result_Scalar => Complex,
193 Right_Matrix => Complex_Matrix,
194 Result_Matrix => Complex_Matrix,
195 Operation => "*");
196
197 function "*" is new Matrix_Vector_Product
198 (Left_Scalar => Real'Base,
199 Right_Scalar => Complex,
200 Result_Scalar => Complex,
201 Matrix => Real_Matrix,
202 Right_Vector => Complex_Vector,
203 Result_Vector => Complex_Vector,
204 Zero => (0.0, 0.0));
205
206 function "*" is new Matrix_Vector_Product
207 (Left_Scalar => Complex,
208 Right_Scalar => Real'Base,
209 Result_Scalar => Complex,
210 Matrix => Complex_Matrix,
211 Right_Vector => Real_Vector,
212 Result_Vector => Complex_Vector,
213 Zero => (0.0, 0.0));
214
215 function "*" is new Matrix_Vector_Product
216 (Left_Scalar => Complex,
217 Right_Scalar => Complex,
218 Result_Scalar => Complex,
219 Matrix => Complex_Matrix,
220 Right_Vector => Complex_Vector,
221 Result_Vector => Complex_Vector,
222 Zero => (0.0, 0.0));
223
224 function "*" is new Vector_Matrix_Product
225 (Left_Scalar => Real'Base,
226 Right_Scalar => Complex,
227 Result_Scalar => Complex,
228 Left_Vector => Real_Vector,
229 Matrix => Complex_Matrix,
230 Result_Vector => Complex_Vector,
231 Zero => (0.0, 0.0));
232
233 function "*" is new Vector_Matrix_Product
234 (Left_Scalar => Complex,
235 Right_Scalar => Real'Base,
236 Result_Scalar => Complex,
237 Left_Vector => Complex_Vector,
238 Matrix => Real_Matrix,
239 Result_Vector => Complex_Vector,
240 Zero => (0.0, 0.0));
241
242 function "*" is new Vector_Matrix_Product
243 (Left_Scalar => Complex,
244 Right_Scalar => Complex,
245 Result_Scalar => Complex,
246 Left_Vector => Complex_Vector,
247 Matrix => Complex_Matrix,
248 Result_Vector => Complex_Vector,
249 Zero => (0.0, 0.0));
250
251 function "*" is new Matrix_Matrix_Product
252 (Left_Scalar => Complex,
253 Right_Scalar => Complex,
254 Result_Scalar => Complex,
255 Left_Matrix => Complex_Matrix,
256 Right_Matrix => Complex_Matrix,
257 Result_Matrix => Complex_Matrix,
258 Zero => (0.0, 0.0));
259
260 function "*" is new Matrix_Matrix_Product
261 (Left_Scalar => Real'Base,
262 Right_Scalar => Complex,
263 Result_Scalar => Complex,
264 Left_Matrix => Real_Matrix,
265 Right_Matrix => Complex_Matrix,
266 Result_Matrix => Complex_Matrix,
267 Zero => (0.0, 0.0));
268
269 function "*" is new Matrix_Matrix_Product
270 (Left_Scalar => Complex,
271 Right_Scalar => Real'Base,
272 Result_Scalar => Complex,
273 Left_Matrix => Complex_Matrix,
274 Right_Matrix => Real_Matrix,
275 Result_Matrix => Complex_Matrix,
276 Zero => (0.0, 0.0));
277
278 ---------
279 -- "+" --
280 ---------
281
282 function "+" is new Vector_Elementwise_Operation
283 (X_Scalar => Complex,
284 Result_Scalar => Complex,
285 X_Vector => Complex_Vector,
286 Result_Vector => Complex_Vector,
287 Operation => "+");
288
289 function "+" is new Vector_Vector_Elementwise_Operation
290 (Left_Scalar => Complex,
291 Right_Scalar => Complex,
292 Result_Scalar => Complex,
293 Left_Vector => Complex_Vector,
294 Right_Vector => Complex_Vector,
295 Result_Vector => Complex_Vector,
296 Operation => "+");
297
298 function "+" is new Vector_Vector_Elementwise_Operation
299 (Left_Scalar => Real'Base,
300 Right_Scalar => Complex,
301 Result_Scalar => Complex,
302 Left_Vector => Real_Vector,
303 Right_Vector => Complex_Vector,
304 Result_Vector => Complex_Vector,
305 Operation => "+");
306
307 function "+" is new Vector_Vector_Elementwise_Operation
308 (Left_Scalar => Complex,
309 Right_Scalar => Real'Base,
310 Result_Scalar => Complex,
311 Left_Vector => Complex_Vector,
312 Right_Vector => Real_Vector,
313 Result_Vector => Complex_Vector,
314 Operation => "+");
315
316 function "+" is new Matrix_Elementwise_Operation
317 (X_Scalar => Complex,
318 Result_Scalar => Complex,
319 X_Matrix => Complex_Matrix,
320 Result_Matrix => Complex_Matrix,
321 Operation => "+");
322
323 function "+" is new Matrix_Matrix_Elementwise_Operation
324 (Left_Scalar => Complex,
325 Right_Scalar => Complex,
326 Result_Scalar => Complex,
327 Left_Matrix => Complex_Matrix,
328 Right_Matrix => Complex_Matrix,
329 Result_Matrix => Complex_Matrix,
330 Operation => "+");
331
332 function "+" is new Matrix_Matrix_Elementwise_Operation
333 (Left_Scalar => Real'Base,
334 Right_Scalar => Complex,
335 Result_Scalar => Complex,
336 Left_Matrix => Real_Matrix,
337 Right_Matrix => Complex_Matrix,
338 Result_Matrix => Complex_Matrix,
339 Operation => "+");
340
341 function "+" is new Matrix_Matrix_Elementwise_Operation
342 (Left_Scalar => Complex,
343 Right_Scalar => Real'Base,
344 Result_Scalar => Complex,
345 Left_Matrix => Complex_Matrix,
346 Right_Matrix => Real_Matrix,
347 Result_Matrix => Complex_Matrix,
348 Operation => "+");
349
350 ---------
351 -- "-" --
352 ---------
353
354 function "-" is new Vector_Elementwise_Operation
355 (X_Scalar => Complex,
356 Result_Scalar => Complex,
357 X_Vector => Complex_Vector,
358 Result_Vector => Complex_Vector,
359 Operation => "-");
360
361 function "-" is new Vector_Vector_Elementwise_Operation
362 (Left_Scalar => Complex,
363 Right_Scalar => Complex,
364 Result_Scalar => Complex,
365 Left_Vector => Complex_Vector,
366 Right_Vector => Complex_Vector,
367 Result_Vector => Complex_Vector,
368 Operation => "-");
369
370 function "-" is new Vector_Vector_Elementwise_Operation
371 (Left_Scalar => Real'Base,
372 Right_Scalar => Complex,
373 Result_Scalar => Complex,
374 Left_Vector => Real_Vector,
375 Right_Vector => Complex_Vector,
376 Result_Vector => Complex_Vector,
377 Operation => "-");
378
379 function "-" is new Vector_Vector_Elementwise_Operation
380 (Left_Scalar => Complex,
381 Right_Scalar => Real'Base,
382 Result_Scalar => Complex,
383 Left_Vector => Complex_Vector,
384 Right_Vector => Real_Vector,
385 Result_Vector => Complex_Vector,
386 Operation => "-");
387
388 function "-" is new Matrix_Elementwise_Operation
389 (X_Scalar => Complex,
390 Result_Scalar => Complex,
391 X_Matrix => Complex_Matrix,
392 Result_Matrix => Complex_Matrix,
393 Operation => "-");
394
395 function "-" is new Matrix_Matrix_Elementwise_Operation
396 (Left_Scalar => Complex,
397 Right_Scalar => Complex,
398 Result_Scalar => Complex,
399 Left_Matrix => Complex_Matrix,
400 Right_Matrix => Complex_Matrix,
401 Result_Matrix => Complex_Matrix,
402 Operation => "-");
403
404 function "-" is new Matrix_Matrix_Elementwise_Operation
405 (Left_Scalar => Real'Base,
406 Right_Scalar => Complex,
407 Result_Scalar => Complex,
408 Left_Matrix => Real_Matrix,
409 Right_Matrix => Complex_Matrix,
410 Result_Matrix => Complex_Matrix,
411 Operation => "-");
412
413 function "-" is new Matrix_Matrix_Elementwise_Operation
414 (Left_Scalar => Complex,
415 Right_Scalar => Real'Base,
416 Result_Scalar => Complex,
417 Left_Matrix => Complex_Matrix,
418 Right_Matrix => Real_Matrix,
419 Result_Matrix => Complex_Matrix,
420 Operation => "-");
421
422 ---------
423 -- "/" --
424 ---------
425
426 function "/" is new Vector_Scalar_Elementwise_Operation
427 (Left_Scalar => Complex,
428 Right_Scalar => Complex,
429 Result_Scalar => Complex,
430 Left_Vector => Complex_Vector,
431 Result_Vector => Complex_Vector,
432 Operation => "/");
433
434 function "/" is new Vector_Scalar_Elementwise_Operation
435 (Left_Scalar => Complex,
436 Right_Scalar => Real'Base,
437 Result_Scalar => Complex,
438 Left_Vector => Complex_Vector,
439 Result_Vector => Complex_Vector,
440 Operation => "/");
441
442 function "/" is new Matrix_Scalar_Elementwise_Operation
443 (Left_Scalar => Complex,
444 Right_Scalar => Complex,
445 Result_Scalar => Complex,
446 Left_Matrix => Complex_Matrix,
447 Result_Matrix => Complex_Matrix,
448 Operation => "/");
449
450 function "/" is new Matrix_Scalar_Elementwise_Operation
451 (Left_Scalar => Complex,
452 Right_Scalar => Real'Base,
453 Result_Scalar => Complex,
454 Left_Matrix => Complex_Matrix,
455 Result_Matrix => Complex_Matrix,
456 Operation => "/");
457
458 -----------
459 -- "abs" --
460 -----------
461
462 function "abs" is new L2_Norm
463 (X_Scalar => Complex,
464 Result_Real => Real'Base,
465 X_Vector => Complex_Vector);
466
467 --------------
468 -- Argument --
469 --------------
470
471 function Argument is new Vector_Elementwise_Operation
472 (X_Scalar => Complex,
473 Result_Scalar => Real'Base,
474 X_Vector => Complex_Vector,
475 Result_Vector => Real_Vector,
476 Operation => Argument);
477
478 function Argument is new Vector_Scalar_Elementwise_Operation
479 (Left_Scalar => Complex,
480 Right_Scalar => Real'Base,
481 Result_Scalar => Real'Base,
482 Left_Vector => Complex_Vector,
483 Result_Vector => Real_Vector,
484 Operation => Argument);
485
486 function Argument is new Matrix_Elementwise_Operation
487 (X_Scalar => Complex,
488 Result_Scalar => Real'Base,
489 X_Matrix => Complex_Matrix,
490 Result_Matrix => Real_Matrix,
491 Operation => Argument);
492
493 function Argument is new Matrix_Scalar_Elementwise_Operation
494 (Left_Scalar => Complex,
495 Right_Scalar => Real'Base,
496 Result_Scalar => Real'Base,
497 Left_Matrix => Complex_Matrix,
498 Result_Matrix => Real_Matrix,
499 Operation => Argument);
500
501 ----------------------------
502 -- Compose_From_Cartesian --
503 ----------------------------
504
505 function Compose_From_Cartesian is new Vector_Elementwise_Operation
506 (X_Scalar => Real'Base,
507 Result_Scalar => Complex,
508 X_Vector => Real_Vector,
509 Result_Vector => Complex_Vector,
510 Operation => Compose_From_Cartesian);
511
512 function Compose_From_Cartesian is
513 new Vector_Vector_Elementwise_Operation
514 (Left_Scalar => Real'Base,
515 Right_Scalar => Real'Base,
516 Result_Scalar => Complex,
517 Left_Vector => Real_Vector,
518 Right_Vector => Real_Vector,
519 Result_Vector => Complex_Vector,
520 Operation => Compose_From_Cartesian);
521
522 function Compose_From_Cartesian is new Matrix_Elementwise_Operation
523 (X_Scalar => Real'Base,
524 Result_Scalar => Complex,
525 X_Matrix => Real_Matrix,
526 Result_Matrix => Complex_Matrix,
527 Operation => Compose_From_Cartesian);
528
529 function Compose_From_Cartesian is
530 new Matrix_Matrix_Elementwise_Operation
531 (Left_Scalar => Real'Base,
532 Right_Scalar => Real'Base,
533 Result_Scalar => Complex,
534 Left_Matrix => Real_Matrix,
535 Right_Matrix => Real_Matrix,
536 Result_Matrix => Complex_Matrix,
537 Operation => Compose_From_Cartesian);
538
539 ------------------------
540 -- Compose_From_Polar --
541 ------------------------
542
543 function Compose_From_Polar is
544 new Vector_Vector_Elementwise_Operation
545 (Left_Scalar => Real'Base,
546 Right_Scalar => Real'Base,
547 Result_Scalar => Complex,
548 Left_Vector => Real_Vector,
549 Right_Vector => Real_Vector,
550 Result_Vector => Complex_Vector,
551 Operation => Compose_From_Polar);
552
553 function Compose_From_Polar is
554 new Vector_Vector_Scalar_Elementwise_Operation
555 (X_Scalar => Real'Base,
556 Y_Scalar => Real'Base,
557 Z_Scalar => Real'Base,
558 Result_Scalar => Complex,
559 X_Vector => Real_Vector,
560 Y_Vector => Real_Vector,
561 Result_Vector => Complex_Vector,
562 Operation => Compose_From_Polar);
563
564 function Compose_From_Polar is
565 new Matrix_Matrix_Elementwise_Operation
566 (Left_Scalar => Real'Base,
567 Right_Scalar => Real'Base,
568 Result_Scalar => Complex,
569 Left_Matrix => Real_Matrix,
570 Right_Matrix => Real_Matrix,
571 Result_Matrix => Complex_Matrix,
572 Operation => Compose_From_Polar);
573
574 function Compose_From_Polar is
575 new Matrix_Matrix_Scalar_Elementwise_Operation
576 (X_Scalar => Real'Base,
577 Y_Scalar => Real'Base,
578 Z_Scalar => Real'Base,
579 Result_Scalar => Complex,
580 X_Matrix => Real_Matrix,
581 Y_Matrix => Real_Matrix,
582 Result_Matrix => Complex_Matrix,
583 Operation => Compose_From_Polar);
584
585 ---------------
586 -- Conjugate --
587 ---------------
588
589 function Conjugate is new Vector_Elementwise_Operation
590 (X_Scalar => Complex,
591 Result_Scalar => Complex,
592 X_Vector => Complex_Vector,
593 Result_Vector => Complex_Vector,
594 Operation => Conjugate);
595
596 function Conjugate is new Matrix_Elementwise_Operation
597 (X_Scalar => Complex,
598 Result_Scalar => Complex,
599 X_Matrix => Complex_Matrix,
600 Result_Matrix => Complex_Matrix,
601 Operation => Conjugate);
602
603 --------
604 -- Im --
605 --------
606
607 function Im is new Vector_Elementwise_Operation
608 (X_Scalar => Complex,
609 Result_Scalar => Real'Base,
610 X_Vector => Complex_Vector,
611 Result_Vector => Real_Vector,
612 Operation => Im);
613
614 function Im is new Matrix_Elementwise_Operation
615 (X_Scalar => Complex,
616 Result_Scalar => Real'Base,
617 X_Matrix => Complex_Matrix,
618 Result_Matrix => Real_Matrix,
619 Operation => Im);
620
621 -------------
622 -- Modulus --
623 -------------
624
625 function Modulus is new Vector_Elementwise_Operation
626 (X_Scalar => Complex,
627 Result_Scalar => Real'Base,
628 X_Vector => Complex_Vector,
629 Result_Vector => Real_Vector,
630 Operation => Modulus);
631
632 function Modulus is new Matrix_Elementwise_Operation
633 (X_Scalar => Complex,
634 Result_Scalar => Real'Base,
635 X_Matrix => Complex_Matrix,
636 Result_Matrix => Real_Matrix,
637 Operation => Modulus);
638
639 --------
640 -- Re --
641 --------
642
643 function Re is new Vector_Elementwise_Operation
644 (X_Scalar => Complex,
645 Result_Scalar => Real'Base,
646 X_Vector => Complex_Vector,
647 Result_Vector => Real_Vector,
648 Operation => Re);
649
650 function Re is new Matrix_Elementwise_Operation
651 (X_Scalar => Complex,
652 Result_Scalar => Real'Base,
653 X_Matrix => Complex_Matrix,
654 Result_Matrix => Real_Matrix,
655 Operation => Re);
656
657 ------------
658 -- Set_Im --
659 ------------
660
661 procedure Set_Im is new Update_Vector_With_Vector
662 (X_Scalar => Complex,
663 Y_Scalar => Real'Base,
664 X_Vector => Complex_Vector,
665 Y_Vector => Real_Vector,
666 Update => Set_Im);
667
668 procedure Set_Im is new Update_Matrix_With_Matrix
669 (X_Scalar => Complex,
670 Y_Scalar => Real'Base,
671 X_Matrix => Complex_Matrix,
672 Y_Matrix => Real_Matrix,
673 Update => Set_Im);
674
675 ------------
676 -- Set_Re --
677 ------------
678
679 procedure Set_Re is new Update_Vector_With_Vector
680 (X_Scalar => Complex,
681 Y_Scalar => Real'Base,
682 X_Vector => Complex_Vector,
683 Y_Vector => Real_Vector,
684 Update => Set_Re);
685
686 procedure Set_Re is new Update_Matrix_With_Matrix
687 (X_Scalar => Complex,
688 Y_Scalar => Real'Base,
689 X_Matrix => Complex_Matrix,
690 Y_Matrix => Real_Matrix,
691 Update => Set_Re);
692
693 -----------
694 -- Solve --
695 -----------
696
697 function Solve is
698 new Matrix_Vector_Solution (Complex, Complex_Vector, Complex_Matrix);
699
700 function Solve is
701 new Matrix_Matrix_Solution (Complex, Complex_Matrix);
702
703 -----------------
704 -- Unit_Matrix --
705 -----------------
706
707 function Unit_Matrix is new System.Generic_Array_Operations.Unit_Matrix
708 (Scalar => Complex,
709 Matrix => Complex_Matrix,
710 Zero => (0.0, 0.0),
711 One => (1.0, 0.0));
712
713 function Unit_Vector is new System.Generic_Array_Operations.Unit_Vector
714 (Scalar => Complex,
715 Vector => Complex_Vector,
716 Zero => (0.0, 0.0),
717 One => (1.0, 0.0));
718 end Instantiations;
719
720 ---------
721 -- "*" --
722 ---------
723
724 function "*"
725 (Left : Complex_Vector;
726 Right : Complex_Vector) return Complex
727 renames Instantiations."*";
728
729 function "*"
730 (Left : Real_Vector;
731 Right : Complex_Vector) return Complex
732 renames Instantiations."*";
733
734 function "*"
735 (Left : Complex_Vector;
736 Right : Real_Vector) return Complex
737 renames Instantiations."*";
738
739 function "*"
740 (Left : Complex;
741 Right : Complex_Vector) return Complex_Vector
742 renames Instantiations."*";
743
744 function "*"
745 (Left : Complex_Vector;
746 Right : Complex) return Complex_Vector
747 renames Instantiations."*";
748
749 function "*"
750 (Left : Real'Base;
751 Right : Complex_Vector) return Complex_Vector
752 renames Instantiations."*";
753
754 function "*"
755 (Left : Complex_Vector;
756 Right : Real'Base) return Complex_Vector
757 renames Instantiations."*";
758
759 function "*"
760 (Left : Complex_Matrix;
761 Right : Complex_Matrix) return Complex_Matrix
762 renames Instantiations."*";
763
764 function "*"
765 (Left : Complex_Vector;
766 Right : Complex_Vector) return Complex_Matrix
767 renames Instantiations."*";
768
769 function "*"
770 (Left : Complex_Vector;
771 Right : Complex_Matrix) return Complex_Vector
772 renames Instantiations."*";
773
774 function "*"
775 (Left : Complex_Matrix;
776 Right : Complex_Vector) return Complex_Vector
777 renames Instantiations."*";
778
779 function "*"
780 (Left : Real_Matrix;
781 Right : Complex_Matrix) return Complex_Matrix
782 renames Instantiations."*";
783
784 function "*"
785 (Left : Complex_Matrix;
786 Right : Real_Matrix) return Complex_Matrix
787 renames Instantiations."*";
788
789 function "*"
790 (Left : Real_Vector;
791 Right : Complex_Vector) return Complex_Matrix
792 renames Instantiations."*";
793
794 function "*"
795 (Left : Complex_Vector;
796 Right : Real_Vector) return Complex_Matrix
797 renames Instantiations."*";
798
799 function "*"
800 (Left : Real_Vector;
801 Right : Complex_Matrix) return Complex_Vector
802 renames Instantiations."*";
803
804 function "*"
805 (Left : Complex_Vector;
806 Right : Real_Matrix) return Complex_Vector
807 renames Instantiations."*";
808
809 function "*"
810 (Left : Real_Matrix;
811 Right : Complex_Vector) return Complex_Vector
812 renames Instantiations."*";
813
814 function "*"
815 (Left : Complex_Matrix;
816 Right : Real_Vector) return Complex_Vector
817 renames Instantiations."*";
818
819 function "*"
820 (Left : Complex;
821 Right : Complex_Matrix) return Complex_Matrix
822 renames Instantiations."*";
823
824 function "*"
825 (Left : Complex_Matrix;
826 Right : Complex) return Complex_Matrix
827 renames Instantiations."*";
828
829 function "*"
830 (Left : Real'Base;
831 Right : Complex_Matrix) return Complex_Matrix
832 renames Instantiations."*";
833
834 function "*"
835 (Left : Complex_Matrix;
836 Right : Real'Base) return Complex_Matrix
837 renames Instantiations."*";
838
839 ---------
840 -- "+" --
841 ---------
842
843 function "+" (Right : Complex_Vector) return Complex_Vector
844 renames Instantiations."+";
845
846 function "+"
847 (Left : Complex_Vector;
848 Right : Complex_Vector) return Complex_Vector
849 renames Instantiations."+";
850
851 function "+"
852 (Left : Real_Vector;
853 Right : Complex_Vector) return Complex_Vector
854 renames Instantiations."+";
855
856 function "+"
857 (Left : Complex_Vector;
858 Right : Real_Vector) return Complex_Vector
859 renames Instantiations."+";
860
861 function "+" (Right : Complex_Matrix) return Complex_Matrix
862 renames Instantiations."+";
863
864 function "+"
865 (Left : Complex_Matrix;
866 Right : Complex_Matrix) return Complex_Matrix
867 renames Instantiations."+";
868
869 function "+"
870 (Left : Real_Matrix;
871 Right : Complex_Matrix) return Complex_Matrix
872 renames Instantiations."+";
873
874 function "+"
875 (Left : Complex_Matrix;
876 Right : Real_Matrix) return Complex_Matrix
877 renames Instantiations."+";
878
879 ---------
880 -- "-" --
881 ---------
882
883 function "-"
884 (Right : Complex_Vector) return Complex_Vector
885 renames Instantiations."-";
886
887 function "-"
888 (Left : Complex_Vector;
889 Right : Complex_Vector) return Complex_Vector
890 renames Instantiations."-";
891
892 function "-"
893 (Left : Real_Vector;
894 Right : Complex_Vector) return Complex_Vector
895 renames Instantiations."-";
896
897 function "-"
898 (Left : Complex_Vector;
899 Right : Real_Vector) return Complex_Vector
900 renames Instantiations."-";
901
902 function "-" (Right : Complex_Matrix) return Complex_Matrix
903 renames Instantiations."-";
904
905 function "-"
906 (Left : Complex_Matrix;
907 Right : Complex_Matrix) return Complex_Matrix
908 renames Instantiations."-";
909
910 function "-"
911 (Left : Real_Matrix;
912 Right : Complex_Matrix) return Complex_Matrix
913 renames Instantiations."-";
914
915 function "-"
916 (Left : Complex_Matrix;
917 Right : Real_Matrix) return Complex_Matrix
918 renames Instantiations."-";
919
920 ---------
921 -- "/" --
922 ---------
923
924 function "/"
925 (Left : Complex_Vector;
926 Right : Complex) return Complex_Vector
927 renames Instantiations."/";
928
929 function "/"
930 (Left : Complex_Vector;
931 Right : Real'Base) return Complex_Vector
932 renames Instantiations."/";
933
934 function "/"
935 (Left : Complex_Matrix;
936 Right : Complex) return Complex_Matrix
937 renames Instantiations."/";
938
939 function "/"
940 (Left : Complex_Matrix;
941 Right : Real'Base) return Complex_Matrix
942 renames Instantiations."/";
943
944 -----------
945 -- "abs" --
946 -----------
947
948 function "abs" (Right : Complex_Vector) return Real'Base
949 renames Instantiations."abs";
950
951 --------------
952 -- Argument --
953 --------------
954
955 function Argument (X : Complex_Vector) return Real_Vector
956 renames Instantiations.Argument;
957
958 function Argument
959 (X : Complex_Vector;
960 Cycle : Real'Base) return Real_Vector
961 renames Instantiations.Argument;
962
963 function Argument (X : Complex_Matrix) return Real_Matrix
964 renames Instantiations.Argument;
965
966 function Argument
967 (X : Complex_Matrix;
968 Cycle : Real'Base) return Real_Matrix
969 renames Instantiations.Argument;
970
971 ----------------------------
972 -- Compose_From_Cartesian --
973 ----------------------------
974
975 function Compose_From_Cartesian (Re : Real_Vector) return Complex_Vector
976 renames Instantiations.Compose_From_Cartesian;
977
978 function Compose_From_Cartesian
979 (Re : Real_Vector;
980 Im : Real_Vector) return Complex_Vector
981 renames Instantiations.Compose_From_Cartesian;
982
983 function Compose_From_Cartesian (Re : Real_Matrix) return Complex_Matrix
984 renames Instantiations.Compose_From_Cartesian;
985
986 function Compose_From_Cartesian
987 (Re : Real_Matrix;
988 Im : Real_Matrix) return Complex_Matrix
989 renames Instantiations.Compose_From_Cartesian;
990
991 ------------------------
992 -- Compose_From_Polar --
993 ------------------------
994
995 function Compose_From_Polar
996 (Modulus : Real_Vector;
997 Argument : Real_Vector) return Complex_Vector
998 renames Instantiations.Compose_From_Polar;
999
1000 function Compose_From_Polar
1001 (Modulus : Real_Vector;
1002 Argument : Real_Vector;
1003 Cycle : Real'Base) return Complex_Vector
1004 renames Instantiations.Compose_From_Polar;
1005
1006 function Compose_From_Polar
1007 (Modulus : Real_Matrix;
1008 Argument : Real_Matrix) return Complex_Matrix
1009 renames Instantiations.Compose_From_Polar;
1010
1011 function Compose_From_Polar
1012 (Modulus : Real_Matrix;
1013 Argument : Real_Matrix;
1014 Cycle : Real'Base) return Complex_Matrix
1015 renames Instantiations.Compose_From_Polar;
1016
1017 ---------------
1018 -- Conjugate --
1019 ---------------
1020
1021 function Conjugate (X : Complex_Vector) return Complex_Vector
1022 renames Instantiations.Conjugate;
1023
1024 function Conjugate (X : Complex_Matrix) return Complex_Matrix
1025 renames Instantiations.Conjugate;
1026
1027 -----------------
1028 -- Determinant --
1029 -----------------
1030
1031 function Determinant (A : Complex_Matrix) return Complex is
1032 M : Complex_Matrix := A;
1033 B : Complex_Matrix (A'Range (1), 1 .. 0);
1034 R : Complex;
1035 begin
1036 Forward_Eliminate (M, B, R);
1037 return R;
1038 end Determinant;
1039
1040 -----------------
1041 -- Eigensystem --
1042 -----------------
1043
1044 procedure Eigensystem
1045 (A : Complex_Matrix;
1046 Values : out Real_Vector;
1047 Vectors : out Complex_Matrix)
1048 is
1049 N : constant Natural := Length (A);
1050
1051 -- For a Hermitian matrix C, we convert the eigenvalue problem to a
1052 -- real symmetric one: if C = A + i * B, then the (N, N) complex
1053 -- eigenvalue problem:
1054 -- (A + i * B) * (u + i * v) = Lambda * (u + i * v)
1055 --
1056 -- is equivalent to the (2 * N, 2 * N) real eigenvalue problem:
1057 -- [ A, B ] [ u ] = Lambda * [ u ]
1058 -- [ -B, A ] [ v ] [ v ]
1059 --
1060 -- Note that the (2 * N, 2 * N) matrix above is symmetric, as
1061 -- Transpose (A) = A and Transpose (B) = -B if C is Hermitian.
1062
1063 -- We solve this eigensystem using the real-valued algorithms. The final
1064 -- result will have every eigenvalue twice, so in the sorted output we
1065 -- just pick every second value, with associated eigenvector u + i * v.
1066
1067 M : Real_Matrix (1 .. 2 * N, 1 .. 2 * N);
1068 Vals : Real_Vector (1 .. 2 * N);
1069 Vecs : Real_Matrix (1 .. 2 * N, 1 .. 2 * N);
1070
1071 begin
1072 for J in 1 .. N loop
1073 for K in 1 .. N loop
1074 declare
1075 C : constant Complex :=
1076 (A (A'First (1) + (J - 1), A'First (2) + (K - 1)));
1077 begin
1078 M (J, K) := Re (C);
1079 M (J + N, K + N) := Re (C);
1080 M (J + N, K) := Im (C);
1081 M (J, K + N) := -Im (C);
1082 end;
1083 end loop;
1084 end loop;
1085
1086 Eigensystem (M, Vals, Vecs);
1087
1088 for J in 1 .. N loop
1089 declare
1090 Col : constant Integer := Values'First + (J - 1);
1091 begin
1092 Values (Col) := Vals (2 * J);
1093
1094 for K in 1 .. N loop
1095 declare
1096 Row : constant Integer := Vectors'First (2) + (K - 1);
1097 begin
1098 Vectors (Row, Col)
1099 := (Vecs (J * 2, Col), Vecs (J * 2, Col + N));
1100 end;
1101 end loop;
1102 end;
1103 end loop;
1104 end Eigensystem;
1105
1106 -----------------
1107 -- Eigenvalues --
1108 -----------------
1109
1110 function Eigenvalues (A : Complex_Matrix) return Real_Vector is
1111 -- See Eigensystem for a description of the algorithm
1112
1113 N : constant Natural := Length (A);
1114 R : Real_Vector (A'Range (1));
1115
1116 M : Real_Matrix (1 .. 2 * N, 1 .. 2 * N);
1117 Vals : Real_Vector (1 .. 2 * N);
1118 begin
1119 for J in 1 .. N loop
1120 for K in 1 .. N loop
1121 declare
1122 C : constant Complex :=
1123 (A (A'First (1) + (J - 1), A'First (2) + (K - 1)));
1124 begin
1125 M (J, K) := Re (C);
1126 M (J + N, K + N) := Re (C);
1127 M (J + N, K) := Im (C);
1128 M (J, K + N) := -Im (C);
1129 end;
1130 end loop;
1131 end loop;
1132
1133 Vals := Eigenvalues (M);
1134
1135 for J in 1 .. N loop
1136 R (A'First (1) + (J - 1)) := Vals (2 * J);
1137 end loop;
1138
1139 return R;
1140 end Eigenvalues;
1141
1142 --------
1143 -- Im --
1144 --------
1145
1146 function Im (X : Complex_Vector) return Real_Vector
1147 renames Instantiations.Im;
1148
1149 function Im (X : Complex_Matrix) return Real_Matrix
1150 renames Instantiations.Im;
1151
1152 -------------
1153 -- Inverse --
1154 -------------
1155
1156 function Inverse (A : Complex_Matrix) return Complex_Matrix is
1157 (Solve (A, Unit_Matrix (Length (A))));
1158
1159 -------------
1160 -- Modulus --
1161 -------------
1162
1163 function Modulus (X : Complex_Vector) return Real_Vector
1164 renames Instantiations.Modulus;
1165
1166 function Modulus (X : Complex_Matrix) return Real_Matrix
1167 renames Instantiations.Modulus;
1168
1169 --------
1170 -- Re --
1171 --------
1172
1173 function Re (X : Complex_Vector) return Real_Vector
1174 renames Instantiations.Re;
1175
1176 function Re (X : Complex_Matrix) return Real_Matrix
1177 renames Instantiations.Re;
1178
1179 ------------
1180 -- Set_Im --
1181 ------------
1182
1183 procedure Set_Im
1184 (X : in out Complex_Matrix;
1185 Im : Real_Matrix)
1186 renames Instantiations.Set_Im;
1187
1188 procedure Set_Im
1189 (X : in out Complex_Vector;
1190 Im : Real_Vector)
1191 renames Instantiations.Set_Im;
1192
1193 ------------
1194 -- Set_Re --
1195 ------------
1196
1197 procedure Set_Re
1198 (X : in out Complex_Matrix;
1199 Re : Real_Matrix)
1200 renames Instantiations.Set_Re;
1201
1202 procedure Set_Re
1203 (X : in out Complex_Vector;
1204 Re : Real_Vector)
1205 renames Instantiations.Set_Re;
1206
1207 -----------
1208 -- Solve --
1209 -----------
1210
1211 function Solve
1212 (A : Complex_Matrix;
1213 X : Complex_Vector) return Complex_Vector
1214 renames Instantiations.Solve;
1215
1216 function Solve
1217 (A : Complex_Matrix;
1218 X : Complex_Matrix) return Complex_Matrix
1219 renames Instantiations.Solve;
1220
1221 ---------------
1222 -- Transpose --
1223 ---------------
1224
1225 function Transpose
1226 (X : Complex_Matrix) return Complex_Matrix
1227 is
1228 R : Complex_Matrix (X'Range (2), X'Range (1));
1229 begin
1230 Transpose (X, R);
1231 return R;
1232 end Transpose;
1233
1234 -----------------
1235 -- Unit_Matrix --
1236 -----------------
1237
1238 function Unit_Matrix
1239 (Order : Positive;
1240 First_1 : Integer := 1;
1241 First_2 : Integer := 1) return Complex_Matrix
1242 renames Instantiations.Unit_Matrix;
1243
1244 -----------------
1245 -- Unit_Vector --
1246 -----------------
1247
1248 function Unit_Vector
1249 (Index : Integer;
1250 Order : Positive;
1251 First : Integer := 1) return Complex_Vector
1252 renames Instantiations.Unit_Vector;
1253
1254 end Ada.Numerics.Generic_Complex_Arrays;
Mirror of the offical gcc git repository hosted at gcc.gnu.org