comparison liboctave/fMatrix.cc @ 7789:82be108cc558

First attempt at single precision tyeps * * * corrections to qrupdate single precision routines * * * prefer demotion to single over promotion to double * * * Add single precision support to log2 function * * * Trivial PROJECT file update * * * Cache optimized hermitian/transpose methods * * * Add tests for tranpose/hermitian and ChangeLog entry for new transpose code
author David Bateman <dbateman@free.fr>
date Sun, 27 Apr 2008 22:34:17 +0200
parents
children f42c6f8d6d8e
comparison
equal deleted inserted replaced
7788:45f5faba05a2 7789:82be108cc558
1 // Matrix manipulations.
2 /*
3
4 Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
5 2003, 2004, 2005, 2006, 2007 John W. Eaton
6
7 This file is part of Octave.
8
9 Octave is free software; you can redistribute it and/or modify it
10 under the terms of the GNU General Public License as published by the
11 Free Software Foundation; either version 3 of the License, or (at your
12 option) any later version.
13
14 Octave is distributed in the hope that it will be useful, but WITHOUT
15 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with Octave; see the file COPYING. If not, see
21 <http://www.gnu.org/licenses/>.
22
23 */
24
25 #ifdef HAVE_CONFIG_H
26 #include <config.h>
27 #endif
28
29 #include <cfloat>
30
31 #include <iostream>
32 #include <vector>
33
34 #include "Array-util.h"
35 #include "byte-swap.h"
36 #include "fMatrix.h"
37 #include "floatDET.h"
38 #include "floatSCHUR.h"
39 #include "floatSVD.h"
40 #include "floatCHOL.h"
41 #include "f77-fcn.h"
42 #include "functor.h"
43 #include "lo-error.h"
44 #include "lo-ieee.h"
45 #include "lo-mappers.h"
46 #include "lo-utils.h"
47 #include "mx-base.h"
48 #include "mx-fm-fdm.h"
49 #include "mx-fdm-fm.h"
50 #include "mx-inlines.cc"
51 #include "oct-cmplx.h"
52 #include "quit.h"
53
54 #if defined (HAVE_FFTW3)
55 #include "oct-fftw.h"
56 #endif
57
58 // Fortran functions we call.
59
60 extern "C"
61 {
62 F77_RET_T
63 F77_FUNC (xilaenv, XILAENV) (const octave_idx_type&, F77_CONST_CHAR_ARG_DECL,
64 F77_CONST_CHAR_ARG_DECL,
65 const octave_idx_type&, const octave_idx_type&,
66 const octave_idx_type&, const octave_idx_type&,
67 octave_idx_type&
68 F77_CHAR_ARG_LEN_DECL F77_CHAR_ARG_LEN_DECL);
69
70 F77_RET_T
71 F77_FUNC (sgebal, SGEBAL) (F77_CONST_CHAR_ARG_DECL,
72 const octave_idx_type&, float*, const octave_idx_type&, octave_idx_type&,
73 octave_idx_type&, float*, octave_idx_type&
74 F77_CHAR_ARG_LEN_DECL);
75
76 F77_RET_T
77 F77_FUNC (sgebak, SGEBAK) (F77_CONST_CHAR_ARG_DECL,
78 F77_CONST_CHAR_ARG_DECL,
79 const octave_idx_type&, const octave_idx_type&, const octave_idx_type&, float*,
80 const octave_idx_type&, float*, const octave_idx_type&, octave_idx_type&
81 F77_CHAR_ARG_LEN_DECL
82 F77_CHAR_ARG_LEN_DECL);
83
84
85 F77_RET_T
86 F77_FUNC (sgemm, SGEMM) (F77_CONST_CHAR_ARG_DECL,
87 F77_CONST_CHAR_ARG_DECL,
88 const octave_idx_type&, const octave_idx_type&, const octave_idx_type&,
89 const float&, const float*, const octave_idx_type&,
90 const float*, const octave_idx_type&, const float&,
91 float*, const octave_idx_type&
92 F77_CHAR_ARG_LEN_DECL
93 F77_CHAR_ARG_LEN_DECL);
94
95 F77_RET_T
96 F77_FUNC (sgemv, SGEMV) (F77_CONST_CHAR_ARG_DECL,
97 const octave_idx_type&, const octave_idx_type&, const float&,
98 const float*, const octave_idx_type&, const float*,
99 const octave_idx_type&, const float&, float*,
100 const octave_idx_type&
101 F77_CHAR_ARG_LEN_DECL);
102
103 F77_RET_T
104 F77_FUNC (xsdot, XSDOT) (const octave_idx_type&, const float*, const octave_idx_type&,
105 const float*, const octave_idx_type&, float&);
106
107 F77_RET_T
108 F77_FUNC (sgetrf, SGETRF) (const octave_idx_type&, const octave_idx_type&, float*, const octave_idx_type&,
109 octave_idx_type*, octave_idx_type&);
110
111 F77_RET_T
112 F77_FUNC (sgetrs, SGETRS) (F77_CONST_CHAR_ARG_DECL, const octave_idx_type&, const octave_idx_type&,
113 const float*, const octave_idx_type&,
114 const octave_idx_type*, float*, const octave_idx_type&, octave_idx_type&
115 F77_CHAR_ARG_LEN_DECL);
116
117 F77_RET_T
118 F77_FUNC (sgetri, SGETRI) (const octave_idx_type&, float*, const octave_idx_type&, const octave_idx_type*,
119 float*, const octave_idx_type&, octave_idx_type&);
120
121 F77_RET_T
122 F77_FUNC (sgecon, SGECON) (F77_CONST_CHAR_ARG_DECL, const octave_idx_type&, float*,
123 const octave_idx_type&, const float&, float&,
124 float*, octave_idx_type*, octave_idx_type&
125 F77_CHAR_ARG_LEN_DECL);
126
127 F77_RET_T
128 F77_FUNC (sgelsy, SGELSY) (const octave_idx_type&, const octave_idx_type&, const octave_idx_type&,
129 float*, const octave_idx_type&, float*,
130 const octave_idx_type&, octave_idx_type*, float&, octave_idx_type&,
131 float*, const octave_idx_type&, octave_idx_type&);
132
133 F77_RET_T
134 F77_FUNC (sgelsd, SGELSD) (const octave_idx_type&, const octave_idx_type&, const octave_idx_type&,
135 float*, const octave_idx_type&, float*,
136 const octave_idx_type&, float*, float&, octave_idx_type&,
137 float*, const octave_idx_type&, octave_idx_type*,
138 octave_idx_type&);
139
140 F77_RET_T
141 F77_FUNC (spotrf, SPOTRF) (F77_CONST_CHAR_ARG_DECL, const octave_idx_type&,
142 float *, const octave_idx_type&,
143 octave_idx_type& F77_CHAR_ARG_LEN_DECL);
144
145 F77_RET_T
146 F77_FUNC (spocon, SPOCON) (F77_CONST_CHAR_ARG_DECL, const octave_idx_type&,
147 float*, const octave_idx_type&, const float&,
148 float&, float*, octave_idx_type*,
149 octave_idx_type& F77_CHAR_ARG_LEN_DECL);
150 F77_RET_T
151 F77_FUNC (spotrs, SPOTRS) (F77_CONST_CHAR_ARG_DECL, const octave_idx_type&,
152 const octave_idx_type&, const float*,
153 const octave_idx_type&, float*,
154 const octave_idx_type&, octave_idx_type&
155 F77_CHAR_ARG_LEN_DECL);
156
157 F77_RET_T
158 F77_FUNC (strtri, STRTRI) (F77_CONST_CHAR_ARG_DECL, F77_CONST_CHAR_ARG_DECL,
159 const octave_idx_type&, const float*,
160 const octave_idx_type&, octave_idx_type&
161 F77_CHAR_ARG_LEN_DECL
162 F77_CHAR_ARG_LEN_DECL);
163 F77_RET_T
164 F77_FUNC (strcon, STRCON) (F77_CONST_CHAR_ARG_DECL, F77_CONST_CHAR_ARG_DECL,
165 F77_CONST_CHAR_ARG_DECL, const octave_idx_type&,
166 const float*, const octave_idx_type&, float&,
167 float*, octave_idx_type*, octave_idx_type&
168 F77_CHAR_ARG_LEN_DECL
169 F77_CHAR_ARG_LEN_DECL
170 F77_CHAR_ARG_LEN_DECL);
171 F77_RET_T
172 F77_FUNC (strtrs, STRTRS) (F77_CONST_CHAR_ARG_DECL, F77_CONST_CHAR_ARG_DECL,
173 F77_CONST_CHAR_ARG_DECL, const octave_idx_type&,
174 const octave_idx_type&, const float*,
175 const octave_idx_type&, float*,
176 const octave_idx_type&, octave_idx_type&
177 F77_CHAR_ARG_LEN_DECL
178 F77_CHAR_ARG_LEN_DECL
179 F77_CHAR_ARG_LEN_DECL);
180
181 // Note that the original complex fft routines were not written for
182 // float complex arguments. They have been modified by adding an
183 // implicit float precision (a-h,o-z) statement at the beginning of
184 // each subroutine.
185
186 F77_RET_T
187 F77_FUNC (cffti, CFFTI) (const octave_idx_type&, FloatComplex*);
188
189 F77_RET_T
190 F77_FUNC (cfftf, CFFTF) (const octave_idx_type&, FloatComplex*, FloatComplex*);
191
192 F77_RET_T
193 F77_FUNC (cfftb, CFFTB) (const octave_idx_type&, FloatComplex*, FloatComplex*);
194
195 F77_RET_T
196 F77_FUNC (slartg, SLARTG) (const float&, const float&, float&,
197 float&, float&);
198
199 F77_RET_T
200 F77_FUNC (strsyl, STRSYL) (F77_CONST_CHAR_ARG_DECL,
201 F77_CONST_CHAR_ARG_DECL,
202 const octave_idx_type&, const octave_idx_type&, const octave_idx_type&,
203 const float*, const octave_idx_type&, const float*,
204 const octave_idx_type&, const float*, const octave_idx_type&,
205 float&, octave_idx_type&
206 F77_CHAR_ARG_LEN_DECL
207 F77_CHAR_ARG_LEN_DECL);
208
209 F77_RET_T
210 F77_FUNC (xslange, XSLANGE) (F77_CONST_CHAR_ARG_DECL, const octave_idx_type&,
211 const octave_idx_type&, const float*,
212 const octave_idx_type&, float*, float&
213 F77_CHAR_ARG_LEN_DECL);
214 }
215
216 // Matrix class.
217
218 FloatMatrix::FloatMatrix (const FloatRowVector& rv)
219 : MArray2<float> (1, rv.length (), 0.0)
220 {
221 for (octave_idx_type i = 0; i < rv.length (); i++)
222 elem (0, i) = rv.elem (i);
223 }
224
225 FloatMatrix::FloatMatrix (const FloatColumnVector& cv)
226 : MArray2<float> (cv.length (), 1, 0.0)
227 {
228 for (octave_idx_type i = 0; i < cv.length (); i++)
229 elem (i, 0) = cv.elem (i);
230 }
231
232 FloatMatrix::FloatMatrix (const FloatDiagMatrix& a)
233 : MArray2<float> (a.rows (), a.cols (), 0.0)
234 {
235 for (octave_idx_type i = 0; i < a.length (); i++)
236 elem (i, i) = a.elem (i, i);
237 }
238
239 // FIXME -- could we use a templated mixed-type copy function
240 // here?
241
242 FloatMatrix::FloatMatrix (const boolMatrix& a)
243 : MArray2<float> (a.rows (), a.cols ())
244 {
245 for (octave_idx_type i = 0; i < a.rows (); i++)
246 for (octave_idx_type j = 0; j < a.cols (); j++)
247 elem (i, j) = a.elem (i, j);
248 }
249
250 FloatMatrix::FloatMatrix (const charMatrix& a)
251 : MArray2<float> (a.rows (), a.cols ())
252 {
253 for (octave_idx_type i = 0; i < a.rows (); i++)
254 for (octave_idx_type j = 0; j < a.cols (); j++)
255 elem (i, j) = a.elem (i, j);
256 }
257
258 bool
259 FloatMatrix::operator == (const FloatMatrix& a) const
260 {
261 if (rows () != a.rows () || cols () != a.cols ())
262 return false;
263
264 return mx_inline_equal (data (), a.data (), length ());
265 }
266
267 bool
268 FloatMatrix::operator != (const FloatMatrix& a) const
269 {
270 return !(*this == a);
271 }
272
273 bool
274 FloatMatrix::is_symmetric (void) const
275 {
276 if (is_square () && rows () > 0)
277 {
278 for (octave_idx_type i = 0; i < rows (); i++)
279 for (octave_idx_type j = i+1; j < cols (); j++)
280 if (elem (i, j) != elem (j, i))
281 return false;
282
283 return true;
284 }
285
286 return false;
287 }
288
289 FloatMatrix&
290 FloatMatrix::insert (const FloatMatrix& a, octave_idx_type r, octave_idx_type c)
291 {
292 Array2<float>::insert (a, r, c);
293 return *this;
294 }
295
296 FloatMatrix&
297 FloatMatrix::insert (const FloatRowVector& a, octave_idx_type r, octave_idx_type c)
298 {
299 octave_idx_type a_len = a.length ();
300
301 if (r < 0 || r >= rows () || c < 0 || c + a_len > cols ())
302 {
303 (*current_liboctave_error_handler) ("range error for insert");
304 return *this;
305 }
306
307 if (a_len > 0)
308 {
309 make_unique ();
310
311 for (octave_idx_type i = 0; i < a_len; i++)
312 xelem (r, c+i) = a.elem (i);
313 }
314
315 return *this;
316 }
317
318 FloatMatrix&
319 FloatMatrix::insert (const FloatColumnVector& a, octave_idx_type r, octave_idx_type c)
320 {
321 octave_idx_type a_len = a.length ();
322
323 if (r < 0 || r + a_len > rows () || c < 0 || c >= cols ())
324 {
325 (*current_liboctave_error_handler) ("range error for insert");
326 return *this;
327 }
328
329 if (a_len > 0)
330 {
331 make_unique ();
332
333 for (octave_idx_type i = 0; i < a_len; i++)
334 xelem (r+i, c) = a.elem (i);
335 }
336
337 return *this;
338 }
339
340 FloatMatrix&
341 FloatMatrix::insert (const FloatDiagMatrix& a, octave_idx_type r, octave_idx_type c)
342 {
343 octave_idx_type a_nr = a.rows ();
344 octave_idx_type a_nc = a.cols ();
345
346 if (r < 0 || r + a_nr > rows () || c < 0 || c + a_nc > cols ())
347 {
348 (*current_liboctave_error_handler) ("range error for insert");
349 return *this;
350 }
351
352 fill (0.0, r, c, r + a_nr - 1, c + a_nc - 1);
353
354 octave_idx_type a_len = a.length ();
355
356 if (a_len > 0)
357 {
358 make_unique ();
359
360 for (octave_idx_type i = 0; i < a_len; i++)
361 xelem (r+i, c+i) = a.elem (i, i);
362 }
363
364 return *this;
365 }
366
367 FloatMatrix&
368 FloatMatrix::fill (float val)
369 {
370 octave_idx_type nr = rows ();
371 octave_idx_type nc = cols ();
372
373 if (nr > 0 && nc > 0)
374 {
375 make_unique ();
376
377 for (octave_idx_type j = 0; j < nc; j++)
378 for (octave_idx_type i = 0; i < nr; i++)
379 xelem (i, j) = val;
380 }
381
382 return *this;
383 }
384
385 FloatMatrix&
386 FloatMatrix::fill (float val, octave_idx_type r1, octave_idx_type c1, octave_idx_type r2, octave_idx_type c2)
387 {
388 octave_idx_type nr = rows ();
389 octave_idx_type nc = cols ();
390
391 if (r1 < 0 || r2 < 0 || c1 < 0 || c2 < 0
392 || r1 >= nr || r2 >= nr || c1 >= nc || c2 >= nc)
393 {
394 (*current_liboctave_error_handler) ("range error for fill");
395 return *this;
396 }
397
398 if (r1 > r2) { octave_idx_type tmp = r1; r1 = r2; r2 = tmp; }
399 if (c1 > c2) { octave_idx_type tmp = c1; c1 = c2; c2 = tmp; }
400
401 if (r2 >= r1 && c2 >= c1)
402 {
403 make_unique ();
404
405 for (octave_idx_type j = c1; j <= c2; j++)
406 for (octave_idx_type i = r1; i <= r2; i++)
407 xelem (i, j) = val;
408 }
409
410 return *this;
411 }
412
413 FloatMatrix
414 FloatMatrix::append (const FloatMatrix& a) const
415 {
416 octave_idx_type nr = rows ();
417 octave_idx_type nc = cols ();
418 if (nr != a.rows ())
419 {
420 (*current_liboctave_error_handler) ("row dimension mismatch for append");
421 return FloatMatrix ();
422 }
423
424 octave_idx_type nc_insert = nc;
425 FloatMatrix retval (nr, nc + a.cols ());
426 retval.insert (*this, 0, 0);
427 retval.insert (a, 0, nc_insert);
428 return retval;
429 }
430
431 FloatMatrix
432 FloatMatrix::append (const FloatRowVector& a) const
433 {
434 octave_idx_type nr = rows ();
435 octave_idx_type nc = cols ();
436 if (nr != 1)
437 {
438 (*current_liboctave_error_handler) ("row dimension mismatch for append");
439 return FloatMatrix ();
440 }
441
442 octave_idx_type nc_insert = nc;
443 FloatMatrix retval (nr, nc + a.length ());
444 retval.insert (*this, 0, 0);
445 retval.insert (a, 0, nc_insert);
446 return retval;
447 }
448
449 FloatMatrix
450 FloatMatrix::append (const FloatColumnVector& a) const
451 {
452 octave_idx_type nr = rows ();
453 octave_idx_type nc = cols ();
454 if (nr != a.length ())
455 {
456 (*current_liboctave_error_handler) ("row dimension mismatch for append");
457 return FloatMatrix ();
458 }
459
460 octave_idx_type nc_insert = nc;
461 FloatMatrix retval (nr, nc + 1);
462 retval.insert (*this, 0, 0);
463 retval.insert (a, 0, nc_insert);
464 return retval;
465 }
466
467 FloatMatrix
468 FloatMatrix::append (const FloatDiagMatrix& a) const
469 {
470 octave_idx_type nr = rows ();
471 octave_idx_type nc = cols ();
472 if (nr != a.rows ())
473 {
474 (*current_liboctave_error_handler) ("row dimension mismatch for append");
475 return *this;
476 }
477
478 octave_idx_type nc_insert = nc;
479 FloatMatrix retval (nr, nc + a.cols ());
480 retval.insert (*this, 0, 0);
481 retval.insert (a, 0, nc_insert);
482 return retval;
483 }
484
485 FloatMatrix
486 FloatMatrix::stack (const FloatMatrix& a) const
487 {
488 octave_idx_type nr = rows ();
489 octave_idx_type nc = cols ();
490 if (nc != a.cols ())
491 {
492 (*current_liboctave_error_handler)
493 ("column dimension mismatch for stack");
494 return FloatMatrix ();
495 }
496
497 octave_idx_type nr_insert = nr;
498 FloatMatrix retval (nr + a.rows (), nc);
499 retval.insert (*this, 0, 0);
500 retval.insert (a, nr_insert, 0);
501 return retval;
502 }
503
504 FloatMatrix
505 FloatMatrix::stack (const FloatRowVector& a) const
506 {
507 octave_idx_type nr = rows ();
508 octave_idx_type nc = cols ();
509 if (nc != a.length ())
510 {
511 (*current_liboctave_error_handler)
512 ("column dimension mismatch for stack");
513 return FloatMatrix ();
514 }
515
516 octave_idx_type nr_insert = nr;
517 FloatMatrix retval (nr + 1, nc);
518 retval.insert (*this, 0, 0);
519 retval.insert (a, nr_insert, 0);
520 return retval;
521 }
522
523 FloatMatrix
524 FloatMatrix::stack (const FloatColumnVector& a) const
525 {
526 octave_idx_type nr = rows ();
527 octave_idx_type nc = cols ();
528 if (nc != 1)
529 {
530 (*current_liboctave_error_handler)
531 ("column dimension mismatch for stack");
532 return FloatMatrix ();
533 }
534
535 octave_idx_type nr_insert = nr;
536 FloatMatrix retval (nr + a.length (), nc);
537 retval.insert (*this, 0, 0);
538 retval.insert (a, nr_insert, 0);
539 return retval;
540 }
541
542 FloatMatrix
543 FloatMatrix::stack (const FloatDiagMatrix& a) const
544 {
545 octave_idx_type nr = rows ();
546 octave_idx_type nc = cols ();
547 if (nc != a.cols ())
548 {
549 (*current_liboctave_error_handler)
550 ("column dimension mismatch for stack");
551 return FloatMatrix ();
552 }
553
554 octave_idx_type nr_insert = nr;
555 FloatMatrix retval (nr + a.rows (), nc);
556 retval.insert (*this, 0, 0);
557 retval.insert (a, nr_insert, 0);
558 return retval;
559 }
560
561 FloatMatrix
562 real (const FloatComplexMatrix& a)
563 {
564 octave_idx_type a_len = a.length ();
565 FloatMatrix retval;
566 if (a_len > 0)
567 retval = FloatMatrix (mx_inline_real_dup (a.data (), a_len),
568 a.rows (), a.cols ());
569 return retval;
570 }
571
572 FloatMatrix
573 imag (const FloatComplexMatrix& a)
574 {
575 octave_idx_type a_len = a.length ();
576 FloatMatrix retval;
577 if (a_len > 0)
578 retval = FloatMatrix (mx_inline_imag_dup (a.data (), a_len),
579 a.rows (), a.cols ());
580 return retval;
581 }
582
583 FloatMatrix
584 FloatMatrix::extract (octave_idx_type r1, octave_idx_type c1, octave_idx_type r2, octave_idx_type c2) const
585 {
586 if (r1 > r2) { octave_idx_type tmp = r1; r1 = r2; r2 = tmp; }
587 if (c1 > c2) { octave_idx_type tmp = c1; c1 = c2; c2 = tmp; }
588
589 octave_idx_type new_r = r2 - r1 + 1;
590 octave_idx_type new_c = c2 - c1 + 1;
591
592 FloatMatrix result (new_r, new_c);
593
594 for (octave_idx_type j = 0; j < new_c; j++)
595 for (octave_idx_type i = 0; i < new_r; i++)
596 result.xelem (i, j) = elem (r1+i, c1+j);
597
598 return result;
599 }
600
601 FloatMatrix
602 FloatMatrix::extract_n (octave_idx_type r1, octave_idx_type c1, octave_idx_type nr, octave_idx_type nc) const
603 {
604 FloatMatrix result (nr, nc);
605
606 for (octave_idx_type j = 0; j < nc; j++)
607 for (octave_idx_type i = 0; i < nr; i++)
608 result.xelem (i, j) = elem (r1+i, c1+j);
609
610 return result;
611 }
612
613 // extract row or column i.
614
615 FloatRowVector
616 FloatMatrix::row (octave_idx_type i) const
617 {
618 octave_idx_type nc = cols ();
619 if (i < 0 || i >= rows ())
620 {
621 (*current_liboctave_error_handler) ("invalid row selection");
622 return FloatRowVector ();
623 }
624
625 FloatRowVector retval (nc);
626 for (octave_idx_type j = 0; j < nc; j++)
627 retval.xelem (j) = elem (i, j);
628
629 return retval;
630 }
631
632 FloatColumnVector
633 FloatMatrix::column (octave_idx_type i) const
634 {
635 octave_idx_type nr = rows ();
636 if (i < 0 || i >= cols ())
637 {
638 (*current_liboctave_error_handler) ("invalid column selection");
639 return FloatColumnVector ();
640 }
641
642 FloatColumnVector retval (nr);
643 for (octave_idx_type j = 0; j < nr; j++)
644 retval.xelem (j) = elem (j, i);
645
646 return retval;
647 }
648
649 FloatMatrix
650 FloatMatrix::inverse (void) const
651 {
652 octave_idx_type info;
653 float rcond;
654 MatrixType mattype (*this);
655 return inverse (mattype, info, rcond, 0, 0);
656 }
657
658 FloatMatrix
659 FloatMatrix::inverse (octave_idx_type& info) const
660 {
661 float rcond;
662 MatrixType mattype (*this);
663 return inverse (mattype, info, rcond, 0, 0);
664 }
665
666 FloatMatrix
667 FloatMatrix::inverse (octave_idx_type& info, float& rcond, int force,
668 int calc_cond) const
669 {
670 MatrixType mattype (*this);
671 return inverse (mattype, info, rcond, force, calc_cond);
672 }
673
674 FloatMatrix
675 FloatMatrix::inverse (MatrixType& mattype) const
676 {
677 octave_idx_type info;
678 float rcond;
679 return inverse (mattype, info, rcond, 0, 0);
680 }
681
682 FloatMatrix
683 FloatMatrix::inverse (MatrixType &mattype, octave_idx_type& info) const
684 {
685 float rcond;
686 return inverse (mattype, info, rcond, 0, 0);
687 }
688
689 FloatMatrix
690 FloatMatrix::tinverse (MatrixType &mattype, octave_idx_type& info, float& rcond,
691 int force, int calc_cond) const
692 {
693 FloatMatrix retval;
694
695 octave_idx_type nr = rows ();
696 octave_idx_type nc = cols ();
697
698 if (nr != nc || nr == 0 || nc == 0)
699 (*current_liboctave_error_handler) ("inverse requires square matrix");
700 else
701 {
702 int typ = mattype.type ();
703 char uplo = (typ == MatrixType::Lower ? 'L' : 'U');
704 char udiag = 'N';
705 retval = *this;
706 float *tmp_data = retval.fortran_vec ();
707
708 F77_XFCN (strtri, STRTRI, (F77_CONST_CHAR_ARG2 (&uplo, 1),
709 F77_CONST_CHAR_ARG2 (&udiag, 1),
710 nr, tmp_data, nr, info
711 F77_CHAR_ARG_LEN (1)
712 F77_CHAR_ARG_LEN (1)));
713
714 // Throw-away extra info LAPACK gives so as to not change output.
715 rcond = 0.0;
716 if (info != 0)
717 info = -1;
718 else if (calc_cond)
719 {
720 octave_idx_type dtrcon_info = 0;
721 char job = '1';
722
723 OCTAVE_LOCAL_BUFFER (float, work, 3 * nr);
724 OCTAVE_LOCAL_BUFFER (octave_idx_type, iwork, nr);
725
726 F77_XFCN (strcon, STRCON, (F77_CONST_CHAR_ARG2 (&job, 1),
727 F77_CONST_CHAR_ARG2 (&uplo, 1),
728 F77_CONST_CHAR_ARG2 (&udiag, 1),
729 nr, tmp_data, nr, rcond,
730 work, iwork, dtrcon_info
731 F77_CHAR_ARG_LEN (1)
732 F77_CHAR_ARG_LEN (1)
733 F77_CHAR_ARG_LEN (1)));
734
735 if (dtrcon_info != 0)
736 info = -1;
737 }
738
739 if (info == -1 && ! force)
740 retval = *this; // Restore matrix contents.
741 }
742
743 return retval;
744 }
745
746
747 FloatMatrix
748 FloatMatrix::finverse (MatrixType &mattype, octave_idx_type& info, float& rcond,
749 int force, int calc_cond) const
750 {
751 FloatMatrix retval;
752
753 octave_idx_type nr = rows ();
754 octave_idx_type nc = cols ();
755
756 if (nr != nc || nr == 0 || nc == 0)
757 (*current_liboctave_error_handler) ("inverse requires square matrix");
758 else
759 {
760 Array<octave_idx_type> ipvt (nr);
761 octave_idx_type *pipvt = ipvt.fortran_vec ();
762
763 retval = *this;
764 float *tmp_data = retval.fortran_vec ();
765
766 Array<float> z(1);
767 octave_idx_type lwork = -1;
768
769 // Query the optimum work array size.
770 F77_XFCN (sgetri, SGETRI, (nc, tmp_data, nr, pipvt,
771 z.fortran_vec (), lwork, info));
772
773 lwork = static_cast<octave_idx_type> (z(0));
774 lwork = (lwork < 2 *nc ? 2*nc : lwork);
775 z.resize (lwork);
776 float *pz = z.fortran_vec ();
777
778 info = 0;
779
780 // Calculate the norm of the matrix, for later use.
781 float anorm = 0;
782 if (calc_cond)
783 anorm = retval.abs().sum().row(static_cast<octave_idx_type>(0)).max();
784
785 F77_XFCN (sgetrf, SGETRF, (nc, nc, tmp_data, nr, pipvt, info));
786
787 // Throw-away extra info LAPACK gives so as to not change output.
788 rcond = 0.0;
789 if (info != 0)
790 info = -1;
791 else if (calc_cond)
792 {
793 octave_idx_type dgecon_info = 0;
794
795 // Now calculate the condition number for non-singular matrix.
796 char job = '1';
797 Array<octave_idx_type> iz (nc);
798 octave_idx_type *piz = iz.fortran_vec ();
799 F77_XFCN (sgecon, SGECON, (F77_CONST_CHAR_ARG2 (&job, 1),
800 nc, tmp_data, nr, anorm,
801 rcond, pz, piz, dgecon_info
802 F77_CHAR_ARG_LEN (1)));
803
804 if (dgecon_info != 0)
805 info = -1;
806 }
807
808 if (info == -1 && ! force)
809 retval = *this; // Restore matrix contents.
810 else
811 {
812 octave_idx_type dgetri_info = 0;
813
814 F77_XFCN (sgetri, SGETRI, (nc, tmp_data, nr, pipvt,
815 pz, lwork, dgetri_info));
816
817 if (dgetri_info != 0)
818 info = -1;
819 }
820
821 if (info != 0)
822 mattype.mark_as_rectangular();
823 }
824
825 return retval;
826 }
827
828 FloatMatrix
829 FloatMatrix::inverse (MatrixType &mattype, octave_idx_type& info, float& rcond,
830 int force, int calc_cond) const
831 {
832 int typ = mattype.type (false);
833 FloatMatrix ret;
834
835 if (typ == MatrixType::Unknown)
836 typ = mattype.type (*this);
837
838 if (typ == MatrixType::Upper || typ == MatrixType::Lower)
839 ret = tinverse (mattype, info, rcond, force, calc_cond);
840 else
841 {
842 if (mattype.is_hermitian ())
843 {
844 FloatCHOL chol (*this, info, calc_cond);
845 if (info == 0)
846 {
847 if (calc_cond)
848 rcond = chol.rcond ();
849 else
850 rcond = 1.0;
851 ret = chol.inverse ();
852 }
853 else
854 mattype.mark_as_unsymmetric ();
855 }
856
857 if (!mattype.is_hermitian ())
858 ret = finverse(mattype, info, rcond, force, calc_cond);
859
860 if ((mattype.is_hermitian () || calc_cond) && rcond == 0.)
861 ret = FloatMatrix (rows (), columns (), octave_Float_Inf);
862 }
863
864 return ret;
865 }
866
867 FloatMatrix
868 FloatMatrix::pseudo_inverse (float tol) const
869 {
870 FloatSVD result (*this, SVD::economy);
871
872 FloatDiagMatrix S = result.singular_values ();
873 FloatMatrix U = result.left_singular_matrix ();
874 FloatMatrix V = result.right_singular_matrix ();
875
876 FloatColumnVector sigma = S.diag ();
877
878 octave_idx_type r = sigma.length () - 1;
879 octave_idx_type nr = rows ();
880 octave_idx_type nc = cols ();
881
882 if (tol <= 0.0)
883 {
884 if (nr > nc)
885 tol = nr * sigma.elem (0) * DBL_EPSILON;
886 else
887 tol = nc * sigma.elem (0) * DBL_EPSILON;
888 }
889
890 while (r >= 0 && sigma.elem (r) < tol)
891 r--;
892
893 if (r < 0)
894 return FloatMatrix (nc, nr, 0.0);
895 else
896 {
897 FloatMatrix Ur = U.extract (0, 0, nr-1, r);
898 FloatDiagMatrix D = FloatDiagMatrix (sigma.extract (0, r)) . inverse ();
899 FloatMatrix Vr = V.extract (0, 0, nc-1, r);
900 return Vr * D * Ur.transpose ();
901 }
902 }
903
904 #if defined (HAVE_FFTW3)
905
906 FloatComplexMatrix
907 FloatMatrix::fourier (void) const
908 {
909 size_t nr = rows ();
910 size_t nc = cols ();
911
912 FloatComplexMatrix retval (nr, nc);
913
914 size_t npts, nsamples;
915
916 if (nr == 1 || nc == 1)
917 {
918 npts = nr > nc ? nr : nc;
919 nsamples = 1;
920 }
921 else
922 {
923 npts = nr;
924 nsamples = nc;
925 }
926
927 const float *in (fortran_vec ());
928 FloatComplex *out (retval.fortran_vec ());
929
930 octave_fftw::fft (in, out, npts, nsamples);
931
932 return retval;
933 }
934
935 FloatComplexMatrix
936 FloatMatrix::ifourier (void) const
937 {
938 size_t nr = rows ();
939 size_t nc = cols ();
940
941 FloatComplexMatrix retval (nr, nc);
942
943 size_t npts, nsamples;
944
945 if (nr == 1 || nc == 1)
946 {
947 npts = nr > nc ? nr : nc;
948 nsamples = 1;
949 }
950 else
951 {
952 npts = nr;
953 nsamples = nc;
954 }
955
956 FloatComplexMatrix tmp (*this);
957 FloatComplex *in (tmp.fortran_vec ());
958 FloatComplex *out (retval.fortran_vec ());
959
960 octave_fftw::ifft (in, out, npts, nsamples);
961
962 return retval;
963 }
964
965 FloatComplexMatrix
966 FloatMatrix::fourier2d (void) const
967 {
968 dim_vector dv(rows (), cols ());
969
970 const float *in = fortran_vec ();
971 FloatComplexMatrix retval (rows (), cols ());
972 octave_fftw::fftNd (in, retval.fortran_vec (), 2, dv);
973
974 return retval;
975 }
976
977 FloatComplexMatrix
978 FloatMatrix::ifourier2d (void) const
979 {
980 dim_vector dv(rows (), cols ());
981
982 FloatComplexMatrix retval (*this);
983 FloatComplex *out (retval.fortran_vec ());
984
985 octave_fftw::ifftNd (out, out, 2, dv);
986
987 return retval;
988 }
989
990 #else
991
992 FloatComplexMatrix
993 FloatMatrix::fourier (void) const
994 {
995 FloatComplexMatrix retval;
996
997 octave_idx_type nr = rows ();
998 octave_idx_type nc = cols ();
999
1000 octave_idx_type npts, nsamples;
1001
1002 if (nr == 1 || nc == 1)
1003 {
1004 npts = nr > nc ? nr : nc;
1005 nsamples = 1;
1006 }
1007 else
1008 {
1009 npts = nr;
1010 nsamples = nc;
1011 }
1012
1013 octave_idx_type nn = 4*npts+15;
1014
1015 Array<FloatComplex> wsave (nn);
1016 FloatComplex *pwsave = wsave.fortran_vec ();
1017
1018 retval = FloatComplexMatrix (*this);
1019 FloatComplex *tmp_data = retval.fortran_vec ();
1020
1021 F77_FUNC (cffti, CFFTI) (npts, pwsave);
1022
1023 for (octave_idx_type j = 0; j < nsamples; j++)
1024 {
1025 OCTAVE_QUIT;
1026
1027 F77_FUNC (cfftf, CFFTF) (npts, &tmp_data[npts*j], pwsave);
1028 }
1029
1030 return retval;
1031 }
1032
1033 FloatComplexMatrix
1034 FloatMatrix::ifourier (void) const
1035 {
1036 FloatComplexMatrix retval;
1037
1038 octave_idx_type nr = rows ();
1039 octave_idx_type nc = cols ();
1040
1041 octave_idx_type npts, nsamples;
1042
1043 if (nr == 1 || nc == 1)
1044 {
1045 npts = nr > nc ? nr : nc;
1046 nsamples = 1;
1047 }
1048 else
1049 {
1050 npts = nr;
1051 nsamples = nc;
1052 }
1053
1054 octave_idx_type nn = 4*npts+15;
1055
1056 Array<FloatComplex> wsave (nn);
1057 FloatComplex *pwsave = wsave.fortran_vec ();
1058
1059 retval = FloatComplexMatrix (*this);
1060 FloatComplex *tmp_data = retval.fortran_vec ();
1061
1062 F77_FUNC (cffti, CFFTI) (npts, pwsave);
1063
1064 for (octave_idx_type j = 0; j < nsamples; j++)
1065 {
1066 OCTAVE_QUIT;
1067
1068 F77_FUNC (cfftb, CFFTB) (npts, &tmp_data[npts*j], pwsave);
1069 }
1070
1071 for (octave_idx_type j = 0; j < npts*nsamples; j++)
1072 tmp_data[j] = tmp_data[j] / static_cast<float> (npts);
1073
1074 return retval;
1075 }
1076
1077 FloatComplexMatrix
1078 FloatMatrix::fourier2d (void) const
1079 {
1080 FloatComplexMatrix retval;
1081
1082 octave_idx_type nr = rows ();
1083 octave_idx_type nc = cols ();
1084
1085 octave_idx_type npts, nsamples;
1086
1087 if (nr == 1 || nc == 1)
1088 {
1089 npts = nr > nc ? nr : nc;
1090 nsamples = 1;
1091 }
1092 else
1093 {
1094 npts = nr;
1095 nsamples = nc;
1096 }
1097
1098 octave_idx_type nn = 4*npts+15;
1099
1100 Array<FloatComplex> wsave (nn);
1101 FloatComplex *pwsave = wsave.fortran_vec ();
1102
1103 retval = FloatComplexMatrix (*this);
1104 FloatComplex *tmp_data = retval.fortran_vec ();
1105
1106 F77_FUNC (cffti, CFFTI) (npts, pwsave);
1107
1108 for (octave_idx_type j = 0; j < nsamples; j++)
1109 {
1110 OCTAVE_QUIT;
1111
1112 F77_FUNC (cfftf, CFFTF) (npts, &tmp_data[npts*j], pwsave);
1113 }
1114
1115 npts = nc;
1116 nsamples = nr;
1117 nn = 4*npts+15;
1118
1119 wsave.resize (nn);
1120 pwsave = wsave.fortran_vec ();
1121
1122 Array<FloatComplex> tmp (npts);
1123 FloatComplex *prow = tmp.fortran_vec ();
1124
1125 F77_FUNC (cffti, CFFTI) (npts, pwsave);
1126
1127 for (octave_idx_type j = 0; j < nsamples; j++)
1128 {
1129 OCTAVE_QUIT;
1130
1131 for (octave_idx_type i = 0; i < npts; i++)
1132 prow[i] = tmp_data[i*nr + j];
1133
1134 F77_FUNC (cfftf, CFFTF) (npts, prow, pwsave);
1135
1136 for (octave_idx_type i = 0; i < npts; i++)
1137 tmp_data[i*nr + j] = prow[i];
1138 }
1139
1140 return retval;
1141 }
1142
1143 FloatComplexMatrix
1144 FloatMatrix::ifourier2d (void) const
1145 {
1146 FloatComplexMatrix retval;
1147
1148 octave_idx_type nr = rows ();
1149 octave_idx_type nc = cols ();
1150
1151 octave_idx_type npts, nsamples;
1152
1153 if (nr == 1 || nc == 1)
1154 {
1155 npts = nr > nc ? nr : nc;
1156 nsamples = 1;
1157 }
1158 else
1159 {
1160 npts = nr;
1161 nsamples = nc;
1162 }
1163
1164 octave_idx_type nn = 4*npts+15;
1165
1166 Array<FloatComplex> wsave (nn);
1167 FloatComplex *pwsave = wsave.fortran_vec ();
1168
1169 retval = FloatComplexMatrix (*this);
1170 FloatComplex *tmp_data = retval.fortran_vec ();
1171
1172 F77_FUNC (cffti, CFFTI) (npts, pwsave);
1173
1174 for (octave_idx_type j = 0; j < nsamples; j++)
1175 {
1176 OCTAVE_QUIT;
1177
1178 F77_FUNC (cfftb, CFFTB) (npts, &tmp_data[npts*j], pwsave);
1179 }
1180
1181 for (octave_idx_type j = 0; j < npts*nsamples; j++)
1182 tmp_data[j] = tmp_data[j] / static_cast<float> (npts);
1183
1184 npts = nc;
1185 nsamples = nr;
1186 nn = 4*npts+15;
1187
1188 wsave.resize (nn);
1189 pwsave = wsave.fortran_vec ();
1190
1191 Array<FloatComplex> tmp (npts);
1192 FloatComplex *prow = tmp.fortran_vec ();
1193
1194 F77_FUNC (cffti, CFFTI) (npts, pwsave);
1195
1196 for (octave_idx_type j = 0; j < nsamples; j++)
1197 {
1198 OCTAVE_QUIT;
1199
1200 for (octave_idx_type i = 0; i < npts; i++)
1201 prow[i] = tmp_data[i*nr + j];
1202
1203 F77_FUNC (cfftb, CFFTB) (npts, prow, pwsave);
1204
1205 for (octave_idx_type i = 0; i < npts; i++)
1206 tmp_data[i*nr + j] = prow[i] / static_cast<float> (npts);
1207 }
1208
1209 return retval;
1210 }
1211
1212 #endif
1213
1214 FloatDET
1215 FloatMatrix::determinant (void) const
1216 {
1217 octave_idx_type info;
1218 float rcond;
1219 return determinant (info, rcond, 0);
1220 }
1221
1222 FloatDET
1223 FloatMatrix::determinant (octave_idx_type& info) const
1224 {
1225 float rcond;
1226 return determinant (info, rcond, 0);
1227 }
1228
1229 FloatDET
1230 FloatMatrix::determinant (octave_idx_type& info, float& rcond, int calc_cond) const
1231 {
1232 FloatDET retval;
1233
1234 octave_idx_type nr = rows ();
1235 octave_idx_type nc = cols ();
1236
1237 if (nr == 0 || nc == 0)
1238 {
1239 retval = FloatDET (1.0, 0);
1240 }
1241 else
1242 {
1243 Array<octave_idx_type> ipvt (nr);
1244 octave_idx_type *pipvt = ipvt.fortran_vec ();
1245
1246 FloatMatrix atmp = *this;
1247 float *tmp_data = atmp.fortran_vec ();
1248
1249 info = 0;
1250
1251 // Calculate the norm of the matrix, for later use.
1252 float anorm = 0;
1253 if (calc_cond)
1254 anorm = atmp.abs().sum().row(static_cast<octave_idx_type>(0)).max();
1255
1256 F77_XFCN (sgetrf, SGETRF, (nr, nr, tmp_data, nr, pipvt, info));
1257
1258 // Throw-away extra info LAPACK gives so as to not change output.
1259 rcond = 0.0;
1260 if (info != 0)
1261 {
1262 info = -1;
1263 retval = FloatDET ();
1264 }
1265 else
1266 {
1267 if (calc_cond)
1268 {
1269 // Now calc the condition number for non-singular matrix.
1270 char job = '1';
1271 Array<float> z (4 * nc);
1272 float *pz = z.fortran_vec ();
1273 Array<octave_idx_type> iz (nc);
1274 octave_idx_type *piz = iz.fortran_vec ();
1275
1276 F77_XFCN (sgecon, SGECON, (F77_CONST_CHAR_ARG2 (&job, 1),
1277 nc, tmp_data, nr, anorm,
1278 rcond, pz, piz, info
1279 F77_CHAR_ARG_LEN (1)));
1280 }
1281
1282 if (info != 0)
1283 {
1284 info = -1;
1285 retval = FloatDET ();
1286 }
1287 else
1288 {
1289 float c = 1.0;
1290 int e = 0;
1291
1292 for (octave_idx_type i = 0; i < nc; i++)
1293 {
1294 if (ipvt(i) != (i+1))
1295 c = -c;
1296
1297 c *= atmp(i,i);
1298
1299 if (c == 0.0)
1300 break;
1301
1302 while (fabs (c) < 0.5)
1303 {
1304 c *= 2.0;
1305 e--;
1306 }
1307
1308 while (fabs (c) >= 2.0)
1309 {
1310 c /= 2.0;
1311 e++;
1312 }
1313 }
1314
1315 retval = FloatDET (c, e);
1316 }
1317 }
1318 }
1319
1320 return retval;
1321 }
1322
1323 FloatMatrix
1324 FloatMatrix::utsolve (MatrixType &mattype, const FloatMatrix& b, octave_idx_type& info,
1325 float& rcond, solve_singularity_handler sing_handler,
1326 bool calc_cond) const
1327 {
1328 FloatMatrix retval;
1329
1330 octave_idx_type nr = rows ();
1331 octave_idx_type nc = cols ();
1332
1333 if (nr != b.rows ())
1334 (*current_liboctave_error_handler)
1335 ("matrix dimension mismatch solution of linear equations");
1336 else if (nr == 0 || nc == 0 || b.cols () == 0)
1337 retval = FloatMatrix (nc, b.cols (), 0.0);
1338 else
1339 {
1340 volatile int typ = mattype.type ();
1341
1342 if (typ == MatrixType::Permuted_Upper ||
1343 typ == MatrixType::Upper)
1344 {
1345 octave_idx_type b_nc = b.cols ();
1346 rcond = 1.;
1347 info = 0;
1348
1349 if (typ == MatrixType::Permuted_Upper)
1350 {
1351 (*current_liboctave_error_handler)
1352 ("permuted triangular matrix not implemented");
1353 }
1354 else
1355 {
1356 const float *tmp_data = fortran_vec ();
1357
1358 if (calc_cond)
1359 {
1360 char norm = '1';
1361 char uplo = 'U';
1362 char dia = 'N';
1363
1364 Array<float> z (3 * nc);
1365 float *pz = z.fortran_vec ();
1366 Array<octave_idx_type> iz (nc);
1367 octave_idx_type *piz = iz.fortran_vec ();
1368
1369 F77_XFCN (strcon, STRCON, (F77_CONST_CHAR_ARG2 (&norm, 1),
1370 F77_CONST_CHAR_ARG2 (&uplo, 1),
1371 F77_CONST_CHAR_ARG2 (&dia, 1),
1372 nr, tmp_data, nr, rcond,
1373 pz, piz, info
1374 F77_CHAR_ARG_LEN (1)
1375 F77_CHAR_ARG_LEN (1)
1376 F77_CHAR_ARG_LEN (1)));
1377
1378 if (info != 0)
1379 info = -2;
1380
1381 volatile float rcond_plus_one = rcond + 1.0;
1382
1383 if (rcond_plus_one == 1.0 || xisnan (rcond))
1384 {
1385 info = -2;
1386
1387 if (sing_handler)
1388 sing_handler (rcond);
1389 else
1390 (*current_liboctave_error_handler)
1391 ("matrix singular to machine precision, rcond = %g",
1392 rcond);
1393 }
1394 }
1395
1396 if (info == 0)
1397 {
1398 retval = b;
1399 float *result = retval.fortran_vec ();
1400
1401 char uplo = 'U';
1402 char trans = 'N';
1403 char dia = 'N';
1404
1405 F77_XFCN (strtrs, STRTRS, (F77_CONST_CHAR_ARG2 (&uplo, 1),
1406 F77_CONST_CHAR_ARG2 (&trans, 1),
1407 F77_CONST_CHAR_ARG2 (&dia, 1),
1408 nr, b_nc, tmp_data, nr,
1409 result, nr, info
1410 F77_CHAR_ARG_LEN (1)
1411 F77_CHAR_ARG_LEN (1)
1412 F77_CHAR_ARG_LEN (1)));
1413 }
1414 }
1415 }
1416 else
1417 (*current_liboctave_error_handler) ("incorrect matrix type");
1418 }
1419
1420 return retval;
1421 }
1422
1423 FloatMatrix
1424 FloatMatrix::ltsolve (MatrixType &mattype, const FloatMatrix& b, octave_idx_type& info,
1425 float& rcond, solve_singularity_handler sing_handler,
1426 bool calc_cond) const
1427 {
1428 FloatMatrix retval;
1429
1430 octave_idx_type nr = rows ();
1431 octave_idx_type nc = cols ();
1432
1433 if (nr != b.rows ())
1434 (*current_liboctave_error_handler)
1435 ("matrix dimension mismatch solution of linear equations");
1436 else if (nr == 0 || nc == 0 || b.cols () == 0)
1437 retval = FloatMatrix (nc, b.cols (), 0.0);
1438 else
1439 {
1440 volatile int typ = mattype.type ();
1441
1442 if (typ == MatrixType::Permuted_Lower ||
1443 typ == MatrixType::Lower)
1444 {
1445 octave_idx_type b_nc = b.cols ();
1446 rcond = 1.;
1447 info = 0;
1448
1449 if (typ == MatrixType::Permuted_Lower)
1450 {
1451 (*current_liboctave_error_handler)
1452 ("permuted triangular matrix not implemented");
1453 }
1454 else
1455 {
1456 const float *tmp_data = fortran_vec ();
1457
1458 if (calc_cond)
1459 {
1460 char norm = '1';
1461 char uplo = 'L';
1462 char dia = 'N';
1463
1464 Array<float> z (3 * nc);
1465 float *pz = z.fortran_vec ();
1466 Array<octave_idx_type> iz (nc);
1467 octave_idx_type *piz = iz.fortran_vec ();
1468
1469 F77_XFCN (strcon, STRCON, (F77_CONST_CHAR_ARG2 (&norm, 1),
1470 F77_CONST_CHAR_ARG2 (&uplo, 1),
1471 F77_CONST_CHAR_ARG2 (&dia, 1),
1472 nr, tmp_data, nr, rcond,
1473 pz, piz, info
1474 F77_CHAR_ARG_LEN (1)
1475 F77_CHAR_ARG_LEN (1)
1476 F77_CHAR_ARG_LEN (1)));
1477
1478 if (info != 0)
1479 info = -2;
1480
1481 volatile float rcond_plus_one = rcond + 1.0;
1482
1483 if (rcond_plus_one == 1.0 || xisnan (rcond))
1484 {
1485 info = -2;
1486
1487 if (sing_handler)
1488 sing_handler (rcond);
1489 else
1490 (*current_liboctave_error_handler)
1491 ("matrix singular to machine precision, rcond = %g",
1492 rcond);
1493 }
1494 }
1495
1496 if (info == 0)
1497 {
1498 retval = b;
1499 float *result = retval.fortran_vec ();
1500
1501 char uplo = 'L';
1502 char trans = 'N';
1503 char dia = 'N';
1504
1505 F77_XFCN (strtrs, STRTRS, (F77_CONST_CHAR_ARG2 (&uplo, 1),
1506 F77_CONST_CHAR_ARG2 (&trans, 1),
1507 F77_CONST_CHAR_ARG2 (&dia, 1),
1508 nr, b_nc, tmp_data, nr,
1509 result, nr, info
1510 F77_CHAR_ARG_LEN (1)
1511 F77_CHAR_ARG_LEN (1)
1512 F77_CHAR_ARG_LEN (1)));
1513 }
1514 }
1515 }
1516 else
1517 (*current_liboctave_error_handler) ("incorrect matrix type");
1518 }
1519
1520 return retval;
1521 }
1522
1523 FloatMatrix
1524 FloatMatrix::fsolve (MatrixType &mattype, const FloatMatrix& b, octave_idx_type& info,
1525 float& rcond, solve_singularity_handler sing_handler,
1526 bool calc_cond) const
1527 {
1528 FloatMatrix retval;
1529
1530 octave_idx_type nr = rows ();
1531 octave_idx_type nc = cols ();
1532
1533 if (nr != nc || nr != b.rows ())
1534 (*current_liboctave_error_handler)
1535 ("matrix dimension mismatch solution of linear equations");
1536 else if (nr == 0 || b.cols () == 0)
1537 retval = FloatMatrix (nc, b.cols (), 0.0);
1538 else
1539 {
1540 volatile int typ = mattype.type ();
1541
1542 // Calculate the norm of the matrix, for later use.
1543 float anorm = -1.;
1544
1545 if (typ == MatrixType::Hermitian)
1546 {
1547 info = 0;
1548 char job = 'L';
1549 FloatMatrix atmp = *this;
1550 float *tmp_data = atmp.fortran_vec ();
1551 anorm = atmp.abs().sum().row(static_cast<octave_idx_type>(0)).max();
1552
1553 F77_XFCN (spotrf, SPOTRF, (F77_CONST_CHAR_ARG2 (&job, 1), nr,
1554 tmp_data, nr, info
1555 F77_CHAR_ARG_LEN (1)));
1556
1557 // Throw-away extra info LAPACK gives so as to not change output.
1558 rcond = 0.0;
1559 if (info != 0)
1560 {
1561 info = -2;
1562
1563 mattype.mark_as_unsymmetric ();
1564 typ = MatrixType::Full;
1565 }
1566 else
1567 {
1568 if (calc_cond)
1569 {
1570 Array<float> z (3 * nc);
1571 float *pz = z.fortran_vec ();
1572 Array<octave_idx_type> iz (nc);
1573 octave_idx_type *piz = iz.fortran_vec ();
1574
1575 F77_XFCN (spocon, SPOCON, (F77_CONST_CHAR_ARG2 (&job, 1),
1576 nr, tmp_data, nr, anorm,
1577 rcond, pz, piz, info
1578 F77_CHAR_ARG_LEN (1)));
1579
1580 if (info != 0)
1581 info = -2;
1582
1583 volatile float rcond_plus_one = rcond + 1.0;
1584
1585 if (rcond_plus_one == 1.0 || xisnan (rcond))
1586 {
1587 info = -2;
1588
1589 if (sing_handler)
1590 sing_handler (rcond);
1591 else
1592 (*current_liboctave_error_handler)
1593 ("matrix singular to machine precision, rcond = %g",
1594 rcond);
1595 }
1596 }
1597
1598 if (info == 0)
1599 {
1600 retval = b;
1601 float *result = retval.fortran_vec ();
1602
1603 octave_idx_type b_nc = b.cols ();
1604
1605 F77_XFCN (spotrs, SPOTRS, (F77_CONST_CHAR_ARG2 (&job, 1),
1606 nr, b_nc, tmp_data, nr,
1607 result, b.rows(), info
1608 F77_CHAR_ARG_LEN (1)));
1609 }
1610 else
1611 {
1612 mattype.mark_as_unsymmetric ();
1613 typ = MatrixType::Full;
1614 }
1615 }
1616 }
1617
1618 if (typ == MatrixType::Full)
1619 {
1620 info = 0;
1621
1622 Array<octave_idx_type> ipvt (nr);
1623 octave_idx_type *pipvt = ipvt.fortran_vec ();
1624
1625 FloatMatrix atmp = *this;
1626 float *tmp_data = atmp.fortran_vec ();
1627 if(anorm < 0.)
1628 anorm = atmp.abs().sum().row(static_cast<octave_idx_type>(0)).max();
1629
1630 Array<float> z (4 * nc);
1631 float *pz = z.fortran_vec ();
1632 Array<octave_idx_type> iz (nc);
1633 octave_idx_type *piz = iz.fortran_vec ();
1634
1635 F77_XFCN (sgetrf, SGETRF, (nr, nr, tmp_data, nr, pipvt, info));
1636
1637 // Throw-away extra info LAPACK gives so as to not change output.
1638 rcond = 0.0;
1639 if (info != 0)
1640 {
1641 info = -2;
1642
1643 if (sing_handler)
1644 sing_handler (rcond);
1645 else
1646 (*current_liboctave_error_handler)
1647 ("matrix singular to machine precision");
1648
1649 mattype.mark_as_rectangular ();
1650 }
1651 else
1652 {
1653 if (calc_cond)
1654 {
1655 // Now calculate the condition number for
1656 // non-singular matrix.
1657 char job = '1';
1658 F77_XFCN (sgecon, SGECON, (F77_CONST_CHAR_ARG2 (&job, 1),
1659 nc, tmp_data, nr, anorm,
1660 rcond, pz, piz, info
1661 F77_CHAR_ARG_LEN (1)));
1662
1663 if (info != 0)
1664 info = -2;
1665
1666 volatile float rcond_plus_one = rcond + 1.0;
1667
1668 if (rcond_plus_one == 1.0 || xisnan (rcond))
1669 {
1670 info = -2;
1671
1672 if (sing_handler)
1673 sing_handler (rcond);
1674 else
1675 (*current_liboctave_error_handler)
1676 ("matrix singular to machine precision, rcond = %g",
1677 rcond);
1678 }
1679 }
1680
1681 if (info == 0)
1682 {
1683 retval = b;
1684 float *result = retval.fortran_vec ();
1685
1686 octave_idx_type b_nc = b.cols ();
1687
1688 char job = 'N';
1689 F77_XFCN (sgetrs, SGETRS, (F77_CONST_CHAR_ARG2 (&job, 1),
1690 nr, b_nc, tmp_data, nr,
1691 pipvt, result, b.rows(), info
1692 F77_CHAR_ARG_LEN (1)));
1693 }
1694 else
1695 mattype.mark_as_rectangular ();
1696 }
1697 }
1698 else if (typ != MatrixType::Hermitian)
1699 (*current_liboctave_error_handler) ("incorrect matrix type");
1700 }
1701
1702 return retval;
1703 }
1704
1705 FloatMatrix
1706 FloatMatrix::solve (MatrixType &typ, const FloatMatrix& b) const
1707 {
1708 octave_idx_type info;
1709 float rcond;
1710 return solve (typ, b, info, rcond, 0);
1711 }
1712
1713 FloatMatrix
1714 FloatMatrix::solve (MatrixType &typ, const FloatMatrix& b, octave_idx_type& info,
1715 float& rcond) const
1716 {
1717 return solve (typ, b, info, rcond, 0);
1718 }
1719
1720 FloatMatrix
1721 FloatMatrix::solve (MatrixType &mattype, const FloatMatrix& b, octave_idx_type& info,
1722 float& rcond, solve_singularity_handler sing_handler,
1723 bool singular_fallback) const
1724 {
1725 FloatMatrix retval;
1726 int typ = mattype.type ();
1727
1728 if (typ == MatrixType::Unknown)
1729 typ = mattype.type (*this);
1730
1731 // Only calculate the condition number for LU/Cholesky
1732 if (typ == MatrixType::Upper || typ == MatrixType::Permuted_Upper)
1733 retval = utsolve (mattype, b, info, rcond, sing_handler, false);
1734 else if (typ == MatrixType::Lower || typ == MatrixType::Permuted_Lower)
1735 retval = ltsolve (mattype, b, info, rcond, sing_handler, false);
1736 else if (typ == MatrixType::Full || typ == MatrixType::Hermitian)
1737 retval = fsolve (mattype, b, info, rcond, sing_handler, true);
1738 else if (typ != MatrixType::Rectangular)
1739 {
1740 (*current_liboctave_error_handler) ("unknown matrix type");
1741 return FloatMatrix ();
1742 }
1743
1744 // Rectangular or one of the above solvers flags a singular matrix
1745 if (singular_fallback && mattype.type () == MatrixType::Rectangular)
1746 {
1747 octave_idx_type rank;
1748 retval = lssolve (b, info, rank, rcond);
1749 }
1750
1751 return retval;
1752 }
1753
1754 FloatComplexMatrix
1755 FloatMatrix::solve (MatrixType &typ, const FloatComplexMatrix& b) const
1756 {
1757 FloatComplexMatrix tmp (*this);
1758 return tmp.solve (typ, b);
1759 }
1760
1761 FloatComplexMatrix
1762 FloatMatrix::solve (MatrixType &typ, const FloatComplexMatrix& b,
1763 octave_idx_type& info) const
1764 {
1765 FloatComplexMatrix tmp (*this);
1766 return tmp.solve (typ, b, info);
1767 }
1768
1769 FloatComplexMatrix
1770 FloatMatrix::solve (MatrixType &typ, const FloatComplexMatrix& b, octave_idx_type& info,
1771 float& rcond) const
1772 {
1773 FloatComplexMatrix tmp (*this);
1774 return tmp.solve (typ, b, info, rcond);
1775 }
1776
1777 FloatComplexMatrix
1778 FloatMatrix::solve (MatrixType &typ, const FloatComplexMatrix& b, octave_idx_type& info,
1779 float& rcond, solve_singularity_handler sing_handler,
1780 bool singular_fallback) const
1781 {
1782 FloatComplexMatrix tmp (*this);
1783 return tmp.solve (typ, b, info, rcond, sing_handler, singular_fallback);
1784 }
1785
1786 FloatColumnVector
1787 FloatMatrix::solve (MatrixType &typ, const FloatColumnVector& b) const
1788 {
1789 octave_idx_type info; float rcond;
1790 return solve (typ, b, info, rcond);
1791 }
1792
1793 FloatColumnVector
1794 FloatMatrix::solve (MatrixType &typ, const FloatColumnVector& b,
1795 octave_idx_type& info) const
1796 {
1797 float rcond;
1798 return solve (typ, b, info, rcond);
1799 }
1800
1801 FloatColumnVector
1802 FloatMatrix::solve (MatrixType &typ, const FloatColumnVector& b, octave_idx_type& info,
1803 float& rcond) const
1804 {
1805 return solve (typ, b, info, rcond, 0);
1806 }
1807
1808 FloatColumnVector
1809 FloatMatrix::solve (MatrixType &typ, const FloatColumnVector& b, octave_idx_type& info,
1810 float& rcond, solve_singularity_handler sing_handler) const
1811 {
1812 FloatMatrix tmp (b);
1813 return solve (typ, tmp, info, rcond, sing_handler).column(static_cast<octave_idx_type> (0));
1814 }
1815
1816 FloatComplexColumnVector
1817 FloatMatrix::solve (MatrixType &typ, const FloatComplexColumnVector& b) const
1818 {
1819 FloatComplexMatrix tmp (*this);
1820 return tmp.solve (typ, b);
1821 }
1822
1823 FloatComplexColumnVector
1824 FloatMatrix::solve (MatrixType &typ, const FloatComplexColumnVector& b,
1825 octave_idx_type& info) const
1826 {
1827 FloatComplexMatrix tmp (*this);
1828 return tmp.solve (typ, b, info);
1829 }
1830
1831 FloatComplexColumnVector
1832 FloatMatrix::solve (MatrixType &typ, const FloatComplexColumnVector& b,
1833 octave_idx_type& info, float& rcond) const
1834 {
1835 FloatComplexMatrix tmp (*this);
1836 return tmp.solve (typ, b, info, rcond);
1837 }
1838
1839 FloatComplexColumnVector
1840 FloatMatrix::solve (MatrixType &typ, const FloatComplexColumnVector& b,
1841 octave_idx_type& info, float& rcond,
1842 solve_singularity_handler sing_handler) const
1843 {
1844 FloatComplexMatrix tmp (*this);
1845 return tmp.solve(typ, b, info, rcond, sing_handler);
1846 }
1847
1848 FloatMatrix
1849 FloatMatrix::solve (const FloatMatrix& b) const
1850 {
1851 octave_idx_type info;
1852 float rcond;
1853 return solve (b, info, rcond, 0);
1854 }
1855
1856 FloatMatrix
1857 FloatMatrix::solve (const FloatMatrix& b, octave_idx_type& info) const
1858 {
1859 float rcond;
1860 return solve (b, info, rcond, 0);
1861 }
1862
1863 FloatMatrix
1864 FloatMatrix::solve (const FloatMatrix& b, octave_idx_type& info, float& rcond) const
1865 {
1866 return solve (b, info, rcond, 0);
1867 }
1868
1869 FloatMatrix
1870 FloatMatrix::solve (const FloatMatrix& b, octave_idx_type& info,
1871 float& rcond, solve_singularity_handler sing_handler) const
1872 {
1873 MatrixType mattype (*this);
1874 return solve (mattype, b, info, rcond, sing_handler);
1875 }
1876
1877 FloatComplexMatrix
1878 FloatMatrix::solve (const FloatComplexMatrix& b) const
1879 {
1880 FloatComplexMatrix tmp (*this);
1881 return tmp.solve (b);
1882 }
1883
1884 FloatComplexMatrix
1885 FloatMatrix::solve (const FloatComplexMatrix& b, octave_idx_type& info) const
1886 {
1887 FloatComplexMatrix tmp (*this);
1888 return tmp.solve (b, info);
1889 }
1890
1891 FloatComplexMatrix
1892 FloatMatrix::solve (const FloatComplexMatrix& b, octave_idx_type& info, float& rcond) const
1893 {
1894 FloatComplexMatrix tmp (*this);
1895 return tmp.solve (b, info, rcond);
1896 }
1897
1898 FloatComplexMatrix
1899 FloatMatrix::solve (const FloatComplexMatrix& b, octave_idx_type& info, float& rcond,
1900 solve_singularity_handler sing_handler) const
1901 {
1902 FloatComplexMatrix tmp (*this);
1903 return tmp.solve (b, info, rcond, sing_handler);
1904 }
1905
1906 FloatColumnVector
1907 FloatMatrix::solve (const FloatColumnVector& b) const
1908 {
1909 octave_idx_type info; float rcond;
1910 return solve (b, info, rcond);
1911 }
1912
1913 FloatColumnVector
1914 FloatMatrix::solve (const FloatColumnVector& b, octave_idx_type& info) const
1915 {
1916 float rcond;
1917 return solve (b, info, rcond);
1918 }
1919
1920 FloatColumnVector
1921 FloatMatrix::solve (const FloatColumnVector& b, octave_idx_type& info, float& rcond) const
1922 {
1923 return solve (b, info, rcond, 0);
1924 }
1925
1926 FloatColumnVector
1927 FloatMatrix::solve (const FloatColumnVector& b, octave_idx_type& info, float& rcond,
1928 solve_singularity_handler sing_handler) const
1929 {
1930 MatrixType mattype (*this);
1931 return solve (mattype, b, info, rcond, sing_handler);
1932 }
1933
1934 FloatComplexColumnVector
1935 FloatMatrix::solve (const FloatComplexColumnVector& b) const
1936 {
1937 FloatComplexMatrix tmp (*this);
1938 return tmp.solve (b);
1939 }
1940
1941 FloatComplexColumnVector
1942 FloatMatrix::solve (const FloatComplexColumnVector& b, octave_idx_type& info) const
1943 {
1944 FloatComplexMatrix tmp (*this);
1945 return tmp.solve (b, info);
1946 }
1947
1948 FloatComplexColumnVector
1949 FloatMatrix::solve (const FloatComplexColumnVector& b, octave_idx_type& info, float& rcond) const
1950 {
1951 FloatComplexMatrix tmp (*this);
1952 return tmp.solve (b, info, rcond);
1953 }
1954
1955 FloatComplexColumnVector
1956 FloatMatrix::solve (const FloatComplexColumnVector& b, octave_idx_type& info, float& rcond,
1957 solve_singularity_handler sing_handler) const
1958 {
1959 FloatComplexMatrix tmp (*this);
1960 return tmp.solve (b, info, rcond, sing_handler);
1961 }
1962
1963 FloatMatrix
1964 FloatMatrix::lssolve (const FloatMatrix& b) const
1965 {
1966 octave_idx_type info;
1967 octave_idx_type rank;
1968 float rcond;
1969 return lssolve (b, info, rank, rcond);
1970 }
1971
1972 FloatMatrix
1973 FloatMatrix::lssolve (const FloatMatrix& b, octave_idx_type& info) const
1974 {
1975 octave_idx_type rank;
1976 float rcond;
1977 return lssolve (b, info, rank, rcond);
1978 }
1979
1980 FloatMatrix
1981 FloatMatrix::lssolve (const FloatMatrix& b, octave_idx_type& info,
1982 octave_idx_type& rank) const
1983 {
1984 float rcond;
1985 return lssolve (b, info, rank, rcond);
1986 }
1987
1988 FloatMatrix
1989 FloatMatrix::lssolve (const FloatMatrix& b, octave_idx_type& info,
1990 octave_idx_type& rank, float &rcond) const
1991 {
1992 FloatMatrix retval;
1993
1994 octave_idx_type nrhs = b.cols ();
1995
1996 octave_idx_type m = rows ();
1997 octave_idx_type n = cols ();
1998
1999 if (m != b.rows ())
2000 (*current_liboctave_error_handler)
2001 ("matrix dimension mismatch solution of linear equations");
2002 else if (m == 0 || n == 0 || b.cols () == 0)
2003 retval = FloatMatrix (n, b.cols (), 0.0);
2004 else
2005 {
2006 volatile octave_idx_type minmn = (m < n ? m : n);
2007 octave_idx_type maxmn = m > n ? m : n;
2008 rcond = -1.0;
2009 if (m != n)
2010 {
2011 retval = FloatMatrix (maxmn, nrhs, 0.0);
2012
2013 for (octave_idx_type j = 0; j < nrhs; j++)
2014 for (octave_idx_type i = 0; i < m; i++)
2015 retval.elem (i, j) = b.elem (i, j);
2016 }
2017 else
2018 retval = b;
2019
2020 FloatMatrix atmp = *this;
2021 float *tmp_data = atmp.fortran_vec ();
2022
2023 float *pretval = retval.fortran_vec ();
2024 Array<float> s (minmn);
2025 float *ps = s.fortran_vec ();
2026
2027 // Ask DGELSD what the dimension of WORK should be.
2028 octave_idx_type lwork = -1;
2029
2030 Array<float> work (1);
2031
2032 octave_idx_type smlsiz;
2033 F77_FUNC (xilaenv, XILAENV) (9, F77_CONST_CHAR_ARG2 ("SGELSD", 6),
2034 F77_CONST_CHAR_ARG2 (" ", 1),
2035 0, 0, 0, 0, smlsiz
2036 F77_CHAR_ARG_LEN (6)
2037 F77_CHAR_ARG_LEN (1));
2038
2039 octave_idx_type mnthr;
2040 F77_FUNC (xilaenv, XILAENV) (6, F77_CONST_CHAR_ARG2 ("SGELSD", 6),
2041 F77_CONST_CHAR_ARG2 (" ", 1),
2042 m, n, nrhs, -1, mnthr
2043 F77_CHAR_ARG_LEN (6)
2044 F77_CHAR_ARG_LEN (1));
2045
2046 // We compute the size of iwork because DGELSD in older versions
2047 // of LAPACK does not return it on a query call.
2048 float dminmn = static_cast<float> (minmn);
2049 float dsmlsizp1 = static_cast<float> (smlsiz+1);
2050 #if defined (HAVE_LOG2)
2051 float tmp = log2 (dminmn / dsmlsizp1);
2052 #else
2053 float tmp = log (dminmn / dsmlsizp1) / log (2.0);
2054 #endif
2055 octave_idx_type nlvl = static_cast<octave_idx_type> (tmp) + 1;
2056 if (nlvl < 0)
2057 nlvl = 0;
2058
2059 octave_idx_type liwork = 3 * minmn * nlvl + 11 * minmn;
2060 if (liwork < 1)
2061 liwork = 1;
2062 Array<octave_idx_type> iwork (liwork);
2063 octave_idx_type* piwork = iwork.fortran_vec ();
2064
2065 F77_XFCN (sgelsd, SGELSD, (m, n, nrhs, tmp_data, m, pretval, maxmn,
2066 ps, rcond, rank, work.fortran_vec (),
2067 lwork, piwork, info));
2068
2069 // The workspace query is broken in at least LAPACK 3.0.0
2070 // through 3.1.1 when n >= mnthr. The obtuse formula below
2071 // should provide sufficient workspace for DGELSD to operate
2072 // efficiently.
2073 if (n >= mnthr)
2074 {
2075 const octave_idx_type wlalsd
2076 = 9*m + 2*m*smlsiz + 8*m*nlvl + m*nrhs + (smlsiz+1)*(smlsiz+1);
2077
2078 octave_idx_type addend = m;
2079
2080 if (2*m-4 > addend)
2081 addend = 2*m-4;
2082
2083 if (nrhs > addend)
2084 addend = nrhs;
2085
2086 if (n-3*m > addend)
2087 addend = n-3*m;
2088
2089 if (wlalsd > addend)
2090 addend = wlalsd;
2091
2092 const octave_idx_type lworkaround = 4*m + m*m + addend;
2093
2094 if (work(0) < lworkaround)
2095 work(0) = lworkaround;
2096 }
2097 else if (m >= n)
2098 {
2099 octave_idx_type lworkaround
2100 = 12*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs + (smlsiz+1)*(smlsiz+1);
2101
2102 if (work(0) < lworkaround)
2103 work(0) = lworkaround;
2104 }
2105
2106 lwork = static_cast<octave_idx_type> (work(0));
2107 work.resize (lwork);
2108
2109 F77_XFCN (sgelsd, SGELSD, (m, n, nrhs, tmp_data, m, pretval,
2110 maxmn, ps, rcond, rank,
2111 work.fortran_vec (), lwork,
2112 piwork, info));
2113
2114 if (rank < minmn)
2115 (*current_liboctave_warning_handler)
2116 ("dgelsd: rank deficient %dx%d matrix, rank = %d", m, n, rank);
2117 if (s.elem (0) == 0.0)
2118 rcond = 0.0;
2119 else
2120 rcond = s.elem (minmn - 1) / s.elem (0);
2121
2122 retval.resize (n, nrhs);
2123 }
2124
2125 return retval;
2126 }
2127
2128 FloatComplexMatrix
2129 FloatMatrix::lssolve (const FloatComplexMatrix& b) const
2130 {
2131 FloatComplexMatrix tmp (*this);
2132 octave_idx_type info;
2133 octave_idx_type rank;
2134 float rcond;
2135 return tmp.lssolve (b, info, rank, rcond);
2136 }
2137
2138 FloatComplexMatrix
2139 FloatMatrix::lssolve (const FloatComplexMatrix& b, octave_idx_type& info) const
2140 {
2141 FloatComplexMatrix tmp (*this);
2142 octave_idx_type rank;
2143 float rcond;
2144 return tmp.lssolve (b, info, rank, rcond);
2145 }
2146
2147 FloatComplexMatrix
2148 FloatMatrix::lssolve (const FloatComplexMatrix& b, octave_idx_type& info,
2149 octave_idx_type& rank) const
2150 {
2151 FloatComplexMatrix tmp (*this);
2152 float rcond;
2153 return tmp.lssolve (b, info, rank, rcond);
2154 }
2155
2156 FloatComplexMatrix
2157 FloatMatrix::lssolve (const FloatComplexMatrix& b, octave_idx_type& info,
2158 octave_idx_type& rank, float& rcond) const
2159 {
2160 FloatComplexMatrix tmp (*this);
2161 return tmp.lssolve (b, info, rank, rcond);
2162 }
2163
2164 FloatColumnVector
2165 FloatMatrix::lssolve (const FloatColumnVector& b) const
2166 {
2167 octave_idx_type info;
2168 octave_idx_type rank;
2169 float rcond;
2170 return lssolve (b, info, rank, rcond);
2171 }
2172
2173 FloatColumnVector
2174 FloatMatrix::lssolve (const FloatColumnVector& b, octave_idx_type& info) const
2175 {
2176 octave_idx_type rank;
2177 float rcond;
2178 return lssolve (b, info, rank, rcond);
2179 }
2180
2181 FloatColumnVector
2182 FloatMatrix::lssolve (const FloatColumnVector& b, octave_idx_type& info,
2183 octave_idx_type& rank) const
2184 {
2185 float rcond;
2186 return lssolve (b, info, rank, rcond);
2187 }
2188
2189 FloatColumnVector
2190 FloatMatrix::lssolve (const FloatColumnVector& b, octave_idx_type& info,
2191 octave_idx_type& rank, float &rcond) const
2192 {
2193 FloatColumnVector retval;
2194
2195 octave_idx_type nrhs = 1;
2196
2197 octave_idx_type m = rows ();
2198 octave_idx_type n = cols ();
2199
2200 if (m != b.length ())
2201 (*current_liboctave_error_handler)
2202 ("matrix dimension mismatch solution of linear equations");
2203 else if (m == 0 || n == 0)
2204 retval = FloatColumnVector (n, 0.0);
2205 else
2206 {
2207 volatile octave_idx_type minmn = (m < n ? m : n);
2208 octave_idx_type maxmn = m > n ? m : n;
2209 rcond = -1.0;
2210
2211 if (m != n)
2212 {
2213 retval = FloatColumnVector (maxmn, 0.0);
2214
2215 for (octave_idx_type i = 0; i < m; i++)
2216 retval.elem (i) = b.elem (i);
2217 }
2218 else
2219 retval = b;
2220
2221 FloatMatrix atmp = *this;
2222 float *tmp_data = atmp.fortran_vec ();
2223
2224 float *pretval = retval.fortran_vec ();
2225 Array<float> s (minmn);
2226 float *ps = s.fortran_vec ();
2227
2228 // Ask DGELSD what the dimension of WORK should be.
2229 octave_idx_type lwork = -1;
2230
2231 Array<float> work (1);
2232
2233 octave_idx_type smlsiz;
2234 F77_FUNC (xilaenv, XILAENV) (9, F77_CONST_CHAR_ARG2 ("SGELSD", 6),
2235 F77_CONST_CHAR_ARG2 (" ", 1),
2236 0, 0, 0, 0, smlsiz
2237 F77_CHAR_ARG_LEN (6)
2238 F77_CHAR_ARG_LEN (1));
2239
2240 // We compute the size of iwork because DGELSD in older versions
2241 // of LAPACK does not return it on a query call.
2242 float dminmn = static_cast<float> (minmn);
2243 float dsmlsizp1 = static_cast<float> (smlsiz+1);
2244 #if defined (HAVE_LOG2)
2245 float tmp = log2 (dminmn / dsmlsizp1);
2246 #else
2247 float tmp = log (dminmn / dsmlsizp1) / log (2.0);
2248 #endif
2249 octave_idx_type nlvl = static_cast<octave_idx_type> (tmp) + 1;
2250 if (nlvl < 0)
2251 nlvl = 0;
2252
2253 octave_idx_type liwork = 3 * minmn * nlvl + 11 * minmn;
2254 if (liwork < 1)
2255 liwork = 1;
2256 Array<octave_idx_type> iwork (liwork);
2257 octave_idx_type* piwork = iwork.fortran_vec ();
2258
2259 F77_XFCN (sgelsd, SGELSD, (m, n, nrhs, tmp_data, m, pretval, maxmn,
2260 ps, rcond, rank, work.fortran_vec (),
2261 lwork, piwork, info));
2262
2263 lwork = static_cast<octave_idx_type> (work(0));
2264 work.resize (lwork);
2265
2266 F77_XFCN (sgelsd, SGELSD, (m, n, nrhs, tmp_data, m, pretval,
2267 maxmn, ps, rcond, rank,
2268 work.fortran_vec (), lwork,
2269 piwork, info));
2270
2271 if (rank < minmn)
2272 {
2273 if (rank < minmn)
2274 (*current_liboctave_warning_handler)
2275 ("dgelsd: rank deficient %dx%d matrix, rank = %d", m, n, rank);
2276 if (s.elem (0) == 0.0)
2277 rcond = 0.0;
2278 else
2279 rcond = s.elem (minmn - 1) / s.elem (0);
2280 }
2281
2282 retval.resize (n, nrhs);
2283 }
2284
2285 return retval;
2286 }
2287
2288 FloatComplexColumnVector
2289 FloatMatrix::lssolve (const FloatComplexColumnVector& b) const
2290 {
2291 FloatComplexMatrix tmp (*this);
2292 octave_idx_type info;
2293 octave_idx_type rank;
2294 float rcond;
2295 return tmp.lssolve (b, info, rank, rcond);
2296 }
2297
2298 FloatComplexColumnVector
2299 FloatMatrix::lssolve (const FloatComplexColumnVector& b, octave_idx_type& info) const
2300 {
2301 FloatComplexMatrix tmp (*this);
2302 octave_idx_type rank;
2303 float rcond;
2304 return tmp.lssolve (b, info, rank, rcond);
2305 }
2306
2307 FloatComplexColumnVector
2308 FloatMatrix::lssolve (const FloatComplexColumnVector& b, octave_idx_type& info,
2309 octave_idx_type& rank) const
2310 {
2311 FloatComplexMatrix tmp (*this);
2312 float rcond;
2313 return tmp.lssolve (b, info, rank, rcond);
2314 }
2315
2316 FloatComplexColumnVector
2317 FloatMatrix::lssolve (const FloatComplexColumnVector& b, octave_idx_type& info,
2318 octave_idx_type& rank, float &rcond) const
2319 {
2320 FloatComplexMatrix tmp (*this);
2321 return tmp.lssolve (b, info, rank, rcond);
2322 }
2323
2324 // Constants for matrix exponential calculation.
2325
2326 static float padec [] =
2327 {
2328 5.0000000000000000e-1,
2329 1.1666666666666667e-1,
2330 1.6666666666666667e-2,
2331 1.6025641025641026e-3,
2332 1.0683760683760684e-4,
2333 4.8562548562548563e-6,
2334 1.3875013875013875e-7,
2335 1.9270852604185938e-9,
2336 };
2337
2338 static void
2339 solve_singularity_warning (float rcond)
2340 {
2341 (*current_liboctave_warning_handler)
2342 ("singular matrix encountered in expm calculation, rcond = %g",
2343 rcond);
2344 }
2345
2346 FloatMatrix
2347 FloatMatrix::expm (void) const
2348 {
2349 FloatMatrix retval;
2350
2351 FloatMatrix m = *this;
2352
2353 if (numel () == 1)
2354 return FloatMatrix (1, 1, exp (m(0)));
2355
2356 octave_idx_type nc = columns ();
2357
2358 // Preconditioning step 1: trace normalization to reduce dynamic
2359 // range of poles, but avoid making stable eigenvalues unstable.
2360
2361 // trace shift value
2362 volatile float trshift = 0.0;
2363
2364 for (octave_idx_type i = 0; i < nc; i++)
2365 trshift += m.elem (i, i);
2366
2367 trshift /= nc;
2368
2369 if (trshift > 0.0)
2370 {
2371 for (octave_idx_type i = 0; i < nc; i++)
2372 m.elem (i, i) -= trshift;
2373 }
2374
2375 // Preconditioning step 2: balancing; code follows development
2376 // in AEPBAL
2377
2378 float *p_m = m.fortran_vec ();
2379
2380 octave_idx_type info, ilo, ihi, ilos, ihis;
2381 Array<float> dpermute (nc);
2382 Array<float> dscale (nc);
2383
2384 // permutation first
2385 char job = 'P';
2386 F77_XFCN (sgebal, SGEBAL, (F77_CONST_CHAR_ARG2 (&job, 1),
2387 nc, p_m, nc, ilo, ihi,
2388 dpermute.fortran_vec (), info
2389 F77_CHAR_ARG_LEN (1)));
2390
2391 // then scaling
2392 job = 'S';
2393 F77_XFCN (sgebal, SGEBAL, (F77_CONST_CHAR_ARG2 (&job, 1),
2394 nc, p_m, nc, ilos, ihis,
2395 dscale.fortran_vec (), info
2396 F77_CHAR_ARG_LEN (1)));
2397
2398 // Preconditioning step 3: scaling.
2399
2400 FloatColumnVector work(nc);
2401 float inf_norm;
2402
2403 F77_XFCN (xslange, XSLANGE, (F77_CONST_CHAR_ARG2 ("I", 1),
2404 nc, nc, m.fortran_vec (), nc,
2405 work.fortran_vec (), inf_norm
2406 F77_CHAR_ARG_LEN (1)));
2407
2408 octave_idx_type sqpow = static_cast<octave_idx_type> (inf_norm > 0.0
2409 ? (1.0 + log (inf_norm) / log (2.0))
2410 : 0.0);
2411
2412 // Check whether we need to square at all.
2413
2414 if (sqpow < 0)
2415 sqpow = 0;
2416
2417 if (sqpow > 0)
2418 {
2419 if (sqpow > 1023)
2420 sqpow = 1023;
2421
2422 float scale_factor = 1.0;
2423 for (octave_idx_type i = 0; i < sqpow; i++)
2424 scale_factor *= 2.0;
2425
2426 m = m / scale_factor;
2427 }
2428
2429 // npp, dpp: pade' approx polynomial matrices.
2430
2431 FloatMatrix npp (nc, nc, 0.0);
2432 float *pnpp = npp.fortran_vec ();
2433 FloatMatrix dpp = npp;
2434 float *pdpp = dpp.fortran_vec ();
2435
2436 // Now powers a^8 ... a^1.
2437
2438 octave_idx_type minus_one_j = -1;
2439 for (octave_idx_type j = 7; j >= 0; j--)
2440 {
2441 for (octave_idx_type i = 0; i < nc; i++)
2442 {
2443 octave_idx_type k = i * nc + i;
2444 pnpp[k] += padec[j];
2445 pdpp[k] += minus_one_j * padec[j];
2446 }
2447
2448 npp = m * npp;
2449 pnpp = npp.fortran_vec ();
2450
2451 dpp = m * dpp;
2452 pdpp = dpp.fortran_vec ();
2453
2454 minus_one_j *= -1;
2455 }
2456
2457 // Zero power.
2458
2459 dpp = -dpp;
2460 for (octave_idx_type j = 0; j < nc; j++)
2461 {
2462 npp.elem (j, j) += 1.0;
2463 dpp.elem (j, j) += 1.0;
2464 }
2465
2466 // Compute pade approximation = inverse (dpp) * npp.
2467
2468 float rcond;
2469 retval = dpp.solve (npp, info, rcond, solve_singularity_warning);
2470
2471 if (info < 0)
2472 return retval;
2473
2474 // Reverse preconditioning step 3: repeated squaring.
2475
2476 while (sqpow)
2477 {
2478 retval = retval * retval;
2479 sqpow--;
2480 }
2481
2482 // Reverse preconditioning step 2: inverse balancing.
2483 // apply inverse scaling to computed exponential
2484 for (octave_idx_type i = 0; i < nc; i++)
2485 for (octave_idx_type j = 0; j < nc; j++)
2486 retval(i,j) *= dscale(i) / dscale(j);
2487
2488 OCTAVE_QUIT;
2489
2490 // construct balancing permutation vector
2491 Array<octave_idx_type> iperm (nc);
2492 for (octave_idx_type i = 0; i < nc; i++)
2493 iperm(i) = i; // identity permutation
2494
2495 // leading permutations in forward order
2496 for (octave_idx_type i = 0; i < (ilo-1); i++)
2497 {
2498 octave_idx_type swapidx = static_cast<octave_idx_type> (dpermute(i)) - 1;
2499 octave_idx_type tmp = iperm(i);
2500 iperm(i) = iperm (swapidx);
2501 iperm(swapidx) = tmp;
2502 }
2503
2504 // construct inverse balancing permutation vector
2505 Array<octave_idx_type> invpvec (nc);
2506 for (octave_idx_type i = 0; i < nc; i++)
2507 invpvec(iperm(i)) = i; // Thanks to R. A. Lippert for this method
2508
2509 OCTAVE_QUIT;
2510
2511 FloatMatrix tmpMat = retval;
2512 for (octave_idx_type i = 0; i < nc; i++)
2513 for (octave_idx_type j = 0; j < nc; j++)
2514 retval(i,j) = tmpMat(invpvec(i),invpvec(j));
2515
2516 OCTAVE_QUIT;
2517
2518 for (octave_idx_type i = 0; i < nc; i++)
2519 iperm(i) = i; // identity permutation
2520
2521 // trailing permutations must be done in reverse order
2522 for (octave_idx_type i = nc - 1; i >= ihi; i--)
2523 {
2524 octave_idx_type swapidx = static_cast<octave_idx_type> (dpermute(i)) - 1;
2525 octave_idx_type tmp = iperm(i);
2526 iperm(i) = iperm(swapidx);
2527 iperm(swapidx) = tmp;
2528 }
2529
2530 // construct inverse balancing permutation vector
2531 for (octave_idx_type i = 0; i < nc; i++)
2532 invpvec(iperm(i)) = i; // Thanks to R. A. Lippert for this method
2533
2534 OCTAVE_QUIT;
2535
2536 tmpMat = retval;
2537 for (octave_idx_type i = 0; i < nc; i++)
2538 for (octave_idx_type j = 0; j < nc; j++)
2539 retval(i,j) = tmpMat(invpvec(i),invpvec(j));
2540
2541 // Reverse preconditioning step 1: fix trace normalization.
2542
2543 if (trshift > 0.0)
2544 retval = expf (trshift) * retval;
2545
2546 return retval;
2547 }
2548
2549 FloatMatrix&
2550 FloatMatrix::operator += (const FloatDiagMatrix& a)
2551 {
2552 octave_idx_type nr = rows ();
2553 octave_idx_type nc = cols ();
2554
2555 octave_idx_type a_nr = a.rows ();
2556 octave_idx_type a_nc = a.cols ();
2557
2558 if (nr != a_nr || nc != a_nc)
2559 {
2560 gripe_nonconformant ("operator +=", nr, nc, a_nr, a_nc);
2561 return *this;
2562 }
2563
2564 for (octave_idx_type i = 0; i < a.length (); i++)
2565 elem (i, i) += a.elem (i, i);
2566
2567 return *this;
2568 }
2569
2570 FloatMatrix&
2571 FloatMatrix::operator -= (const FloatDiagMatrix& a)
2572 {
2573 octave_idx_type nr = rows ();
2574 octave_idx_type nc = cols ();
2575
2576 octave_idx_type a_nr = a.rows ();
2577 octave_idx_type a_nc = a.cols ();
2578
2579 if (nr != a_nr || nc != a_nc)
2580 {
2581 gripe_nonconformant ("operator -=", nr, nc, a_nr, a_nc);
2582 return *this;
2583 }
2584
2585 for (octave_idx_type i = 0; i < a.length (); i++)
2586 elem (i, i) -= a.elem (i, i);
2587
2588 return *this;
2589 }
2590
2591 // unary operations
2592
2593 boolMatrix
2594 FloatMatrix::operator ! (void) const
2595 {
2596 octave_idx_type nr = rows ();
2597 octave_idx_type nc = cols ();
2598
2599 boolMatrix b (nr, nc);
2600
2601 for (octave_idx_type j = 0; j < nc; j++)
2602 for (octave_idx_type i = 0; i < nr; i++)
2603 b.elem (i, j) = ! elem (i, j);
2604
2605 return b;
2606 }
2607
2608 // column vector by row vector -> matrix operations
2609
2610 FloatMatrix
2611 operator * (const FloatColumnVector& v, const FloatRowVector& a)
2612 {
2613 FloatMatrix retval;
2614
2615 octave_idx_type len = v.length ();
2616
2617 if (len != 0)
2618 {
2619 octave_idx_type a_len = a.length ();
2620
2621 retval.resize (len, a_len);
2622 float *c = retval.fortran_vec ();
2623
2624 F77_XFCN (sgemm, SGEMM, (F77_CONST_CHAR_ARG2 ("N", 1),
2625 F77_CONST_CHAR_ARG2 ("N", 1),
2626 len, a_len, 1, 1.0, v.data (), len,
2627 a.data (), 1, 0.0, c, len
2628 F77_CHAR_ARG_LEN (1)
2629 F77_CHAR_ARG_LEN (1)));
2630 }
2631
2632 return retval;
2633 }
2634
2635 // other operations.
2636
2637 FloatMatrix
2638 FloatMatrix::map (dmapper fcn) const
2639 {
2640 return MArray2<float>::map<float> (func_ptr (fcn));
2641 }
2642
2643 FloatComplexMatrix
2644 FloatMatrix::map (cmapper fcn) const
2645 {
2646 return MArray2<float>::map<FloatComplex> (func_ptr (fcn));
2647 }
2648
2649 boolMatrix
2650 FloatMatrix::map (bmapper fcn) const
2651 {
2652 return MArray2<float>::map<bool> (func_ptr (fcn));
2653 }
2654
2655 bool
2656 FloatMatrix::any_element_is_negative (bool neg_zero) const
2657 {
2658 octave_idx_type nel = nelem ();
2659
2660 if (neg_zero)
2661 {
2662 for (octave_idx_type i = 0; i < nel; i++)
2663 if (lo_ieee_signbit (elem (i)))
2664 return true;
2665 }
2666 else
2667 {
2668 for (octave_idx_type i = 0; i < nel; i++)
2669 if (elem (i) < 0)
2670 return true;
2671 }
2672
2673 return false;
2674 }
2675
2676
2677 bool
2678 FloatMatrix::any_element_is_inf_or_nan (void) const
2679 {
2680 octave_idx_type nel = nelem ();
2681
2682 for (octave_idx_type i = 0; i < nel; i++)
2683 {
2684 float val = elem (i);
2685 if (xisinf (val) || xisnan (val))
2686 return true;
2687 }
2688
2689 return false;
2690 }
2691
2692 bool
2693 FloatMatrix::any_element_not_one_or_zero (void) const
2694 {
2695 octave_idx_type nel = nelem ();
2696
2697 for (octave_idx_type i = 0; i < nel; i++)
2698 {
2699 float val = elem (i);
2700 if (val != 0 && val != 1)
2701 return true;
2702 }
2703
2704 return false;
2705 }
2706
2707 bool
2708 FloatMatrix::all_elements_are_int_or_inf_or_nan (void) const
2709 {
2710 octave_idx_type nel = nelem ();
2711
2712 for (octave_idx_type i = 0; i < nel; i++)
2713 {
2714 float val = elem (i);
2715 if (xisnan (val) || D_NINT (val) == val)
2716 continue;
2717 else
2718 return false;
2719 }
2720
2721 return true;
2722 }
2723
2724 // Return nonzero if any element of M is not an integer. Also extract
2725 // the largest and smallest values and return them in MAX_VAL and MIN_VAL.
2726
2727 bool
2728 FloatMatrix::all_integers (float& max_val, float& min_val) const
2729 {
2730 octave_idx_type nel = nelem ();
2731
2732 if (nel > 0)
2733 {
2734 max_val = elem (0);
2735 min_val = elem (0);
2736 }
2737 else
2738 return false;
2739
2740 for (octave_idx_type i = 0; i < nel; i++)
2741 {
2742 float val = elem (i);
2743
2744 if (val > max_val)
2745 max_val = val;
2746
2747 if (val < min_val)
2748 min_val = val;
2749
2750 if (D_NINT (val) != val)
2751 return false;
2752 }
2753
2754 return true;
2755 }
2756
2757 bool
2758 FloatMatrix::too_large_for_float (void) const
2759 {
2760 octave_idx_type nel = nelem ();
2761
2762 for (octave_idx_type i = 0; i < nel; i++)
2763 {
2764 float val = elem (i);
2765
2766 if (! (xisnan (val) || xisinf (val))
2767 && fabs (val) > FLT_MAX)
2768 return true;
2769 }
2770
2771 return false;
2772 }
2773
2774 // FIXME Do these really belong here? Maybe they should be
2775 // in a base class?
2776
2777 boolMatrix
2778 FloatMatrix::all (int dim) const
2779 {
2780 MX_ALL_OP (dim);
2781 }
2782
2783 boolMatrix
2784 FloatMatrix::any (int dim) const
2785 {
2786 MX_ANY_OP (dim);
2787 }
2788
2789 FloatMatrix
2790 FloatMatrix::cumprod (int dim) const
2791 {
2792 MX_CUMULATIVE_OP (FloatMatrix, float, *=);
2793 }
2794
2795 FloatMatrix
2796 FloatMatrix::cumsum (int dim) const
2797 {
2798 MX_CUMULATIVE_OP (FloatMatrix, float, +=);
2799 }
2800
2801 FloatMatrix
2802 FloatMatrix::prod (int dim) const
2803 {
2804 MX_REDUCTION_OP (FloatMatrix, *=, 1.0, 1.0);
2805 }
2806
2807 FloatMatrix
2808 FloatMatrix::sum (int dim) const
2809 {
2810 MX_REDUCTION_OP (FloatMatrix, +=, 0.0, 0.0);
2811 }
2812
2813 FloatMatrix
2814 FloatMatrix::sumsq (int dim) const
2815 {
2816 #define ROW_EXPR \
2817 float d = elem (i, j); \
2818 retval.elem (i, 0) += d * d
2819
2820 #define COL_EXPR \
2821 float d = elem (i, j); \
2822 retval.elem (0, j) += d * d
2823
2824 MX_BASE_REDUCTION_OP (FloatMatrix, ROW_EXPR, COL_EXPR, 0.0, 0.0);
2825
2826 #undef ROW_EXPR
2827 #undef COL_EXPR
2828 }
2829
2830 FloatMatrix
2831 FloatMatrix::abs (void) const
2832 {
2833 octave_idx_type nr = rows ();
2834 octave_idx_type nc = cols ();
2835
2836 FloatMatrix retval (nr, nc);
2837
2838 for (octave_idx_type j = 0; j < nc; j++)
2839 for (octave_idx_type i = 0; i < nr; i++)
2840 retval (i, j) = fabs (elem (i, j));
2841
2842 return retval;
2843 }
2844
2845 FloatMatrix
2846 FloatMatrix::diag (octave_idx_type k) const
2847 {
2848 return MArray2<float>::diag (k);
2849 }
2850
2851 FloatColumnVector
2852 FloatMatrix::row_min (void) const
2853 {
2854 Array<octave_idx_type> dummy_idx;
2855 return row_min (dummy_idx);
2856 }
2857
2858 FloatColumnVector
2859 FloatMatrix::row_min (Array<octave_idx_type>& idx_arg) const
2860 {
2861 FloatColumnVector result;
2862
2863 octave_idx_type nr = rows ();
2864 octave_idx_type nc = cols ();
2865
2866 if (nr > 0 && nc > 0)
2867 {
2868 result.resize (nr);
2869 idx_arg.resize (nr);
2870
2871 for (octave_idx_type i = 0; i < nr; i++)
2872 {
2873 octave_idx_type idx_j;
2874
2875 float tmp_min = octave_Float_NaN;
2876
2877 for (idx_j = 0; idx_j < nc; idx_j++)
2878 {
2879 tmp_min = elem (i, idx_j);
2880
2881 if (! xisnan (tmp_min))
2882 break;
2883 }
2884
2885 for (octave_idx_type j = idx_j+1; j < nc; j++)
2886 {
2887 float tmp = elem (i, j);
2888
2889 if (xisnan (tmp))
2890 continue;
2891 else if (tmp < tmp_min)
2892 {
2893 idx_j = j;
2894 tmp_min = tmp;
2895 }
2896 }
2897
2898 result.elem (i) = tmp_min;
2899 idx_arg.elem (i) = xisnan (tmp_min) ? 0 : idx_j;
2900 }
2901 }
2902
2903 return result;
2904 }
2905
2906 FloatColumnVector
2907 FloatMatrix::row_max (void) const
2908 {
2909 Array<octave_idx_type> dummy_idx;
2910 return row_max (dummy_idx);
2911 }
2912
2913 FloatColumnVector
2914 FloatMatrix::row_max (Array<octave_idx_type>& idx_arg) const
2915 {
2916 FloatColumnVector result;
2917
2918 octave_idx_type nr = rows ();
2919 octave_idx_type nc = cols ();
2920
2921 if (nr > 0 && nc > 0)
2922 {
2923 result.resize (nr);
2924 idx_arg.resize (nr);
2925
2926 for (octave_idx_type i = 0; i < nr; i++)
2927 {
2928 octave_idx_type idx_j;
2929
2930 float tmp_max = octave_Float_NaN;
2931
2932 for (idx_j = 0; idx_j < nc; idx_j++)
2933 {
2934 tmp_max = elem (i, idx_j);
2935
2936 if (! xisnan (tmp_max))
2937 break;
2938 }
2939
2940 for (octave_idx_type j = idx_j+1; j < nc; j++)
2941 {
2942 float tmp = elem (i, j);
2943
2944 if (xisnan (tmp))
2945 continue;
2946 else if (tmp > tmp_max)
2947 {
2948 idx_j = j;
2949 tmp_max = tmp;
2950 }
2951 }
2952
2953 result.elem (i) = tmp_max;
2954 idx_arg.elem (i) = xisnan (tmp_max) ? 0 : idx_j;
2955 }
2956 }
2957
2958 return result;
2959 }
2960
2961 FloatRowVector
2962 FloatMatrix::column_min (void) const
2963 {
2964 Array<octave_idx_type> dummy_idx;
2965 return column_min (dummy_idx);
2966 }
2967
2968 FloatRowVector
2969 FloatMatrix::column_min (Array<octave_idx_type>& idx_arg) const
2970 {
2971 FloatRowVector 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 (nc);
2979 idx_arg.resize (nc);
2980
2981 for (octave_idx_type j = 0; j < nc; j++)
2982 {
2983 octave_idx_type idx_i;
2984
2985 float tmp_min = octave_Float_NaN;
2986
2987 for (idx_i = 0; idx_i < nr; idx_i++)
2988 {
2989 tmp_min = elem (idx_i, j);
2990
2991 if (! xisnan (tmp_min))
2992 break;
2993 }
2994
2995 for (octave_idx_type i = idx_i+1; i < nr; i++)
2996 {
2997 float tmp = elem (i, j);
2998
2999 if (xisnan (tmp))
3000 continue;
3001 else if (tmp < tmp_min)
3002 {
3003 idx_i = i;
3004 tmp_min = tmp;
3005 }
3006 }
3007
3008 result.elem (j) = tmp_min;
3009 idx_arg.elem (j) = xisnan (tmp_min) ? 0 : idx_i;
3010 }
3011 }
3012
3013 return result;
3014 }
3015
3016 FloatRowVector
3017 FloatMatrix::column_max (void) const
3018 {
3019 Array<octave_idx_type> dummy_idx;
3020 return column_max (dummy_idx);
3021 }
3022
3023 FloatRowVector
3024 FloatMatrix::column_max (Array<octave_idx_type>& idx_arg) const
3025 {
3026 FloatRowVector result;
3027
3028 octave_idx_type nr = rows ();
3029 octave_idx_type nc = cols ();
3030
3031 if (nr > 0 && nc > 0)
3032 {
3033 result.resize (nc);
3034 idx_arg.resize (nc);
3035
3036 for (octave_idx_type j = 0; j < nc; j++)
3037 {
3038 octave_idx_type idx_i;
3039
3040 float tmp_max = octave_Float_NaN;
3041
3042 for (idx_i = 0; idx_i < nr; idx_i++)
3043 {
3044 tmp_max = elem (idx_i, j);
3045
3046 if (! xisnan (tmp_max))
3047 break;
3048 }
3049
3050 for (octave_idx_type i = idx_i+1; i < nr; i++)
3051 {
3052 float tmp = elem (i, j);
3053
3054 if (xisnan (tmp))
3055 continue;
3056 else if (tmp > tmp_max)
3057 {
3058 idx_i = i;
3059 tmp_max = tmp;
3060 }
3061 }
3062
3063 result.elem (j) = tmp_max;
3064 idx_arg.elem (j) = xisnan (tmp_max) ? 0 : idx_i;
3065 }
3066 }
3067
3068 return result;
3069 }
3070
3071 std::ostream&
3072 operator << (std::ostream& os, const FloatMatrix& a)
3073 {
3074 for (octave_idx_type i = 0; i < a.rows (); i++)
3075 {
3076 for (octave_idx_type j = 0; j < a.cols (); j++)
3077 {
3078 os << " ";
3079 octave_write_float (os, a.elem (i, j));
3080 }
3081 os << "\n";
3082 }
3083 return os;
3084 }
3085
3086 std::istream&
3087 operator >> (std::istream& is, FloatMatrix& a)
3088 {
3089 octave_idx_type nr = a.rows ();
3090 octave_idx_type nc = a.cols ();
3091
3092 if (nr < 1 || nc < 1)
3093 is.clear (std::ios::badbit);
3094 else
3095 {
3096 float tmp;
3097 for (octave_idx_type i = 0; i < nr; i++)
3098 for (octave_idx_type j = 0; j < nc; j++)
3099 {
3100 tmp = octave_read_float (is);
3101 if (is)
3102 a.elem (i, j) = tmp;
3103 else
3104 goto done;
3105 }
3106 }
3107
3108 done:
3109
3110 return is;
3111 }
3112
3113 FloatMatrix
3114 Givens (float x, float y)
3115 {
3116 float cc, s, temp_r;
3117
3118 F77_FUNC (slartg, SLARTG) (x, y, cc, s, temp_r);
3119
3120 FloatMatrix g (2, 2);
3121
3122 g.elem (0, 0) = cc;
3123 g.elem (1, 1) = cc;
3124 g.elem (0, 1) = s;
3125 g.elem (1, 0) = -s;
3126
3127 return g;
3128 }
3129
3130 FloatMatrix
3131 Sylvester (const FloatMatrix& a, const FloatMatrix& b, const FloatMatrix& c)
3132 {
3133 FloatMatrix retval;
3134
3135 // FIXME -- need to check that a, b, and c are all the same
3136 // size.
3137
3138 // Compute Schur decompositions.
3139
3140 FloatSCHUR as (a, "U");
3141 FloatSCHUR bs (b, "U");
3142
3143 // Transform c to new coordinates.
3144
3145 FloatMatrix ua = as.unitary_matrix ();
3146 FloatMatrix sch_a = as.schur_matrix ();
3147
3148 FloatMatrix ub = bs.unitary_matrix ();
3149 FloatMatrix sch_b = bs.schur_matrix ();
3150
3151 FloatMatrix cx = ua.transpose () * c * ub;
3152
3153 // Solve the sylvester equation, back-transform, and return the
3154 // solution.
3155
3156 octave_idx_type a_nr = a.rows ();
3157 octave_idx_type b_nr = b.rows ();
3158
3159 float scale;
3160 octave_idx_type info;
3161
3162 float *pa = sch_a.fortran_vec ();
3163 float *pb = sch_b.fortran_vec ();
3164 float *px = cx.fortran_vec ();
3165
3166 F77_XFCN (strsyl, STRSYL, (F77_CONST_CHAR_ARG2 ("N", 1),
3167 F77_CONST_CHAR_ARG2 ("N", 1),
3168 1, a_nr, b_nr, pa, a_nr, pb,
3169 b_nr, px, a_nr, scale, info
3170 F77_CHAR_ARG_LEN (1)
3171 F77_CHAR_ARG_LEN (1)));
3172
3173
3174 // FIXME -- check info?
3175
3176 retval = -ua*cx*ub.transpose ();
3177
3178 return retval;
3179 }
3180
3181 // matrix by matrix -> matrix operations
3182
3183 /* Simple Dot Product, Matrix-Vector and Matrix-Matrix Unit tests
3184 %!assert([1 2 3] * [ 4 ; 5 ; 6], 32, 1e-14)
3185 %!assert([1 2 ; 3 4 ] * [5 ; 6], [17 ; 39 ], 1e-14)
3186 %!assert([1 2 ; 3 4 ] * [5 6 ; 7 8], [19 22; 43 50], 1e-14)
3187 */
3188
3189 /* Test some simple identities
3190 %!shared M, cv, rv
3191 %! M = randn(10,10);
3192 %! cv = randn(10,1);
3193 %! rv = randn(1,10);
3194 %!assert([M*cv,M*cv],M*[cv,cv],1e-14)
3195 %!assert([rv*M;rv*M],[rv;rv]*M,1e-14)
3196 %!assert(2*rv*cv,[rv,rv]*[cv;cv],1e-14)
3197 */
3198
3199
3200 FloatMatrix
3201 operator * (const FloatMatrix& m, const FloatMatrix& a)
3202 {
3203 FloatMatrix retval;
3204
3205 octave_idx_type nr = m.rows ();
3206 octave_idx_type nc = m.cols ();
3207
3208 octave_idx_type a_nr = a.rows ();
3209 octave_idx_type a_nc = a.cols ();
3210
3211 if (nc != a_nr)
3212 gripe_nonconformant ("operator *", nr, nc, a_nr, a_nc);
3213 else
3214 {
3215 if (nr == 0 || nc == 0 || a_nc == 0)
3216 retval.resize (nr, a_nc, 0.0);
3217 else
3218 {
3219 octave_idx_type ld = nr;
3220 octave_idx_type lda = a_nr;
3221
3222 retval.resize (nr, a_nc);
3223 float *c = retval.fortran_vec ();
3224
3225 if (a_nc == 1)
3226 {
3227 if (nr == 1)
3228 F77_FUNC (xsdot, XSDOT) (nc, m.data (), 1, a.data (), 1, *c);
3229 else
3230 {
3231 F77_XFCN (sgemv, SGEMV, (F77_CONST_CHAR_ARG2 ("N", 1),
3232 nr, nc, 1.0, m.data (), ld,
3233 a.data (), 1, 0.0, c, 1
3234 F77_CHAR_ARG_LEN (1)));
3235 }
3236 }
3237 else
3238 {
3239 F77_XFCN (sgemm, SGEMM, (F77_CONST_CHAR_ARG2 ("N", 1),
3240 F77_CONST_CHAR_ARG2 ("N", 1),
3241 nr, a_nc, nc, 1.0, m.data (),
3242 ld, a.data (), lda, 0.0, c, nr
3243 F77_CHAR_ARG_LEN (1)
3244 F77_CHAR_ARG_LEN (1)));
3245 }
3246 }
3247 }
3248
3249 return retval;
3250 }
3251
3252 // FIXME -- it would be nice to share code among the min/max
3253 // functions below.
3254
3255 #define EMPTY_RETURN_CHECK(T) \
3256 if (nr == 0 || nc == 0) \
3257 return T (nr, nc);
3258
3259 FloatMatrix
3260 min (float d, const FloatMatrix& m)
3261 {
3262 octave_idx_type nr = m.rows ();
3263 octave_idx_type nc = m.columns ();
3264
3265 EMPTY_RETURN_CHECK (FloatMatrix);
3266
3267 FloatMatrix result (nr, nc);
3268
3269 for (octave_idx_type j = 0; j < nc; j++)
3270 for (octave_idx_type i = 0; i < nr; i++)
3271 {
3272 OCTAVE_QUIT;
3273 result (i, j) = xmin (d, m (i, j));
3274 }
3275
3276 return result;
3277 }
3278
3279 FloatMatrix
3280 min (const FloatMatrix& m, float d)
3281 {
3282 octave_idx_type nr = m.rows ();
3283 octave_idx_type nc = m.columns ();
3284
3285 EMPTY_RETURN_CHECK (FloatMatrix);
3286
3287 FloatMatrix result (nr, nc);
3288
3289 for (octave_idx_type j = 0; j < nc; j++)
3290 for (octave_idx_type i = 0; i < nr; i++)
3291 {
3292 OCTAVE_QUIT;
3293 result (i, j) = xmin (m (i, j), d);
3294 }
3295
3296 return result;
3297 }
3298
3299 FloatMatrix
3300 min (const FloatMatrix& a, const FloatMatrix& b)
3301 {
3302 octave_idx_type nr = a.rows ();
3303 octave_idx_type nc = a.columns ();
3304
3305 if (nr != b.rows () || nc != b.columns ())
3306 {
3307 (*current_liboctave_error_handler)
3308 ("two-arg min expecting args of same size");
3309 return FloatMatrix ();
3310 }
3311
3312 EMPTY_RETURN_CHECK (FloatMatrix);
3313
3314 FloatMatrix result (nr, nc);
3315
3316 for (octave_idx_type j = 0; j < nc; j++)
3317 for (octave_idx_type i = 0; i < nr; i++)
3318 {
3319 OCTAVE_QUIT;
3320 result (i, j) = xmin (a (i, j), b (i, j));
3321 }
3322
3323 return result;
3324 }
3325
3326 FloatMatrix
3327 max (float d, const FloatMatrix& m)
3328 {
3329 octave_idx_type nr = m.rows ();
3330 octave_idx_type nc = m.columns ();
3331
3332 EMPTY_RETURN_CHECK (FloatMatrix);
3333
3334 FloatMatrix result (nr, nc);
3335
3336 for (octave_idx_type j = 0; j < nc; j++)
3337 for (octave_idx_type i = 0; i < nr; i++)
3338 {
3339 OCTAVE_QUIT;
3340 result (i, j) = xmax (d, m (i, j));
3341 }
3342
3343 return result;
3344 }
3345
3346 FloatMatrix
3347 max (const FloatMatrix& m, float d)
3348 {
3349 octave_idx_type nr = m.rows ();
3350 octave_idx_type nc = m.columns ();
3351
3352 EMPTY_RETURN_CHECK (FloatMatrix);
3353
3354 FloatMatrix result (nr, nc);
3355
3356 for (octave_idx_type j = 0; j < nc; j++)
3357 for (octave_idx_type i = 0; i < nr; i++)
3358 {
3359 OCTAVE_QUIT;
3360 result (i, j) = xmax (m (i, j), d);
3361 }
3362
3363 return result;
3364 }
3365
3366 FloatMatrix
3367 max (const FloatMatrix& a, const FloatMatrix& b)
3368 {
3369 octave_idx_type nr = a.rows ();
3370 octave_idx_type nc = a.columns ();
3371
3372 if (nr != b.rows () || nc != b.columns ())
3373 {
3374 (*current_liboctave_error_handler)
3375 ("two-arg max expecting args of same size");
3376 return FloatMatrix ();
3377 }
3378
3379 EMPTY_RETURN_CHECK (FloatMatrix);
3380
3381 FloatMatrix result (nr, nc);
3382
3383 for (octave_idx_type j = 0; j < nc; j++)
3384 for (octave_idx_type i = 0; i < nr; i++)
3385 {
3386 OCTAVE_QUIT;
3387 result (i, j) = xmax (a (i, j), b (i, j));
3388 }
3389
3390 return result;
3391 }
3392
3393 MS_CMP_OPS(FloatMatrix, , float, )
3394 MS_BOOL_OPS(FloatMatrix, float, 0.0)
3395
3396 SM_CMP_OPS(float, , FloatMatrix, )
3397 SM_BOOL_OPS(float, FloatMatrix, 0.0)
3398
3399 MM_CMP_OPS(FloatMatrix, , FloatMatrix, )
3400 MM_BOOL_OPS(FloatMatrix, FloatMatrix, 0.0)
3401
3402 /*
3403 ;;; Local Variables: ***
3404 ;;; mode: C++ ***
3405 ;;; End: ***
3406 */