GNU Octave 10.1.0
A high-level interpreted language, primarily intended for numerical computations, mostly compatible with Matlab
 
Loading...
Searching...
No Matches
CMatrix.cc
Go to the documentation of this file.
1////////////////////////////////////////////////////////////////////////
2//
3// Copyright (C) 1994-2025 The Octave Project Developers
4//
5// See the file COPYRIGHT.md in the top-level directory of this
6// distribution or <https://octave.org/copyright/>.
7//
8// This file is part of Octave.
9//
10// Octave is free software: you can redistribute it and/or modify it
11// under the terms of the GNU General Public License as published by
12// the Free Software Foundation, either version 3 of the License, or
13// (at your option) any later version.
14//
15// Octave is distributed in the hope that it will be useful, but
16// WITHOUT ANY WARRANTY; without even the implied warranty of
17// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18// GNU General Public License for more details.
19//
20// You should have received a copy of the GNU General Public License
21// along with Octave; see the file COPYING. If not, see
22// <https://www.gnu.org/licenses/>.
23//
24////////////////////////////////////////////////////////////////////////
25
26#if defined (HAVE_CONFIG_H)
27# include "config.h"
28#endif
29
30#include <algorithm>
31#include <cmath>
32#include <complex>
33#include <istream>
34#include <limits>
35#include <ostream>
36
37#include "Array-util.h"
38#include "CDiagMatrix.h"
39#include "CMatrix.h"
40#include "CNDArray.h"
41#include "CRowVector.h"
42#include "DET.h"
43#include "boolMatrix.h"
44#include "chMatrix.h"
45#include "chol.h"
46#include "dDiagMatrix.h"
47#include "dMatrix.h"
48#include "dRowVector.h"
49#include "lo-blas-proto.h"
50#include "lo-error.h"
51#include "lo-ieee.h"
52#include "lo-lapack-proto.h"
53#include "lo-mappers.h"
54#include "lo-utils.h"
55#include "mx-cm-dm.h"
56#include "mx-cm-s.h"
57#include "mx-dm-cm.h"
58#include "mx-inlines.cc"
59#include "mx-op-defs.h"
60#include "oct-cmplx.h"
61#include "oct-fftw.h"
62#include "oct-locbuf.h"
63#include "oct-norm.h"
64#include "schur.h"
65#include "svd.h"
66
67static const Complex Complex_NaN_result (octave::numeric_limits<double>::NaN (),
68 octave::numeric_limits<double>::NaN ());
69
70// Complex Matrix class
71
75
79
83
85 : ComplexNDArray (a.dims (), 0.0)
86{
87 for (octave_idx_type i = 0; i < a.length (); i++)
88 elem (i, i) = a.elem (i, i);
89}
90
92 : ComplexNDArray (a.dims (), 0.0)
93{
94 for (octave_idx_type i = 0; i < a.length (); i++)
95 elem (i, i) = a.elem (i, i);
96}
97
99 : ComplexNDArray (a.dims (), 0.0)
100{
101 for (octave_idx_type i = 0; i < a.length (); i++)
102 elem (i, i) = a.elem (i, i);
103}
104
108
112
114 : ComplexNDArray (a.dims (), 0.0)
115{
116 for (octave_idx_type i = 0; i < a.length (); i++)
117 elem (i, i) = a.elem (i, i);
118}
119
121 : ComplexNDArray (a.dims (), 0.0)
122{
123 for (octave_idx_type i = 0; i < a.length (); i++)
124 elem (i, i) = a.elem (i, i);
125}
126
128 : ComplexNDArray (a.dims (), 0.0)
129{
130 for (octave_idx_type i = 0; i < a.length (); i++)
131 elem (i, i) = a.elem (i, i);
132}
133
134// FIXME: could we use a templated mixed-type copy function here?
135
139
141 : ComplexNDArray (a.dims (), 0.0)
142{
143 for (octave_idx_type i = 0; i < a.rows (); i++)
144 for (octave_idx_type j = 0; j < a.cols (); j++)
145 elem (i, j) = static_cast<unsigned char> (a.elem (i, j));
146}
147
149 : ComplexNDArray (re.dims ())
150{
151 if (im.rows () != rows () || im.cols () != cols ())
152 (*current_liboctave_error_handler) ("complex: internal error");
153
154 octave_idx_type nel = numel ();
155 for (octave_idx_type i = 0; i < nel; i++)
156 xelem (i) = Complex (re(i), im(i));
157}
158
159bool
161{
162 if (rows () != a.rows () || cols () != a.cols ())
163 return false;
164
165 return mx_inline_equal (numel (), data (), a.data ());
166}
167
168bool
170{
171 return !(*this == a);
172}
174bool
176{
177 octave_idx_type nr = rows ();
178 octave_idx_type nc = cols ();
179
180 if (issquare () && nr > 0)
181 {
182 for (octave_idx_type i = 0; i < nr; i++)
183 for (octave_idx_type j = i; j < nc; j++)
184 if (elem (i, j) != conj (elem (j, i)))
185 return false;
186
187 return true;
188 }
189
190 return false;
191}
192
193// destructive insert/delete/reorder operations
194
197{
198 octave_idx_type a_nr = a.rows ();
199 octave_idx_type a_nc = a.cols ();
200
201 if (r < 0 || r + a_nr > rows () || c < 0 || c + a_nc > cols ())
202 (*current_liboctave_error_handler) ("range error for insert");
203
204 if (a_nr >0 && a_nc > 0)
205 {
206 make_unique ();
207
208 for (octave_idx_type j = 0; j < a_nc; j++)
209 for (octave_idx_type i = 0; i < a_nr; i++)
210 xelem (r+i, c+j) = a.elem (i, j);
211 }
212
213 return *this;
214}
215
218{
219 octave_idx_type a_len = a.numel ();
220
221 if (r < 0 || r >= rows () || c < 0 || c + a_len > cols ())
222 (*current_liboctave_error_handler) ("range error for insert");
223
224 if (a_len > 0)
225 {
226 make_unique ();
227
228 for (octave_idx_type i = 0; i < a_len; i++)
229 xelem (r, c+i) = a.elem (i);
230 }
231
232 return *this;
233}
234
238{
239 octave_idx_type a_len = a.numel ();
240
241 if (r < 0 || r + a_len > rows () || c < 0 || c >= cols ())
242 (*current_liboctave_error_handler) ("range error for insert");
243
244 if (a_len > 0)
245 {
246 make_unique ();
247
248 for (octave_idx_type i = 0; i < a_len; i++)
249 xelem (r+i, c) = a.elem (i);
250 }
251
252 return *this;
253}
254
258{
259 octave_idx_type a_nr = a.rows ();
260 octave_idx_type a_nc = a.cols ();
261
262 if (r < 0 || r + a_nr > rows () || c < 0 || c + a_nc > cols ())
263 (*current_liboctave_error_handler) ("range error for insert");
264
265 fill (0.0, r, c, r + a_nr - 1, c + a_nc - 1);
266
267 octave_idx_type a_len = a.length ();
268
269 if (a_len > 0)
270 {
271 make_unique ();
272
273 for (octave_idx_type i = 0; i < a_len; i++)
274 xelem (r+i, c+i) = a.elem (i, i);
275 }
276
277 return *this;
278}
279
283{
284 ComplexNDArray::insert (a, r, c);
285 return *this;
286}
287
291{
292 octave_idx_type a_len = a.numel ();
293 if (r < 0 || r >= rows () || c < 0 || c + a_len > cols ())
294 (*current_liboctave_error_handler) ("range error for insert");
295
296 for (octave_idx_type i = 0; i < a_len; i++)
297 elem (r, c+i) = a.elem (i);
298
299 return *this;
300}
301
305{
306 octave_idx_type a_len = a.numel ();
307
308 if (r < 0 || r + a_len > rows () || c < 0 || c >= cols ())
309 (*current_liboctave_error_handler) ("range error for insert");
310
311 if (a_len > 0)
312 {
313 make_unique ();
314
315 for (octave_idx_type i = 0; i < a_len; i++)
316 xelem (r+i, c) = a.elem (i);
317 }
318
319 return *this;
320}
321
325{
326 octave_idx_type a_nr = a.rows ();
327 octave_idx_type a_nc = a.cols ();
328
329 if (r < 0 || r + a_nr > rows () || c < 0 || c + a_nc > cols ())
330 (*current_liboctave_error_handler) ("range error for insert");
331
332 fill (0.0, r, c, r + a_nr - 1, c + a_nc - 1);
333
334 octave_idx_type a_len = a.length ();
335
336 if (a_len > 0)
337 {
338 make_unique ();
339
340 for (octave_idx_type i = 0; i < a_len; i++)
341 xelem (r+i, c+i) = a.elem (i, i);
342 }
343
344 return *this;
345}
346
349{
350 octave_idx_type nr = rows ();
351 octave_idx_type nc = cols ();
352
353 if (nr > 0 && nc > 0)
354 {
355 make_unique ();
356
357 for (octave_idx_type j = 0; j < nc; j++)
358 for (octave_idx_type i = 0; i < nr; i++)
359 xelem (i, j) = val;
360 }
361
362 return *this;
363}
364
367{
368 octave_idx_type nr = rows ();
369 octave_idx_type nc = cols ();
370
371 if (nr > 0 && nc > 0)
372 {
373 make_unique ();
374
375 for (octave_idx_type j = 0; j < nc; j++)
376 for (octave_idx_type i = 0; i < nr; i++)
377 xelem (i, j) = val;
378 }
379
380 return *this;
381}
382
386{
387 octave_idx_type nr = rows ();
388 octave_idx_type nc = cols ();
389
390 if (r1 < 0 || r2 < 0 || c1 < 0 || c2 < 0
391 || r1 >= nr || r2 >= nr || c1 >= nc || c2 >= nc)
392 (*current_liboctave_error_handler) ("range error for fill");
393
394 if (r1 > r2) { std::swap (r1, r2); }
395 if (c1 > c2) { std::swap (c1, c2); }
396
397 if (r2 >= r1 && c2 >= c1)
398 {
399 make_unique ();
400
401 for (octave_idx_type j = c1; j <= c2; j++)
402 for (octave_idx_type i = r1; i <= r2; i++)
403 xelem (i, j) = val;
404 }
405
406 return *this;
407}
408
412{
413 octave_idx_type nr = rows ();
414 octave_idx_type nc = cols ();
415
416 if (r1 < 0 || r2 < 0 || c1 < 0 || c2 < 0
417 || r1 >= nr || r2 >= nr || c1 >= nc || c2 >= nc)
418 (*current_liboctave_error_handler) ("range error for fill");
419
420 if (r1 > r2) { std::swap (r1, r2); }
421 if (c1 > c2) { std::swap (c1, c2); }
422
423 if (r2 >= r1 && c2 >=c1)
424 {
425 make_unique ();
426
427 for (octave_idx_type j = c1; j <= c2; j++)
428 for (octave_idx_type i = r1; i <= r2; i++)
429 xelem (i, j) = val;
430 }
431
432 return *this;
433}
434
437{
438 octave_idx_type nr = rows ();
439 octave_idx_type nc = cols ();
440 if (nr != a.rows ())
441 (*current_liboctave_error_handler) ("row dimension mismatch for append");
442
443 octave_idx_type nc_insert = nc;
444 ComplexMatrix retval (nr, nc + a.cols ());
445 retval.insert (*this, 0, 0);
446 retval.insert (a, 0, nc_insert);
447 return retval;
448}
449
452{
453 octave_idx_type nr = rows ();
454 octave_idx_type nc = cols ();
455 if (nr != 1)
456 (*current_liboctave_error_handler) ("row dimension mismatch for append");
457
458 octave_idx_type nc_insert = nc;
459 ComplexMatrix retval (nr, nc + a.numel ());
460 retval.insert (*this, 0, 0);
461 retval.insert (a, 0, nc_insert);
462 return retval;
463}
464
467{
468 octave_idx_type nr = rows ();
469 octave_idx_type nc = cols ();
470 if (nr != a.numel ())
471 (*current_liboctave_error_handler) ("row dimension mismatch for append");
472
473 octave_idx_type nc_insert = nc;
474 ComplexMatrix retval (nr, nc + 1);
475 retval.insert (*this, 0, 0);
476 retval.insert (a, 0, nc_insert);
477 return retval;
478}
479
482{
483 octave_idx_type nr = rows ();
484 octave_idx_type nc = cols ();
485 if (nr != a.rows ())
486 (*current_liboctave_error_handler) ("row dimension mismatch for append");
487
488 octave_idx_type nc_insert = nc;
489 ComplexMatrix retval (nr, nc + a.cols ());
490 retval.insert (*this, 0, 0);
491 retval.insert (a, 0, nc_insert);
492 return retval;
493}
494
497{
498 octave_idx_type nr = rows ();
499 octave_idx_type nc = cols ();
500 if (nr != a.rows ())
501 (*current_liboctave_error_handler) ("row dimension mismatch for append");
502
503 octave_idx_type nc_insert = nc;
504 ComplexMatrix retval (nr, nc + a.cols ());
505 retval.insert (*this, 0, 0);
506 retval.insert (a, 0, nc_insert);
507 return retval;
508}
509
512{
513 octave_idx_type nr = rows ();
514 octave_idx_type nc = cols ();
515 if (nr != 1)
516 (*current_liboctave_error_handler) ("row dimension mismatch for append");
517
518 octave_idx_type nc_insert = nc;
519 ComplexMatrix retval (nr, nc + a.numel ());
520 retval.insert (*this, 0, 0);
521 retval.insert (a, 0, nc_insert);
522 return retval;
523}
524
527{
528 octave_idx_type nr = rows ();
529 octave_idx_type nc = cols ();
530 if (nr != a.numel ())
531 (*current_liboctave_error_handler) ("row dimension mismatch for append");
532
533 octave_idx_type nc_insert = nc;
534 ComplexMatrix retval (nr, nc + 1);
535 retval.insert (*this, 0, 0);
536 retval.insert (a, 0, nc_insert);
537 return retval;
538}
539
542{
543 octave_idx_type nr = rows ();
544 octave_idx_type nc = cols ();
545 if (nr != a.rows ())
546 (*current_liboctave_error_handler) ("row dimension mismatch for append");
547
548 octave_idx_type nc_insert = nc;
549 ComplexMatrix retval (nr, nc + a.cols ());
550 retval.insert (*this, 0, 0);
551 retval.insert (a, 0, nc_insert);
552 return retval;
553}
554
557{
558 octave_idx_type nr = rows ();
559 octave_idx_type nc = cols ();
560 if (nc != a.cols ())
561 (*current_liboctave_error_handler) ("column dimension mismatch for stack");
562
563 octave_idx_type nr_insert = nr;
564 ComplexMatrix retval (nr + a.rows (), nc);
565 retval.insert (*this, 0, 0);
566 retval.insert (a, nr_insert, 0);
567 return retval;
568}
569
572{
573 octave_idx_type nr = rows ();
574 octave_idx_type nc = cols ();
575 if (nc != a.numel ())
576 (*current_liboctave_error_handler) ("column dimension mismatch for stack");
577
578 octave_idx_type nr_insert = nr;
579 ComplexMatrix retval (nr + 1, nc);
580 retval.insert (*this, 0, 0);
581 retval.insert (a, nr_insert, 0);
582 return retval;
583}
584
587{
588 octave_idx_type nr = rows ();
589 octave_idx_type nc = cols ();
590 if (nc != 1)
591 (*current_liboctave_error_handler) ("column dimension mismatch for stack");
592
593 octave_idx_type nr_insert = nr;
594 ComplexMatrix retval (nr + a.numel (), nc);
595 retval.insert (*this, 0, 0);
596 retval.insert (a, nr_insert, 0);
597 return retval;
598}
599
602{
603 octave_idx_type nr = rows ();
604 octave_idx_type nc = cols ();
605 if (nc != a.cols ())
606 (*current_liboctave_error_handler) ("column dimension mismatch for stack");
607
608 octave_idx_type nr_insert = nr;
609 ComplexMatrix retval (nr + a.rows (), nc);
610 retval.insert (*this, 0, 0);
611 retval.insert (a, nr_insert, 0);
612 return retval;
613}
614
617{
618 octave_idx_type nr = rows ();
619 octave_idx_type nc = cols ();
620 if (nc != a.cols ())
621 (*current_liboctave_error_handler) ("column dimension mismatch for stack");
622
623 octave_idx_type nr_insert = nr;
624 ComplexMatrix retval (nr + a.rows (), nc);
625 retval.insert (*this, 0, 0);
626 retval.insert (a, nr_insert, 0);
627 return retval;
628}
629
632{
633 octave_idx_type nr = rows ();
634 octave_idx_type nc = cols ();
635 if (nc != a.numel ())
636 (*current_liboctave_error_handler) ("column dimension mismatch for stack");
637
638 octave_idx_type nr_insert = nr;
639 ComplexMatrix retval (nr + 1, nc);
640 retval.insert (*this, 0, 0);
641 retval.insert (a, nr_insert, 0);
642 return retval;
643}
644
647{
648 octave_idx_type nr = rows ();
649 octave_idx_type nc = cols ();
650 if (nc != 1)
651 (*current_liboctave_error_handler) ("column dimension mismatch for stack");
652
653 octave_idx_type nr_insert = nr;
654 ComplexMatrix retval (nr + a.numel (), nc);
655 retval.insert (*this, 0, 0);
656 retval.insert (a, nr_insert, 0);
657 return retval;
658}
659
662{
663 octave_idx_type nr = rows ();
664 octave_idx_type nc = cols ();
665 if (nc != a.cols ())
666 (*current_liboctave_error_handler) ("column dimension mismatch for stack");
667
668 octave_idx_type nr_insert = nr;
669 ComplexMatrix retval (nr + a.rows (), nc);
670 retval.insert (*this, 0, 0);
671 retval.insert (a, nr_insert, 0);
672 return retval;
673}
674
677{
678 return do_mx_unary_map<Complex, Complex, std::conj<double>> (a);
679}
680
681// resize is the destructive equivalent for this one
682
685 octave_idx_type r2, octave_idx_type c2) const
686{
687 if (r1 > r2) { std::swap (r1, r2); }
688 if (c1 > c2) { std::swap (c1, c2); }
689
690 return index (octave::idx_vector (r1, r2+1), octave::idx_vector (c1, c2+1));
691}
692
695 octave_idx_type nr, octave_idx_type nc) const
696{
697 return index (octave::idx_vector (r1, r1 + nr), octave::idx_vector (c1, c1 + nc));
698}
699
700// extract row or column i.
701
704{
705 return index (octave::idx_vector (i), octave::idx_vector::colon);
706}
707
710{
711 return index (octave::idx_vector::colon, octave::idx_vector (i));
712}
713
714// Local function to calculate the 1-norm.
715static
716double
717norm1 (const ComplexMatrix& a)
718{
719 double anorm = 0.0;
720 RowVector colsum = a.abs ().sum ().row (0);
721
722 for (octave_idx_type i = 0; i < colsum.numel (); i++)
723 {
724 double sum = colsum.xelem (i);
725 if (octave::math::isinf (sum) || octave::math::isnan (sum))
726 {
727 anorm = sum; // Pass Inf or NaN to output
728 break;
729 }
730 else
731 anorm = std::max (anorm, sum);
732 }
733
734 return anorm;
735}
736
737// Local function to check if matrix is singular based on rcond.
738static inline
739bool
740is_singular (const double rcond)
741{
742 return (std::abs (rcond) <= std::numeric_limits<double>::epsilon ());
743}
744
747{
748 octave_idx_type info;
749 double rcon;
750 MatrixType mattype (*this);
751 return inverse (mattype, info, rcon, false, false);
752}
753
756{
757 double rcon;
758 MatrixType mattype (*this);
759 return inverse (mattype, info, rcon, false, false);
760}
761
763ComplexMatrix::inverse (octave_idx_type& info, double& rcon, bool force,
764 bool calc_cond) const
765{
766 MatrixType mattype (*this);
767 return inverse (mattype, info, rcon, force, calc_cond);
768}
769
772{
773 octave_idx_type info;
774 double rcon;
775 return inverse (mattype, info, rcon, false, false);
776}
777
780{
781 double rcon;
782 return inverse (mattype, info, rcon, false, false);
783}
784
786ComplexMatrix::tinverse (MatrixType& mattype, octave_idx_type& info,
787 double& rcon, bool force, bool calc_cond) const
788{
789 ComplexMatrix retval;
790
791 F77_INT nr = octave::to_f77_int (rows ());
792 F77_INT nc = octave::to_f77_int (cols ());
793
794 if (nr != nc || nr == 0 || nc == 0)
795 (*current_liboctave_error_handler) ("inverse requires square matrix");
796
797 int typ = mattype.type ();
798 char uplo = (typ == MatrixType::Lower ? 'L' : 'U');
799 char udiag = 'N';
800 retval = *this;
801 Complex *tmp_data = retval.rwdata ();
802
803 F77_INT tmp_info = 0;
804
805 F77_XFCN (ztrtri, ZTRTRI, (F77_CONST_CHAR_ARG2 (&uplo, 1),
806 F77_CONST_CHAR_ARG2 (&udiag, 1),
807 nr, F77_DBLE_CMPLX_ARG (tmp_data), nr, tmp_info
808 F77_CHAR_ARG_LEN (1)
809 F77_CHAR_ARG_LEN (1)));
810
811 info = tmp_info;
812
813 // Throw away extra info LAPACK gives so as to not change output.
814 rcon = 0.0;
815 if (info != 0)
816 info = -1;
817 else if (calc_cond)
818 {
819 F77_INT ztrcon_info = 0;
820 char job = '1';
821
822 OCTAVE_LOCAL_BUFFER (Complex, cwork, 2*nr);
823 OCTAVE_LOCAL_BUFFER (double, rwork, nr);
824
825 F77_XFCN (ztrcon, ZTRCON, (F77_CONST_CHAR_ARG2 (&job, 1),
826 F77_CONST_CHAR_ARG2 (&uplo, 1),
827 F77_CONST_CHAR_ARG2 (&udiag, 1),
828 nr, F77_DBLE_CMPLX_ARG (tmp_data), nr, rcon,
829 F77_DBLE_CMPLX_ARG (cwork), rwork, ztrcon_info
830 F77_CHAR_ARG_LEN (1)
831 F77_CHAR_ARG_LEN (1)
832 F77_CHAR_ARG_LEN (1)));
833
834 if (ztrcon_info != 0)
835 info = -1;
836 }
837
838 if (info == -1 && ! force)
839 retval = *this; // Restore matrix contents.
840
841 return retval;
842}
843
845ComplexMatrix::finverse (MatrixType& mattype, octave_idx_type& info,
846 double& rcon, bool force, bool calc_cond) const
847{
848 ComplexMatrix retval;
849
850 F77_INT nr = octave::to_f77_int (rows ());
851 F77_INT nc = octave::to_f77_int (cols ());
852
853 if (nr != nc)
854 (*current_liboctave_error_handler) ("inverse requires square matrix");
855
856 Array<F77_INT> ipvt (dim_vector (nr, 1));
857 F77_INT *pipvt = ipvt.rwdata ();
858
859 retval = *this;
860 Complex *tmp_data = retval.rwdata ();
861
862 Array<Complex> z (dim_vector (1, 1));
863 F77_INT lwork = -1;
864
865 // Query the optimum work array size.
866
867 F77_INT tmp_info = 0;
868
869 F77_XFCN (zgetri, ZGETRI, (nc, F77_DBLE_CMPLX_ARG (tmp_data), nr, pipvt,
870 F77_DBLE_CMPLX_ARG (z.rwdata ()), lwork,
871 tmp_info));
872
873 lwork = static_cast<F77_INT> (std::real (z(0)));
874 lwork = (lwork < 2 * nc ? 2 * nc : lwork);
875 z.resize (dim_vector (lwork, 1));
876 Complex *pz = z.rwdata ();
877
878 info = 0;
879 tmp_info = 0;
880
881 // Calculate norm of the matrix (always, see bug #45577) for later use.
882 double anorm = norm1 (retval);
883
884 // Work around bug #45577, LAPACK crashes Octave if norm is NaN
885 // and bug #46330, segfault with matrices containing Inf & NaN
886 if (octave::math::isnan (anorm) || octave::math::isinf (anorm))
887 info = -1;
888 else
889 {
890 F77_XFCN (zgetrf, ZGETRF, (nc, nc, F77_DBLE_CMPLX_ARG (tmp_data), nr,
891 pipvt, tmp_info));
892
893 info = tmp_info;
894 }
895
896 // Throw away extra info LAPACK gives so as to not change output.
897 rcon = 0.0;
898 if (info != 0)
899 info = -1;
900 else if (calc_cond)
901 {
902 if (octave::math::isnan (anorm))
903 rcon = octave::numeric_limits<double>::NaN ();
904 else
905 {
906 F77_INT zgecon_info = 0;
907
908 // Now calculate the condition number for non-singular matrix.
909 char job = '1';
910 Array<double> rz (dim_vector (2 * nc, 1));
911 double *prz = rz.rwdata ();
912 F77_XFCN (zgecon, ZGECON, (F77_CONST_CHAR_ARG2 (&job, 1),
913 nc, F77_DBLE_CMPLX_ARG (tmp_data), nr,
914 anorm, rcon, F77_DBLE_CMPLX_ARG (pz), prz,
915 zgecon_info F77_CHAR_ARG_LEN (1)));
916
917 if (zgecon_info != 0)
918 info = -1;
919 }
920 }
921
922 if ((info == -1 && ! force)
923 || octave::math::isnan (anorm) || octave::math::isinf (anorm))
924 retval = *this; // Restore contents.
925 else
926 {
927 F77_INT zgetri_info = 0;
928
929 F77_XFCN (zgetri, ZGETRI, (nc, F77_DBLE_CMPLX_ARG (tmp_data), nr, pipvt,
930 F77_DBLE_CMPLX_ARG (pz), lwork, zgetri_info));
931
932 if (zgetri_info != 0)
933 info = -1;
934 }
935
936 if (info != 0)
937 mattype.mark_as_rectangular ();
938
939 return retval;
940}
941
944 double& rcon, bool force, bool calc_cond) const
945{
946 int typ = mattype.type (false);
947 ComplexMatrix ret;
948
949 if (typ == MatrixType::Unknown)
950 typ = mattype.type (*this);
951
952 if (typ == MatrixType::Diagonal) // a scalar is classified as Diagonal.
953 {
954 Complex scalar = this->elem (0);
955 double real = std::real (scalar);
956 double imag = std::imag (scalar);
957
958 if (real == 0 && imag == 0)
959 ret = ComplexMatrix (1, 1,
960 Complex (octave::numeric_limits<double>::Inf (), 0.0));
961 else
962 ret = Complex (1, 0) / (*this);
963
964 if (calc_cond)
965 {
966 if (octave::math::isfinite (real) && octave::math::isfinite (imag)
967 && (real != 0 || imag != 0))
968 rcon = 1.0;
969 else if (octave::math::isinf (real) || octave::math::isinf (imag)
970 || (real == 0 && imag == 0))
971 rcon = 0.0;
972 else
973 rcon = octave::numeric_limits<double>::NaN ();
974 }
975 }
976 else if (typ == MatrixType::Upper || typ == MatrixType::Lower)
977 ret = tinverse (mattype, info, rcon, force, calc_cond);
978 else
979 {
980 if (mattype.ishermitian ())
981 {
982 octave::math::chol<ComplexMatrix> chol (*this, info, true, calc_cond);
983 if (info == 0)
984 {
985 if (calc_cond)
986 rcon = chol.rcond ();
987 else
988 rcon = 1.0;
989 ret = chol.inverse ();
990 }
991 else
992 mattype.mark_as_unsymmetric ();
993 }
994
995 if (! mattype.ishermitian ())
996 ret = finverse (mattype, info, rcon, force, calc_cond);
997
998 if ((calc_cond || mattype.ishermitian ()) && rcon == 0.0)
999 {
1000 ret = ComplexMatrix (rows (), columns (),
1001 Complex (octave::numeric_limits<double>::Inf (), 0.0));
1002 }
1003 }
1004
1005 return ret;
1006}
1007
1010{
1011 ComplexMatrix retval;
1012
1013 octave::math::svd<ComplexMatrix> result (*this,
1014 octave::math::svd<ComplexMatrix>::Type::economy);
1015
1016 DiagMatrix S = result.singular_values ();
1017 ComplexMatrix U = result.left_singular_matrix ();
1018 ComplexMatrix V = result.right_singular_matrix ();
1019
1020 ColumnVector sigma = S.extract_diag ();
1021
1022 octave_idx_type r = sigma.numel () - 1;
1023 octave_idx_type nr = rows ();
1024 octave_idx_type nc = cols ();
1025
1026 if (tol <= 0.0)
1027 {
1028 tol = std::max (nr, nc) * sigma.elem (0)
1029 * std::numeric_limits<double>::epsilon ();
1030
1031 if (tol == 0)
1032 tol = std::numeric_limits<double>::min ();
1033 }
1034
1035 while (r >= 0 && sigma.elem (r) < tol)
1036 r--;
1037
1038 if (r < 0)
1039 retval = ComplexMatrix (nc, nr, 0.0);
1040 else
1041 {
1042 ComplexMatrix Ur = U.extract (0, 0, nr-1, r);
1043 DiagMatrix D = DiagMatrix (sigma.extract (0, r)).inverse ();
1044 ComplexMatrix Vr = V.extract (0, 0, nc-1, r);
1045 retval = Vr * D * Ur.hermitian ();
1046 }
1047
1048 return retval;
1049}
1050
1051#if defined (HAVE_FFTW)
1052
1055{
1056 std::size_t nr = rows ();
1057 std::size_t nc = cols ();
1058
1059 ComplexMatrix retval (nr, nc);
1060
1061 std::size_t npts, nsamples;
1062
1063 if (nr == 1 || nc == 1)
1064 {
1065 npts = (nr > nc ? nr : nc);
1066 nsamples = 1;
1067 }
1068 else
1069 {
1070 npts = nr;
1071 nsamples = nc;
1072 }
1073
1074 const Complex *in (data ());
1075 Complex *out (retval.rwdata ());
1076
1077 octave::fftw::fft (in, out, npts, nsamples);
1078
1079 return retval;
1080}
1081
1084{
1085 std::size_t nr = rows ();
1086 std::size_t nc = cols ();
1087
1088 ComplexMatrix retval (nr, nc);
1089
1090 std::size_t npts, nsamples;
1091
1092 if (nr == 1 || nc == 1)
1093 {
1094 npts = (nr > nc ? nr : nc);
1095 nsamples = 1;
1096 }
1097 else
1098 {
1099 npts = nr;
1100 nsamples = nc;
1101 }
1102
1103 const Complex *in (data ());
1104 Complex *out (retval.rwdata ());
1105
1106 octave::fftw::ifft (in, out, npts, nsamples);
1107
1108 return retval;
1109}
1110
1113{
1114 dim_vector dv (rows (), cols ());
1115
1116 ComplexMatrix retval (rows (), cols ());
1117 const Complex *in (data ());
1118 Complex *out (retval.rwdata ());
1119
1120 octave::fftw::fftNd (in, out, 2, dv);
1121
1122 return retval;
1123}
1124
1127{
1128 dim_vector dv (rows (), cols ());
1129
1130 ComplexMatrix retval (rows (), cols ());
1131 const Complex *in (data ());
1132 Complex *out (retval.rwdata ());
1133
1134 octave::fftw::ifftNd (in, out, 2, dv);
1135
1136 return retval;
1137}
1138
1139#else
1140
1143{
1144 (*current_liboctave_error_handler)
1145 ("support for FFTW was unavailable or disabled when liboctave was built");
1146
1147 return ComplexMatrix ();
1148}
1149
1152{
1153 (*current_liboctave_error_handler)
1154 ("support for FFTW was unavailable or disabled when liboctave was built");
1155
1156 return ComplexMatrix ();
1157}
1158
1161{
1162 (*current_liboctave_error_handler)
1163 ("support for FFTW was unavailable or disabled when liboctave was built");
1164
1165 return ComplexMatrix ();
1166}
1167
1170{
1171 (*current_liboctave_error_handler)
1172 ("support for FFTW was unavailable or disabled when liboctave was built");
1173
1174 return ComplexMatrix ();
1175}
1176
1177#endif
1178
1181{
1182 octave_idx_type info;
1183 double rcon;
1184 return determinant (info, rcon, 0);
1185}
1186
1189{
1190 double rcon;
1191 return determinant (info, rcon, 0);
1192}
1193
1196 bool calc_cond) const
1197{
1198 MatrixType mattype (*this);
1199 return determinant (mattype, info, rcon, calc_cond);
1200}
1201
1204 octave_idx_type& info, double& rcon,
1205 bool calc_cond) const
1206{
1207 ComplexDET retval (1.0);
1208
1209 info = 0;
1210 rcon = 0.0;
1211
1212 F77_INT nr = octave::to_f77_int (rows ());
1213 F77_INT nc = octave::to_f77_int (cols ());
1214
1215 if (nr != nc)
1216 (*current_liboctave_error_handler) ("matrix must be square");
1217
1218 int typ = mattype.type ();
1219
1220 // Even though the matrix is marked as singular (Rectangular), we may
1221 // still get a useful number from the LU factorization, because it always
1222 // completes.
1223
1224 if (typ == MatrixType::Unknown)
1225 typ = mattype.type (*this);
1226 else if (typ == MatrixType::Rectangular)
1227 typ = MatrixType::Full;
1228
1229 if (typ == MatrixType::Lower || typ == MatrixType::Upper)
1230 {
1231 for (F77_INT i = 0; i < nc; i++)
1232 retval *= elem (i, i);
1233 }
1234 else if (typ == MatrixType::Hermitian)
1235 {
1236 ComplexMatrix atmp = *this;
1237 Complex *tmp_data = atmp.rwdata ();
1238
1239 double anorm;
1240 if (calc_cond)
1241 anorm = norm1 (*this);
1242
1243 F77_INT tmp_info = 0;
1244
1245 char job = 'L';
1246 F77_XFCN (zpotrf, ZPOTRF, (F77_CONST_CHAR_ARG2 (&job, 1), nr,
1247 F77_DBLE_CMPLX_ARG (tmp_data), nr, tmp_info
1248 F77_CHAR_ARG_LEN (1)));
1249
1250 info = tmp_info;
1251
1252 if (info != 0)
1253 {
1254 rcon = 0.0;
1255 mattype.mark_as_unsymmetric ();
1256 typ = MatrixType::Full;
1257 }
1258 else
1259 {
1260 if (calc_cond)
1261 {
1262 Array<Complex> z (dim_vector (2 * nc, 1));
1263 Complex *pz = z.rwdata ();
1264 Array<double> rz (dim_vector (nc, 1));
1265 double *prz = rz.rwdata ();
1266
1267 F77_XFCN (zpocon, ZPOCON, (F77_CONST_CHAR_ARG2 (&job, 1),
1268 nr, F77_DBLE_CMPLX_ARG (tmp_data), nr, anorm,
1269 rcon, F77_DBLE_CMPLX_ARG (pz), prz, tmp_info
1270 F77_CHAR_ARG_LEN (1)));
1271
1272 info = tmp_info;
1273
1274 if (info != 0)
1275 rcon = 0.0;
1276 }
1277
1278 for (F77_INT i = 0; i < nc; i++)
1279 retval *= atmp(i, i);
1280
1281 retval = retval.square ();
1282 }
1283 }
1284 else if (typ != MatrixType::Full)
1285 (*current_liboctave_error_handler) ("det: invalid dense matrix type");
1286
1287 if (typ == MatrixType::Full)
1288 {
1289 Array<F77_INT> ipvt (dim_vector (nr, 1));
1290 F77_INT *pipvt = ipvt.rwdata ();
1291
1292 ComplexMatrix atmp = *this;
1293 Complex *tmp_data = atmp.rwdata ();
1294
1295 info = 0;
1296
1297 // Calculate norm of the matrix (always, see bug #45577) for later use.
1298 double anorm = norm1 (*this);
1299
1300 F77_INT tmp_info = 0;
1301
1302 // Work around bug #45577, LAPACK crashes Octave if norm is NaN
1303 if (octave::math::isnan (anorm))
1304 info = -1;
1305 else
1306 {
1307 F77_XFCN (zgetrf, ZGETRF, (nr, nr, F77_DBLE_CMPLX_ARG (tmp_data), nr, pipvt,
1308 tmp_info));
1309
1310 info = tmp_info;
1311 }
1312
1313 // Throw away extra info LAPACK gives so as to not change output.
1314 rcon = 0.0;
1315 if (info != 0)
1316 {
1317 info = -1;
1318 retval = ComplexDET ();
1319 }
1320 else
1321 {
1322 if (calc_cond)
1323 {
1324 // Now calc the condition number for non-singular matrix.
1325 char job = '1';
1326 Array<Complex> z (dim_vector (2 * nc, 1));
1327 Complex *pz = z.rwdata ();
1328 Array<double> rz (dim_vector (2 * nc, 1));
1329 double *prz = rz.rwdata ();
1330
1331 F77_XFCN (zgecon, ZGECON, (F77_CONST_CHAR_ARG2 (&job, 1),
1332 nc, F77_DBLE_CMPLX_ARG (tmp_data), nr, anorm,
1333 rcon, F77_DBLE_CMPLX_ARG (pz), prz, tmp_info
1334 F77_CHAR_ARG_LEN (1)));
1335
1336 info = tmp_info;
1337 }
1338
1339 if (info != 0)
1340 {
1341 info = -1;
1342 retval = ComplexDET ();
1343 }
1344 else
1345 {
1346 for (F77_INT i = 0; i < nc; i++)
1347 {
1348 Complex c = atmp(i, i);
1349 retval *= (ipvt(i) != (i+1)) ? -c : c;
1350 }
1351 }
1352 }
1353 }
1354
1355 return retval;
1356}
1357
1358double
1360{
1361 MatrixType mattype (*this);
1362 return rcond (mattype);
1363}
1364
1365double
1367{
1368 double rcon = octave::numeric_limits<double>::NaN ();
1369 F77_INT nr = octave::to_f77_int (rows ());
1370 F77_INT nc = octave::to_f77_int (cols ());
1371
1372 if (nr != nc)
1373 (*current_liboctave_error_handler) ("matrix must be square");
1374
1375 if (nr == 0 || nc == 0)
1376 rcon = octave::numeric_limits<double>::Inf ();
1377 else
1378 {
1379 int typ = mattype.type ();
1380
1381 if (typ == MatrixType::Unknown)
1382 typ = mattype.type (*this);
1383
1384 // Only calculate the condition number for LU/Cholesky
1385 if (typ == MatrixType::Upper)
1386 {
1387 const Complex *tmp_data = data ();
1388 F77_INT info = 0;
1389 char norm = '1';
1390 char uplo = 'U';
1391 char dia = 'N';
1392
1393 Array<Complex> z (dim_vector (2 * nc, 1));
1394 Complex *pz = z.rwdata ();
1395 Array<double> rz (dim_vector (nc, 1));
1396 double *prz = rz.rwdata ();
1397
1398 F77_XFCN (ztrcon, ZTRCON, (F77_CONST_CHAR_ARG2 (&norm, 1),
1399 F77_CONST_CHAR_ARG2 (&uplo, 1),
1400 F77_CONST_CHAR_ARG2 (&dia, 1),
1401 nr, F77_CONST_DBLE_CMPLX_ARG (tmp_data), nr, rcon,
1402 F77_DBLE_CMPLX_ARG (pz), prz, info
1403 F77_CHAR_ARG_LEN (1)
1404 F77_CHAR_ARG_LEN (1)
1405 F77_CHAR_ARG_LEN (1)));
1406
1407 if (info != 0)
1408 rcon = 0;
1409 }
1410 else if (typ == MatrixType::Permuted_Upper)
1411 (*current_liboctave_error_handler)
1412 ("permuted triangular matrix not implemented");
1413 else if (typ == MatrixType::Lower)
1414 {
1415 const Complex *tmp_data = data ();
1416 F77_INT info = 0;
1417 char norm = '1';
1418 char uplo = 'L';
1419 char dia = 'N';
1420
1421 Array<Complex> z (dim_vector (2 * nc, 1));
1422 Complex *pz = z.rwdata ();
1423 Array<double> rz (dim_vector (nc, 1));
1424 double *prz = rz.rwdata ();
1425
1426 F77_XFCN (ztrcon, ZTRCON, (F77_CONST_CHAR_ARG2 (&norm, 1),
1427 F77_CONST_CHAR_ARG2 (&uplo, 1),
1428 F77_CONST_CHAR_ARG2 (&dia, 1),
1429 nr, F77_CONST_DBLE_CMPLX_ARG (tmp_data), nr, rcon,
1430 F77_DBLE_CMPLX_ARG (pz), prz, info
1431 F77_CHAR_ARG_LEN (1)
1432 F77_CHAR_ARG_LEN (1)
1433 F77_CHAR_ARG_LEN (1)));
1434
1435 if (info != 0)
1436 rcon = 0.0;
1437 }
1438 else if (typ == MatrixType::Permuted_Lower)
1439 (*current_liboctave_error_handler)
1440 ("permuted triangular matrix not implemented");
1441 else if (typ == MatrixType::Full || typ == MatrixType::Hermitian)
1442 {
1443 double anorm = -1.0;
1444
1445 if (typ == MatrixType::Hermitian)
1446 {
1447 F77_INT info = 0;
1448 char job = 'L';
1449
1450 ComplexMatrix atmp = *this;
1451 Complex *tmp_data = atmp.rwdata ();
1452
1453 anorm = norm1 (atmp);
1454
1455 F77_XFCN (zpotrf, ZPOTRF, (F77_CONST_CHAR_ARG2 (&job, 1), nr,
1456 F77_DBLE_CMPLX_ARG (tmp_data), nr, info
1457 F77_CHAR_ARG_LEN (1)));
1458
1459 if (info != 0)
1460 {
1461 rcon = 0.0;
1462
1463 mattype.mark_as_unsymmetric ();
1464 typ = MatrixType::Full;
1465 }
1466 else
1467 {
1468 Array<Complex> z (dim_vector (2 * nc, 1));
1469 Complex *pz = z.rwdata ();
1470 Array<double> rz (dim_vector (nc, 1));
1471 double *prz = rz.rwdata ();
1472
1473 F77_XFCN (zpocon, ZPOCON, (F77_CONST_CHAR_ARG2 (&job, 1),
1474 nr, F77_DBLE_CMPLX_ARG (tmp_data), nr, anorm,
1475 rcon, F77_DBLE_CMPLX_ARG (pz), prz, info
1476 F77_CHAR_ARG_LEN (1)));
1477
1478 if (info != 0)
1479 rcon = 0.0;
1480 }
1481 }
1482
1483 if (typ == MatrixType::Full)
1484 {
1485 F77_INT info = 0;
1486
1487 ComplexMatrix atmp = *this;
1488 Complex *tmp_data = atmp.rwdata ();
1489
1490 Array<F77_INT> ipvt (dim_vector (nr, 1));
1491 F77_INT *pipvt = ipvt.rwdata ();
1492
1493 if (anorm < 0.0)
1494 anorm = norm1 (atmp);
1495
1496 Array<Complex> z (dim_vector (2 * nc, 1));
1497 Complex *pz = z.rwdata ();
1498 Array<double> rz (dim_vector (2 * nc, 1));
1499 double *prz = rz.rwdata ();
1500
1501 // Work around bug #45577, LAPACK crashes Octave if norm is NaN
1502 if (octave::math::isnan (anorm))
1503 info = -1;
1504 else
1505 F77_XFCN (zgetrf, ZGETRF, (nr, nr,
1506 F77_DBLE_CMPLX_ARG (tmp_data),
1507 nr, pipvt, info));
1508
1509 if (info != 0)
1510 {
1511 rcon = 0.0;
1512 mattype.mark_as_rectangular ();
1513 }
1514 else
1515 {
1516 char job = '1';
1517 F77_XFCN (zgecon, ZGECON, (F77_CONST_CHAR_ARG2 (&job, 1),
1518 nc, F77_DBLE_CMPLX_ARG (tmp_data), nr, anorm,
1519 rcon, F77_DBLE_CMPLX_ARG (pz), prz, info
1520 F77_CHAR_ARG_LEN (1)));
1521
1522 if (info != 0)
1523 rcon = 0.0;
1524 }
1525 }
1526 }
1527 else
1528 rcon = 0.0;
1529 }
1530
1531 return rcon;
1532}
1533
1535ComplexMatrix::utsolve (MatrixType& mattype, const ComplexMatrix& b,
1536 octave_idx_type& info, double& rcon,
1537 solve_singularity_handler sing_handler,
1538 bool calc_cond, blas_trans_type transt) const
1539{
1540 ComplexMatrix retval;
1541
1542 F77_INT nr = octave::to_f77_int (rows ());
1543 F77_INT nc = octave::to_f77_int (cols ());
1544
1545 F77_INT b_nr = octave::to_f77_int (b.rows ());
1546 F77_INT b_nc = octave::to_f77_int (b.cols ());
1547
1548 if (nr != b_nr)
1549 (*current_liboctave_error_handler)
1550 ("matrix dimension mismatch solution of linear equations");
1551
1552 if (nr == 0 || nc == 0 || b_nc == 0)
1553 retval = ComplexMatrix (nc, b_nc, Complex (0.0, 0.0));
1554 else
1555 {
1556 int typ = mattype.type ();
1557
1558 if (typ != MatrixType::Permuted_Upper && typ != MatrixType::Upper)
1559 (*current_liboctave_error_handler) ("incorrect matrix type");
1560
1561 rcon = 1.0;
1562 info = 0;
1563
1564 if (typ == MatrixType::Permuted_Upper)
1565 (*current_liboctave_error_handler)
1566 ("permuted triangular matrix not implemented");
1567
1568 const Complex *tmp_data = data ();
1569
1570 retval = b;
1571 Complex *result = retval.rwdata ();
1572
1573 char uplo = 'U';
1574 char trans = get_blas_char (transt);
1575 char dia = 'N';
1576
1577 F77_INT tmp_info = 0;
1578
1579 F77_XFCN (ztrtrs, ZTRTRS, (F77_CONST_CHAR_ARG2 (&uplo, 1),
1580 F77_CONST_CHAR_ARG2 (&trans, 1),
1581 F77_CONST_CHAR_ARG2 (&dia, 1),
1582 nr, b_nc, F77_CONST_DBLE_CMPLX_ARG (tmp_data), nr,
1583 F77_DBLE_CMPLX_ARG (result), nr, tmp_info
1584 F77_CHAR_ARG_LEN (1)
1585 F77_CHAR_ARG_LEN (1)
1586 F77_CHAR_ARG_LEN (1)));
1587
1588 info = tmp_info;
1589
1590 if (calc_cond)
1591 {
1592 char norm = '1';
1593 uplo = 'U';
1594 dia = 'N';
1595
1596 Array<Complex> z (dim_vector (2 * nc, 1));
1597 Complex *pz = z.rwdata ();
1598 Array<double> rz (dim_vector (nc, 1));
1599 double *prz = rz.rwdata ();
1600
1601 F77_XFCN (ztrcon, ZTRCON, (F77_CONST_CHAR_ARG2 (&norm, 1),
1602 F77_CONST_CHAR_ARG2 (&uplo, 1),
1603 F77_CONST_CHAR_ARG2 (&dia, 1),
1604 nr, F77_CONST_DBLE_CMPLX_ARG (tmp_data), nr, rcon,
1605 F77_DBLE_CMPLX_ARG (pz), prz, tmp_info
1606 F77_CHAR_ARG_LEN (1)
1607 F77_CHAR_ARG_LEN (1)
1608 F77_CHAR_ARG_LEN (1)));
1609
1610 info = tmp_info;
1611
1612 if (info != 0)
1613 info = -2;
1614
1615 if (is_singular (rcon) || octave::math::isnan (rcon))
1616 {
1617 info = -2;
1618
1619 if (sing_handler)
1620 sing_handler (rcon);
1621 else
1622 octave::warn_singular_matrix (rcon);
1623 }
1624 }
1625 }
1626
1627 return retval;
1628}
1629
1631ComplexMatrix::ltsolve (MatrixType& mattype, const ComplexMatrix& b,
1632 octave_idx_type& info, double& rcon,
1633 solve_singularity_handler sing_handler,
1634 bool calc_cond, blas_trans_type transt) const
1635{
1636 ComplexMatrix retval;
1637
1638 F77_INT nr = octave::to_f77_int (rows ());
1639 F77_INT nc = octave::to_f77_int (cols ());
1640
1641 F77_INT b_nr = octave::to_f77_int (b.rows ());
1642 F77_INT b_nc = octave::to_f77_int (b.cols ());
1643
1644 if (nr != b_nr)
1645 (*current_liboctave_error_handler)
1646 ("matrix dimension mismatch solution of linear equations");
1647
1648 if (nr == 0 || nc == 0 || b_nc == 0)
1649 retval = ComplexMatrix (nc, b_nc, Complex (0.0, 0.0));
1650 else
1651 {
1652 int typ = mattype.type ();
1653
1654 if (typ != MatrixType::Permuted_Lower && typ != MatrixType::Lower)
1655 (*current_liboctave_error_handler) ("incorrect matrix type");
1656
1657 rcon = 1.0;
1658 info = 0;
1659
1660 if (typ == MatrixType::Permuted_Lower)
1661 (*current_liboctave_error_handler)
1662 ("permuted triangular matrix not implemented");
1663
1664 const Complex *tmp_data = data ();
1665
1666 retval = b;
1667 Complex *result = retval.rwdata ();
1668
1669 char uplo = 'L';
1670 char trans = get_blas_char (transt);
1671 char dia = 'N';
1672
1673 F77_INT tmp_info = 0;
1674
1675 F77_XFCN (ztrtrs, ZTRTRS, (F77_CONST_CHAR_ARG2 (&uplo, 1),
1676 F77_CONST_CHAR_ARG2 (&trans, 1),
1677 F77_CONST_CHAR_ARG2 (&dia, 1),
1678 nr, b_nc, F77_CONST_DBLE_CMPLX_ARG (tmp_data), nr,
1679 F77_DBLE_CMPLX_ARG (result), nr, tmp_info
1680 F77_CHAR_ARG_LEN (1)
1681 F77_CHAR_ARG_LEN (1)
1682 F77_CHAR_ARG_LEN (1)));
1683
1684 info = tmp_info;
1685
1686 if (calc_cond)
1687 {
1688 char norm = '1';
1689 uplo = 'L';
1690 dia = 'N';
1691
1692 Array<Complex> z (dim_vector (2 * nc, 1));
1693 Complex *pz = z.rwdata ();
1694 Array<double> rz (dim_vector (nc, 1));
1695 double *prz = rz.rwdata ();
1696
1697 F77_XFCN (ztrcon, ZTRCON, (F77_CONST_CHAR_ARG2 (&norm, 1),
1698 F77_CONST_CHAR_ARG2 (&uplo, 1),
1699 F77_CONST_CHAR_ARG2 (&dia, 1),
1700 nr, F77_CONST_DBLE_CMPLX_ARG (tmp_data), nr, rcon,
1701 F77_DBLE_CMPLX_ARG (pz), prz, tmp_info
1702 F77_CHAR_ARG_LEN (1)
1703 F77_CHAR_ARG_LEN (1)
1704 F77_CHAR_ARG_LEN (1)));
1705
1706 info = tmp_info;
1707
1708 if (info != 0)
1709 info = -2;
1710
1711 if (is_singular (rcon) || octave::math::isnan (rcon))
1712 {
1713 info = -2;
1714
1715 if (sing_handler)
1716 sing_handler (rcon);
1717 else
1718 octave::warn_singular_matrix (rcon);
1719 }
1720 }
1721 }
1722
1723 return retval;
1724}
1725
1727ComplexMatrix::fsolve (MatrixType& mattype, const ComplexMatrix& b,
1728 octave_idx_type& info, double& rcon,
1729 solve_singularity_handler sing_handler,
1730 bool calc_cond) const
1731{
1732 ComplexMatrix retval;
1733
1734 F77_INT nr = octave::to_f77_int (rows ());
1735 F77_INT nc = octave::to_f77_int (cols ());
1736
1737 F77_INT b_nr = octave::to_f77_int (b.rows ());
1738 F77_INT b_nc = octave::to_f77_int (b.cols ());
1739
1740 if (nr != nc || nr != b_nr)
1741 (*current_liboctave_error_handler)
1742 ("matrix dimension mismatch solution of linear equations");
1743
1744 if (nr == 0 || b_nc == 0)
1745 retval = ComplexMatrix (nc, b_nc, Complex (0.0, 0.0));
1746 else
1747 {
1748 int typ = mattype.type ();
1749
1750 // Calculate the norm of the matrix for later use when determining rcon.
1751 double anorm = -1.0;
1752
1753 if (typ == MatrixType::Hermitian)
1754 {
1755 info = 0;
1756 char job = 'L';
1757
1758 ComplexMatrix atmp = *this;
1759 Complex *tmp_data = atmp.rwdata ();
1760
1761 // The norm of the matrix for later use when determining rcon.
1762 if (calc_cond)
1763 anorm = norm1 (atmp);
1764
1765 F77_INT tmp_info = 0;
1766
1767 F77_XFCN (zpotrf, ZPOTRF, (F77_CONST_CHAR_ARG2 (&job, 1), nr,
1768 F77_DBLE_CMPLX_ARG (tmp_data), nr, tmp_info
1769 F77_CHAR_ARG_LEN (1)));
1770
1771 info = tmp_info;
1772
1773 // Throw away extra info LAPACK gives so as to not change output.
1774 rcon = 0.0;
1775 if (info != 0)
1776 {
1777 info = -2;
1778
1779 mattype.mark_as_unsymmetric ();
1780 typ = MatrixType::Full;
1781 }
1782 else
1783 {
1784 if (calc_cond)
1785 {
1786 Array<Complex> z (dim_vector (2 * nc, 1));
1787 Complex *pz = z.rwdata ();
1788 Array<double> rz (dim_vector (nc, 1));
1789 double *prz = rz.rwdata ();
1790
1791 F77_XFCN (zpocon, ZPOCON, (F77_CONST_CHAR_ARG2 (&job, 1),
1792 nr, F77_DBLE_CMPLX_ARG (tmp_data), nr, anorm,
1793 rcon, F77_DBLE_CMPLX_ARG (pz), prz, tmp_info
1794 F77_CHAR_ARG_LEN (1)));
1795
1796 info = tmp_info;
1797
1798 if (info != 0)
1799 info = -2;
1800
1801 if (is_singular (rcon) || octave::math::isnan (rcon))
1802 {
1803 info = -2;
1804
1805 if (sing_handler)
1806 sing_handler (rcon);
1807 else
1808 octave::warn_singular_matrix (rcon);
1809 }
1810 }
1811
1812 if (info == 0)
1813 {
1814 retval = b;
1815 Complex *result = retval.rwdata ();
1816
1817 F77_XFCN (zpotrs, ZPOTRS, (F77_CONST_CHAR_ARG2 (&job, 1),
1818 nr, b_nc, F77_DBLE_CMPLX_ARG (tmp_data), nr,
1819 F77_DBLE_CMPLX_ARG (result), b_nr, tmp_info
1820 F77_CHAR_ARG_LEN (1)));
1821
1822 info = tmp_info;
1823 }
1824 else
1825 {
1826 mattype.mark_as_unsymmetric ();
1827 typ = MatrixType::Full;
1828 }
1829 }
1830 }
1831
1832 if (typ == MatrixType::Full)
1833 {
1834 info = 0;
1835
1836 Array<F77_INT> ipvt (dim_vector (nr, 1));
1837 F77_INT *pipvt = ipvt.rwdata ();
1838
1839 ComplexMatrix atmp = *this;
1840 Complex *tmp_data = atmp.rwdata ();
1841
1842 Array<Complex> z (dim_vector (2 * nc, 1));
1843 Complex *pz = z.rwdata ();
1844 Array<double> rz (dim_vector (2 * nc, 1));
1845 double *prz = rz.rwdata ();
1846
1847 // Calculate the norm of the matrix, for later use.
1848 if (calc_cond && anorm < 0.0)
1849 anorm = norm1 (atmp);
1850
1851 F77_INT tmp_info = 0;
1852
1853 // Work around bug #45577, LAPACK crashes Octave if norm is NaN
1854 // and bug #46330, segfault with matrices containing Inf & NaN
1855 if (octave::math::isnan (anorm) || octave::math::isinf (anorm))
1856 info = -2;
1857 else
1858 {
1859 F77_XFCN (zgetrf, ZGETRF, (nr, nr, F77_DBLE_CMPLX_ARG (tmp_data),
1860 nr, pipvt, tmp_info));
1861
1862 info = tmp_info;
1863 }
1864
1865 // Throw away extra info LAPACK gives so as to not change output.
1866 rcon = 0.0;
1867 if (info != 0)
1868 {
1869 info = -2;
1870
1871 if (sing_handler)
1872 sing_handler (rcon);
1873 else
1874 octave::warn_singular_matrix ();
1875
1876 mattype.mark_as_rectangular ();
1877 }
1878 else
1879 {
1880 if (calc_cond)
1881 {
1882 // Calculate the condition number for non-singular matrix.
1883 char job = '1';
1884 F77_XFCN (zgecon, ZGECON, (F77_CONST_CHAR_ARG2 (&job, 1),
1885 nc, F77_DBLE_CMPLX_ARG (tmp_data), nr, anorm,
1886 rcon, F77_DBLE_CMPLX_ARG (pz), prz, tmp_info
1887 F77_CHAR_ARG_LEN (1)));
1888
1889 info = tmp_info;
1890
1891 if (info != 0)
1892 info = -2;
1893
1894 if (is_singular (rcon) || octave::math::isnan (rcon))
1895 {
1896 if (sing_handler)
1897 sing_handler (rcon);
1898 else
1899 octave::warn_singular_matrix (rcon);
1900 }
1901 }
1902
1903 if (info == 0)
1904 {
1905 retval = b;
1906 Complex *result = retval.rwdata ();
1907
1908 char job = 'N';
1909 F77_XFCN (zgetrs, ZGETRS, (F77_CONST_CHAR_ARG2 (&job, 1),
1910 nr, b_nc, F77_DBLE_CMPLX_ARG (tmp_data), nr,
1911 pipvt, F77_DBLE_CMPLX_ARG (result), b_nr, tmp_info
1912 F77_CHAR_ARG_LEN (1)));
1913
1914 info = tmp_info;
1915 }
1916 else
1917 mattype.mark_as_rectangular ();
1918 }
1919 }
1920
1921 if (octave::math::isinf (anorm))
1922 {
1923 retval = ComplexMatrix (b_nr, b_nc, Complex (0, 0));
1924 mattype.mark_as_full ();
1925 }
1926 }
1927
1928 return retval;
1929}
1930
1932ComplexMatrix::solve (MatrixType& mattype, const Matrix& b) const
1933{
1934 octave_idx_type info;
1935 double rcon;
1936 return solve (mattype, b, info, rcon, nullptr);
1937}
1938
1941 octave_idx_type& info) const
1942{
1943 double rcon;
1944 return solve (mattype, b, info, rcon, nullptr);
1945}
1946
1949 octave_idx_type& info, double& rcon) const
1950{
1951 return solve (mattype, b, info, rcon, nullptr);
1952}
1953
1956 octave_idx_type& info, double& rcon,
1957 solve_singularity_handler sing_handler,
1958 bool singular_fallback, blas_trans_type transt) const
1959{
1960 ComplexMatrix tmp (b);
1961 return solve (mattype, tmp, info, rcon, sing_handler, singular_fallback,
1962 transt);
1963}
1964
1967{
1968 octave_idx_type info;
1969 double rcon;
1970 return solve (mattype, b, info, rcon, nullptr);
1971}
1972
1975 octave_idx_type& info) const
1976{
1977 double rcon;
1978 return solve (mattype, b, info, rcon, nullptr);
1979}
1980
1983 octave_idx_type& info, double& rcon) const
1984{
1985 return solve (mattype, b, info, rcon, nullptr);
1986}
1987
1990 octave_idx_type& info, double& rcon,
1991 solve_singularity_handler sing_handler,
1992 bool singular_fallback, blas_trans_type transt) const
1993{
1994 ComplexMatrix retval;
1995 int typ = mattype.type ();
1996
1997 if (typ == MatrixType::Unknown)
1998 typ = mattype.type (*this);
1999
2000 // Only calculate the condition number for LU/Cholesky
2001 if (typ == MatrixType::Upper || typ == MatrixType::Permuted_Upper)
2002 retval = utsolve (mattype, b, info, rcon, sing_handler, true, transt);
2003 else if (typ == MatrixType::Lower || typ == MatrixType::Permuted_Lower)
2004 retval = ltsolve (mattype, b, info, rcon, sing_handler, true, transt);
2005 else if (transt == blas_trans)
2006 return transpose ().solve (mattype, b, info, rcon, sing_handler,
2007 singular_fallback);
2008 else if (transt == blas_conj_trans)
2009 retval = hermitian ().solve (mattype, b, info, rcon, sing_handler,
2010 singular_fallback);
2011 else if (typ == MatrixType::Full || typ == MatrixType::Hermitian)
2012 retval = fsolve (mattype, b, info, rcon, sing_handler, true);
2013 else if (typ != MatrixType::Rectangular)
2014 (*current_liboctave_error_handler) ("unknown matrix type");
2015
2016 // Rectangular or one of the above solvers flags a singular matrix
2017 if (singular_fallback && mattype.type () == MatrixType::Rectangular)
2018 {
2019 octave_idx_type rank;
2020 retval = lssolve (b, info, rank, rcon);
2021 }
2022
2023 return retval;
2024}
2025
2028{
2029 octave_idx_type info;
2030 double rcon;
2031 return solve (mattype, ComplexColumnVector (b), info, rcon, nullptr);
2032}
2033
2036 octave_idx_type& info) const
2037{
2038 double rcon;
2039 return solve (mattype, ComplexColumnVector (b), info, rcon, nullptr);
2040}
2041
2044 octave_idx_type& info, double& rcon) const
2045{
2046 return solve (mattype, ComplexColumnVector (b), info, rcon, nullptr);
2047}
2048
2051 octave_idx_type& info, double& rcon,
2052 solve_singularity_handler sing_handler,
2053 blas_trans_type transt) const
2054{
2055 return solve (mattype, ComplexColumnVector (b), info, rcon, sing_handler,
2056 transt);
2057}
2058
2061{
2062 octave_idx_type info;
2063 double rcon;
2064 return solve (mattype, b, info, rcon, nullptr);
2065}
2066
2069 octave_idx_type& info) const
2070{
2071 double rcon;
2072 return solve (mattype, b, info, rcon, nullptr);
2073}
2074
2077 octave_idx_type& info, double& rcon) const
2078{
2079 return solve (mattype, b, info, rcon, nullptr);
2080}
2081
2084 octave_idx_type& info, double& rcon,
2085 solve_singularity_handler sing_handler,
2086 blas_trans_type transt) const
2087{
2088
2089 ComplexMatrix tmp (b);
2090 tmp = solve (mattype, tmp, info, rcon, sing_handler, true, transt);
2091 return tmp.column (static_cast<octave_idx_type> (0));
2092}
2093
2096{
2097 octave_idx_type info;
2098 double rcon;
2099 return solve (b, info, rcon, nullptr);
2100}
2101
2104{
2105 double rcon;
2106 return solve (b, info, rcon, nullptr);
2107}
2108
2111 double& rcon) const
2112{
2113 return solve (b, info, rcon, nullptr);
2114}
2115
2117ComplexMatrix::solve (const Matrix& b, octave_idx_type& info, double& rcon,
2118 solve_singularity_handler sing_handler,
2119 blas_trans_type transt) const
2120{
2121 ComplexMatrix tmp (b);
2122 return solve (tmp, info, rcon, sing_handler, transt);
2123}
2124
2127{
2128 octave_idx_type info;
2129 double rcon;
2130 return solve (b, info, rcon, nullptr);
2131}
2132
2135{
2136 double rcon;
2137 return solve (b, info, rcon, nullptr);
2138}
2139
2142 double& rcon) const
2143{
2144 return solve (b, info, rcon, nullptr);
2145}
2146
2149 double& rcon,
2150 solve_singularity_handler sing_handler,
2151 blas_trans_type transt) const
2152{
2153 MatrixType mattype (*this);
2154 return solve (mattype, b, info, rcon, sing_handler, true, transt);
2155}
2156
2159{
2160 octave_idx_type info;
2161 double rcon;
2162 return solve (ComplexColumnVector (b), info, rcon, nullptr);
2163}
2164
2167{
2168 double rcon;
2169 return solve (ComplexColumnVector (b), info, rcon, nullptr);
2170}
2171
2174 double& rcon) const
2175{
2176 return solve (ComplexColumnVector (b), info, rcon, nullptr);
2177}
2178
2181 double& rcon,
2182 solve_singularity_handler sing_handler,
2183 blas_trans_type transt) const
2184{
2185 return solve (ComplexColumnVector (b), info, rcon, sing_handler, transt);
2186}
2187
2190{
2191 octave_idx_type info;
2192 double rcon;
2193 return solve (b, info, rcon, nullptr);
2194}
2195
2198{
2199 double rcon;
2200 return solve (b, info, rcon, nullptr);
2201}
2202
2205 double& rcon) const
2206{
2207 return solve (b, info, rcon, nullptr);
2208}
2209
2212 double& rcon,
2213 solve_singularity_handler sing_handler,
2214 blas_trans_type transt) const
2215{
2216 MatrixType mattype (*this);
2217 return solve (mattype, b, info, rcon, sing_handler, transt);
2218}
2219
2222{
2223 octave_idx_type info;
2224 octave_idx_type rank;
2225 double rcon;
2226 return lssolve (ComplexMatrix (b), info, rank, rcon);
2227}
2228
2231{
2232 octave_idx_type rank;
2233 double rcon;
2234 return lssolve (ComplexMatrix (b), info, rank, rcon);
2235}
2236
2239 octave_idx_type& rank) const
2240{
2241 double rcon;
2242 return lssolve (ComplexMatrix (b), info, rank, rcon);
2243}
2244
2247 octave_idx_type& rank, double& rcon) const
2248{
2249 return lssolve (ComplexMatrix (b), info, rank, rcon);
2250}
2251
2254{
2255 octave_idx_type info;
2256 octave_idx_type rank;
2257 double rcon;
2258 return lssolve (b, info, rank, rcon);
2259}
2260
2263{
2264 octave_idx_type rank;
2265 double rcon;
2266 return lssolve (b, info, rank, rcon);
2267}
2268
2271 octave_idx_type& rank) const
2272{
2273 double rcon;
2274 return lssolve (b, info, rank, rcon);
2275}
2276
2279 octave_idx_type& rank, double& rcon) const
2280{
2281 ComplexMatrix retval;
2282
2283 F77_INT m = octave::to_f77_int (rows ());
2284 F77_INT n = octave::to_f77_int (cols ());
2285
2286 F77_INT b_nr = octave::to_f77_int (b.rows ());
2287 F77_INT b_nc = octave::to_f77_int (b.cols ());
2288 F77_INT nrhs = b_nc; // alias for code readability
2289
2290 if (m != b_nr)
2291 (*current_liboctave_error_handler)
2292 ("matrix dimension mismatch solution of linear equations");
2293
2294 if (m == 0 || n == 0 || b_nc == 0)
2295 retval = ComplexMatrix (n, b_nc, Complex (0.0, 0.0));
2296 else
2297 {
2298 F77_INT minmn = (m < n ? m : n);
2299 F77_INT maxmn = (m > n ? m : n);
2300 rcon = -1.0;
2301
2302 if (m != n)
2303 {
2304 retval = ComplexMatrix (maxmn, nrhs);
2305
2306 for (F77_INT j = 0; j < nrhs; j++)
2307 for (F77_INT i = 0; i < m; i++)
2308 retval.elem (i, j) = b.elem (i, j);
2309 }
2310 else
2311 retval = b;
2312
2313 ComplexMatrix atmp = *this;
2314 Complex *tmp_data = atmp.rwdata ();
2315
2316 Complex *pretval = retval.rwdata ();
2317 Array<double> s (dim_vector (minmn, 1));
2318 double *ps = s.rwdata ();
2319
2320 // Ask ZGELSD what the dimension of WORK should be.
2321 F77_INT lwork = -1;
2322
2323 Array<Complex> work (dim_vector (1, 1));
2324
2325 F77_INT smlsiz;
2326 F77_FUNC (xilaenv, XILAENV) (9, F77_CONST_CHAR_ARG2 ("ZGELSD", 6),
2327 F77_CONST_CHAR_ARG2 (" ", 1),
2328 0, 0, 0, 0, smlsiz
2329 F77_CHAR_ARG_LEN (6)
2330 F77_CHAR_ARG_LEN (1));
2331
2332 F77_INT mnthr;
2333 F77_FUNC (xilaenv, XILAENV) (6, F77_CONST_CHAR_ARG2 ("ZGELSD", 6),
2334 F77_CONST_CHAR_ARG2 (" ", 1),
2335 m, n, nrhs, -1, mnthr
2336 F77_CHAR_ARG_LEN (6)
2337 F77_CHAR_ARG_LEN (1));
2338
2339 // We compute the size of rwork and iwork because ZGELSD in
2340 // older versions of LAPACK does not return them on a query
2341 // call.
2342 double dminmn = static_cast<double> (minmn);
2343 double dsmlsizp1 = static_cast<double> (smlsiz+1);
2344 double tmp = octave::math::log2 (dminmn / dsmlsizp1);
2345
2346 F77_INT nlvl = static_cast<F77_INT> (tmp) + 1;
2347 if (nlvl < 0)
2348 nlvl = 0;
2349
2350 F77_INT lrwork = minmn*(10 + 2*smlsiz + 8*nlvl)
2351 + 3*smlsiz*nrhs
2352 + std::max ((smlsiz+1)*(smlsiz+1),
2353 n*(1+nrhs) + 2*nrhs);
2354 if (lrwork < 1)
2355 lrwork = 1;
2356 Array<double> rwork (dim_vector (lrwork, 1));
2357 double *prwork = rwork.rwdata ();
2358
2359 F77_INT liwork = 3 * minmn * nlvl + 11 * minmn;
2360 if (liwork < 1)
2361 liwork = 1;
2362 Array<F77_INT> iwork (dim_vector (liwork, 1));
2363 F77_INT *piwork = iwork.rwdata ();
2364
2365 F77_INT tmp_info = 0;
2366 F77_INT tmp_rank = 0;
2367
2368 F77_XFCN (zgelsd, ZGELSD, (m, n, nrhs, F77_DBLE_CMPLX_ARG (tmp_data), m,
2369 F77_DBLE_CMPLX_ARG (pretval), maxmn,
2370 ps, rcon, tmp_rank, F77_DBLE_CMPLX_ARG (work.rwdata ()),
2371 lwork, prwork, piwork, tmp_info));
2372
2373 info = tmp_info;
2374 rank = tmp_rank;
2375
2376 // The workspace query is broken in at least LAPACK 3.0.0
2377 // through 3.1.1 when n >= mnthr. The obtuse formula below
2378 // should provide sufficient workspace for ZGELSD to operate
2379 // efficiently.
2380 if (n > m && n >= mnthr)
2381 {
2382 F77_INT addend = m;
2383
2384 if (2*m-4 > addend)
2385 addend = 2*m-4;
2386
2387 if (nrhs > addend)
2388 addend = nrhs;
2389
2390 if (n-3*m > addend)
2391 addend = n-3*m;
2392
2393 const F77_INT lworkaround = 4*m + m*m + addend;
2394
2395 if (std::real (work(0)) < lworkaround)
2396 work(0) = lworkaround;
2397 }
2398 else if (m >= n)
2399 {
2400 F77_INT lworkaround = 2*m + m*nrhs;
2401
2402 if (std::real (work(0)) < lworkaround)
2403 work(0) = lworkaround;
2404 }
2405
2406 lwork = static_cast<F77_INT> (std::real (work(0)));
2407 work.resize (dim_vector (lwork, 1));
2408
2409 double anorm = norm1 (*this);
2410
2411 if (octave::math::isinf (anorm))
2412 {
2413 rcon = 0.0;
2414 retval = ComplexMatrix (n, b_nc, 0.0);
2415 }
2416 else if (octave::math::isnan (anorm))
2417 {
2418 rcon = octave::numeric_limits<double>::NaN ();
2419 retval = ComplexMatrix (n, b_nc,
2420 octave::numeric_limits<double>::NaN ());
2421 }
2422 else
2423 {
2424 F77_XFCN (zgelsd, ZGELSD, (m, n, nrhs, F77_DBLE_CMPLX_ARG (tmp_data),
2425 m, F77_DBLE_CMPLX_ARG (pretval),
2426 maxmn, ps, rcon, tmp_rank,
2427 F77_DBLE_CMPLX_ARG (work.rwdata ()),
2428 lwork, prwork, piwork, tmp_info));
2429
2430 info = tmp_info;
2431 rank = tmp_rank;
2432
2433 if (s.elem (0) == 0.0)
2434 rcon = 0.0;
2435 else
2436 rcon = s.elem (minmn - 1) / s.elem (0);
2437
2438 retval.resize (n, nrhs);
2439 }
2440 }
2441
2442 return retval;
2443}
2444
2447{
2448 octave_idx_type info;
2449 octave_idx_type rank;
2450 double rcon;
2451 return lssolve (ComplexColumnVector (b), info, rank, rcon);
2452}
2453
2456{
2457 octave_idx_type rank;
2458 double rcon;
2459 return lssolve (ComplexColumnVector (b), info, rank, rcon);
2460}
2461
2464 octave_idx_type& rank) const
2465{
2466 double rcon;
2467 return lssolve (ComplexColumnVector (b), info, rank, rcon);
2468}
2469
2472 octave_idx_type& rank, double& rcon) const
2473{
2474 return lssolve (ComplexColumnVector (b), info, rank, rcon);
2475}
2476
2479{
2480 octave_idx_type info;
2481 octave_idx_type rank;
2482 double rcon;
2483 return lssolve (b, info, rank, rcon);
2484}
2485
2488 octave_idx_type& info) const
2489{
2490 octave_idx_type rank;
2491 double rcon;
2492 return lssolve (b, info, rank, rcon);
2493}
2494
2497 octave_idx_type& rank) const
2498{
2499 double rcon;
2500 return lssolve (b, info, rank, rcon);
2501
2502}
2503
2506 octave_idx_type& rank, double& rcon) const
2507{
2508 ComplexColumnVector retval;
2509
2510 F77_INT nrhs = 1;
2511
2512 F77_INT m = octave::to_f77_int (rows ());
2513 F77_INT n = octave::to_f77_int (cols ());
2514
2515 F77_INT b_nel = octave::to_f77_int (b.numel ());
2516
2517 if (m != b_nel)
2518 (*current_liboctave_error_handler)
2519 ("matrix dimension mismatch solution of linear equations");
2520
2521 if (m == 0 || n == 0)
2522 retval = ComplexColumnVector (n, Complex (0.0, 0.0));
2523 else
2524 {
2525 F77_INT minmn = (m < n ? m : n);
2526 F77_INT maxmn = (m > n ? m : n);
2527 rcon = -1.0;
2528
2529 if (m != n)
2530 {
2531 retval = ComplexColumnVector (maxmn);
2532
2533 for (F77_INT i = 0; i < m; i++)
2534 retval.elem (i) = b.elem (i);
2535 }
2536 else
2537 retval = b;
2538
2539 ComplexMatrix atmp = *this;
2540 Complex *tmp_data = atmp.rwdata ();
2541
2542 Complex *pretval = retval.rwdata ();
2543 Array<double> s (dim_vector (minmn, 1));
2544 double *ps = s.rwdata ();
2545
2546 // Ask ZGELSD what the dimension of WORK should be.
2547 F77_INT lwork = -1;
2548
2549 Array<Complex> work (dim_vector (1, 1));
2550
2551 F77_INT smlsiz;
2552 F77_FUNC (xilaenv, XILAENV) (9, F77_CONST_CHAR_ARG2 ("ZGELSD", 6),
2553 F77_CONST_CHAR_ARG2 (" ", 1),
2554 0, 0, 0, 0, smlsiz
2555 F77_CHAR_ARG_LEN (6)
2556 F77_CHAR_ARG_LEN (1));
2557
2558 // We compute the size of rwork and iwork because ZGELSD in
2559 // older versions of LAPACK does not return them on a query
2560 // call.
2561 double dminmn = static_cast<double> (minmn);
2562 double dsmlsizp1 = static_cast<double> (smlsiz+1);
2563 double tmp = octave::math::log2 (dminmn / dsmlsizp1);
2564
2565 F77_INT nlvl = static_cast<F77_INT> (tmp) + 1;
2566 if (nlvl < 0)
2567 nlvl = 0;
2568
2569 F77_INT lrwork = minmn*(10 + 2*smlsiz + 8*nlvl)
2570 + 3*smlsiz*nrhs + (smlsiz+1)*(smlsiz+1);
2571 if (lrwork < 1)
2572 lrwork = 1;
2573 Array<double> rwork (dim_vector (lrwork, 1));
2574 double *prwork = rwork.rwdata ();
2575
2576 F77_INT liwork = 3 * minmn * nlvl + 11 * minmn;
2577 if (liwork < 1)
2578 liwork = 1;
2579 Array<F77_INT> iwork (dim_vector (liwork, 1));
2580 F77_INT *piwork = iwork.rwdata ();
2581
2582 F77_INT tmp_info = 0;
2583 F77_INT tmp_rank = 0;
2584
2585 F77_XFCN (zgelsd, ZGELSD, (m, n, nrhs, F77_DBLE_CMPLX_ARG (tmp_data), m,
2586 F77_DBLE_CMPLX_ARG (pretval), maxmn,
2587 ps, rcon, tmp_rank, F77_DBLE_CMPLX_ARG (work.rwdata ()),
2588 lwork, prwork, piwork, tmp_info));
2589
2590 info = tmp_info;
2591 rank = tmp_rank;
2592
2593 lwork = static_cast<F77_INT> (std::real (work(0)));
2594 work.resize (dim_vector (lwork, 1));
2595 rwork.resize (dim_vector (static_cast<F77_INT> (rwork(0)), 1));
2596 iwork.resize (dim_vector (iwork(0), 1));
2597
2598 F77_XFCN (zgelsd, ZGELSD, (m, n, nrhs, F77_DBLE_CMPLX_ARG (tmp_data), m,
2599 F77_DBLE_CMPLX_ARG (pretval),
2600 maxmn, ps, rcon, tmp_rank,
2601 F77_DBLE_CMPLX_ARG (work.rwdata ()), lwork,
2602 prwork, piwork, tmp_info));
2603
2604 info = tmp_info;
2605 rank = tmp_rank;
2606
2607 if (rank < minmn)
2608 {
2609 if (s.elem (0) == 0.0)
2610 rcon = 0.0;
2611 else
2612 rcon = s.elem (minmn - 1) / s.elem (0);
2613
2614 retval.resize (n);
2615 }
2616 }
2617
2618 return retval;
2619}
2620
2621// column vector by row vector -> matrix operations
2622
2625{
2626 ComplexColumnVector tmp (v);
2627 return tmp * a;
2628}
2629
2632{
2633 ComplexRowVector tmp (b);
2634 return a * tmp;
2635}
2636
2639{
2640 ComplexMatrix retval;
2641
2642 F77_INT len = octave::to_f77_int (v.numel ());
2643
2644 if (len != 0)
2645 {
2646 F77_INT a_len = octave::to_f77_int (a.numel ());
2647
2648 retval = ComplexMatrix (len, a_len);
2649 Complex *c = retval.rwdata ();
2650
2651 F77_XFCN (zgemm, ZGEMM, (F77_CONST_CHAR_ARG2 ("N", 1),
2652 F77_CONST_CHAR_ARG2 ("N", 1),
2653 len, a_len, 1, 1.0, F77_CONST_DBLE_CMPLX_ARG (v.data ()), len,
2655 F77_CHAR_ARG_LEN (1)
2656 F77_CHAR_ARG_LEN (1)));
2657 }
2658
2659 return retval;
2660}
2661
2662// matrix by diagonal matrix -> matrix operations
2663
2666{
2667 octave_idx_type nr = rows ();
2668 octave_idx_type nc = cols ();
2669
2670 octave_idx_type a_nr = a.rows ();
2671 octave_idx_type a_nc = a.cols ();
2672
2673 if (nr != a_nr || nc != a_nc)
2674 octave::err_nonconformant ("operator +=", nr, nc, a_nr, a_nc);
2675
2676 for (octave_idx_type i = 0; i < a.length (); i++)
2677 elem (i, i) += a.elem (i, i);
2678
2679 return *this;
2680}
2681
2684{
2685 octave_idx_type nr = rows ();
2686 octave_idx_type nc = cols ();
2687
2688 octave_idx_type a_nr = a.rows ();
2689 octave_idx_type a_nc = a.cols ();
2690
2691 if (nr != a_nr || nc != a_nc)
2692 octave::err_nonconformant ("operator -=", nr, nc, a_nr, a_nc);
2693
2694 for (octave_idx_type i = 0; i < a.length (); i++)
2695 elem (i, i) -= a.elem (i, i);
2696
2697 return *this;
2698}
2699
2702{
2703 octave_idx_type nr = rows ();
2704 octave_idx_type nc = cols ();
2705
2706 octave_idx_type a_nr = a.rows ();
2707 octave_idx_type a_nc = a.cols ();
2708
2709 if (nr != a_nr || nc != a_nc)
2710 octave::err_nonconformant ("operator +=", nr, nc, a_nr, a_nc);
2711
2712 for (octave_idx_type i = 0; i < a.length (); i++)
2713 elem (i, i) += a.elem (i, i);
2714
2715 return *this;
2716}
2717
2720{
2721 octave_idx_type nr = rows ();
2722 octave_idx_type nc = cols ();
2723
2724 octave_idx_type a_nr = a.rows ();
2725 octave_idx_type a_nc = a.cols ();
2726
2727 if (nr != a_nr || nc != a_nc)
2728 octave::err_nonconformant ("operator -=", nr, nc, a_nr, a_nc);
2729
2730 for (octave_idx_type i = 0; i < a.length (); i++)
2731 elem (i, i) -= a.elem (i, i);
2732
2733 return *this;
2734}
2735
2736// matrix by matrix -> matrix operations
2737
2740{
2741 octave_idx_type nr = rows ();
2742 octave_idx_type nc = cols ();
2743
2744 octave_idx_type a_nr = a.rows ();
2745 octave_idx_type a_nc = a.cols ();
2746
2747 if (nr != a_nr || nc != a_nc)
2748 octave::err_nonconformant ("operator +=", nr, nc, a_nr, a_nc);
2749
2750 if (nr == 0 || nc == 0)
2751 return *this;
2752
2753 Complex *d = rwdata (); // Ensures only one reference to my privates!
2754
2755 mx_inline_add2 (numel (), d, a.data ());
2756 return *this;
2757}
2758
2761{
2762 octave_idx_type nr = rows ();
2763 octave_idx_type nc = cols ();
2764
2765 octave_idx_type a_nr = a.rows ();
2766 octave_idx_type a_nc = a.cols ();
2767
2768 if (nr != a_nr || nc != a_nc)
2769 octave::err_nonconformant ("operator -=", nr, nc, a_nr, a_nc);
2770
2771 if (nr == 0 || nc == 0)
2772 return *this;
2773
2774 Complex *d = rwdata (); // Ensures only one reference to my privates!
2775
2776 mx_inline_sub2 (numel (), d, a.data ());
2777 return *this;
2778}
2779
2780// other operations
2781
2783ComplexMatrix::all (int dim) const
2784{
2785 return ComplexNDArray::all (dim);
2786}
2787
2789ComplexMatrix::any (int dim) const
2790{
2791 return ComplexNDArray::any (dim);
2792}
2793
2796{
2797 return ComplexNDArray::cumprod (dim);
2798}
2799
2802{
2803 return ComplexNDArray::cumsum (dim);
2804}
2805
2807ComplexMatrix::prod (int dim) const
2808{
2809 return ComplexNDArray::prod (dim);
2810}
2811
2813ComplexMatrix::sum (int dim) const
2814{
2815 return ComplexNDArray::sum (dim);
2816}
2817
2820{
2821 return ComplexNDArray::sumsq (dim);
2822}
2823
2824Matrix
2826{
2827 return ComplexNDArray::abs ();
2828}
2829
2832{
2833 return ComplexNDArray::diag (k);
2834}
2835
2838{
2839 octave_idx_type nr = rows ();
2840 octave_idx_type nc = cols ();
2841
2842 if (nr != 1 && nc != 1)
2843 (*current_liboctave_error_handler) ("diag: expecting vector argument");
2844
2845 return ComplexDiagMatrix (*this, m, n);
2846}
2847
2848bool
2850{
2851 bool retval = true;
2852
2853 octave_idx_type nc = columns ();
2854
2855 for (octave_idx_type j = 0; j < nc; j++)
2856 {
2857 if (std::imag (elem (i, j)) != 0.0)
2858 {
2859 retval = false;
2860 break;
2861 }
2862 }
2863
2864 return retval;
2865}
2866
2867bool
2869{
2870 bool retval = true;
2871
2872 octave_idx_type nr = rows ();
2873
2874 for (octave_idx_type i = 0; i < nr; i++)
2875 {
2876 if (std::imag (elem (i, j)) != 0.0)
2877 {
2878 retval = false;
2879 break;
2880 }
2881 }
2882
2883 return retval;
2884}
2885
2888{
2889 Array<octave_idx_type> dummy_idx;
2890 return row_min (dummy_idx);
2891}
2892
2895{
2896 ComplexColumnVector result;
2897
2898 octave_idx_type nr = rows ();
2899 octave_idx_type nc = cols ();
2900
2901 if (nr > 0 && nc > 0)
2902 {
2903 result.resize (nr);
2904 idx_arg.resize (dim_vector (nr, 1));
2905
2906 for (octave_idx_type i = 0; i < nr; i++)
2907 {
2908 bool real_only = row_is_real_only (i);
2909
2910 octave_idx_type idx_j;
2911
2912 Complex tmp_min;
2913
2914 double abs_min = octave::numeric_limits<double>::NaN ();
2915
2916 for (idx_j = 0; idx_j < nc; idx_j++)
2917 {
2918 tmp_min = elem (i, idx_j);
2919
2920 if (! octave::math::isnan (tmp_min))
2921 {
2922 abs_min = (real_only ? tmp_min.real ()
2923 : std::abs (tmp_min));
2924 break;
2925 }
2926 }
2927
2928 for (octave_idx_type j = idx_j+1; j < nc; j++)
2929 {
2930 Complex tmp = elem (i, j);
2931
2932 if (octave::math::isnan (tmp))
2933 continue;
2934
2935 double abs_tmp = (real_only ? tmp.real () : std::abs (tmp));
2936
2937 if (abs_tmp < abs_min)
2938 {
2939 idx_j = j;
2940 tmp_min = tmp;
2941 abs_min = abs_tmp;
2942 }
2943 }
2944
2945 if (octave::math::isnan (tmp_min))
2946 {
2947 result.elem (i) = Complex_NaN_result;
2948 idx_arg.elem (i) = 0;
2949 }
2950 else
2951 {
2952 result.elem (i) = tmp_min;
2953 idx_arg.elem (i) = idx_j;
2954 }
2955 }
2956 }
2957
2958 return result;
2959}
2960
2963{
2964 Array<octave_idx_type> dummy_idx;
2965 return row_max (dummy_idx);
2966}
2967
2970{
2971 ComplexColumnVector result;
2972
2973 octave_idx_type nr = rows ();
2974 octave_idx_type nc = cols ();
2975
2976 if (nr > 0 && nc > 0)
2977 {
2978 result.resize (nr);
2979 idx_arg.resize (dim_vector (nr, 1));
2980
2981 for (octave_idx_type i = 0; i < nr; i++)
2982 {
2983 bool real_only = row_is_real_only (i);
2984
2985 octave_idx_type idx_j;
2986
2987 Complex tmp_max;
2988
2989 double abs_max = octave::numeric_limits<double>::NaN ();
2990
2991 for (idx_j = 0; idx_j < nc; idx_j++)
2992 {
2993 tmp_max = elem (i, idx_j);
2994
2995 if (! octave::math::isnan (tmp_max))
2996 {
2997 abs_max = (real_only ? tmp_max.real ()
2998 : std::abs (tmp_max));
2999 break;
3000 }
3001 }
3002
3003 for (octave_idx_type j = idx_j+1; j < nc; j++)
3004 {
3005 Complex tmp = elem (i, j);
3006
3007 if (octave::math::isnan (tmp))
3008 continue;
3009
3010 double abs_tmp = (real_only ? tmp.real () : std::abs (tmp));
3011
3012 if (abs_tmp > abs_max)
3013 {
3014 idx_j = j;
3015 tmp_max = tmp;
3016 abs_max = abs_tmp;
3017 }
3018 }
3019
3020 if (octave::math::isnan (tmp_max))
3021 {
3022 result.elem (i) = Complex_NaN_result;
3023 idx_arg.elem (i) = 0;
3024 }
3025 else
3026 {
3027 result.elem (i) = tmp_max;
3028 idx_arg.elem (i) = idx_j;
3029 }
3030 }
3031 }
3032
3033 return result;
3034}
3035
3038{
3039 Array<octave_idx_type> dummy_idx;
3040 return column_min (dummy_idx);
3041}
3042
3045{
3046 ComplexRowVector result;
3047
3048 octave_idx_type nr = rows ();
3049 octave_idx_type nc = cols ();
3050
3051 if (nr > 0 && nc > 0)
3052 {
3053 result.resize (nc);
3054 idx_arg.resize (dim_vector (1, nc));
3055
3056 for (octave_idx_type j = 0; j < nc; j++)
3057 {
3058 bool real_only = column_is_real_only (j);
3059
3060 octave_idx_type idx_i;
3061
3062 Complex tmp_min;
3063
3064 double abs_min = octave::numeric_limits<double>::NaN ();
3065
3066 for (idx_i = 0; idx_i < nr; idx_i++)
3067 {
3068 tmp_min = elem (idx_i, j);
3069
3070 if (! octave::math::isnan (tmp_min))
3071 {
3072 abs_min = (real_only ? tmp_min.real ()
3073 : std::abs (tmp_min));
3074 break;
3075 }
3076 }
3077
3078 for (octave_idx_type i = idx_i+1; i < nr; i++)
3079 {
3080 Complex tmp = elem (i, j);
3081
3082 if (octave::math::isnan (tmp))
3083 continue;
3084
3085 double abs_tmp = (real_only ? tmp.real () : std::abs (tmp));
3086
3087 if (abs_tmp < abs_min)
3088 {
3089 idx_i = i;
3090 tmp_min = tmp;
3091 abs_min = abs_tmp;
3092 }
3093 }
3094
3095 if (octave::math::isnan (tmp_min))
3096 {
3097 result.elem (j) = Complex_NaN_result;
3098 idx_arg.elem (j) = 0;
3099 }
3100 else
3101 {
3102 result.elem (j) = tmp_min;
3103 idx_arg.elem (j) = idx_i;
3104 }
3105 }
3106 }
3107
3108 return result;
3109}
3110
3113{
3114 Array<octave_idx_type> dummy_idx;
3115 return column_max (dummy_idx);
3116}
3117
3120{
3121 ComplexRowVector result;
3122
3123 octave_idx_type nr = rows ();
3124 octave_idx_type nc = cols ();
3125
3126 if (nr > 0 && nc > 0)
3127 {
3128 result.resize (nc);
3129 idx_arg.resize (dim_vector (1, nc));
3130
3131 for (octave_idx_type j = 0; j < nc; j++)
3132 {
3133 bool real_only = column_is_real_only (j);
3134
3135 octave_idx_type idx_i;
3136
3137 Complex tmp_max;
3138
3139 double abs_max = octave::numeric_limits<double>::NaN ();
3140
3141 for (idx_i = 0; idx_i < nr; idx_i++)
3142 {
3143 tmp_max = elem (idx_i, j);
3144
3145 if (! octave::math::isnan (tmp_max))
3146 {
3147 abs_max = (real_only ? tmp_max.real ()
3148 : std::abs (tmp_max));
3149 break;
3150 }
3151 }
3152
3153 for (octave_idx_type i = idx_i+1; i < nr; i++)
3154 {
3155 Complex tmp = elem (i, j);
3156
3157 if (octave::math::isnan (tmp))
3158 continue;
3159
3160 double abs_tmp = (real_only ? tmp.real () : std::abs (tmp));
3161
3162 if (abs_tmp > abs_max)
3163 {
3164 idx_i = i;
3165 tmp_max = tmp;
3166 abs_max = abs_tmp;
3167 }
3168 }
3169
3170 if (octave::math::isnan (tmp_max))
3171 {
3172 result.elem (j) = Complex_NaN_result;
3173 idx_arg.elem (j) = 0;
3174 }
3175 else
3176 {
3177 result.elem (j) = tmp_max;
3178 idx_arg.elem (j) = idx_i;
3179 }
3180 }
3181 }
3182
3183 return result;
3184}
3185
3186// i/o
3187
3188std::ostream&
3189operator << (std::ostream& os, const ComplexMatrix& a)
3190{
3191 for (octave_idx_type i = 0; i < a.rows (); i++)
3192 {
3193 for (octave_idx_type j = 0; j < a.cols (); j++)
3194 {
3195 os << ' ';
3196 octave::write_value<Complex> (os, a.elem (i, j));
3197 }
3198 os << "\n";
3199 }
3200 return os;
3201}
3202
3203std::istream&
3204operator >> (std::istream& is, ComplexMatrix& a)
3205{
3206 octave_idx_type nr = a.rows ();
3207 octave_idx_type nc = a.cols ();
3208
3209 if (nr > 0 && nc > 0)
3210 {
3211 Complex tmp;
3212 for (octave_idx_type i = 0; i < nr; i++)
3213 for (octave_idx_type j = 0; j < nc; j++)
3214 {
3215 tmp = octave::read_value<Complex> (is);
3216 if (is)
3217 a.elem (i, j) = tmp;
3218 else
3219 return is;
3220 }
3221 }
3222
3223 return is;
3224}
3225
3227Givens (const Complex& x, const Complex& y)
3228{
3229 double cc;
3230 Complex cs, temp_r;
3231
3232 F77_FUNC (zlartg, ZLARTG) (F77_CONST_DBLE_CMPLX_ARG (&x),
3234 cc,
3235 F77_DBLE_CMPLX_ARG (&cs),
3236 F77_DBLE_CMPLX_ARG (&temp_r));
3237
3238 ComplexMatrix g (2, 2);
3239
3240 g.elem (0, 0) = cc;
3241 g.elem (1, 1) = cc;
3242 g.elem (0, 1) = cs;
3243 g.elem (1, 0) = -conj (cs);
3244
3245 return g;
3246}
3247
3250 const ComplexMatrix& c)
3251{
3252 ComplexMatrix retval;
3253
3254 // FIXME: need to check that a, b, and c are all the same size.
3255
3256 // Compute Schur decompositions
3257
3258 octave::math::schur<ComplexMatrix> as (a, "U");
3259 octave::math::schur<ComplexMatrix> bs (b, "U");
3260
3261 // Transform c to new coordinates.
3262
3263 ComplexMatrix ua = as.unitary_schur_matrix ();
3264 ComplexMatrix sch_a = as.schur_matrix ();
3265
3266 ComplexMatrix ub = bs.unitary_schur_matrix ();
3267 ComplexMatrix sch_b = bs.schur_matrix ();
3268
3269 ComplexMatrix cx = ua.hermitian () * c * ub;
3270
3271 // Solve the sylvester equation, back-transform, and return the solution.
3272
3273 F77_INT a_nr = octave::to_f77_int (a.rows ());
3274 F77_INT b_nr = octave::to_f77_int (b.rows ());
3275
3276 double scale;
3277 F77_INT info;
3278
3279 Complex *pa = sch_a.rwdata ();
3280 Complex *pb = sch_b.rwdata ();
3281 Complex *px = cx.rwdata ();
3282
3283 F77_XFCN (ztrsyl, ZTRSYL, (F77_CONST_CHAR_ARG2 ("N", 1),
3284 F77_CONST_CHAR_ARG2 ("N", 1),
3285 1, a_nr, b_nr, F77_DBLE_CMPLX_ARG (pa), a_nr, F77_DBLE_CMPLX_ARG (pb),
3286 b_nr, F77_DBLE_CMPLX_ARG (px), a_nr, scale, info
3287 F77_CHAR_ARG_LEN (1)
3288 F77_CHAR_ARG_LEN (1)));
3289
3290 // FIXME: check info?
3291
3292 retval = ua * cx * ub.hermitian ();
3293
3294 return retval;
3295}
3296
3299{
3300 if (m.columns () > std::min (m.rows (), a.columns ()) / 10)
3301 return ComplexMatrix (real (m) * a, imag (m) * a);
3302 else
3303 return m * ComplexMatrix (a);
3304}
3305
3308{
3309 if (a.rows () > std::min (m.rows (), a.columns ()) / 10)
3310 return ComplexMatrix (m * real (a), m * imag (a));
3311 else
3312 return ComplexMatrix (m) * a;
3313}
3314
3315/*
3316
3317## Simple Dot Product, Matrix-Vector, and Matrix-Matrix Unit tests
3318%!assert ([1+i 2+i 3+i] * [ 4+i ; 5+i ; 6+i], 29+21i, 1e-14)
3319%!assert ([1+i 2+i ; 3+i 4+i ] * [5+i ; 6+i], [15 + 14i ; 37 + 18i], 1e-14)
3320%!assert ([1+i 2+i ; 3+i 4+i ] * [5+i 6+i ; 7+i 8+i], [17 + 15i 20 + 17i; 41 + 19i 48 + 21i], 1e-14)
3321%!assert ([1 i]*[i 0]', -i)
3322
3323## Test some simple identities
3324%!shared M, cv, rv
3325%! M = randn (10,10) + i*rand (10,10);
3326%! cv = randn (10,1) + i*rand (10,1);
3327%! rv = randn (1,10) + i*rand (1,10);
3328%!assert ([M*cv,M*cv], M*[cv,cv], 1e-14)
3329%!assert ([M.'*cv,M.'*cv], M.'*[cv,cv], 1e-14)
3330%!assert ([M'*cv,M'*cv], M'*[cv,cv], 1e-14)
3331%!assert ([rv*M;rv*M], [rv;rv]*M, 1e-14)
3332%!assert ([rv*M.';rv*M.'], [rv;rv]*M.', 1e-14)
3333%!assert ([rv*M';rv*M'], [rv;rv]*M', 1e-14)
3334%!assert (2*rv*cv, [rv,rv]*[cv;cv], 2e-14)
3335
3336*/
3337
3338static inline char
3339get_blas_trans_arg (bool trans, bool conj)
3340{
3341 return trans ? (conj ? 'C' : 'T') : 'N';
3342}
3343
3344// the general GEMM operation
3345
3348 blas_trans_type transa, blas_trans_type transb)
3349{
3350 ComplexMatrix retval;
3351
3352 bool tra = transa != blas_no_trans;
3353 bool trb = transb != blas_no_trans;
3354 bool cja = transa == blas_conj_trans;
3355 bool cjb = transb == blas_conj_trans;
3356
3357 F77_INT a_nr = octave::to_f77_int (tra ? a.cols () : a.rows ());
3358 F77_INT a_nc = octave::to_f77_int (tra ? a.rows () : a.cols ());
3359
3360 F77_INT b_nr = octave::to_f77_int (trb ? b.cols () : b.rows ());
3361 F77_INT b_nc = octave::to_f77_int (trb ? b.rows () : b.cols ());
3362
3363 if (a_nc != b_nr)
3364 octave::err_nonconformant ("operator *", a_nr, a_nc, b_nr, b_nc);
3365
3366 if (a_nr == 0 || a_nc == 0 || b_nc == 0)
3367 retval = ComplexMatrix (a_nr, b_nc, 0.0);
3368 else if (a.data () == b.data () && a_nr == b_nc && tra != trb)
3369 {
3370 F77_INT lda = octave::to_f77_int (a.rows ());
3371
3372 // FIXME: looking at the reference BLAS, it appears that it
3373 // should not be necessary to initialize the output matrix if
3374 // BETA is 0 in the call to ZHERK, but ATLAS appears to
3375 // use the result matrix before zeroing the elements.
3376
3377 retval = ComplexMatrix (a_nr, b_nc, 0.0);
3378 Complex *c = retval.rwdata ();
3379
3380 const char ctra = get_blas_trans_arg (tra, cja);
3381 if (cja || cjb)
3382 {
3383 F77_XFCN (zherk, ZHERK, (F77_CONST_CHAR_ARG2 ("U", 1),
3384 F77_CONST_CHAR_ARG2 (&ctra, 1),
3385 a_nr, a_nc, 1.0,
3386 F77_CONST_DBLE_CMPLX_ARG (a.data ()), lda, 0.0, F77_DBLE_CMPLX_ARG (c), a_nr
3387 F77_CHAR_ARG_LEN (1)
3388 F77_CHAR_ARG_LEN (1)));
3389 for (F77_INT j = 0; j < a_nr; j++)
3390 for (F77_INT i = 0; i < j; i++)
3391 retval.xelem (j, i) = octave::math::conj (retval.xelem (i, j));
3392 }
3393 else
3394 {
3395 F77_XFCN (zsyrk, ZSYRK, (F77_CONST_CHAR_ARG2 ("U", 1),
3396 F77_CONST_CHAR_ARG2 (&ctra, 1),
3397 a_nr, a_nc, 1.0,
3398 F77_CONST_DBLE_CMPLX_ARG (a.data ()), lda, 0.0, F77_DBLE_CMPLX_ARG (c), a_nr
3399 F77_CHAR_ARG_LEN (1)
3400 F77_CHAR_ARG_LEN (1)));
3401 for (F77_INT j = 0; j < a_nr; j++)
3402 for (F77_INT i = 0; i < j; i++)
3403 retval.xelem (j, i) = retval.xelem (i, j);
3404
3405 }
3406
3407 }
3408 else
3409 {
3410 F77_INT lda = octave::to_f77_int (a.rows ());
3411 F77_INT tda = octave::to_f77_int (a.cols ());
3412 F77_INT ldb = octave::to_f77_int (b.rows ());
3413 F77_INT tdb = octave::to_f77_int (b.cols ());
3414
3415 retval = ComplexMatrix (a_nr, b_nc, 0.0);
3416 Complex *c = retval.rwdata ();
3417
3418 if (b_nc == 1 && a_nr == 1)
3419 {
3420 if (cja == cjb)
3421 {
3422 F77_FUNC (xzdotu, XZDOTU) (a_nc, F77_CONST_DBLE_CMPLX_ARG (a.data ()), 1,
3424 F77_DBLE_CMPLX_ARG (c));
3425 if (cja) *c = octave::math::conj (*c);
3426 }
3427 else if (cja)
3428 F77_FUNC (xzdotc, XZDOTC) (a_nc, F77_CONST_DBLE_CMPLX_ARG (a.data ()), 1,
3430 F77_DBLE_CMPLX_ARG (c));
3431 else
3432 F77_FUNC (xzdotc, XZDOTC) (a_nc, F77_CONST_DBLE_CMPLX_ARG (b.data ()), 1,
3434 F77_DBLE_CMPLX_ARG (c));
3435 }
3436 else if (b_nc == 1 && ! cjb)
3437 {
3438 const char ctra = get_blas_trans_arg (tra, cja);
3439 F77_XFCN (zgemv, ZGEMV, (F77_CONST_CHAR_ARG2 (&ctra, 1),
3440 lda, tda, 1.0, F77_CONST_DBLE_CMPLX_ARG (a.data ()), lda,
3441 F77_CONST_DBLE_CMPLX_ARG (b.data ()), 1, 0.0, F77_DBLE_CMPLX_ARG (c), 1
3442 F77_CHAR_ARG_LEN (1)));
3443 }
3444 else if (a_nr == 1 && ! cja && ! cjb)
3445 {
3446 const char crevtrb = get_blas_trans_arg (! trb, cjb);
3447 F77_XFCN (zgemv, ZGEMV, (F77_CONST_CHAR_ARG2 (&crevtrb, 1),
3448 ldb, tdb, 1.0, F77_CONST_DBLE_CMPLX_ARG (b.data ()), ldb,
3449 F77_CONST_DBLE_CMPLX_ARG (a.data ()), 1, 0.0, F77_DBLE_CMPLX_ARG (c), 1
3450 F77_CHAR_ARG_LEN (1)));
3451 }
3452 else
3453 {
3454 const char ctra = get_blas_trans_arg (tra, cja);
3455 const char ctrb = get_blas_trans_arg (trb, cjb);
3456 F77_XFCN (zgemm, ZGEMM, (F77_CONST_CHAR_ARG2 (&ctra, 1),
3457 F77_CONST_CHAR_ARG2 (&ctrb, 1),
3458 a_nr, b_nc, a_nc, 1.0, F77_CONST_DBLE_CMPLX_ARG (a.data ()),
3459 lda, F77_CONST_DBLE_CMPLX_ARG (b.data ()), ldb, 0.0, F77_DBLE_CMPLX_ARG (c),
3460 a_nr
3461 F77_CHAR_ARG_LEN (1)
3462 F77_CHAR_ARG_LEN (1)));
3463 }
3464 }
3465
3466 return retval;
3467}
3468
3471{
3472 return xgemm (a, b);
3473}
3474
3475// FIXME: it would be nice to share code among the min/max functions below.
3476
3477#define EMPTY_RETURN_CHECK(T) \
3478 if (nr == 0 || nc == 0) \
3479 return T (nr, nc);
3480
3482min (const Complex& c, const ComplexMatrix& m)
3483{
3484 octave_idx_type nr = m.rows ();
3485 octave_idx_type nc = m.columns ();
3486
3488
3489 ComplexMatrix result (nr, nc);
3490
3491 for (octave_idx_type j = 0; j < nc; j++)
3492 for (octave_idx_type i = 0; i < nr; i++)
3493 {
3494 octave_quit ();
3495 result(i, j) = octave::math::min (c, m(i, j));
3496 }
3497
3498 return result;
3499}
3500
3502min (const ComplexMatrix& m, const Complex& c)
3503{
3504 return min (c, m);
3505}
3506
3508min (const ComplexMatrix& a, const ComplexMatrix& b)
3509{
3510 octave_idx_type nr = a.rows ();
3511 octave_idx_type nc = a.columns ();
3512
3513 if (nr != b.rows () || nc != b.columns ())
3514 (*current_liboctave_error_handler)
3515 ("two-arg min requires same size arguments");
3516
3518
3519 ComplexMatrix result (nr, nc);
3520
3521 for (octave_idx_type j = 0; j < nc; j++)
3522 {
3523 bool columns_are_real_only = true;
3524 for (octave_idx_type i = 0; i < nr; i++)
3525 {
3526 octave_quit ();
3527 if (std::imag (a(i, j)) != 0.0 || std::imag (b(i, j)) != 0.0)
3528 {
3529 columns_are_real_only = false;
3530 break;
3531 }
3532 }
3533
3534 if (columns_are_real_only)
3535 {
3536 for (octave_idx_type i = 0; i < nr; i++)
3537 result(i, j) = octave::math::min (std::real (a(i, j)),
3538 std::real (b(i, j)));
3539 }
3540 else
3541 {
3542 for (octave_idx_type i = 0; i < nr; i++)
3543 {
3544 octave_quit ();
3545 result(i, j) = octave::math::min (a(i, j), b(i, j));
3546 }
3547 }
3548 }
3549
3550 return result;
3551}
3552
3554max (const Complex& c, const ComplexMatrix& m)
3555{
3556 octave_idx_type nr = m.rows ();
3557 octave_idx_type nc = m.columns ();
3558
3560
3561 ComplexMatrix result (nr, nc);
3562
3563 for (octave_idx_type j = 0; j < nc; j++)
3564 for (octave_idx_type i = 0; i < nr; i++)
3565 {
3566 octave_quit ();
3567 result(i, j) = octave::math::max (c, m(i, j));
3568 }
3569
3570 return result;
3571}
3572
3574max (const ComplexMatrix& m, const Complex& c)
3575{
3576 return max (c, m);
3577}
3578
3580max (const ComplexMatrix& a, const ComplexMatrix& b)
3581{
3582 octave_idx_type nr = a.rows ();
3583 octave_idx_type nc = a.columns ();
3584
3585 if (nr != b.rows () || nc != b.columns ())
3586 (*current_liboctave_error_handler)
3587 ("two-arg max requires same size arguments");
3588
3590
3591 ComplexMatrix result (nr, nc);
3592
3593 for (octave_idx_type j = 0; j < nc; j++)
3594 {
3595 bool columns_are_real_only = true;
3596 for (octave_idx_type i = 0; i < nr; i++)
3597 {
3598 octave_quit ();
3599 if (std::imag (a(i, j)) != 0.0 || std::imag (b(i, j)) != 0.0)
3600 {
3601 columns_are_real_only = false;
3602 break;
3603 }
3604 }
3605
3606 // FIXME: is it so much faster?
3607 if (columns_are_real_only)
3608 {
3609 for (octave_idx_type i = 0; i < nr; i++)
3610 {
3611 octave_quit ();
3612 result(i, j) = octave::math::max (std::real (a(i, j)),
3613 std::real (b(i, j)));
3614 }
3615 }
3616 else
3617 {
3618 for (octave_idx_type i = 0; i < nr; i++)
3619 {
3620 octave_quit ();
3621 result(i, j) = octave::math::max (a(i, j), b(i, j));
3622 }
3623 }
3624 }
3625
3626 return result;
3627}
3628
3631 const ComplexColumnVector& x2,
3633{
3634 octave_idx_type m = x1.numel ();
3635
3636 if (x2.numel () != m)
3637 (*current_liboctave_error_handler)
3638 ("linspace: vectors must be of equal length");
3639
3640 ComplexMatrix retval;
3641
3642 if (n < 1)
3643 {
3644 retval.clear (m, 0);
3645 return retval;
3646 }
3647
3648 retval.clear (m, n);
3649 for (octave_idx_type i = 0; i < m; i++)
3650 retval.insert (linspace (x1(i), x2(i), n), i, 0);
3651
3652 return retval;
3653}
3654
3657
3660
std::ostream & operator<<(std::ostream &os, const ComplexMatrix &a)
Definition CMatrix.cc:3189
ComplexMatrix max(const Complex &c, const ComplexMatrix &m)
Definition CMatrix.cc:3554
ComplexMatrix Givens(const Complex &x, const Complex &y)
Definition CMatrix.cc:3227
ComplexMatrix conj(const ComplexMatrix &a)
Definition CMatrix.cc:676
ComplexMatrix linspace(const ComplexColumnVector &x1, const ComplexColumnVector &x2, octave_idx_type n)
Definition CMatrix.cc:3630
ComplexMatrix Sylvester(const ComplexMatrix &a, const ComplexMatrix &b, const ComplexMatrix &c)
Definition CMatrix.cc:3249
ComplexMatrix min(const Complex &c, const ComplexMatrix &m)
Definition CMatrix.cc:3482
#define EMPTY_RETURN_CHECK(T)
Definition CMatrix.cc:3477
ComplexMatrix operator*(const ColumnVector &v, const ComplexRowVector &a)
Definition CMatrix.cc:2624
ComplexMatrix xgemm(const ComplexMatrix &a, const ComplexMatrix &b, blas_trans_type transa, blas_trans_type transb)
Definition CMatrix.cc:3347
std::istream & operator>>(std::istream &is, ComplexMatrix &a)
Definition CMatrix.cc:3204
base_det< Complex > ComplexDET
Definition DET.h:87
N Dimensional Array with copy-on-write semantics.
Definition Array.h:130
T & xelem(octave_idx_type n)
Size of the specified dimension.
Definition Array.h:525
Array< T, Alloc > index(const octave::idx_vector &i) const
Indexing without resizing.
bool issquare() const
Size of the specified dimension.
Definition Array.h:649
void clear()
T & elem(octave_idx_type n)
Size of the specified dimension.
Definition Array.h:563
octave_idx_type rows() const
Definition Array.h:463
void resize(const dim_vector &dv, const T &rfv)
Size of the specified dimension.
octave_idx_type columns() const
Definition Array.h:475
octave_idx_type cols() const
Definition Array.h:473
void make_unique()
Definition Array.h:220
const T * data() const
Size of the specified dimension.
Definition Array.h:665
T * rwdata()
Size of the specified dimension.
octave_idx_type numel() const
Number of elements in the array.
Definition Array.h:418
ColumnVector extract(octave_idx_type r1, octave_idx_type r2) const
void resize(octave_idx_type n, const Complex &rfv=Complex(0))
Definition CColVector.h:146
ComplexRowVector column_max() const
Definition CMatrix.cc:3112
ComplexMatrix & operator+=(const DiagMatrix &a)
Definition CMatrix.cc:2665
ComplexMatrix & operator-=(const DiagMatrix &a)
Definition CMatrix.cc:2683
ComplexMatrix lssolve(const Matrix &b) const
Definition CMatrix.cc:2221
ComplexMatrix ifourier2d() const
Definition CMatrix.cc:1126
ComplexColumnVector row_max() const
Definition CMatrix.cc:2962
ComplexMatrix extract(octave_idx_type r1, octave_idx_type c1, octave_idx_type r2, octave_idx_type c2) const
Definition CMatrix.cc:684
ComplexColumnVector row_min() const
Definition CMatrix.cc:2887
ComplexMatrix fourier() const
Definition CMatrix.cc:1054
friend ComplexMatrix conj(const ComplexMatrix &a)
Definition CMatrix.cc:676
boolMatrix all(int dim=-1) const
Definition CMatrix.cc:2783
ComplexMatrix & fill(double val)
Definition CMatrix.cc:348
ComplexMatrix append(const Matrix &a) const
Definition CMatrix.cc:436
ComplexMatrix diag(octave_idx_type k=0) const
Definition CMatrix.cc:2831
ComplexMatrix pseudo_inverse(double tol=0.0) const
Definition CMatrix.cc:1009
bool operator==(const ComplexMatrix &a) const
Definition CMatrix.cc:160
ComplexMatrix fourier2d() const
Definition CMatrix.cc:1112
ComplexRowVector row(octave_idx_type i) const
Definition CMatrix.cc:703
ComplexMatrix & insert(const Matrix &a, octave_idx_type r, octave_idx_type c)
Definition CMatrix.cc:196
double rcond() const
Definition CMatrix.cc:1359
ComplexMatrix solve(MatrixType &mattype, const Matrix &b) const
Definition CMatrix.cc:1932
ComplexMatrix inverse() const
Definition CMatrix.cc:746
bool row_is_real_only(octave_idx_type) const
Definition CMatrix.cc:2849
ComplexMatrix sumsq(int dim=-1) const
Definition CMatrix.cc:2819
void resize(octave_idx_type nr, octave_idx_type nc, const Complex &rfv=Complex(0))
Definition CMatrix.h:191
Matrix abs() const
Definition CMatrix.cc:2825
ComplexMatrix extract_n(octave_idx_type r1, octave_idx_type c1, octave_idx_type nr, octave_idx_type nc) const
Definition CMatrix.cc:694
ComplexMatrix stack(const Matrix &a) const
Definition CMatrix.cc:556
ComplexMatrix cumprod(int dim=-1) const
Definition CMatrix.cc:2795
ComplexMatrix transpose() const
Definition CMatrix.h:170
ComplexMatrix prod(int dim=-1) const
Definition CMatrix.cc:2807
ComplexDET determinant() const
Definition CMatrix.cc:1180
ComplexMatrix cumsum(int dim=-1) const
Definition CMatrix.cc:2801
ComplexMatrix ifourier() const
Definition CMatrix.cc:1083
boolMatrix any(int dim=-1) const
Definition CMatrix.cc:2789
ComplexRowVector column_min() const
Definition CMatrix.cc:3037
bool operator!=(const ComplexMatrix &a) const
Definition CMatrix.cc:169
ComplexMatrix hermitian() const
Definition CMatrix.h:168
bool column_is_real_only(octave_idx_type) const
Definition CMatrix.cc:2868
ComplexMatrix sum(int dim=-1) const
Definition CMatrix.cc:2813
ComplexMatrix()=default
ComplexColumnVector column(octave_idx_type i) const
Definition CMatrix.cc:709
bool ishermitian() const
Definition CMatrix.cc:175
boolNDArray any(int dim=-1) const
Definition CNDArray.cc:352
ComplexNDArray prod(int dim=-1) const
Definition CNDArray.cc:370
NDArray abs() const
Definition CNDArray.cc:478
ComplexNDArray sumsq(int dim=-1) const
Definition CNDArray.cc:388
ComplexNDArray diag(octave_idx_type k=0) const
Definition CNDArray.cc:585
ComplexNDArray cumsum(int dim=-1) const
Definition CNDArray.cc:364
ComplexNDArray & insert(const NDArray &a, octave_idx_type r, octave_idx_type c)
Definition CNDArray.cc:508
ComplexNDArray cumprod(int dim=-1) const
Definition CNDArray.cc:358
boolNDArray all(int dim=-1) const
Definition CNDArray.cc:346
ComplexNDArray sum(int dim=-1) const
Definition CNDArray.cc:376
void resize(octave_idx_type n, const Complex &rfv=Complex(0))
Definition CRowVector.h:127
octave_idx_type rows() const
Definition DiagArray2.h:86
octave_idx_type length() const
Definition DiagArray2.h:92
T elem(octave_idx_type r, octave_idx_type c) const
Definition DiagArray2.h:114
octave_idx_type cols() const
Definition DiagArray2.h:87
DiagMatrix inverse() const
ColumnVector extract_diag(octave_idx_type k=0) const
Template for two dimensional diagonal array with math operators.
Definition MDiagArray2.h:54
bool ishermitian() const
Definition MatrixType.h:121
void mark_as_unsymmetric()
void mark_as_full()
Definition MatrixType.h:152
int type(bool quiet=true)
void mark_as_rectangular()
Definition MatrixType.h:154
Matrix sum(int dim=-1) const
Definition dMatrix.cc:2389
RowVector row(octave_idx_type i) const
Definition dMatrix.cc:417
Definition DET.h:38
base_det square() const
Definition DET.h:67
Definition chol.h:37
COND_T rcond() const
Definition chol.h:62
T inverse() const
Definition chol.cc:250
Vector representing the dimensions (size) of an Array.
Definition dim-vector.h:90
ColumnVector real(const ComplexColumnVector &a)
ColumnVector imag(const ComplexColumnVector &a)
#define F77_DBLE_CMPLX_ARG(x)
Definition f77-fcn.h:316
#define F77_XFCN(f, F, args)
Definition f77-fcn.h:45
octave_f77_int_type F77_INT
Definition f77-fcn.h:306
#define F77_CONST_DBLE_CMPLX_ARG(x)
Definition f77-fcn.h:319
double norm(const ColumnVector &v)
Definition graphics.cc:5778
void scale(Matrix &m, double x, double y, double z)
Definition graphics.cc:5731
F77_RET_T const F77_INT const F77_INT const F77_INT const F77_DBLE const F77_DBLE F77_INT F77_DBLE * V
F77_RET_T const F77_DBLE const F77_DBLE F77_DBLE * d
F77_RET_T const F77_DBLE * x
blas_trans_type
Definition mx-defs.h:80
@ blas_no_trans
Definition mx-defs.h:81
@ blas_conj_trans
Definition mx-defs.h:83
@ blas_trans
Definition mx-defs.h:82
char get_blas_char(blas_trans_type transt)
Definition mx-defs.h:87
void mx_inline_sub2(std::size_t n, R *r, const X *x)
void mx_inline_add2(std::size_t n, R *r, const X *x)
bool mx_inline_equal(std::size_t n, const T1 *x, const T2 *y)
#define MM_BOOL_OPS(M1, M2)
Definition mx-op-defs.h:213
#define MM_CMP_OPS(M1, M2)
Definition mx-op-defs.h:196
#define MS_CMP_OPS(M, S)
Definition mx-op-defs.h:110
#define SM_CMP_OPS(S, M)
Definition mx-op-defs.h:153
#define SM_BOOL_OPS(S, M)
Definition mx-op-defs.h:170
#define MS_BOOL_OPS(M, S)
Definition mx-op-defs.h:127
std::complex< double > Complex
Definition oct-cmplx.h:33
#define OCTAVE_LOCAL_BUFFER(T, buf, size)
Definition oct-locbuf.h:44
F77_RET_T F77_FUNC(xerbla, XERBLA)(F77_CONST_CHAR_ARG_DEF(s_arg
F77_RET_T len
Definition xerbla.cc:61
subroutine xilaenv(ispec, name, opts, n1, n2, n3, n4, retval)
Definition xilaenv.f:2
subroutine xzdotc(n, zx, incx, zy, incy, retval)
Definition xzdotc.f:2
subroutine xzdotu(n, zx, incx, zy, incy, retval)
Definition xzdotu.f:2