Xmipp  v3.23.11-Nereus
linalg.cpp
Go to the documentation of this file.
1 /*************************************************************************
2 Copyright (c) Sergey Bochkanov (ALGLIB project).
3 
4 >>> SOURCE LICENSE >>>
5 This program is free software; you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation (www.fsf.org); either version 2 of the
8 License, or (at your option) any later version.
9 
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14 
15 A copy of the GNU General Public License is available at
16 http://www.fsf.org/licensing/licenses
17 >>> END OF LICENSE >>>
18 *************************************************************************/
19 #include "stdafx.h"
20 #include "linalg.h"
21 
22 // disable some irrelevant warnings
23 #if (AE_COMPILER==AE_MSVC)
24 #pragma warning(disable:4100)
25 #pragma warning(disable:4127)
26 #pragma warning(disable:4702)
27 #pragma warning(disable:4996)
28 #endif
29 using namespace std;
30 
32 //
33 // THIS SECTION CONTAINS IMPLEMENTATION OF C++ INTERFACE
34 //
36 namespace alglib
37 {
38 
39 
40 /*************************************************************************
41 Cache-oblivous complex "copy-and-transpose"
42 
43 Input parameters:
44  M - number of rows
45  N - number of columns
46  A - source matrix, MxN submatrix is copied and transposed
47  IA - submatrix offset (row index)
48  JA - submatrix offset (column index)
49  B - destination matrix, must be large enough to store result
50  IB - submatrix offset (row index)
51  JB - submatrix offset (column index)
52 *************************************************************************/
53 void cmatrixtranspose(const ae_int_t m, const ae_int_t n, const complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, complex_2d_array &b, const ae_int_t ib, const ae_int_t jb)
54 {
55  alglib_impl::ae_state _alglib_env_state;
56  alglib_impl::ae_state_init(&_alglib_env_state);
57  try
58  {
59  alglib_impl::cmatrixtranspose(m, n, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), ia, ja, const_cast<alglib_impl::ae_matrix*>(b.c_ptr()), ib, jb, &_alglib_env_state);
60  alglib_impl::ae_state_clear(&_alglib_env_state);
61  return;
62  }
64  {
65  throw ap_error(_alglib_env_state.error_msg);
66  }
67 }
68 
69 /*************************************************************************
70 Cache-oblivous real "copy-and-transpose"
71 
72 Input parameters:
73  M - number of rows
74  N - number of columns
75  A - source matrix, MxN submatrix is copied and transposed
76  IA - submatrix offset (row index)
77  JA - submatrix offset (column index)
78  B - destination matrix, must be large enough to store result
79  IB - submatrix offset (row index)
80  JB - submatrix offset (column index)
81 *************************************************************************/
82 void rmatrixtranspose(const ae_int_t m, const ae_int_t n, const real_2d_array &a, const ae_int_t ia, const ae_int_t ja, real_2d_array &b, const ae_int_t ib, const ae_int_t jb)
83 {
84  alglib_impl::ae_state _alglib_env_state;
85  alglib_impl::ae_state_init(&_alglib_env_state);
86  try
87  {
88  alglib_impl::rmatrixtranspose(m, n, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), ia, ja, const_cast<alglib_impl::ae_matrix*>(b.c_ptr()), ib, jb, &_alglib_env_state);
89  alglib_impl::ae_state_clear(&_alglib_env_state);
90  return;
91  }
93  {
94  throw ap_error(_alglib_env_state.error_msg);
95  }
96 }
97 
98 /*************************************************************************
99 This code enforces symmetricy of the matrix by copying Upper part to lower
100 one (or vice versa).
101 
102 INPUT PARAMETERS:
103  A - matrix
104  N - number of rows/columns
105  IsUpper - whether we want to copy upper triangle to lower one (True)
106  or vice versa (False).
107 *************************************************************************/
108 void rmatrixenforcesymmetricity(const real_2d_array &a, const ae_int_t n, const bool isupper)
109 {
110  alglib_impl::ae_state _alglib_env_state;
111  alglib_impl::ae_state_init(&_alglib_env_state);
112  try
113  {
114  alglib_impl::rmatrixenforcesymmetricity(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, &_alglib_env_state);
115  alglib_impl::ae_state_clear(&_alglib_env_state);
116  return;
117  }
119  {
120  throw ap_error(_alglib_env_state.error_msg);
121  }
122 }
123 
124 /*************************************************************************
125 Copy
126 
127 Input parameters:
128  M - number of rows
129  N - number of columns
130  A - source matrix, MxN submatrix is copied and transposed
131  IA - submatrix offset (row index)
132  JA - submatrix offset (column index)
133  B - destination matrix, must be large enough to store result
134  IB - submatrix offset (row index)
135  JB - submatrix offset (column index)
136 *************************************************************************/
137 void cmatrixcopy(const ae_int_t m, const ae_int_t n, const complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, complex_2d_array &b, const ae_int_t ib, const ae_int_t jb)
138 {
139  alglib_impl::ae_state _alglib_env_state;
140  alglib_impl::ae_state_init(&_alglib_env_state);
141  try
142  {
143  alglib_impl::cmatrixcopy(m, n, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), ia, ja, const_cast<alglib_impl::ae_matrix*>(b.c_ptr()), ib, jb, &_alglib_env_state);
144  alglib_impl::ae_state_clear(&_alglib_env_state);
145  return;
146  }
148  {
149  throw ap_error(_alglib_env_state.error_msg);
150  }
151 }
152 
153 /*************************************************************************
154 Copy
155 
156 Input parameters:
157  M - number of rows
158  N - number of columns
159  A - source matrix, MxN submatrix is copied and transposed
160  IA - submatrix offset (row index)
161  JA - submatrix offset (column index)
162  B - destination matrix, must be large enough to store result
163  IB - submatrix offset (row index)
164  JB - submatrix offset (column index)
165 *************************************************************************/
166 void rmatrixcopy(const ae_int_t m, const ae_int_t n, const real_2d_array &a, const ae_int_t ia, const ae_int_t ja, real_2d_array &b, const ae_int_t ib, const ae_int_t jb)
167 {
168  alglib_impl::ae_state _alglib_env_state;
169  alglib_impl::ae_state_init(&_alglib_env_state);
170  try
171  {
172  alglib_impl::rmatrixcopy(m, n, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), ia, ja, const_cast<alglib_impl::ae_matrix*>(b.c_ptr()), ib, jb, &_alglib_env_state);
173  alglib_impl::ae_state_clear(&_alglib_env_state);
174  return;
175  }
177  {
178  throw ap_error(_alglib_env_state.error_msg);
179  }
180 }
181 
182 /*************************************************************************
183 Rank-1 correction: A := A + u*v'
184 
185 INPUT PARAMETERS:
186  M - number of rows
187  N - number of columns
188  A - target matrix, MxN submatrix is updated
189  IA - submatrix offset (row index)
190  JA - submatrix offset (column index)
191  U - vector #1
192  IU - subvector offset
193  V - vector #2
194  IV - subvector offset
195 *************************************************************************/
196 void cmatrixrank1(const ae_int_t m, const ae_int_t n, complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, complex_1d_array &u, const ae_int_t iu, complex_1d_array &v, const ae_int_t iv)
197 {
198  alglib_impl::ae_state _alglib_env_state;
199  alglib_impl::ae_state_init(&_alglib_env_state);
200  try
201  {
202  alglib_impl::cmatrixrank1(m, n, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), ia, ja, const_cast<alglib_impl::ae_vector*>(u.c_ptr()), iu, const_cast<alglib_impl::ae_vector*>(v.c_ptr()), iv, &_alglib_env_state);
203  alglib_impl::ae_state_clear(&_alglib_env_state);
204  return;
205  }
207  {
208  throw ap_error(_alglib_env_state.error_msg);
209  }
210 }
211 
212 /*************************************************************************
213 Rank-1 correction: A := A + u*v'
214 
215 INPUT PARAMETERS:
216  M - number of rows
217  N - number of columns
218  A - target matrix, MxN submatrix is updated
219  IA - submatrix offset (row index)
220  JA - submatrix offset (column index)
221  U - vector #1
222  IU - subvector offset
223  V - vector #2
224  IV - subvector offset
225 *************************************************************************/
226 void rmatrixrank1(const ae_int_t m, const ae_int_t n, real_2d_array &a, const ae_int_t ia, const ae_int_t ja, real_1d_array &u, const ae_int_t iu, real_1d_array &v, const ae_int_t iv)
227 {
228  alglib_impl::ae_state _alglib_env_state;
229  alglib_impl::ae_state_init(&_alglib_env_state);
230  try
231  {
232  alglib_impl::rmatrixrank1(m, n, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), ia, ja, const_cast<alglib_impl::ae_vector*>(u.c_ptr()), iu, const_cast<alglib_impl::ae_vector*>(v.c_ptr()), iv, &_alglib_env_state);
233  alglib_impl::ae_state_clear(&_alglib_env_state);
234  return;
235  }
237  {
238  throw ap_error(_alglib_env_state.error_msg);
239  }
240 }
241 
242 /*************************************************************************
243 Matrix-vector product: y := op(A)*x
244 
245 INPUT PARAMETERS:
246  M - number of rows of op(A)
247  M>=0
248  N - number of columns of op(A)
249  N>=0
250  A - target matrix
251  IA - submatrix offset (row index)
252  JA - submatrix offset (column index)
253  OpA - operation type:
254  * OpA=0 => op(A) = A
255  * OpA=1 => op(A) = A^T
256  * OpA=2 => op(A) = A^H
257  X - input vector
258  IX - subvector offset
259  IY - subvector offset
260  Y - preallocated matrix, must be large enough to store result
261 
262 OUTPUT PARAMETERS:
263  Y - vector which stores result
264 
265 if M=0, then subroutine does nothing.
266 if N=0, Y is filled by zeros.
267 
268 
269  -- ALGLIB routine --
270 
271  28.01.2010
272  Bochkanov Sergey
273 *************************************************************************/
274 void cmatrixmv(const ae_int_t m, const ae_int_t n, const complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t opa, const complex_1d_array &x, const ae_int_t ix, complex_1d_array &y, const ae_int_t iy)
275 {
276  alglib_impl::ae_state _alglib_env_state;
277  alglib_impl::ae_state_init(&_alglib_env_state);
278  try
279  {
280  alglib_impl::cmatrixmv(m, n, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), ia, ja, opa, const_cast<alglib_impl::ae_vector*>(x.c_ptr()), ix, const_cast<alglib_impl::ae_vector*>(y.c_ptr()), iy, &_alglib_env_state);
281  alglib_impl::ae_state_clear(&_alglib_env_state);
282  return;
283  }
285  {
286  throw ap_error(_alglib_env_state.error_msg);
287  }
288 }
289 
290 /*************************************************************************
291 Matrix-vector product: y := op(A)*x
292 
293 INPUT PARAMETERS:
294  M - number of rows of op(A)
295  N - number of columns of op(A)
296  A - target matrix
297  IA - submatrix offset (row index)
298  JA - submatrix offset (column index)
299  OpA - operation type:
300  * OpA=0 => op(A) = A
301  * OpA=1 => op(A) = A^T
302  X - input vector
303  IX - subvector offset
304  IY - subvector offset
305  Y - preallocated matrix, must be large enough to store result
306 
307 OUTPUT PARAMETERS:
308  Y - vector which stores result
309 
310 if M=0, then subroutine does nothing.
311 if N=0, Y is filled by zeros.
312 
313 
314  -- ALGLIB routine --
315 
316  28.01.2010
317  Bochkanov Sergey
318 *************************************************************************/
319 void rmatrixmv(const ae_int_t m, const ae_int_t n, const real_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t opa, const real_1d_array &x, const ae_int_t ix, real_1d_array &y, const ae_int_t iy)
320 {
321  alglib_impl::ae_state _alglib_env_state;
322  alglib_impl::ae_state_init(&_alglib_env_state);
323  try
324  {
325  alglib_impl::rmatrixmv(m, n, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), ia, ja, opa, const_cast<alglib_impl::ae_vector*>(x.c_ptr()), ix, const_cast<alglib_impl::ae_vector*>(y.c_ptr()), iy, &_alglib_env_state);
326  alglib_impl::ae_state_clear(&_alglib_env_state);
327  return;
328  }
330  {
331  throw ap_error(_alglib_env_state.error_msg);
332  }
333 }
334 
335 /*************************************************************************
336 
337 *************************************************************************/
338 void cmatrixrighttrsm(const ae_int_t m, const ae_int_t n, const complex_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const complex_2d_array &x, const ae_int_t i2, const ae_int_t j2)
339 {
340  alglib_impl::ae_state _alglib_env_state;
341  alglib_impl::ae_state_init(&_alglib_env_state);
342  try
343  {
344  alglib_impl::cmatrixrighttrsm(m, n, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), i1, j1, isupper, isunit, optype, const_cast<alglib_impl::ae_matrix*>(x.c_ptr()), i2, j2, &_alglib_env_state);
345  alglib_impl::ae_state_clear(&_alglib_env_state);
346  return;
347  }
349  {
350  throw ap_error(_alglib_env_state.error_msg);
351  }
352 }
353 
354 
355 void smp_cmatrixrighttrsm(const ae_int_t m, const ae_int_t n, const complex_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const complex_2d_array &x, const ae_int_t i2, const ae_int_t j2)
356 {
357  alglib_impl::ae_state _alglib_env_state;
358  alglib_impl::ae_state_init(&_alglib_env_state);
359  try
360  {
361  alglib_impl::_pexec_cmatrixrighttrsm(m, n, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), i1, j1, isupper, isunit, optype, const_cast<alglib_impl::ae_matrix*>(x.c_ptr()), i2, j2, &_alglib_env_state);
362  alglib_impl::ae_state_clear(&_alglib_env_state);
363  return;
364  }
366  {
367  throw ap_error(_alglib_env_state.error_msg);
368  }
369 }
370 
371 /*************************************************************************
372 
373 *************************************************************************/
374 void cmatrixlefttrsm(const ae_int_t m, const ae_int_t n, const complex_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const complex_2d_array &x, const ae_int_t i2, const ae_int_t j2)
375 {
376  alglib_impl::ae_state _alglib_env_state;
377  alglib_impl::ae_state_init(&_alglib_env_state);
378  try
379  {
380  alglib_impl::cmatrixlefttrsm(m, n, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), i1, j1, isupper, isunit, optype, const_cast<alglib_impl::ae_matrix*>(x.c_ptr()), i2, j2, &_alglib_env_state);
381  alglib_impl::ae_state_clear(&_alglib_env_state);
382  return;
383  }
385  {
386  throw ap_error(_alglib_env_state.error_msg);
387  }
388 }
389 
390 
391 void smp_cmatrixlefttrsm(const ae_int_t m, const ae_int_t n, const complex_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const complex_2d_array &x, const ae_int_t i2, const ae_int_t j2)
392 {
393  alglib_impl::ae_state _alglib_env_state;
394  alglib_impl::ae_state_init(&_alglib_env_state);
395  try
396  {
397  alglib_impl::_pexec_cmatrixlefttrsm(m, n, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), i1, j1, isupper, isunit, optype, const_cast<alglib_impl::ae_matrix*>(x.c_ptr()), i2, j2, &_alglib_env_state);
398  alglib_impl::ae_state_clear(&_alglib_env_state);
399  return;
400  }
402  {
403  throw ap_error(_alglib_env_state.error_msg);
404  }
405 }
406 
407 /*************************************************************************
408 
409 *************************************************************************/
410 void rmatrixrighttrsm(const ae_int_t m, const ae_int_t n, const real_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const real_2d_array &x, const ae_int_t i2, const ae_int_t j2)
411 {
412  alglib_impl::ae_state _alglib_env_state;
413  alglib_impl::ae_state_init(&_alglib_env_state);
414  try
415  {
416  alglib_impl::rmatrixrighttrsm(m, n, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), i1, j1, isupper, isunit, optype, const_cast<alglib_impl::ae_matrix*>(x.c_ptr()), i2, j2, &_alglib_env_state);
417  alglib_impl::ae_state_clear(&_alglib_env_state);
418  return;
419  }
421  {
422  throw ap_error(_alglib_env_state.error_msg);
423  }
424 }
425 
426 
427 void smp_rmatrixrighttrsm(const ae_int_t m, const ae_int_t n, const real_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const real_2d_array &x, const ae_int_t i2, const ae_int_t j2)
428 {
429  alglib_impl::ae_state _alglib_env_state;
430  alglib_impl::ae_state_init(&_alglib_env_state);
431  try
432  {
433  alglib_impl::_pexec_rmatrixrighttrsm(m, n, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), i1, j1, isupper, isunit, optype, const_cast<alglib_impl::ae_matrix*>(x.c_ptr()), i2, j2, &_alglib_env_state);
434  alglib_impl::ae_state_clear(&_alglib_env_state);
435  return;
436  }
438  {
439  throw ap_error(_alglib_env_state.error_msg);
440  }
441 }
442 
443 /*************************************************************************
444 
445 *************************************************************************/
446 void rmatrixlefttrsm(const ae_int_t m, const ae_int_t n, const real_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const real_2d_array &x, const ae_int_t i2, const ae_int_t j2)
447 {
448  alglib_impl::ae_state _alglib_env_state;
449  alglib_impl::ae_state_init(&_alglib_env_state);
450  try
451  {
452  alglib_impl::rmatrixlefttrsm(m, n, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), i1, j1, isupper, isunit, optype, const_cast<alglib_impl::ae_matrix*>(x.c_ptr()), i2, j2, &_alglib_env_state);
453  alglib_impl::ae_state_clear(&_alglib_env_state);
454  return;
455  }
457  {
458  throw ap_error(_alglib_env_state.error_msg);
459  }
460 }
461 
462 
463 void smp_rmatrixlefttrsm(const ae_int_t m, const ae_int_t n, const real_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const real_2d_array &x, const ae_int_t i2, const ae_int_t j2)
464 {
465  alglib_impl::ae_state _alglib_env_state;
466  alglib_impl::ae_state_init(&_alglib_env_state);
467  try
468  {
469  alglib_impl::_pexec_rmatrixlefttrsm(m, n, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), i1, j1, isupper, isunit, optype, const_cast<alglib_impl::ae_matrix*>(x.c_ptr()), i2, j2, &_alglib_env_state);
470  alglib_impl::ae_state_clear(&_alglib_env_state);
471  return;
472  }
474  {
475  throw ap_error(_alglib_env_state.error_msg);
476  }
477 }
478 
479 /*************************************************************************
480 
481 *************************************************************************/
482 void cmatrixsyrk(const ae_int_t n, const ae_int_t k, const double alpha, const complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const double beta, const complex_2d_array &c, const ae_int_t ic, const ae_int_t jc, const bool isupper)
483 {
484  alglib_impl::ae_state _alglib_env_state;
485  alglib_impl::ae_state_init(&_alglib_env_state);
486  try
487  {
488  alglib_impl::cmatrixsyrk(n, k, alpha, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), ia, ja, optypea, beta, const_cast<alglib_impl::ae_matrix*>(c.c_ptr()), ic, jc, isupper, &_alglib_env_state);
489  alglib_impl::ae_state_clear(&_alglib_env_state);
490  return;
491  }
493  {
494  throw ap_error(_alglib_env_state.error_msg);
495  }
496 }
497 
498 
499 void smp_cmatrixsyrk(const ae_int_t n, const ae_int_t k, const double alpha, const complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const double beta, const complex_2d_array &c, const ae_int_t ic, const ae_int_t jc, const bool isupper)
500 {
501  alglib_impl::ae_state _alglib_env_state;
502  alglib_impl::ae_state_init(&_alglib_env_state);
503  try
504  {
505  alglib_impl::_pexec_cmatrixsyrk(n, k, alpha, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), ia, ja, optypea, beta, const_cast<alglib_impl::ae_matrix*>(c.c_ptr()), ic, jc, isupper, &_alglib_env_state);
506  alglib_impl::ae_state_clear(&_alglib_env_state);
507  return;
508  }
510  {
511  throw ap_error(_alglib_env_state.error_msg);
512  }
513 }
514 
515 /*************************************************************************
516 
517 *************************************************************************/
518 void rmatrixsyrk(const ae_int_t n, const ae_int_t k, const double alpha, const real_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const double beta, const real_2d_array &c, const ae_int_t ic, const ae_int_t jc, const bool isupper)
519 {
520  alglib_impl::ae_state _alglib_env_state;
521  alglib_impl::ae_state_init(&_alglib_env_state);
522  try
523  {
524  alglib_impl::rmatrixsyrk(n, k, alpha, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), ia, ja, optypea, beta, const_cast<alglib_impl::ae_matrix*>(c.c_ptr()), ic, jc, isupper, &_alglib_env_state);
525  alglib_impl::ae_state_clear(&_alglib_env_state);
526  return;
527  }
529  {
530  throw ap_error(_alglib_env_state.error_msg);
531  }
532 }
533 
534 
535 void smp_rmatrixsyrk(const ae_int_t n, const ae_int_t k, const double alpha, const real_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const double beta, const real_2d_array &c, const ae_int_t ic, const ae_int_t jc, const bool isupper)
536 {
537  alglib_impl::ae_state _alglib_env_state;
538  alglib_impl::ae_state_init(&_alglib_env_state);
539  try
540  {
541  alglib_impl::_pexec_rmatrixsyrk(n, k, alpha, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), ia, ja, optypea, beta, const_cast<alglib_impl::ae_matrix*>(c.c_ptr()), ic, jc, isupper, &_alglib_env_state);
542  alglib_impl::ae_state_clear(&_alglib_env_state);
543  return;
544  }
546  {
547  throw ap_error(_alglib_env_state.error_msg);
548  }
549 }
550 
551 /*************************************************************************
552 
553 *************************************************************************/
554 void cmatrixgemm(const ae_int_t m, const ae_int_t n, const ae_int_t k, const alglib::complex alpha, const complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const complex_2d_array &b, const ae_int_t ib, const ae_int_t jb, const ae_int_t optypeb, const alglib::complex beta, const complex_2d_array &c, const ae_int_t ic, const ae_int_t jc)
555 {
556  alglib_impl::ae_state _alglib_env_state;
557  alglib_impl::ae_state_init(&_alglib_env_state);
558  try
559  {
560  alglib_impl::cmatrixgemm(m, n, k, *alpha.c_ptr(), const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), ia, ja, optypea, const_cast<alglib_impl::ae_matrix*>(b.c_ptr()), ib, jb, optypeb, *beta.c_ptr(), const_cast<alglib_impl::ae_matrix*>(c.c_ptr()), ic, jc, &_alglib_env_state);
561  alglib_impl::ae_state_clear(&_alglib_env_state);
562  return;
563  }
565  {
566  throw ap_error(_alglib_env_state.error_msg);
567  }
568 }
569 
570 
571 void smp_cmatrixgemm(const ae_int_t m, const ae_int_t n, const ae_int_t k, const alglib::complex alpha, const complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const complex_2d_array &b, const ae_int_t ib, const ae_int_t jb, const ae_int_t optypeb, const alglib::complex beta, const complex_2d_array &c, const ae_int_t ic, const ae_int_t jc)
572 {
573  alglib_impl::ae_state _alglib_env_state;
574  alglib_impl::ae_state_init(&_alglib_env_state);
575  try
576  {
577  alglib_impl::_pexec_cmatrixgemm(m, n, k, *alpha.c_ptr(), const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), ia, ja, optypea, const_cast<alglib_impl::ae_matrix*>(b.c_ptr()), ib, jb, optypeb, *beta.c_ptr(), const_cast<alglib_impl::ae_matrix*>(c.c_ptr()), ic, jc, &_alglib_env_state);
578  alglib_impl::ae_state_clear(&_alglib_env_state);
579  return;
580  }
582  {
583  throw ap_error(_alglib_env_state.error_msg);
584  }
585 }
586 
587 /*************************************************************************
588 
589 *************************************************************************/
590 void rmatrixgemm(const ae_int_t m, const ae_int_t n, const ae_int_t k, const double alpha, const real_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const real_2d_array &b, const ae_int_t ib, const ae_int_t jb, const ae_int_t optypeb, const double beta, const real_2d_array &c, const ae_int_t ic, const ae_int_t jc)
591 {
592  alglib_impl::ae_state _alglib_env_state;
593  alglib_impl::ae_state_init(&_alglib_env_state);
594  try
595  {
596  alglib_impl::rmatrixgemm(m, n, k, alpha, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), ia, ja, optypea, const_cast<alglib_impl::ae_matrix*>(b.c_ptr()), ib, jb, optypeb, beta, const_cast<alglib_impl::ae_matrix*>(c.c_ptr()), ic, jc, &_alglib_env_state);
597  alglib_impl::ae_state_clear(&_alglib_env_state);
598  return;
599  }
601  {
602  throw ap_error(_alglib_env_state.error_msg);
603  }
604 }
605 
606 
607 void smp_rmatrixgemm(const ae_int_t m, const ae_int_t n, const ae_int_t k, const double alpha, const real_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const real_2d_array &b, const ae_int_t ib, const ae_int_t jb, const ae_int_t optypeb, const double beta, const real_2d_array &c, const ae_int_t ic, const ae_int_t jc)
608 {
609  alglib_impl::ae_state _alglib_env_state;
610  alglib_impl::ae_state_init(&_alglib_env_state);
611  try
612  {
613  alglib_impl::_pexec_rmatrixgemm(m, n, k, alpha, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), ia, ja, optypea, const_cast<alglib_impl::ae_matrix*>(b.c_ptr()), ib, jb, optypeb, beta, const_cast<alglib_impl::ae_matrix*>(c.c_ptr()), ic, jc, &_alglib_env_state);
614  alglib_impl::ae_state_clear(&_alglib_env_state);
615  return;
616  }
618  {
619  throw ap_error(_alglib_env_state.error_msg);
620  }
621 }
622 
623 /*************************************************************************
624 QR decomposition of a rectangular matrix of size MxN
625 
626 Input parameters:
627  A - matrix A whose indexes range within [0..M-1, 0..N-1].
628  M - number of rows in matrix A.
629  N - number of columns in matrix A.
630 
631 Output parameters:
632  A - matrices Q and R in compact form (see below).
633  Tau - array of scalar factors which are used to form
634  matrix Q. Array whose index ranges within [0.. Min(M-1,N-1)].
635 
636 Matrix A is represented as A = QR, where Q is an orthogonal matrix of size
637 MxM, R - upper triangular (or upper trapezoid) matrix of size M x N.
638 
639 The elements of matrix R are located on and above the main diagonal of
640 matrix A. The elements which are located in Tau array and below the main
641 diagonal of matrix A are used to form matrix Q as follows:
642 
643 Matrix Q is represented as a product of elementary reflections
644 
645 Q = H(0)*H(2)*...*H(k-1),
646 
647 where k = min(m,n), and each H(i) is in the form
648 
649 H(i) = 1 - tau * v * (v^T)
650 
651 where tau is a scalar stored in Tau[I]; v - real vector,
652 so that v(0:i-1) = 0, v(i) = 1, v(i+1:m-1) stored in A(i+1:m-1,i).
653 
654  -- ALGLIB routine --
655  17.02.2010
656  Bochkanov Sergey
657 *************************************************************************/
659 {
660  alglib_impl::ae_state _alglib_env_state;
661  alglib_impl::ae_state_init(&_alglib_env_state);
662  try
663  {
664  alglib_impl::rmatrixqr(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), m, n, const_cast<alglib_impl::ae_vector*>(tau.c_ptr()), &_alglib_env_state);
665  alglib_impl::ae_state_clear(&_alglib_env_state);
666  return;
667  }
669  {
670  throw ap_error(_alglib_env_state.error_msg);
671  }
672 }
673 
674 /*************************************************************************
675 LQ decomposition of a rectangular matrix of size MxN
676 
677 Input parameters:
678  A - matrix A whose indexes range within [0..M-1, 0..N-1].
679  M - number of rows in matrix A.
680  N - number of columns in matrix A.
681 
682 Output parameters:
683  A - matrices L and Q in compact form (see below)
684  Tau - array of scalar factors which are used to form
685  matrix Q. Array whose index ranges within [0..Min(M,N)-1].
686 
687 Matrix A is represented as A = LQ, where Q is an orthogonal matrix of size
688 MxM, L - lower triangular (or lower trapezoid) matrix of size M x N.
689 
690 The elements of matrix L are located on and below the main diagonal of
691 matrix A. The elements which are located in Tau array and above the main
692 diagonal of matrix A are used to form matrix Q as follows:
693 
694 Matrix Q is represented as a product of elementary reflections
695 
696 Q = H(k-1)*H(k-2)*...*H(1)*H(0),
697 
698 where k = min(m,n), and each H(i) is of the form
699 
700 H(i) = 1 - tau * v * (v^T)
701 
702 where tau is a scalar stored in Tau[I]; v - real vector, so that v(0:i-1)=0,
703 v(i) = 1, v(i+1:n-1) stored in A(i,i+1:n-1).
704 
705  -- ALGLIB routine --
706  17.02.2010
707  Bochkanov Sergey
708 *************************************************************************/
710 {
711  alglib_impl::ae_state _alglib_env_state;
712  alglib_impl::ae_state_init(&_alglib_env_state);
713  try
714  {
715  alglib_impl::rmatrixlq(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), m, n, const_cast<alglib_impl::ae_vector*>(tau.c_ptr()), &_alglib_env_state);
716  alglib_impl::ae_state_clear(&_alglib_env_state);
717  return;
718  }
720  {
721  throw ap_error(_alglib_env_state.error_msg);
722  }
723 }
724 
725 /*************************************************************************
726 QR decomposition of a rectangular complex matrix of size MxN
727 
728 Input parameters:
729  A - matrix A whose indexes range within [0..M-1, 0..N-1]
730  M - number of rows in matrix A.
731  N - number of columns in matrix A.
732 
733 Output parameters:
734  A - matrices Q and R in compact form
735  Tau - array of scalar factors which are used to form matrix Q. Array
736  whose indexes range within [0.. Min(M,N)-1]
737 
738 Matrix A is represented as A = QR, where Q is an orthogonal matrix of size
739 MxM, R - upper triangular (or upper trapezoid) matrix of size MxN.
740 
741  -- LAPACK routine (version 3.0) --
742  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
743  Courant Institute, Argonne National Lab, and Rice University
744  September 30, 1994
745 *************************************************************************/
747 {
748  alglib_impl::ae_state _alglib_env_state;
749  alglib_impl::ae_state_init(&_alglib_env_state);
750  try
751  {
752  alglib_impl::cmatrixqr(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), m, n, const_cast<alglib_impl::ae_vector*>(tau.c_ptr()), &_alglib_env_state);
753  alglib_impl::ae_state_clear(&_alglib_env_state);
754  return;
755  }
757  {
758  throw ap_error(_alglib_env_state.error_msg);
759  }
760 }
761 
762 /*************************************************************************
763 LQ decomposition of a rectangular complex matrix of size MxN
764 
765 Input parameters:
766  A - matrix A whose indexes range within [0..M-1, 0..N-1]
767  M - number of rows in matrix A.
768  N - number of columns in matrix A.
769 
770 Output parameters:
771  A - matrices Q and L in compact form
772  Tau - array of scalar factors which are used to form matrix Q. Array
773  whose indexes range within [0.. Min(M,N)-1]
774 
775 Matrix A is represented as A = LQ, where Q is an orthogonal matrix of size
776 MxM, L - lower triangular (or lower trapezoid) matrix of size MxN.
777 
778  -- LAPACK routine (version 3.0) --
779  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
780  Courant Institute, Argonne National Lab, and Rice University
781  September 30, 1994
782 *************************************************************************/
784 {
785  alglib_impl::ae_state _alglib_env_state;
786  alglib_impl::ae_state_init(&_alglib_env_state);
787  try
788  {
789  alglib_impl::cmatrixlq(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), m, n, const_cast<alglib_impl::ae_vector*>(tau.c_ptr()), &_alglib_env_state);
790  alglib_impl::ae_state_clear(&_alglib_env_state);
791  return;
792  }
794  {
795  throw ap_error(_alglib_env_state.error_msg);
796  }
797 }
798 
799 /*************************************************************************
800 Partial unpacking of matrix Q from the QR decomposition of a matrix A
801 
802 Input parameters:
803  A - matrices Q and R in compact form.
804  Output of RMatrixQR subroutine.
805  M - number of rows in given matrix A. M>=0.
806  N - number of columns in given matrix A. N>=0.
807  Tau - scalar factors which are used to form Q.
808  Output of the RMatrixQR subroutine.
809  QColumns - required number of columns of matrix Q. M>=QColumns>=0.
810 
811 Output parameters:
812  Q - first QColumns columns of matrix Q.
813  Array whose indexes range within [0..M-1, 0..QColumns-1].
814  If QColumns=0, the array remains unchanged.
815 
816  -- ALGLIB routine --
817  17.02.2010
818  Bochkanov Sergey
819 *************************************************************************/
820 void rmatrixqrunpackq(const real_2d_array &a, const ae_int_t m, const ae_int_t n, const real_1d_array &tau, const ae_int_t qcolumns, real_2d_array &q)
821 {
822  alglib_impl::ae_state _alglib_env_state;
823  alglib_impl::ae_state_init(&_alglib_env_state);
824  try
825  {
826  alglib_impl::rmatrixqrunpackq(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), m, n, const_cast<alglib_impl::ae_vector*>(tau.c_ptr()), qcolumns, const_cast<alglib_impl::ae_matrix*>(q.c_ptr()), &_alglib_env_state);
827  alglib_impl::ae_state_clear(&_alglib_env_state);
828  return;
829  }
831  {
832  throw ap_error(_alglib_env_state.error_msg);
833  }
834 }
835 
836 /*************************************************************************
837 Unpacking of matrix R from the QR decomposition of a matrix A
838 
839 Input parameters:
840  A - matrices Q and R in compact form.
841  Output of RMatrixQR subroutine.
842  M - number of rows in given matrix A. M>=0.
843  N - number of columns in given matrix A. N>=0.
844 
845 Output parameters:
846  R - matrix R, array[0..M-1, 0..N-1].
847 
848  -- ALGLIB routine --
849  17.02.2010
850  Bochkanov Sergey
851 *************************************************************************/
853 {
854  alglib_impl::ae_state _alglib_env_state;
855  alglib_impl::ae_state_init(&_alglib_env_state);
856  try
857  {
858  alglib_impl::rmatrixqrunpackr(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), m, n, const_cast<alglib_impl::ae_matrix*>(r.c_ptr()), &_alglib_env_state);
859  alglib_impl::ae_state_clear(&_alglib_env_state);
860  return;
861  }
863  {
864  throw ap_error(_alglib_env_state.error_msg);
865  }
866 }
867 
868 /*************************************************************************
869 Partial unpacking of matrix Q from the LQ decomposition of a matrix A
870 
871 Input parameters:
872  A - matrices L and Q in compact form.
873  Output of RMatrixLQ subroutine.
874  M - number of rows in given matrix A. M>=0.
875  N - number of columns in given matrix A. N>=0.
876  Tau - scalar factors which are used to form Q.
877  Output of the RMatrixLQ subroutine.
878  QRows - required number of rows in matrix Q. N>=QRows>=0.
879 
880 Output parameters:
881  Q - first QRows rows of matrix Q. Array whose indexes range
882  within [0..QRows-1, 0..N-1]. If QRows=0, the array remains
883  unchanged.
884 
885  -- ALGLIB routine --
886  17.02.2010
887  Bochkanov Sergey
888 *************************************************************************/
889 void rmatrixlqunpackq(const real_2d_array &a, const ae_int_t m, const ae_int_t n, const real_1d_array &tau, const ae_int_t qrows, real_2d_array &q)
890 {
891  alglib_impl::ae_state _alglib_env_state;
892  alglib_impl::ae_state_init(&_alglib_env_state);
893  try
894  {
895  alglib_impl::rmatrixlqunpackq(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), m, n, const_cast<alglib_impl::ae_vector*>(tau.c_ptr()), qrows, const_cast<alglib_impl::ae_matrix*>(q.c_ptr()), &_alglib_env_state);
896  alglib_impl::ae_state_clear(&_alglib_env_state);
897  return;
898  }
900  {
901  throw ap_error(_alglib_env_state.error_msg);
902  }
903 }
904 
905 /*************************************************************************
906 Unpacking of matrix L from the LQ decomposition of a matrix A
907 
908 Input parameters:
909  A - matrices Q and L in compact form.
910  Output of RMatrixLQ subroutine.
911  M - number of rows in given matrix A. M>=0.
912  N - number of columns in given matrix A. N>=0.
913 
914 Output parameters:
915  L - matrix L, array[0..M-1, 0..N-1].
916 
917  -- ALGLIB routine --
918  17.02.2010
919  Bochkanov Sergey
920 *************************************************************************/
922 {
923  alglib_impl::ae_state _alglib_env_state;
924  alglib_impl::ae_state_init(&_alglib_env_state);
925  try
926  {
927  alglib_impl::rmatrixlqunpackl(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), m, n, const_cast<alglib_impl::ae_matrix*>(l.c_ptr()), &_alglib_env_state);
928  alglib_impl::ae_state_clear(&_alglib_env_state);
929  return;
930  }
932  {
933  throw ap_error(_alglib_env_state.error_msg);
934  }
935 }
936 
937 /*************************************************************************
938 Partial unpacking of matrix Q from QR decomposition of a complex matrix A.
939 
940 Input parameters:
941  A - matrices Q and R in compact form.
942  Output of CMatrixQR subroutine .
943  M - number of rows in matrix A. M>=0.
944  N - number of columns in matrix A. N>=0.
945  Tau - scalar factors which are used to form Q.
946  Output of CMatrixQR subroutine .
947  QColumns - required number of columns in matrix Q. M>=QColumns>=0.
948 
949 Output parameters:
950  Q - first QColumns columns of matrix Q.
951  Array whose index ranges within [0..M-1, 0..QColumns-1].
952  If QColumns=0, array isn't changed.
953 
954  -- ALGLIB routine --
955  17.02.2010
956  Bochkanov Sergey
957 *************************************************************************/
958 void cmatrixqrunpackq(const complex_2d_array &a, const ae_int_t m, const ae_int_t n, const complex_1d_array &tau, const ae_int_t qcolumns, complex_2d_array &q)
959 {
960  alglib_impl::ae_state _alglib_env_state;
961  alglib_impl::ae_state_init(&_alglib_env_state);
962  try
963  {
964  alglib_impl::cmatrixqrunpackq(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), m, n, const_cast<alglib_impl::ae_vector*>(tau.c_ptr()), qcolumns, const_cast<alglib_impl::ae_matrix*>(q.c_ptr()), &_alglib_env_state);
965  alglib_impl::ae_state_clear(&_alglib_env_state);
966  return;
967  }
969  {
970  throw ap_error(_alglib_env_state.error_msg);
971  }
972 }
973 
974 /*************************************************************************
975 Unpacking of matrix R from the QR decomposition of a matrix A
976 
977 Input parameters:
978  A - matrices Q and R in compact form.
979  Output of CMatrixQR subroutine.
980  M - number of rows in given matrix A. M>=0.
981  N - number of columns in given matrix A. N>=0.
982 
983 Output parameters:
984  R - matrix R, array[0..M-1, 0..N-1].
985 
986  -- ALGLIB routine --
987  17.02.2010
988  Bochkanov Sergey
989 *************************************************************************/
991 {
992  alglib_impl::ae_state _alglib_env_state;
993  alglib_impl::ae_state_init(&_alglib_env_state);
994  try
995  {
996  alglib_impl::cmatrixqrunpackr(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), m, n, const_cast<alglib_impl::ae_matrix*>(r.c_ptr()), &_alglib_env_state);
997  alglib_impl::ae_state_clear(&_alglib_env_state);
998  return;
999  }
1001  {
1002  throw ap_error(_alglib_env_state.error_msg);
1003  }
1004 }
1005 
1006 /*************************************************************************
1007 Partial unpacking of matrix Q from LQ decomposition of a complex matrix A.
1008 
1009 Input parameters:
1010  A - matrices Q and R in compact form.
1011  Output of CMatrixLQ subroutine .
1012  M - number of rows in matrix A. M>=0.
1013  N - number of columns in matrix A. N>=0.
1014  Tau - scalar factors which are used to form Q.
1015  Output of CMatrixLQ subroutine .
1016  QRows - required number of rows in matrix Q. N>=QColumns>=0.
1017 
1018 Output parameters:
1019  Q - first QRows rows of matrix Q.
1020  Array whose index ranges within [0..QRows-1, 0..N-1].
1021  If QRows=0, array isn't changed.
1022 
1023  -- ALGLIB routine --
1024  17.02.2010
1025  Bochkanov Sergey
1026 *************************************************************************/
1027 void cmatrixlqunpackq(const complex_2d_array &a, const ae_int_t m, const ae_int_t n, const complex_1d_array &tau, const ae_int_t qrows, complex_2d_array &q)
1028 {
1029  alglib_impl::ae_state _alglib_env_state;
1030  alglib_impl::ae_state_init(&_alglib_env_state);
1031  try
1032  {
1033  alglib_impl::cmatrixlqunpackq(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), m, n, const_cast<alglib_impl::ae_vector*>(tau.c_ptr()), qrows, const_cast<alglib_impl::ae_matrix*>(q.c_ptr()), &_alglib_env_state);
1034  alglib_impl::ae_state_clear(&_alglib_env_state);
1035  return;
1036  }
1038  {
1039  throw ap_error(_alglib_env_state.error_msg);
1040  }
1041 }
1042 
1043 /*************************************************************************
1044 Unpacking of matrix L from the LQ decomposition of a matrix A
1045 
1046 Input parameters:
1047  A - matrices Q and L in compact form.
1048  Output of CMatrixLQ subroutine.
1049  M - number of rows in given matrix A. M>=0.
1050  N - number of columns in given matrix A. N>=0.
1051 
1052 Output parameters:
1053  L - matrix L, array[0..M-1, 0..N-1].
1054 
1055  -- ALGLIB routine --
1056  17.02.2010
1057  Bochkanov Sergey
1058 *************************************************************************/
1060 {
1061  alglib_impl::ae_state _alglib_env_state;
1062  alglib_impl::ae_state_init(&_alglib_env_state);
1063  try
1064  {
1065  alglib_impl::cmatrixlqunpackl(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), m, n, const_cast<alglib_impl::ae_matrix*>(l.c_ptr()), &_alglib_env_state);
1066  alglib_impl::ae_state_clear(&_alglib_env_state);
1067  return;
1068  }
1070  {
1071  throw ap_error(_alglib_env_state.error_msg);
1072  }
1073 }
1074 
1075 /*************************************************************************
1076 Reduction of a rectangular matrix to bidiagonal form
1077 
1078 The algorithm reduces the rectangular matrix A to bidiagonal form by
1079 orthogonal transformations P and Q: A = Q*B*P.
1080 
1081 Input parameters:
1082  A - source matrix. array[0..M-1, 0..N-1]
1083  M - number of rows in matrix A.
1084  N - number of columns in matrix A.
1085 
1086 Output parameters:
1087  A - matrices Q, B, P in compact form (see below).
1088  TauQ - scalar factors which are used to form matrix Q.
1089  TauP - scalar factors which are used to form matrix P.
1090 
1091 The main diagonal and one of the secondary diagonals of matrix A are
1092 replaced with bidiagonal matrix B. Other elements contain elementary
1093 reflections which form MxM matrix Q and NxN matrix P, respectively.
1094 
1095 If M>=N, B is the upper bidiagonal MxN matrix and is stored in the
1096 corresponding elements of matrix A. Matrix Q is represented as a
1097 product of elementary reflections Q = H(0)*H(1)*...*H(n-1), where
1098 H(i) = 1-tau*v*v'. Here tau is a scalar which is stored in TauQ[i], and
1099 vector v has the following structure: v(0:i-1)=0, v(i)=1, v(i+1:m-1) is
1100 stored in elements A(i+1:m-1,i). Matrix P is as follows: P =
1101 G(0)*G(1)*...*G(n-2), where G(i) = 1 - tau*u*u'. Tau is stored in TauP[i],
1102 u(0:i)=0, u(i+1)=1, u(i+2:n-1) is stored in elements A(i,i+2:n-1).
1103 
1104 If M<N, B is the lower bidiagonal MxN matrix and is stored in the
1105 corresponding elements of matrix A. Q = H(0)*H(1)*...*H(m-2), where
1106 H(i) = 1 - tau*v*v', tau is stored in TauQ, v(0:i)=0, v(i+1)=1, v(i+2:m-1)
1107 is stored in elements A(i+2:m-1,i). P = G(0)*G(1)*...*G(m-1),
1108 G(i) = 1-tau*u*u', tau is stored in TauP, u(0:i-1)=0, u(i)=1, u(i+1:n-1)
1109 is stored in A(i,i+1:n-1).
1110 
1111 EXAMPLE:
1112 
1113 m=6, n=5 (m > n): m=5, n=6 (m < n):
1114 
1115 ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
1116 ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
1117 ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
1118 ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
1119 ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
1120 ( v1 v2 v3 v4 v5 )
1121 
1122 Here vi and ui are vectors which form H(i) and G(i), and d and e -
1123 are the diagonal and off-diagonal elements of matrix B.
1124 
1125  -- LAPACK routine (version 3.0) --
1126  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
1127  Courant Institute, Argonne National Lab, and Rice University
1128  September 30, 1994.
1129  Sergey Bochkanov, ALGLIB project, translation from FORTRAN to
1130  pseudocode, 2007-2010.
1131 *************************************************************************/
1133 {
1134  alglib_impl::ae_state _alglib_env_state;
1135  alglib_impl::ae_state_init(&_alglib_env_state);
1136  try
1137  {
1138  alglib_impl::rmatrixbd(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), m, n, const_cast<alglib_impl::ae_vector*>(tauq.c_ptr()), const_cast<alglib_impl::ae_vector*>(taup.c_ptr()), &_alglib_env_state);
1139  alglib_impl::ae_state_clear(&_alglib_env_state);
1140  return;
1141  }
1143  {
1144  throw ap_error(_alglib_env_state.error_msg);
1145  }
1146 }
1147 
1148 /*************************************************************************
1149 Unpacking matrix Q which reduces a matrix to bidiagonal form.
1150 
1151 Input parameters:
1152  QP - matrices Q and P in compact form.
1153  Output of ToBidiagonal subroutine.
1154  M - number of rows in matrix A.
1155  N - number of columns in matrix A.
1156  TAUQ - scalar factors which are used to form Q.
1157  Output of ToBidiagonal subroutine.
1158  QColumns - required number of columns in matrix Q.
1159  M>=QColumns>=0.
1160 
1161 Output parameters:
1162  Q - first QColumns columns of matrix Q.
1163  Array[0..M-1, 0..QColumns-1]
1164  If QColumns=0, the array is not modified.
1165 
1166  -- ALGLIB --
1167  2005-2010
1168  Bochkanov Sergey
1169 *************************************************************************/
1170 void rmatrixbdunpackq(const real_2d_array &qp, const ae_int_t m, const ae_int_t n, const real_1d_array &tauq, const ae_int_t qcolumns, real_2d_array &q)
1171 {
1172  alglib_impl::ae_state _alglib_env_state;
1173  alglib_impl::ae_state_init(&_alglib_env_state);
1174  try
1175  {
1176  alglib_impl::rmatrixbdunpackq(const_cast<alglib_impl::ae_matrix*>(qp.c_ptr()), m, n, const_cast<alglib_impl::ae_vector*>(tauq.c_ptr()), qcolumns, const_cast<alglib_impl::ae_matrix*>(q.c_ptr()), &_alglib_env_state);
1177  alglib_impl::ae_state_clear(&_alglib_env_state);
1178  return;
1179  }
1181  {
1182  throw ap_error(_alglib_env_state.error_msg);
1183  }
1184 }
1185 
1186 /*************************************************************************
1187 Multiplication by matrix Q which reduces matrix A to bidiagonal form.
1188 
1189 The algorithm allows pre- or post-multiply by Q or Q'.
1190 
1191 Input parameters:
1192  QP - matrices Q and P in compact form.
1193  Output of ToBidiagonal subroutine.
1194  M - number of rows in matrix A.
1195  N - number of columns in matrix A.
1196  TAUQ - scalar factors which are used to form Q.
1197  Output of ToBidiagonal subroutine.
1198  Z - multiplied matrix.
1199  array[0..ZRows-1,0..ZColumns-1]
1200  ZRows - number of rows in matrix Z. If FromTheRight=False,
1201  ZRows=M, otherwise ZRows can be arbitrary.
1202  ZColumns - number of columns in matrix Z. If FromTheRight=True,
1203  ZColumns=M, otherwise ZColumns can be arbitrary.
1204  FromTheRight - pre- or post-multiply.
1205  DoTranspose - multiply by Q or Q'.
1206 
1207 Output parameters:
1208  Z - product of Z and Q.
1209  Array[0..ZRows-1,0..ZColumns-1]
1210  If ZRows=0 or ZColumns=0, the array is not modified.
1211 
1212  -- ALGLIB --
1213  2005-2010
1214  Bochkanov Sergey
1215 *************************************************************************/
1216 void rmatrixbdmultiplybyq(const real_2d_array &qp, const ae_int_t m, const ae_int_t n, const real_1d_array &tauq, real_2d_array &z, const ae_int_t zrows, const ae_int_t zcolumns, const bool fromtheright, const bool dotranspose)
1217 {
1218  alglib_impl::ae_state _alglib_env_state;
1219  alglib_impl::ae_state_init(&_alglib_env_state);
1220  try
1221  {
1222  alglib_impl::rmatrixbdmultiplybyq(const_cast<alglib_impl::ae_matrix*>(qp.c_ptr()), m, n, const_cast<alglib_impl::ae_vector*>(tauq.c_ptr()), const_cast<alglib_impl::ae_matrix*>(z.c_ptr()), zrows, zcolumns, fromtheright, dotranspose, &_alglib_env_state);
1223  alglib_impl::ae_state_clear(&_alglib_env_state);
1224  return;
1225  }
1227  {
1228  throw ap_error(_alglib_env_state.error_msg);
1229  }
1230 }
1231 
1232 /*************************************************************************
1233 Unpacking matrix P which reduces matrix A to bidiagonal form.
1234 The subroutine returns transposed matrix P.
1235 
1236 Input parameters:
1237  QP - matrices Q and P in compact form.
1238  Output of ToBidiagonal subroutine.
1239  M - number of rows in matrix A.
1240  N - number of columns in matrix A.
1241  TAUP - scalar factors which are used to form P.
1242  Output of ToBidiagonal subroutine.
1243  PTRows - required number of rows of matrix P^T. N >= PTRows >= 0.
1244 
1245 Output parameters:
1246  PT - first PTRows columns of matrix P^T
1247  Array[0..PTRows-1, 0..N-1]
1248  If PTRows=0, the array is not modified.
1249 
1250  -- ALGLIB --
1251  2005-2010
1252  Bochkanov Sergey
1253 *************************************************************************/
1254 void rmatrixbdunpackpt(const real_2d_array &qp, const ae_int_t m, const ae_int_t n, const real_1d_array &taup, const ae_int_t ptrows, real_2d_array &pt)
1255 {
1256  alglib_impl::ae_state _alglib_env_state;
1257  alglib_impl::ae_state_init(&_alglib_env_state);
1258  try
1259  {
1260  alglib_impl::rmatrixbdunpackpt(const_cast<alglib_impl::ae_matrix*>(qp.c_ptr()), m, n, const_cast<alglib_impl::ae_vector*>(taup.c_ptr()), ptrows, const_cast<alglib_impl::ae_matrix*>(pt.c_ptr()), &_alglib_env_state);
1261  alglib_impl::ae_state_clear(&_alglib_env_state);
1262  return;
1263  }
1265  {
1266  throw ap_error(_alglib_env_state.error_msg);
1267  }
1268 }
1269 
1270 /*************************************************************************
1271 Multiplication by matrix P which reduces matrix A to bidiagonal form.
1272 
1273 The algorithm allows pre- or post-multiply by P or P'.
1274 
1275 Input parameters:
1276  QP - matrices Q and P in compact form.
1277  Output of RMatrixBD subroutine.
1278  M - number of rows in matrix A.
1279  N - number of columns in matrix A.
1280  TAUP - scalar factors which are used to form P.
1281  Output of RMatrixBD subroutine.
1282  Z - multiplied matrix.
1283  Array whose indexes range within [0..ZRows-1,0..ZColumns-1].
1284  ZRows - number of rows in matrix Z. If FromTheRight=False,
1285  ZRows=N, otherwise ZRows can be arbitrary.
1286  ZColumns - number of columns in matrix Z. If FromTheRight=True,
1287  ZColumns=N, otherwise ZColumns can be arbitrary.
1288  FromTheRight - pre- or post-multiply.
1289  DoTranspose - multiply by P or P'.
1290 
1291 Output parameters:
1292  Z - product of Z and P.
1293  Array whose indexes range within [0..ZRows-1,0..ZColumns-1].
1294  If ZRows=0 or ZColumns=0, the array is not modified.
1295 
1296  -- ALGLIB --
1297  2005-2010
1298  Bochkanov Sergey
1299 *************************************************************************/
1300 void rmatrixbdmultiplybyp(const real_2d_array &qp, const ae_int_t m, const ae_int_t n, const real_1d_array &taup, real_2d_array &z, const ae_int_t zrows, const ae_int_t zcolumns, const bool fromtheright, const bool dotranspose)
1301 {
1302  alglib_impl::ae_state _alglib_env_state;
1303  alglib_impl::ae_state_init(&_alglib_env_state);
1304  try
1305  {
1306  alglib_impl::rmatrixbdmultiplybyp(const_cast<alglib_impl::ae_matrix*>(qp.c_ptr()), m, n, const_cast<alglib_impl::ae_vector*>(taup.c_ptr()), const_cast<alglib_impl::ae_matrix*>(z.c_ptr()), zrows, zcolumns, fromtheright, dotranspose, &_alglib_env_state);
1307  alglib_impl::ae_state_clear(&_alglib_env_state);
1308  return;
1309  }
1311  {
1312  throw ap_error(_alglib_env_state.error_msg);
1313  }
1314 }
1315 
1316 /*************************************************************************
1317 Unpacking of the main and secondary diagonals of bidiagonal decomposition
1318 of matrix A.
1319 
1320 Input parameters:
1321  B - output of RMatrixBD subroutine.
1322  M - number of rows in matrix B.
1323  N - number of columns in matrix B.
1324 
1325 Output parameters:
1326  IsUpper - True, if the matrix is upper bidiagonal.
1327  otherwise IsUpper is False.
1328  D - the main diagonal.
1329  Array whose index ranges within [0..Min(M,N)-1].
1330  E - the secondary diagonal (upper or lower, depending on
1331  the value of IsUpper).
1332  Array index ranges within [0..Min(M,N)-1], the last
1333  element is not used.
1334 
1335  -- ALGLIB --
1336  2005-2010
1337  Bochkanov Sergey
1338 *************************************************************************/
1339 void rmatrixbdunpackdiagonals(const real_2d_array &b, const ae_int_t m, const ae_int_t n, bool &isupper, real_1d_array &d, real_1d_array &e)
1340 {
1341  alglib_impl::ae_state _alglib_env_state;
1342  alglib_impl::ae_state_init(&_alglib_env_state);
1343  try
1344  {
1345  alglib_impl::rmatrixbdunpackdiagonals(const_cast<alglib_impl::ae_matrix*>(b.c_ptr()), m, n, &isupper, const_cast<alglib_impl::ae_vector*>(d.c_ptr()), const_cast<alglib_impl::ae_vector*>(e.c_ptr()), &_alglib_env_state);
1346  alglib_impl::ae_state_clear(&_alglib_env_state);
1347  return;
1348  }
1350  {
1351  throw ap_error(_alglib_env_state.error_msg);
1352  }
1353 }
1354 
1355 /*************************************************************************
1356 Reduction of a square matrix to upper Hessenberg form: Q'*A*Q = H,
1357 where Q is an orthogonal matrix, H - Hessenberg matrix.
1358 
1359 Input parameters:
1360  A - matrix A with elements [0..N-1, 0..N-1]
1361  N - size of matrix A.
1362 
1363 Output parameters:
1364  A - matrices Q and P in compact form (see below).
1365  Tau - array of scalar factors which are used to form matrix Q.
1366  Array whose index ranges within [0..N-2]
1367 
1368 Matrix H is located on the main diagonal, on the lower secondary diagonal
1369 and above the main diagonal of matrix A. The elements which are used to
1370 form matrix Q are situated in array Tau and below the lower secondary
1371 diagonal of matrix A as follows:
1372 
1373 Matrix Q is represented as a product of elementary reflections
1374 
1375 Q = H(0)*H(2)*...*H(n-2),
1376 
1377 where each H(i) is given by
1378 
1379 H(i) = 1 - tau * v * (v^T)
1380 
1381 where tau is a scalar stored in Tau[I]; v - is a real vector,
1382 so that v(0:i) = 0, v(i+1) = 1, v(i+2:n-1) stored in A(i+2:n-1,i).
1383 
1384  -- LAPACK routine (version 3.0) --
1385  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
1386  Courant Institute, Argonne National Lab, and Rice University
1387  October 31, 1992
1388 *************************************************************************/
1390 {
1391  alglib_impl::ae_state _alglib_env_state;
1392  alglib_impl::ae_state_init(&_alglib_env_state);
1393  try
1394  {
1395  alglib_impl::rmatrixhessenberg(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, const_cast<alglib_impl::ae_vector*>(tau.c_ptr()), &_alglib_env_state);
1396  alglib_impl::ae_state_clear(&_alglib_env_state);
1397  return;
1398  }
1400  {
1401  throw ap_error(_alglib_env_state.error_msg);
1402  }
1403 }
1404 
1405 /*************************************************************************
1406 Unpacking matrix Q which reduces matrix A to upper Hessenberg form
1407 
1408 Input parameters:
1409  A - output of RMatrixHessenberg subroutine.
1410  N - size of matrix A.
1411  Tau - scalar factors which are used to form Q.
1412  Output of RMatrixHessenberg subroutine.
1413 
1414 Output parameters:
1415  Q - matrix Q.
1416  Array whose indexes range within [0..N-1, 0..N-1].
1417 
1418  -- ALGLIB --
1419  2005-2010
1420  Bochkanov Sergey
1421 *************************************************************************/
1423 {
1424  alglib_impl::ae_state _alglib_env_state;
1425  alglib_impl::ae_state_init(&_alglib_env_state);
1426  try
1427  {
1428  alglib_impl::rmatrixhessenbergunpackq(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, const_cast<alglib_impl::ae_vector*>(tau.c_ptr()), const_cast<alglib_impl::ae_matrix*>(q.c_ptr()), &_alglib_env_state);
1429  alglib_impl::ae_state_clear(&_alglib_env_state);
1430  return;
1431  }
1433  {
1434  throw ap_error(_alglib_env_state.error_msg);
1435  }
1436 }
1437 
1438 /*************************************************************************
1439 Unpacking matrix H (the result of matrix A reduction to upper Hessenberg form)
1440 
1441 Input parameters:
1442  A - output of RMatrixHessenberg subroutine.
1443  N - size of matrix A.
1444 
1445 Output parameters:
1446  H - matrix H. Array whose indexes range within [0..N-1, 0..N-1].
1447 
1448  -- ALGLIB --
1449  2005-2010
1450  Bochkanov Sergey
1451 *************************************************************************/
1453 {
1454  alglib_impl::ae_state _alglib_env_state;
1455  alglib_impl::ae_state_init(&_alglib_env_state);
1456  try
1457  {
1458  alglib_impl::rmatrixhessenbergunpackh(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, const_cast<alglib_impl::ae_matrix*>(h.c_ptr()), &_alglib_env_state);
1459  alglib_impl::ae_state_clear(&_alglib_env_state);
1460  return;
1461  }
1463  {
1464  throw ap_error(_alglib_env_state.error_msg);
1465  }
1466 }
1467 
1468 /*************************************************************************
1469 Reduction of a symmetric matrix which is given by its higher or lower
1470 triangular part to a tridiagonal matrix using orthogonal similarity
1471 transformation: Q'*A*Q=T.
1472 
1473 Input parameters:
1474  A - matrix to be transformed
1475  array with elements [0..N-1, 0..N-1].
1476  N - size of matrix A.
1477  IsUpper - storage format. If IsUpper = True, then matrix A is given
1478  by its upper triangle, and the lower triangle is not used
1479  and not modified by the algorithm, and vice versa
1480  if IsUpper = False.
1481 
1482 Output parameters:
1483  A - matrices T and Q in compact form (see lower)
1484  Tau - array of factors which are forming matrices H(i)
1485  array with elements [0..N-2].
1486  D - main diagonal of symmetric matrix T.
1487  array with elements [0..N-1].
1488  E - secondary diagonal of symmetric matrix T.
1489  array with elements [0..N-2].
1490 
1491 
1492  If IsUpper=True, the matrix Q is represented as a product of elementary
1493  reflectors
1494 
1495  Q = H(n-2) . . . H(2) H(0).
1496 
1497  Each H(i) has the form
1498 
1499  H(i) = I - tau * v * v'
1500 
1501  where tau is a real scalar, and v is a real vector with
1502  v(i+1:n-1) = 0, v(i) = 1, v(0:i-1) is stored on exit in
1503  A(0:i-1,i+1), and tau in TAU(i).
1504 
1505  If IsUpper=False, the matrix Q is represented as a product of elementary
1506  reflectors
1507 
1508  Q = H(0) H(2) . . . H(n-2).
1509 
1510  Each H(i) has the form
1511 
1512  H(i) = I - tau * v * v'
1513 
1514  where tau is a real scalar, and v is a real vector with
1515  v(0:i) = 0, v(i+1) = 1, v(i+2:n-1) is stored on exit in A(i+2:n-1,i),
1516  and tau in TAU(i).
1517 
1518  The contents of A on exit are illustrated by the following examples
1519  with n = 5:
1520 
1521  if UPLO = 'U': if UPLO = 'L':
1522 
1523  ( d e v1 v2 v3 ) ( d )
1524  ( d e v2 v3 ) ( e d )
1525  ( d e v3 ) ( v0 e d )
1526  ( d e ) ( v0 v1 e d )
1527  ( d ) ( v0 v1 v2 e d )
1528 
1529  where d and e denote diagonal and off-diagonal elements of T, and vi
1530  denotes an element of the vector defining H(i).
1531 
1532  -- LAPACK routine (version 3.0) --
1533  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
1534  Courant Institute, Argonne National Lab, and Rice University
1535  October 31, 1992
1536 *************************************************************************/
1537 void smatrixtd(real_2d_array &a, const ae_int_t n, const bool isupper, real_1d_array &tau, real_1d_array &d, real_1d_array &e)
1538 {
1539  alglib_impl::ae_state _alglib_env_state;
1540  alglib_impl::ae_state_init(&_alglib_env_state);
1541  try
1542  {
1543  alglib_impl::smatrixtd(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, const_cast<alglib_impl::ae_vector*>(tau.c_ptr()), const_cast<alglib_impl::ae_vector*>(d.c_ptr()), const_cast<alglib_impl::ae_vector*>(e.c_ptr()), &_alglib_env_state);
1544  alglib_impl::ae_state_clear(&_alglib_env_state);
1545  return;
1546  }
1548  {
1549  throw ap_error(_alglib_env_state.error_msg);
1550  }
1551 }
1552 
1553 /*************************************************************************
1554 Unpacking matrix Q which reduces symmetric matrix to a tridiagonal
1555 form.
1556 
1557 Input parameters:
1558  A - the result of a SMatrixTD subroutine
1559  N - size of matrix A.
1560  IsUpper - storage format (a parameter of SMatrixTD subroutine)
1561  Tau - the result of a SMatrixTD subroutine
1562 
1563 Output parameters:
1564  Q - transformation matrix.
1565  array with elements [0..N-1, 0..N-1].
1566 
1567  -- ALGLIB --
1568  Copyright 2005-2010 by Bochkanov Sergey
1569 *************************************************************************/
1570 void smatrixtdunpackq(const real_2d_array &a, const ae_int_t n, const bool isupper, const real_1d_array &tau, real_2d_array &q)
1571 {
1572  alglib_impl::ae_state _alglib_env_state;
1573  alglib_impl::ae_state_init(&_alglib_env_state);
1574  try
1575  {
1576  alglib_impl::smatrixtdunpackq(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, const_cast<alglib_impl::ae_vector*>(tau.c_ptr()), const_cast<alglib_impl::ae_matrix*>(q.c_ptr()), &_alglib_env_state);
1577  alglib_impl::ae_state_clear(&_alglib_env_state);
1578  return;
1579  }
1581  {
1582  throw ap_error(_alglib_env_state.error_msg);
1583  }
1584 }
1585 
1586 /*************************************************************************
1587 Reduction of a Hermitian matrix which is given by its higher or lower
1588 triangular part to a real tridiagonal matrix using unitary similarity
1589 transformation: Q'*A*Q = T.
1590 
1591 Input parameters:
1592  A - matrix to be transformed
1593  array with elements [0..N-1, 0..N-1].
1594  N - size of matrix A.
1595  IsUpper - storage format. If IsUpper = True, then matrix A is given
1596  by its upper triangle, and the lower triangle is not used
1597  and not modified by the algorithm, and vice versa
1598  if IsUpper = False.
1599 
1600 Output parameters:
1601  A - matrices T and Q in compact form (see lower)
1602  Tau - array of factors which are forming matrices H(i)
1603  array with elements [0..N-2].
1604  D - main diagonal of real symmetric matrix T.
1605  array with elements [0..N-1].
1606  E - secondary diagonal of real symmetric matrix T.
1607  array with elements [0..N-2].
1608 
1609 
1610  If IsUpper=True, the matrix Q is represented as a product of elementary
1611  reflectors
1612 
1613  Q = H(n-2) . . . H(2) H(0).
1614 
1615  Each H(i) has the form
1616 
1617  H(i) = I - tau * v * v'
1618 
1619  where tau is a complex scalar, and v is a complex vector with
1620  v(i+1:n-1) = 0, v(i) = 1, v(0:i-1) is stored on exit in
1621  A(0:i-1,i+1), and tau in TAU(i).
1622 
1623  If IsUpper=False, the matrix Q is represented as a product of elementary
1624  reflectors
1625 
1626  Q = H(0) H(2) . . . H(n-2).
1627 
1628  Each H(i) has the form
1629 
1630  H(i) = I - tau * v * v'
1631 
1632  where tau is a complex scalar, and v is a complex vector with
1633  v(0:i) = 0, v(i+1) = 1, v(i+2:n-1) is stored on exit in A(i+2:n-1,i),
1634  and tau in TAU(i).
1635 
1636  The contents of A on exit are illustrated by the following examples
1637  with n = 5:
1638 
1639  if UPLO = 'U': if UPLO = 'L':
1640 
1641  ( d e v1 v2 v3 ) ( d )
1642  ( d e v2 v3 ) ( e d )
1643  ( d e v3 ) ( v0 e d )
1644  ( d e ) ( v0 v1 e d )
1645  ( d ) ( v0 v1 v2 e d )
1646 
1647 where d and e denote diagonal and off-diagonal elements of T, and vi
1648 denotes an element of the vector defining H(i).
1649 
1650  -- LAPACK routine (version 3.0) --
1651  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
1652  Courant Institute, Argonne National Lab, and Rice University
1653  October 31, 1992
1654 *************************************************************************/
1655 void hmatrixtd(complex_2d_array &a, const ae_int_t n, const bool isupper, complex_1d_array &tau, real_1d_array &d, real_1d_array &e)
1656 {
1657  alglib_impl::ae_state _alglib_env_state;
1658  alglib_impl::ae_state_init(&_alglib_env_state);
1659  try
1660  {
1661  alglib_impl::hmatrixtd(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, const_cast<alglib_impl::ae_vector*>(tau.c_ptr()), const_cast<alglib_impl::ae_vector*>(d.c_ptr()), const_cast<alglib_impl::ae_vector*>(e.c_ptr()), &_alglib_env_state);
1662  alglib_impl::ae_state_clear(&_alglib_env_state);
1663  return;
1664  }
1666  {
1667  throw ap_error(_alglib_env_state.error_msg);
1668  }
1669 }
1670 
1671 /*************************************************************************
1672 Unpacking matrix Q which reduces a Hermitian matrix to a real tridiagonal
1673 form.
1674 
1675 Input parameters:
1676  A - the result of a HMatrixTD subroutine
1677  N - size of matrix A.
1678  IsUpper - storage format (a parameter of HMatrixTD subroutine)
1679  Tau - the result of a HMatrixTD subroutine
1680 
1681 Output parameters:
1682  Q - transformation matrix.
1683  array with elements [0..N-1, 0..N-1].
1684 
1685  -- ALGLIB --
1686  Copyright 2005-2010 by Bochkanov Sergey
1687 *************************************************************************/
1688 void hmatrixtdunpackq(const complex_2d_array &a, const ae_int_t n, const bool isupper, const complex_1d_array &tau, complex_2d_array &q)
1689 {
1690  alglib_impl::ae_state _alglib_env_state;
1691  alglib_impl::ae_state_init(&_alglib_env_state);
1692  try
1693  {
1694  alglib_impl::hmatrixtdunpackq(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, const_cast<alglib_impl::ae_vector*>(tau.c_ptr()), const_cast<alglib_impl::ae_matrix*>(q.c_ptr()), &_alglib_env_state);
1695  alglib_impl::ae_state_clear(&_alglib_env_state);
1696  return;
1697  }
1699  {
1700  throw ap_error(_alglib_env_state.error_msg);
1701  }
1702 }
1703 
1704 /*************************************************************************
1705 Singular value decomposition of a bidiagonal matrix (extended algorithm)
1706 
1707 The algorithm performs the singular value decomposition of a bidiagonal
1708 matrix B (upper or lower) representing it as B = Q*S*P^T, where Q and P -
1709 orthogonal matrices, S - diagonal matrix with non-negative elements on the
1710 main diagonal, in descending order.
1711 
1712 The algorithm finds singular values. In addition, the algorithm can
1713 calculate matrices Q and P (more precisely, not the matrices, but their
1714 product with given matrices U and VT - U*Q and (P^T)*VT)). Of course,
1715 matrices U and VT can be of any type, including identity. Furthermore, the
1716 algorithm can calculate Q'*C (this product is calculated more effectively
1717 than U*Q, because this calculation operates with rows instead of matrix
1718 columns).
1719 
1720 The feature of the algorithm is its ability to find all singular values
1721 including those which are arbitrarily close to 0 with relative accuracy
1722 close to machine precision. If the parameter IsFractionalAccuracyRequired
1723 is set to True, all singular values will have high relative accuracy close
1724 to machine precision. If the parameter is set to False, only the biggest
1725 singular value will have relative accuracy close to machine precision.
1726 The absolute error of other singular values is equal to the absolute error
1727 of the biggest singular value.
1728 
1729 Input parameters:
1730  D - main diagonal of matrix B.
1731  Array whose index ranges within [0..N-1].
1732  E - superdiagonal (or subdiagonal) of matrix B.
1733  Array whose index ranges within [0..N-2].
1734  N - size of matrix B.
1735  IsUpper - True, if the matrix is upper bidiagonal.
1736  IsFractionalAccuracyRequired -
1737  THIS PARAMETER IS IGNORED SINCE ALGLIB 3.5.0
1738  SINGULAR VALUES ARE ALWAYS SEARCHED WITH HIGH ACCURACY.
1739  U - matrix to be multiplied by Q.
1740  Array whose indexes range within [0..NRU-1, 0..N-1].
1741  The matrix can be bigger, in that case only the submatrix
1742  [0..NRU-1, 0..N-1] will be multiplied by Q.
1743  NRU - number of rows in matrix U.
1744  C - matrix to be multiplied by Q'.
1745  Array whose indexes range within [0..N-1, 0..NCC-1].
1746  The matrix can be bigger, in that case only the submatrix
1747  [0..N-1, 0..NCC-1] will be multiplied by Q'.
1748  NCC - number of columns in matrix C.
1749  VT - matrix to be multiplied by P^T.
1750  Array whose indexes range within [0..N-1, 0..NCVT-1].
1751  The matrix can be bigger, in that case only the submatrix
1752  [0..N-1, 0..NCVT-1] will be multiplied by P^T.
1753  NCVT - number of columns in matrix VT.
1754 
1755 Output parameters:
1756  D - singular values of matrix B in descending order.
1757  U - if NRU>0, contains matrix U*Q.
1758  VT - if NCVT>0, contains matrix (P^T)*VT.
1759  C - if NCC>0, contains matrix Q'*C.
1760 
1761 Result:
1762  True, if the algorithm has converged.
1763  False, if the algorithm hasn't converged (rare case).
1764 
1765 Additional information:
1766  The type of convergence is controlled by the internal parameter TOL.
1767  If the parameter is greater than 0, the singular values will have
1768  relative accuracy TOL. If TOL<0, the singular values will have
1769  absolute accuracy ABS(TOL)*norm(B).
1770  By default, |TOL| falls within the range of 10*Epsilon and 100*Epsilon,
1771  where Epsilon is the machine precision. It is not recommended to use
1772  TOL less than 10*Epsilon since this will considerably slow down the
1773  algorithm and may not lead to error decreasing.
1774 History:
1775  * 31 March, 2007.
1776  changed MAXITR from 6 to 12.
1777 
1778  -- LAPACK routine (version 3.0) --
1779  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
1780  Courant Institute, Argonne National Lab, and Rice University
1781  October 31, 1999.
1782 *************************************************************************/
1783 bool rmatrixbdsvd(real_1d_array &d, const real_1d_array &e, const ae_int_t n, const bool isupper, const bool isfractionalaccuracyrequired, real_2d_array &u, const ae_int_t nru, real_2d_array &c, const ae_int_t ncc, real_2d_array &vt, const ae_int_t ncvt)
1784 {
1785  alglib_impl::ae_state _alglib_env_state;
1786  alglib_impl::ae_state_init(&_alglib_env_state);
1787  try
1788  {
1789  ae_bool result = alglib_impl::rmatrixbdsvd(const_cast<alglib_impl::ae_vector*>(d.c_ptr()), const_cast<alglib_impl::ae_vector*>(e.c_ptr()), n, isupper, isfractionalaccuracyrequired, const_cast<alglib_impl::ae_matrix*>(u.c_ptr()), nru, const_cast<alglib_impl::ae_matrix*>(c.c_ptr()), ncc, const_cast<alglib_impl::ae_matrix*>(vt.c_ptr()), ncvt, &_alglib_env_state);
1790  alglib_impl::ae_state_clear(&_alglib_env_state);
1791  return *(reinterpret_cast<bool*>(&result));
1792  }
1794  {
1795  throw ap_error(_alglib_env_state.error_msg);
1796  }
1797 }
1798 
1799 /*************************************************************************
1800 Singular value decomposition of a rectangular matrix.
1801 
1802 The algorithm calculates the singular value decomposition of a matrix of
1803 size MxN: A = U * S * V^T
1804 
1805 The algorithm finds the singular values and, optionally, matrices U and V^T.
1806 The algorithm can find both first min(M,N) columns of matrix U and rows of
1807 matrix V^T (singular vectors), and matrices U and V^T wholly (of sizes MxM
1808 and NxN respectively).
1809 
1810 Take into account that the subroutine does not return matrix V but V^T.
1811 
1812 Input parameters:
1813  A - matrix to be decomposed.
1814  Array whose indexes range within [0..M-1, 0..N-1].
1815  M - number of rows in matrix A.
1816  N - number of columns in matrix A.
1817  UNeeded - 0, 1 or 2. See the description of the parameter U.
1818  VTNeeded - 0, 1 or 2. See the description of the parameter VT.
1819  AdditionalMemory -
1820  If the parameter:
1821  * equals 0, the algorithm doesn’t use additional
1822  memory (lower requirements, lower performance).
1823  * equals 1, the algorithm uses additional
1824  memory of size min(M,N)*min(M,N) of real numbers.
1825  It often speeds up the algorithm.
1826  * equals 2, the algorithm uses additional
1827  memory of size M*min(M,N) of real numbers.
1828  It allows to get a maximum performance.
1829  The recommended value of the parameter is 2.
1830 
1831 Output parameters:
1832  W - contains singular values in descending order.
1833  U - if UNeeded=0, U isn't changed, the left singular vectors
1834  are not calculated.
1835  if Uneeded=1, U contains left singular vectors (first
1836  min(M,N) columns of matrix U). Array whose indexes range
1837  within [0..M-1, 0..Min(M,N)-1].
1838  if UNeeded=2, U contains matrix U wholly. Array whose
1839  indexes range within [0..M-1, 0..M-1].
1840  VT - if VTNeeded=0, VT isn’t changed, the right singular vectors
1841  are not calculated.
1842  if VTNeeded=1, VT contains right singular vectors (first
1843  min(M,N) rows of matrix V^T). Array whose indexes range
1844  within [0..min(M,N)-1, 0..N-1].
1845  if VTNeeded=2, VT contains matrix V^T wholly. Array whose
1846  indexes range within [0..N-1, 0..N-1].
1847 
1848  -- ALGLIB --
1849  Copyright 2005 by Bochkanov Sergey
1850 *************************************************************************/
1851 bool rmatrixsvd(const real_2d_array &a, const ae_int_t m, const ae_int_t n, const ae_int_t uneeded, const ae_int_t vtneeded, const ae_int_t additionalmemory, real_1d_array &w, real_2d_array &u, real_2d_array &vt)
1852 {
1853  alglib_impl::ae_state _alglib_env_state;
1854  alglib_impl::ae_state_init(&_alglib_env_state);
1855  try
1856  {
1857  ae_bool result = alglib_impl::rmatrixsvd(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), m, n, uneeded, vtneeded, additionalmemory, const_cast<alglib_impl::ae_vector*>(w.c_ptr()), const_cast<alglib_impl::ae_matrix*>(u.c_ptr()), const_cast<alglib_impl::ae_matrix*>(vt.c_ptr()), &_alglib_env_state);
1858  alglib_impl::ae_state_clear(&_alglib_env_state);
1859  return *(reinterpret_cast<bool*>(&result));
1860  }
1862  {
1863  throw ap_error(_alglib_env_state.error_msg);
1864  }
1865 }
1866 
1867 /*************************************************************************
1868 Finding the eigenvalues and eigenvectors of a symmetric matrix
1869 
1870 The algorithm finds eigen pairs of a symmetric matrix by reducing it to
1871 tridiagonal form and using the QL/QR algorithm.
1872 
1873 Input parameters:
1874  A - symmetric matrix which is given by its upper or lower
1875  triangular part.
1876  Array whose indexes range within [0..N-1, 0..N-1].
1877  N - size of matrix A.
1878  ZNeeded - flag controlling whether the eigenvectors are needed or not.
1879  If ZNeeded is equal to:
1880  * 0, the eigenvectors are not returned;
1881  * 1, the eigenvectors are returned.
1882  IsUpper - storage format.
1883 
1884 Output parameters:
1885  D - eigenvalues in ascending order.
1886  Array whose index ranges within [0..N-1].
1887  Z - if ZNeeded is equal to:
1888  * 0, Z hasn’t changed;
1889  * 1, Z contains the eigenvectors.
1890  Array whose indexes range within [0..N-1, 0..N-1].
1891  The eigenvectors are stored in the matrix columns.
1892 
1893 Result:
1894  True, if the algorithm has converged.
1895  False, if the algorithm hasn't converged (rare case).
1896 
1897  -- ALGLIB --
1898  Copyright 2005-2008 by Bochkanov Sergey
1899 *************************************************************************/
1900 bool smatrixevd(const real_2d_array &a, const ae_int_t n, const ae_int_t zneeded, const bool isupper, real_1d_array &d, real_2d_array &z)
1901 {
1902  alglib_impl::ae_state _alglib_env_state;
1903  alglib_impl::ae_state_init(&_alglib_env_state);
1904  try
1905  {
1906  ae_bool result = alglib_impl::smatrixevd(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, zneeded, isupper, const_cast<alglib_impl::ae_vector*>(d.c_ptr()), const_cast<alglib_impl::ae_matrix*>(z.c_ptr()), &_alglib_env_state);
1907  alglib_impl::ae_state_clear(&_alglib_env_state);
1908  return *(reinterpret_cast<bool*>(&result));
1909  }
1911  {
1912  throw ap_error(_alglib_env_state.error_msg);
1913  }
1914 }
1915 
1916 /*************************************************************************
1917 Subroutine for finding the eigenvalues (and eigenvectors) of a symmetric
1918 matrix in a given half open interval (A, B] by using a bisection and
1919 inverse iteration
1920 
1921 Input parameters:
1922  A - symmetric matrix which is given by its upper or lower
1923  triangular part. Array [0..N-1, 0..N-1].
1924  N - size of matrix A.
1925  ZNeeded - flag controlling whether the eigenvectors are needed or not.
1926  If ZNeeded is equal to:
1927  * 0, the eigenvectors are not returned;
1928  * 1, the eigenvectors are returned.
1929  IsUpperA - storage format of matrix A.
1930  B1, B2 - half open interval (B1, B2] to search eigenvalues in.
1931 
1932 Output parameters:
1933  M - number of eigenvalues found in a given half-interval (M>=0).
1934  W - array of the eigenvalues found.
1935  Array whose index ranges within [0..M-1].
1936  Z - if ZNeeded is equal to:
1937  * 0, Z hasn’t changed;
1938  * 1, Z contains eigenvectors.
1939  Array whose indexes range within [0..N-1, 0..M-1].
1940  The eigenvectors are stored in the matrix columns.
1941 
1942 Result:
1943  True, if successful. M contains the number of eigenvalues in the given
1944  half-interval (could be equal to 0), W contains the eigenvalues,
1945  Z contains the eigenvectors (if needed).
1946 
1947  False, if the bisection method subroutine wasn't able to find the
1948  eigenvalues in the given interval or if the inverse iteration subroutine
1949  wasn't able to find all the corresponding eigenvectors.
1950  In that case, the eigenvalues and eigenvectors are not returned,
1951  M is equal to 0.
1952 
1953  -- ALGLIB --
1954  Copyright 07.01.2006 by Bochkanov Sergey
1955 *************************************************************************/
1956 bool smatrixevdr(const real_2d_array &a, const ae_int_t n, const ae_int_t zneeded, const bool isupper, const double b1, const double b2, ae_int_t &m, real_1d_array &w, real_2d_array &z)
1957 {
1958  alglib_impl::ae_state _alglib_env_state;
1959  alglib_impl::ae_state_init(&_alglib_env_state);
1960  try
1961  {
1962  ae_bool result = alglib_impl::smatrixevdr(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, zneeded, isupper, b1, b2, &m, const_cast<alglib_impl::ae_vector*>(w.c_ptr()), const_cast<alglib_impl::ae_matrix*>(z.c_ptr()), &_alglib_env_state);
1963  alglib_impl::ae_state_clear(&_alglib_env_state);
1964  return *(reinterpret_cast<bool*>(&result));
1965  }
1967  {
1968  throw ap_error(_alglib_env_state.error_msg);
1969  }
1970 }
1971 
1972 /*************************************************************************
1973 Subroutine for finding the eigenvalues and eigenvectors of a symmetric
1974 matrix with given indexes by using bisection and inverse iteration methods.
1975 
1976 Input parameters:
1977  A - symmetric matrix which is given by its upper or lower
1978  triangular part. Array whose indexes range within [0..N-1, 0..N-1].
1979  N - size of matrix A.
1980  ZNeeded - flag controlling whether the eigenvectors are needed or not.
1981  If ZNeeded is equal to:
1982  * 0, the eigenvectors are not returned;
1983  * 1, the eigenvectors are returned.
1984  IsUpperA - storage format of matrix A.
1985  I1, I2 - index interval for searching (from I1 to I2).
1986  0 <= I1 <= I2 <= N-1.
1987 
1988 Output parameters:
1989  W - array of the eigenvalues found.
1990  Array whose index ranges within [0..I2-I1].
1991  Z - if ZNeeded is equal to:
1992  * 0, Z hasn’t changed;
1993  * 1, Z contains eigenvectors.
1994  Array whose indexes range within [0..N-1, 0..I2-I1].
1995  In that case, the eigenvectors are stored in the matrix columns.
1996 
1997 Result:
1998  True, if successful. W contains the eigenvalues, Z contains the
1999  eigenvectors (if needed).
2000 
2001  False, if the bisection method subroutine wasn't able to find the
2002  eigenvalues in the given interval or if the inverse iteration subroutine
2003  wasn't able to find all the corresponding eigenvectors.
2004  In that case, the eigenvalues and eigenvectors are not returned.
2005 
2006  -- ALGLIB --
2007  Copyright 07.01.2006 by Bochkanov Sergey
2008 *************************************************************************/
2009 bool smatrixevdi(const real_2d_array &a, const ae_int_t n, const ae_int_t zneeded, const bool isupper, const ae_int_t i1, const ae_int_t i2, real_1d_array &w, real_2d_array &z)
2010 {
2011  alglib_impl::ae_state _alglib_env_state;
2012  alglib_impl::ae_state_init(&_alglib_env_state);
2013  try
2014  {
2015  ae_bool result = alglib_impl::smatrixevdi(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, zneeded, isupper, i1, i2, const_cast<alglib_impl::ae_vector*>(w.c_ptr()), const_cast<alglib_impl::ae_matrix*>(z.c_ptr()), &_alglib_env_state);
2016  alglib_impl::ae_state_clear(&_alglib_env_state);
2017  return *(reinterpret_cast<bool*>(&result));
2018  }
2020  {
2021  throw ap_error(_alglib_env_state.error_msg);
2022  }
2023 }
2024 
2025 /*************************************************************************
2026 Finding the eigenvalues and eigenvectors of a Hermitian matrix
2027 
2028 The algorithm finds eigen pairs of a Hermitian matrix by reducing it to
2029 real tridiagonal form and using the QL/QR algorithm.
2030 
2031 Input parameters:
2032  A - Hermitian matrix which is given by its upper or lower
2033  triangular part.
2034  Array whose indexes range within [0..N-1, 0..N-1].
2035  N - size of matrix A.
2036  IsUpper - storage format.
2037  ZNeeded - flag controlling whether the eigenvectors are needed or
2038  not. If ZNeeded is equal to:
2039  * 0, the eigenvectors are not returned;
2040  * 1, the eigenvectors are returned.
2041 
2042 Output parameters:
2043  D - eigenvalues in ascending order.
2044  Array whose index ranges within [0..N-1].
2045  Z - if ZNeeded is equal to:
2046  * 0, Z hasn’t changed;
2047  * 1, Z contains the eigenvectors.
2048  Array whose indexes range within [0..N-1, 0..N-1].
2049  The eigenvectors are stored in the matrix columns.
2050 
2051 Result:
2052  True, if the algorithm has converged.
2053  False, if the algorithm hasn't converged (rare case).
2054 
2055 Note:
2056  eigenvectors of Hermitian matrix are defined up to multiplication by
2057  a complex number L, such that |L|=1.
2058 
2059  -- ALGLIB --
2060  Copyright 2005, 23 March 2007 by Bochkanov Sergey
2061 *************************************************************************/
2062 bool hmatrixevd(const complex_2d_array &a, const ae_int_t n, const ae_int_t zneeded, const bool isupper, real_1d_array &d, complex_2d_array &z)
2063 {
2064  alglib_impl::ae_state _alglib_env_state;
2065  alglib_impl::ae_state_init(&_alglib_env_state);
2066  try
2067  {
2068  ae_bool result = alglib_impl::hmatrixevd(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, zneeded, isupper, const_cast<alglib_impl::ae_vector*>(d.c_ptr()), const_cast<alglib_impl::ae_matrix*>(z.c_ptr()), &_alglib_env_state);
2069  alglib_impl::ae_state_clear(&_alglib_env_state);
2070  return *(reinterpret_cast<bool*>(&result));
2071  }
2073  {
2074  throw ap_error(_alglib_env_state.error_msg);
2075  }
2076 }
2077 
2078 /*************************************************************************
2079 Subroutine for finding the eigenvalues (and eigenvectors) of a Hermitian
2080 matrix in a given half-interval (A, B] by using a bisection and inverse
2081 iteration
2082 
2083 Input parameters:
2084  A - Hermitian matrix which is given by its upper or lower
2085  triangular part. Array whose indexes range within
2086  [0..N-1, 0..N-1].
2087  N - size of matrix A.
2088  ZNeeded - flag controlling whether the eigenvectors are needed or
2089  not. If ZNeeded is equal to:
2090  * 0, the eigenvectors are not returned;
2091  * 1, the eigenvectors are returned.
2092  IsUpperA - storage format of matrix A.
2093  B1, B2 - half-interval (B1, B2] to search eigenvalues in.
2094 
2095 Output parameters:
2096  M - number of eigenvalues found in a given half-interval, M>=0
2097  W - array of the eigenvalues found.
2098  Array whose index ranges within [0..M-1].
2099  Z - if ZNeeded is equal to:
2100  * 0, Z hasn’t changed;
2101  * 1, Z contains eigenvectors.
2102  Array whose indexes range within [0..N-1, 0..M-1].
2103  The eigenvectors are stored in the matrix columns.
2104 
2105 Result:
2106  True, if successful. M contains the number of eigenvalues in the given
2107  half-interval (could be equal to 0), W contains the eigenvalues,
2108  Z contains the eigenvectors (if needed).
2109 
2110  False, if the bisection method subroutine wasn't able to find the
2111  eigenvalues in the given interval or if the inverse iteration
2112  subroutine wasn't able to find all the corresponding eigenvectors.
2113  In that case, the eigenvalues and eigenvectors are not returned, M is
2114  equal to 0.
2115 
2116 Note:
2117  eigen vectors of Hermitian matrix are defined up to multiplication by
2118  a complex number L, such as |L|=1.
2119 
2120  -- ALGLIB --
2121  Copyright 07.01.2006, 24.03.2007 by Bochkanov Sergey.
2122 *************************************************************************/
2123 bool hmatrixevdr(const complex_2d_array &a, const ae_int_t n, const ae_int_t zneeded, const bool isupper, const double b1, const double b2, ae_int_t &m, real_1d_array &w, complex_2d_array &z)
2124 {
2125  alglib_impl::ae_state _alglib_env_state;
2126  alglib_impl::ae_state_init(&_alglib_env_state);
2127  try
2128  {
2129  ae_bool result = alglib_impl::hmatrixevdr(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, zneeded, isupper, b1, b2, &m, const_cast<alglib_impl::ae_vector*>(w.c_ptr()), const_cast<alglib_impl::ae_matrix*>(z.c_ptr()), &_alglib_env_state);
2130  alglib_impl::ae_state_clear(&_alglib_env_state);
2131  return *(reinterpret_cast<bool*>(&result));
2132  }
2134  {
2135  throw ap_error(_alglib_env_state.error_msg);
2136  }
2137 }
2138 
2139 /*************************************************************************
2140 Subroutine for finding the eigenvalues and eigenvectors of a Hermitian
2141 matrix with given indexes by using bisection and inverse iteration methods
2142 
2143 Input parameters:
2144  A - Hermitian matrix which is given by its upper or lower
2145  triangular part.
2146  Array whose indexes range within [0..N-1, 0..N-1].
2147  N - size of matrix A.
2148  ZNeeded - flag controlling whether the eigenvectors are needed or
2149  not. If ZNeeded is equal to:
2150  * 0, the eigenvectors are not returned;
2151  * 1, the eigenvectors are returned.
2152  IsUpperA - storage format of matrix A.
2153  I1, I2 - index interval for searching (from I1 to I2).
2154  0 <= I1 <= I2 <= N-1.
2155 
2156 Output parameters:
2157  W - array of the eigenvalues found.
2158  Array whose index ranges within [0..I2-I1].
2159  Z - if ZNeeded is equal to:
2160  * 0, Z hasn’t changed;
2161  * 1, Z contains eigenvectors.
2162  Array whose indexes range within [0..N-1, 0..I2-I1].
2163  In that case, the eigenvectors are stored in the matrix
2164  columns.
2165 
2166 Result:
2167  True, if successful. W contains the eigenvalues, Z contains the
2168  eigenvectors (if needed).
2169 
2170  False, if the bisection method subroutine wasn't able to find the
2171  eigenvalues in the given interval or if the inverse iteration
2172  subroutine wasn't able to find all the corresponding eigenvectors.
2173  In that case, the eigenvalues and eigenvectors are not returned.
2174 
2175 Note:
2176  eigen vectors of Hermitian matrix are defined up to multiplication by
2177  a complex number L, such as |L|=1.
2178 
2179  -- ALGLIB --
2180  Copyright 07.01.2006, 24.03.2007 by Bochkanov Sergey.
2181 *************************************************************************/
2182 bool hmatrixevdi(const complex_2d_array &a, const ae_int_t n, const ae_int_t zneeded, const bool isupper, const ae_int_t i1, const ae_int_t i2, real_1d_array &w, complex_2d_array &z)
2183 {
2184  alglib_impl::ae_state _alglib_env_state;
2185  alglib_impl::ae_state_init(&_alglib_env_state);
2186  try
2187  {
2188  ae_bool result = alglib_impl::hmatrixevdi(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, zneeded, isupper, i1, i2, const_cast<alglib_impl::ae_vector*>(w.c_ptr()), const_cast<alglib_impl::ae_matrix*>(z.c_ptr()), &_alglib_env_state);
2189  alglib_impl::ae_state_clear(&_alglib_env_state);
2190  return *(reinterpret_cast<bool*>(&result));
2191  }
2193  {
2194  throw ap_error(_alglib_env_state.error_msg);
2195  }
2196 }
2197 
2198 /*************************************************************************
2199 Finding the eigenvalues and eigenvectors of a tridiagonal symmetric matrix
2200 
2201 The algorithm finds the eigen pairs of a tridiagonal symmetric matrix by
2202 using an QL/QR algorithm with implicit shifts.
2203 
2204 Input parameters:
2205  D - the main diagonal of a tridiagonal matrix.
2206  Array whose index ranges within [0..N-1].
2207  E - the secondary diagonal of a tridiagonal matrix.
2208  Array whose index ranges within [0..N-2].
2209  N - size of matrix A.
2210  ZNeeded - flag controlling whether the eigenvectors are needed or not.
2211  If ZNeeded is equal to:
2212  * 0, the eigenvectors are not needed;
2213  * 1, the eigenvectors of a tridiagonal matrix
2214  are multiplied by the square matrix Z. It is used if the
2215  tridiagonal matrix is obtained by the similarity
2216  transformation of a symmetric matrix;
2217  * 2, the eigenvectors of a tridiagonal matrix replace the
2218  square matrix Z;
2219  * 3, matrix Z contains the first row of the eigenvectors
2220  matrix.
2221  Z - if ZNeeded=1, Z contains the square matrix by which the
2222  eigenvectors are multiplied.
2223  Array whose indexes range within [0..N-1, 0..N-1].
2224 
2225 Output parameters:
2226  D - eigenvalues in ascending order.
2227  Array whose index ranges within [0..N-1].
2228  Z - if ZNeeded is equal to:
2229  * 0, Z hasn’t changed;
2230  * 1, Z contains the product of a given matrix (from the left)
2231  and the eigenvectors matrix (from the right);
2232  * 2, Z contains the eigenvectors.
2233  * 3, Z contains the first row of the eigenvectors matrix.
2234  If ZNeeded<3, Z is the array whose indexes range within [0..N-1, 0..N-1].
2235  In that case, the eigenvectors are stored in the matrix columns.
2236  If ZNeeded=3, Z is the array whose indexes range within [0..0, 0..N-1].
2237 
2238 Result:
2239  True, if the algorithm has converged.
2240  False, if the algorithm hasn't converged.
2241 
2242  -- LAPACK routine (version 3.0) --
2243  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
2244  Courant Institute, Argonne National Lab, and Rice University
2245  September 30, 1994
2246 *************************************************************************/
2247 bool smatrixtdevd(real_1d_array &d, const real_1d_array &e, const ae_int_t n, const ae_int_t zneeded, real_2d_array &z)
2248 {
2249  alglib_impl::ae_state _alglib_env_state;
2250  alglib_impl::ae_state_init(&_alglib_env_state);
2251  try
2252  {
2253  ae_bool result = alglib_impl::smatrixtdevd(const_cast<alglib_impl::ae_vector*>(d.c_ptr()), const_cast<alglib_impl::ae_vector*>(e.c_ptr()), n, zneeded, const_cast<alglib_impl::ae_matrix*>(z.c_ptr()), &_alglib_env_state);
2254  alglib_impl::ae_state_clear(&_alglib_env_state);
2255  return *(reinterpret_cast<bool*>(&result));
2256  }
2258  {
2259  throw ap_error(_alglib_env_state.error_msg);
2260  }
2261 }
2262 
2263 /*************************************************************************
2264 Subroutine for finding the tridiagonal matrix eigenvalues/vectors in a
2265 given half-interval (A, B] by using bisection and inverse iteration.
2266 
2267 Input parameters:
2268  D - the main diagonal of a tridiagonal matrix.
2269  Array whose index ranges within [0..N-1].
2270  E - the secondary diagonal of a tridiagonal matrix.
2271  Array whose index ranges within [0..N-2].
2272  N - size of matrix, N>=0.
2273  ZNeeded - flag controlling whether the eigenvectors are needed or not.
2274  If ZNeeded is equal to:
2275  * 0, the eigenvectors are not needed;
2276  * 1, the eigenvectors of a tridiagonal matrix are multiplied
2277  by the square matrix Z. It is used if the tridiagonal
2278  matrix is obtained by the similarity transformation
2279  of a symmetric matrix.
2280  * 2, the eigenvectors of a tridiagonal matrix replace matrix Z.
2281  A, B - half-interval (A, B] to search eigenvalues in.
2282  Z - if ZNeeded is equal to:
2283  * 0, Z isn't used and remains unchanged;
2284  * 1, Z contains the square matrix (array whose indexes range
2285  within [0..N-1, 0..N-1]) which reduces the given symmetric
2286  matrix to tridiagonal form;
2287  * 2, Z isn't used (but changed on the exit).
2288 
2289 Output parameters:
2290  D - array of the eigenvalues found.
2291  Array whose index ranges within [0..M-1].
2292  M - number of eigenvalues found in the given half-interval (M>=0).
2293  Z - if ZNeeded is equal to:
2294  * 0, doesn't contain any information;
2295  * 1, contains the product of a given NxN matrix Z (from the
2296  left) and NxM matrix of the eigenvectors found (from the
2297  right). Array whose indexes range within [0..N-1, 0..M-1].
2298  * 2, contains the matrix of the eigenvectors found.
2299  Array whose indexes range within [0..N-1, 0..M-1].
2300 
2301 Result:
2302 
2303  True, if successful. In that case, M contains the number of eigenvalues
2304  in the given half-interval (could be equal to 0), D contains the eigenvalues,
2305  Z contains the eigenvectors (if needed).
2306  It should be noted that the subroutine changes the size of arrays D and Z.
2307 
2308  False, if the bisection method subroutine wasn't able to find the
2309  eigenvalues in the given interval or if the inverse iteration subroutine
2310  wasn't able to find all the corresponding eigenvectors. In that case,
2311  the eigenvalues and eigenvectors are not returned, M is equal to 0.
2312 
2313  -- ALGLIB --
2314  Copyright 31.03.2008 by Bochkanov Sergey
2315 *************************************************************************/
2316 bool smatrixtdevdr(real_1d_array &d, const real_1d_array &e, const ae_int_t n, const ae_int_t zneeded, const double a, const double b, ae_int_t &m, real_2d_array &z)
2317 {
2318  alglib_impl::ae_state _alglib_env_state;
2319  alglib_impl::ae_state_init(&_alglib_env_state);
2320  try
2321  {
2322  ae_bool result = alglib_impl::smatrixtdevdr(const_cast<alglib_impl::ae_vector*>(d.c_ptr()), const_cast<alglib_impl::ae_vector*>(e.c_ptr()), n, zneeded, a, b, &m, const_cast<alglib_impl::ae_matrix*>(z.c_ptr()), &_alglib_env_state);
2323  alglib_impl::ae_state_clear(&_alglib_env_state);
2324  return *(reinterpret_cast<bool*>(&result));
2325  }
2327  {
2328  throw ap_error(_alglib_env_state.error_msg);
2329  }
2330 }
2331 
2332 /*************************************************************************
2333 Subroutine for finding tridiagonal matrix eigenvalues/vectors with given
2334 indexes (in ascending order) by using the bisection and inverse iteraion.
2335 
2336 Input parameters:
2337  D - the main diagonal of a tridiagonal matrix.
2338  Array whose index ranges within [0..N-1].
2339  E - the secondary diagonal of a tridiagonal matrix.
2340  Array whose index ranges within [0..N-2].
2341  N - size of matrix. N>=0.
2342  ZNeeded - flag controlling whether the eigenvectors are needed or not.
2343  If ZNeeded is equal to:
2344  * 0, the eigenvectors are not needed;
2345  * 1, the eigenvectors of a tridiagonal matrix are multiplied
2346  by the square matrix Z. It is used if the
2347  tridiagonal matrix is obtained by the similarity transformation
2348  of a symmetric matrix.
2349  * 2, the eigenvectors of a tridiagonal matrix replace
2350  matrix Z.
2351  I1, I2 - index interval for searching (from I1 to I2).
2352  0 <= I1 <= I2 <= N-1.
2353  Z - if ZNeeded is equal to:
2354  * 0, Z isn't used and remains unchanged;
2355  * 1, Z contains the square matrix (array whose indexes range within [0..N-1, 0..N-1])
2356  which reduces the given symmetric matrix to tridiagonal form;
2357  * 2, Z isn't used (but changed on the exit).
2358 
2359 Output parameters:
2360  D - array of the eigenvalues found.
2361  Array whose index ranges within [0..I2-I1].
2362  Z - if ZNeeded is equal to:
2363  * 0, doesn't contain any information;
2364  * 1, contains the product of a given NxN matrix Z (from the left) and
2365  Nx(I2-I1) matrix of the eigenvectors found (from the right).
2366  Array whose indexes range within [0..N-1, 0..I2-I1].
2367  * 2, contains the matrix of the eigenvalues found.
2368  Array whose indexes range within [0..N-1, 0..I2-I1].
2369 
2370 
2371 Result:
2372 
2373  True, if successful. In that case, D contains the eigenvalues,
2374  Z contains the eigenvectors (if needed).
2375  It should be noted that the subroutine changes the size of arrays D and Z.
2376 
2377  False, if the bisection method subroutine wasn't able to find the eigenvalues
2378  in the given interval or if the inverse iteration subroutine wasn't able
2379  to find all the corresponding eigenvectors. In that case, the eigenvalues
2380  and eigenvectors are not returned.
2381 
2382  -- ALGLIB --
2383  Copyright 25.12.2005 by Bochkanov Sergey
2384 *************************************************************************/
2385 bool smatrixtdevdi(real_1d_array &d, const real_1d_array &e, const ae_int_t n, const ae_int_t zneeded, const ae_int_t i1, const ae_int_t i2, real_2d_array &z)
2386 {
2387  alglib_impl::ae_state _alglib_env_state;
2388  alglib_impl::ae_state_init(&_alglib_env_state);
2389  try
2390  {
2391  ae_bool result = alglib_impl::smatrixtdevdi(const_cast<alglib_impl::ae_vector*>(d.c_ptr()), const_cast<alglib_impl::ae_vector*>(e.c_ptr()), n, zneeded, i1, i2, const_cast<alglib_impl::ae_matrix*>(z.c_ptr()), &_alglib_env_state);
2392  alglib_impl::ae_state_clear(&_alglib_env_state);
2393  return *(reinterpret_cast<bool*>(&result));
2394  }
2396  {
2397  throw ap_error(_alglib_env_state.error_msg);
2398  }
2399 }
2400 
2401 /*************************************************************************
2402 Finding eigenvalues and eigenvectors of a general matrix
2403 
2404 The algorithm finds eigenvalues and eigenvectors of a general matrix by
2405 using the QR algorithm with multiple shifts. The algorithm can find
2406 eigenvalues and both left and right eigenvectors.
2407 
2408 The right eigenvector is a vector x such that A*x = w*x, and the left
2409 eigenvector is a vector y such that y'*A = w*y' (here y' implies a complex
2410 conjugate transposition of vector y).
2411 
2412 Input parameters:
2413  A - matrix. Array whose indexes range within [0..N-1, 0..N-1].
2414  N - size of matrix A.
2415  VNeeded - flag controlling whether eigenvectors are needed or not.
2416  If VNeeded is equal to:
2417  * 0, eigenvectors are not returned;
2418  * 1, right eigenvectors are returned;
2419  * 2, left eigenvectors are returned;
2420  * 3, both left and right eigenvectors are returned.
2421 
2422 Output parameters:
2423  WR - real parts of eigenvalues.
2424  Array whose index ranges within [0..N-1].
2425  WR - imaginary parts of eigenvalues.
2426  Array whose index ranges within [0..N-1].
2427  VL, VR - arrays of left and right eigenvectors (if they are needed).
2428  If WI[i]=0, the respective eigenvalue is a real number,
2429  and it corresponds to the column number I of matrices VL/VR.
2430  If WI[i]>0, we have a pair of complex conjugate numbers with
2431  positive and negative imaginary parts:
2432  the first eigenvalue WR[i] + sqrt(-1)*WI[i];
2433  the second eigenvalue WR[i+1] + sqrt(-1)*WI[i+1];
2434  WI[i]>0
2435  WI[i+1] = -WI[i] < 0
2436  In that case, the eigenvector corresponding to the first
2437  eigenvalue is located in i and i+1 columns of matrices
2438  VL/VR (the column number i contains the real part, and the
2439  column number i+1 contains the imaginary part), and the vector
2440  corresponding to the second eigenvalue is a complex conjugate to
2441  the first vector.
2442  Arrays whose indexes range within [0..N-1, 0..N-1].
2443 
2444 Result:
2445  True, if the algorithm has converged.
2446  False, if the algorithm has not converged.
2447 
2448 Note 1:
2449  Some users may ask the following question: what if WI[N-1]>0?
2450  WI[N] must contain an eigenvalue which is complex conjugate to the
2451  N-th eigenvalue, but the array has only size N?
2452  The answer is as follows: such a situation cannot occur because the
2453  algorithm finds a pairs of eigenvalues, therefore, if WI[i]>0, I is
2454  strictly less than N-1.
2455 
2456 Note 2:
2457  The algorithm performance depends on the value of the internal parameter
2458  NS of the InternalSchurDecomposition subroutine which defines the number
2459  of shifts in the QR algorithm (similarly to the block width in block-matrix
2460  algorithms of linear algebra). If you require maximum performance
2461  on your machine, it is recommended to adjust this parameter manually.
2462 
2463 
2464 See also the InternalTREVC subroutine.
2465 
2466 The algorithm is based on the LAPACK 3.0 library.
2467 *************************************************************************/
2468 bool rmatrixevd(const real_2d_array &a, const ae_int_t n, const ae_int_t vneeded, real_1d_array &wr, real_1d_array &wi, real_2d_array &vl, real_2d_array &vr)
2469 {
2470  alglib_impl::ae_state _alglib_env_state;
2471  alglib_impl::ae_state_init(&_alglib_env_state);
2472  try
2473  {
2474  ae_bool result = alglib_impl::rmatrixevd(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, vneeded, const_cast<alglib_impl::ae_vector*>(wr.c_ptr()), const_cast<alglib_impl::ae_vector*>(wi.c_ptr()), const_cast<alglib_impl::ae_matrix*>(vl.c_ptr()), const_cast<alglib_impl::ae_matrix*>(vr.c_ptr()), &_alglib_env_state);
2475  alglib_impl::ae_state_clear(&_alglib_env_state);
2476  return *(reinterpret_cast<bool*>(&result));
2477  }
2479  {
2480  throw ap_error(_alglib_env_state.error_msg);
2481  }
2482 }
2483 
2484 /*************************************************************************
2485 Generation of a random uniformly distributed (Haar) orthogonal matrix
2486 
2487 INPUT PARAMETERS:
2488  N - matrix size, N>=1
2489 
2490 OUTPUT PARAMETERS:
2491  A - orthogonal NxN matrix, array[0..N-1,0..N-1]
2492 
2493  -- ALGLIB routine --
2494  04.12.2009
2495  Bochkanov Sergey
2496 *************************************************************************/
2498 {
2499  alglib_impl::ae_state _alglib_env_state;
2500  alglib_impl::ae_state_init(&_alglib_env_state);
2501  try
2502  {
2503  alglib_impl::rmatrixrndorthogonal(n, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), &_alglib_env_state);
2504  alglib_impl::ae_state_clear(&_alglib_env_state);
2505  return;
2506  }
2508  {
2509  throw ap_error(_alglib_env_state.error_msg);
2510  }
2511 }
2512 
2513 /*************************************************************************
2514 Generation of random NxN matrix with given condition number and norm2(A)=1
2515 
2516 INPUT PARAMETERS:
2517  N - matrix size
2518  C - condition number (in 2-norm)
2519 
2520 OUTPUT PARAMETERS:
2521  A - random matrix with norm2(A)=1 and cond(A)=C
2522 
2523  -- ALGLIB routine --
2524  04.12.2009
2525  Bochkanov Sergey
2526 *************************************************************************/
2527 void rmatrixrndcond(const ae_int_t n, const double c, real_2d_array &a)
2528 {
2529  alglib_impl::ae_state _alglib_env_state;
2530  alglib_impl::ae_state_init(&_alglib_env_state);
2531  try
2532  {
2533  alglib_impl::rmatrixrndcond(n, c, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), &_alglib_env_state);
2534  alglib_impl::ae_state_clear(&_alglib_env_state);
2535  return;
2536  }
2538  {
2539  throw ap_error(_alglib_env_state.error_msg);
2540  }
2541 }
2542 
2543 /*************************************************************************
2544 Generation of a random Haar distributed orthogonal complex matrix
2545 
2546 INPUT PARAMETERS:
2547  N - matrix size, N>=1
2548 
2549 OUTPUT PARAMETERS:
2550  A - orthogonal NxN matrix, array[0..N-1,0..N-1]
2551 
2552  -- ALGLIB routine --
2553  04.12.2009
2554  Bochkanov Sergey
2555 *************************************************************************/
2557 {
2558  alglib_impl::ae_state _alglib_env_state;
2559  alglib_impl::ae_state_init(&_alglib_env_state);
2560  try
2561  {
2562  alglib_impl::cmatrixrndorthogonal(n, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), &_alglib_env_state);
2563  alglib_impl::ae_state_clear(&_alglib_env_state);
2564  return;
2565  }
2567  {
2568  throw ap_error(_alglib_env_state.error_msg);
2569  }
2570 }
2571 
2572 /*************************************************************************
2573 Generation of random NxN complex matrix with given condition number C and
2574 norm2(A)=1
2575 
2576 INPUT PARAMETERS:
2577  N - matrix size
2578  C - condition number (in 2-norm)
2579 
2580 OUTPUT PARAMETERS:
2581  A - random matrix with norm2(A)=1 and cond(A)=C
2582 
2583  -- ALGLIB routine --
2584  04.12.2009
2585  Bochkanov Sergey
2586 *************************************************************************/
2587 void cmatrixrndcond(const ae_int_t n, const double c, complex_2d_array &a)
2588 {
2589  alglib_impl::ae_state _alglib_env_state;
2590  alglib_impl::ae_state_init(&_alglib_env_state);
2591  try
2592  {
2593  alglib_impl::cmatrixrndcond(n, c, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), &_alglib_env_state);
2594  alglib_impl::ae_state_clear(&_alglib_env_state);
2595  return;
2596  }
2598  {
2599  throw ap_error(_alglib_env_state.error_msg);
2600  }
2601 }
2602 
2603 /*************************************************************************
2604 Generation of random NxN symmetric matrix with given condition number and
2605 norm2(A)=1
2606 
2607 INPUT PARAMETERS:
2608  N - matrix size
2609  C - condition number (in 2-norm)
2610 
2611 OUTPUT PARAMETERS:
2612  A - random matrix with norm2(A)=1 and cond(A)=C
2613 
2614  -- ALGLIB routine --
2615  04.12.2009
2616  Bochkanov Sergey
2617 *************************************************************************/
2618 void smatrixrndcond(const ae_int_t n, const double c, real_2d_array &a)
2619 {
2620  alglib_impl::ae_state _alglib_env_state;
2621  alglib_impl::ae_state_init(&_alglib_env_state);
2622  try
2623  {
2624  alglib_impl::smatrixrndcond(n, c, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), &_alglib_env_state);
2625  alglib_impl::ae_state_clear(&_alglib_env_state);
2626  return;
2627  }
2629  {
2630  throw ap_error(_alglib_env_state.error_msg);
2631  }
2632 }
2633 
2634 /*************************************************************************
2635 Generation of random NxN symmetric positive definite matrix with given
2636 condition number and norm2(A)=1
2637 
2638 INPUT PARAMETERS:
2639  N - matrix size
2640  C - condition number (in 2-norm)
2641 
2642 OUTPUT PARAMETERS:
2643  A - random SPD matrix with norm2(A)=1 and cond(A)=C
2644 
2645  -- ALGLIB routine --
2646  04.12.2009
2647  Bochkanov Sergey
2648 *************************************************************************/
2649 void spdmatrixrndcond(const ae_int_t n, const double c, real_2d_array &a)
2650 {
2651  alglib_impl::ae_state _alglib_env_state;
2652  alglib_impl::ae_state_init(&_alglib_env_state);
2653  try
2654  {
2655  alglib_impl::spdmatrixrndcond(n, c, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), &_alglib_env_state);
2656  alglib_impl::ae_state_clear(&_alglib_env_state);
2657  return;
2658  }
2660  {
2661  throw ap_error(_alglib_env_state.error_msg);
2662  }
2663 }
2664 
2665 /*************************************************************************
2666 Generation of random NxN Hermitian matrix with given condition number and
2667 norm2(A)=1
2668 
2669 INPUT PARAMETERS:
2670  N - matrix size
2671  C - condition number (in 2-norm)
2672 
2673 OUTPUT PARAMETERS:
2674  A - random matrix with norm2(A)=1 and cond(A)=C
2675 
2676  -- ALGLIB routine --
2677  04.12.2009
2678  Bochkanov Sergey
2679 *************************************************************************/
2680 void hmatrixrndcond(const ae_int_t n, const double c, complex_2d_array &a)
2681 {
2682  alglib_impl::ae_state _alglib_env_state;
2683  alglib_impl::ae_state_init(&_alglib_env_state);
2684  try
2685  {
2686  alglib_impl::hmatrixrndcond(n, c, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), &_alglib_env_state);
2687  alglib_impl::ae_state_clear(&_alglib_env_state);
2688  return;
2689  }
2691  {
2692  throw ap_error(_alglib_env_state.error_msg);
2693  }
2694 }
2695 
2696 /*************************************************************************
2697 Generation of random NxN Hermitian positive definite matrix with given
2698 condition number and norm2(A)=1
2699 
2700 INPUT PARAMETERS:
2701  N - matrix size
2702  C - condition number (in 2-norm)
2703 
2704 OUTPUT PARAMETERS:
2705  A - random HPD matrix with norm2(A)=1 and cond(A)=C
2706 
2707  -- ALGLIB routine --
2708  04.12.2009
2709  Bochkanov Sergey
2710 *************************************************************************/
2711 void hpdmatrixrndcond(const ae_int_t n, const double c, complex_2d_array &a)
2712 {
2713  alglib_impl::ae_state _alglib_env_state;
2714  alglib_impl::ae_state_init(&_alglib_env_state);
2715  try
2716  {
2717  alglib_impl::hpdmatrixrndcond(n, c, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), &_alglib_env_state);
2718  alglib_impl::ae_state_clear(&_alglib_env_state);
2719  return;
2720  }
2722  {
2723  throw ap_error(_alglib_env_state.error_msg);
2724  }
2725 }
2726 
2727 /*************************************************************************
2728 Multiplication of MxN matrix by NxN random Haar distributed orthogonal matrix
2729 
2730 INPUT PARAMETERS:
2731  A - matrix, array[0..M-1, 0..N-1]
2732  M, N- matrix size
2733 
2734 OUTPUT PARAMETERS:
2735  A - A*Q, where Q is random NxN orthogonal matrix
2736 
2737  -- ALGLIB routine --
2738  04.12.2009
2739  Bochkanov Sergey
2740 *************************************************************************/
2742 {
2743  alglib_impl::ae_state _alglib_env_state;
2744  alglib_impl::ae_state_init(&_alglib_env_state);
2745  try
2746  {
2747  alglib_impl::rmatrixrndorthogonalfromtheright(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), m, n, &_alglib_env_state);
2748  alglib_impl::ae_state_clear(&_alglib_env_state);
2749  return;
2750  }
2752  {
2753  throw ap_error(_alglib_env_state.error_msg);
2754  }
2755 }
2756 
2757 /*************************************************************************
2758 Multiplication of MxN matrix by MxM random Haar distributed orthogonal matrix
2759 
2760 INPUT PARAMETERS:
2761  A - matrix, array[0..M-1, 0..N-1]
2762  M, N- matrix size
2763 
2764 OUTPUT PARAMETERS:
2765  A - Q*A, where Q is random MxM orthogonal matrix
2766 
2767  -- ALGLIB routine --
2768  04.12.2009
2769  Bochkanov Sergey
2770 *************************************************************************/
2772 {
2773  alglib_impl::ae_state _alglib_env_state;
2774  alglib_impl::ae_state_init(&_alglib_env_state);
2775  try
2776  {
2777  alglib_impl::rmatrixrndorthogonalfromtheleft(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), m, n, &_alglib_env_state);
2778  alglib_impl::ae_state_clear(&_alglib_env_state);
2779  return;
2780  }
2782  {
2783  throw ap_error(_alglib_env_state.error_msg);
2784  }
2785 }
2786 
2787 /*************************************************************************
2788 Multiplication of MxN complex matrix by NxN random Haar distributed
2789 complex orthogonal matrix
2790 
2791 INPUT PARAMETERS:
2792  A - matrix, array[0..M-1, 0..N-1]
2793  M, N- matrix size
2794 
2795 OUTPUT PARAMETERS:
2796  A - A*Q, where Q is random NxN orthogonal matrix
2797 
2798  -- ALGLIB routine --
2799  04.12.2009
2800  Bochkanov Sergey
2801 *************************************************************************/
2803 {
2804  alglib_impl::ae_state _alglib_env_state;
2805  alglib_impl::ae_state_init(&_alglib_env_state);
2806  try
2807  {
2808  alglib_impl::cmatrixrndorthogonalfromtheright(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), m, n, &_alglib_env_state);
2809  alglib_impl::ae_state_clear(&_alglib_env_state);
2810  return;
2811  }
2813  {
2814  throw ap_error(_alglib_env_state.error_msg);
2815  }
2816 }
2817 
2818 /*************************************************************************
2819 Multiplication of MxN complex matrix by MxM random Haar distributed
2820 complex orthogonal matrix
2821 
2822 INPUT PARAMETERS:
2823  A - matrix, array[0..M-1, 0..N-1]
2824  M, N- matrix size
2825 
2826 OUTPUT PARAMETERS:
2827  A - Q*A, where Q is random MxM orthogonal matrix
2828 
2829  -- ALGLIB routine --
2830  04.12.2009
2831  Bochkanov Sergey
2832 *************************************************************************/
2834 {
2835  alglib_impl::ae_state _alglib_env_state;
2836  alglib_impl::ae_state_init(&_alglib_env_state);
2837  try
2838  {
2839  alglib_impl::cmatrixrndorthogonalfromtheleft(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), m, n, &_alglib_env_state);
2840  alglib_impl::ae_state_clear(&_alglib_env_state);
2841  return;
2842  }
2844  {
2845  throw ap_error(_alglib_env_state.error_msg);
2846  }
2847 }
2848 
2849 /*************************************************************************
2850 Symmetric multiplication of NxN matrix by random Haar distributed
2851 orthogonal matrix
2852 
2853 INPUT PARAMETERS:
2854  A - matrix, array[0..N-1, 0..N-1]
2855  N - matrix size
2856 
2857 OUTPUT PARAMETERS:
2858  A - Q'*A*Q, where Q is random NxN orthogonal matrix
2859 
2860  -- ALGLIB routine --
2861  04.12.2009
2862  Bochkanov Sergey
2863 *************************************************************************/
2865 {
2866  alglib_impl::ae_state _alglib_env_state;
2867  alglib_impl::ae_state_init(&_alglib_env_state);
2868  try
2869  {
2870  alglib_impl::smatrixrndmultiply(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, &_alglib_env_state);
2871  alglib_impl::ae_state_clear(&_alglib_env_state);
2872  return;
2873  }
2875  {
2876  throw ap_error(_alglib_env_state.error_msg);
2877  }
2878 }
2879 
2880 /*************************************************************************
2881 Hermitian multiplication of NxN matrix by random Haar distributed
2882 complex orthogonal matrix
2883 
2884 INPUT PARAMETERS:
2885  A - matrix, array[0..N-1, 0..N-1]
2886  N - matrix size
2887 
2888 OUTPUT PARAMETERS:
2889  A - Q^H*A*Q, where Q is random NxN orthogonal matrix
2890 
2891  -- ALGLIB routine --
2892  04.12.2009
2893  Bochkanov Sergey
2894 *************************************************************************/
2896 {
2897  alglib_impl::ae_state _alglib_env_state;
2898  alglib_impl::ae_state_init(&_alglib_env_state);
2899  try
2900  {
2901  alglib_impl::hmatrixrndmultiply(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, &_alglib_env_state);
2902  alglib_impl::ae_state_clear(&_alglib_env_state);
2903  return;
2904  }
2906  {
2907  throw ap_error(_alglib_env_state.error_msg);
2908  }
2909 }
2910 
2911 /*************************************************************************
2912 LU decomposition of a general real matrix with row pivoting
2913 
2914 A is represented as A = P*L*U, where:
2915 * L is lower unitriangular matrix
2916 * U is upper triangular matrix
2917 * P = P0*P1*...*PK, K=min(M,N)-1,
2918  Pi - permutation matrix for I and Pivots[I]
2919 
2920 This is cache-oblivous implementation of LU decomposition.
2921 It is optimized for square matrices. As for rectangular matrices:
2922 * best case - M>>N
2923 * worst case - N>>M, small M, large N, matrix does not fit in CPU cache
2924 
2925 INPUT PARAMETERS:
2926  A - array[0..M-1, 0..N-1].
2927  M - number of rows in matrix A.
2928  N - number of columns in matrix A.
2929 
2930 
2931 OUTPUT PARAMETERS:
2932  A - matrices L and U in compact form:
2933  * L is stored under main diagonal
2934  * U is stored on and above main diagonal
2935  Pivots - permutation matrix in compact form.
2936  array[0..Min(M-1,N-1)].
2937 
2938  -- ALGLIB routine --
2939  10.01.2010
2940  Bochkanov Sergey
2941 *************************************************************************/
2943 {
2944  alglib_impl::ae_state _alglib_env_state;
2945  alglib_impl::ae_state_init(&_alglib_env_state);
2946  try
2947  {
2948  alglib_impl::rmatrixlu(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), m, n, const_cast<alglib_impl::ae_vector*>(pivots.c_ptr()), &_alglib_env_state);
2949  alglib_impl::ae_state_clear(&_alglib_env_state);
2950  return;
2951  }
2953  {
2954  throw ap_error(_alglib_env_state.error_msg);
2955  }
2956 }
2957 
2958 /*************************************************************************
2959 LU decomposition of a general complex matrix with row pivoting
2960 
2961 A is represented as A = P*L*U, where:
2962 * L is lower unitriangular matrix
2963 * U is upper triangular matrix
2964 * P = P0*P1*...*PK, K=min(M,N)-1,
2965  Pi - permutation matrix for I and Pivots[I]
2966 
2967 This is cache-oblivous implementation of LU decomposition. It is optimized
2968 for square matrices. As for rectangular matrices:
2969 * best case - M>>N
2970 * worst case - N>>M, small M, large N, matrix does not fit in CPU cache
2971 
2972 INPUT PARAMETERS:
2973  A - array[0..M-1, 0..N-1].
2974  M - number of rows in matrix A.
2975  N - number of columns in matrix A.
2976 
2977 
2978 OUTPUT PARAMETERS:
2979  A - matrices L and U in compact form:
2980  * L is stored under main diagonal
2981  * U is stored on and above main diagonal
2982  Pivots - permutation matrix in compact form.
2983  array[0..Min(M-1,N-1)].
2984 
2985  -- ALGLIB routine --
2986  10.01.2010
2987  Bochkanov Sergey
2988 *************************************************************************/
2990 {
2991  alglib_impl::ae_state _alglib_env_state;
2992  alglib_impl::ae_state_init(&_alglib_env_state);
2993  try
2994  {
2995  alglib_impl::cmatrixlu(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), m, n, const_cast<alglib_impl::ae_vector*>(pivots.c_ptr()), &_alglib_env_state);
2996  alglib_impl::ae_state_clear(&_alglib_env_state);
2997  return;
2998  }
3000  {
3001  throw ap_error(_alglib_env_state.error_msg);
3002  }
3003 }
3004 
3005 /*************************************************************************
3006 Cache-oblivious Cholesky decomposition
3007 
3008 The algorithm computes Cholesky decomposition of a Hermitian positive-
3009 definite matrix. The result of an algorithm is a representation of A as
3010 A=U'*U or A=L*L' (here X' detones conj(X^T)).
3011 
3012 INPUT PARAMETERS:
3013  A - upper or lower triangle of a factorized matrix.
3014  array with elements [0..N-1, 0..N-1].
3015  N - size of matrix A.
3016  IsUpper - if IsUpper=True, then A contains an upper triangle of
3017  a symmetric matrix, otherwise A contains a lower one.
3018 
3019 OUTPUT PARAMETERS:
3020  A - the result of factorization. If IsUpper=True, then
3021  the upper triangle contains matrix U, so that A = U'*U,
3022  and the elements below the main diagonal are not modified.
3023  Similarly, if IsUpper = False.
3024 
3025 RESULT:
3026  If the matrix is positive-definite, the function returns True.
3027  Otherwise, the function returns False. Contents of A is not determined
3028  in such case.
3029 
3030  -- ALGLIB routine --
3031  15.12.2009
3032  Bochkanov Sergey
3033 *************************************************************************/
3034 bool hpdmatrixcholesky(complex_2d_array &a, const ae_int_t n, const bool isupper)
3035 {
3036  alglib_impl::ae_state _alglib_env_state;
3037  alglib_impl::ae_state_init(&_alglib_env_state);
3038  try
3039  {
3040  ae_bool result = alglib_impl::hpdmatrixcholesky(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, &_alglib_env_state);
3041  alglib_impl::ae_state_clear(&_alglib_env_state);
3042  return *(reinterpret_cast<bool*>(&result));
3043  }
3045  {
3046  throw ap_error(_alglib_env_state.error_msg);
3047  }
3048 }
3049 
3050 /*************************************************************************
3051 Cache-oblivious Cholesky decomposition
3052 
3053 The algorithm computes Cholesky decomposition of a symmetric positive-
3054 definite matrix. The result of an algorithm is a representation of A as
3055 A=U^T*U or A=L*L^T
3056 
3057 INPUT PARAMETERS:
3058  A - upper or lower triangle of a factorized matrix.
3059  array with elements [0..N-1, 0..N-1].
3060  N - size of matrix A.
3061  IsUpper - if IsUpper=True, then A contains an upper triangle of
3062  a symmetric matrix, otherwise A contains a lower one.
3063 
3064 OUTPUT PARAMETERS:
3065  A - the result of factorization. If IsUpper=True, then
3066  the upper triangle contains matrix U, so that A = U^T*U,
3067  and the elements below the main diagonal are not modified.
3068  Similarly, if IsUpper = False.
3069 
3070 RESULT:
3071  If the matrix is positive-definite, the function returns True.
3072  Otherwise, the function returns False. Contents of A is not determined
3073  in such case.
3074 
3075  -- ALGLIB routine --
3076  15.12.2009
3077  Bochkanov Sergey
3078 *************************************************************************/
3079 bool spdmatrixcholesky(real_2d_array &a, const ae_int_t n, const bool isupper)
3080 {
3081  alglib_impl::ae_state _alglib_env_state;
3082  alglib_impl::ae_state_init(&_alglib_env_state);
3083  try
3084  {
3085  ae_bool result = alglib_impl::spdmatrixcholesky(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, &_alglib_env_state);
3086  alglib_impl::ae_state_clear(&_alglib_env_state);
3087  return *(reinterpret_cast<bool*>(&result));
3088  }
3090  {
3091  throw ap_error(_alglib_env_state.error_msg);
3092  }
3093 }
3094 
3095 /*************************************************************************
3096 Estimate of a matrix condition number (1-norm)
3097 
3098 The algorithm calculates a lower bound of the condition number. In this case,
3099 the algorithm does not return a lower bound of the condition number, but an
3100 inverse number (to avoid an overflow in case of a singular matrix).
3101 
3102 Input parameters:
3103  A - matrix. Array whose indexes range within [0..N-1, 0..N-1].
3104  N - size of matrix A.
3105 
3106 Result: 1/LowerBound(cond(A))
3107 
3108 NOTE:
3109  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
3110  0.0 is returned in such cases.
3111 *************************************************************************/
3112 double rmatrixrcond1(const real_2d_array &a, const ae_int_t n)
3113 {
3114  alglib_impl::ae_state _alglib_env_state;
3115  alglib_impl::ae_state_init(&_alglib_env_state);
3116  try
3117  {
3118  double result = alglib_impl::rmatrixrcond1(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, &_alglib_env_state);
3119  alglib_impl::ae_state_clear(&_alglib_env_state);
3120  return *(reinterpret_cast<double*>(&result));
3121  }
3123  {
3124  throw ap_error(_alglib_env_state.error_msg);
3125  }
3126 }
3127 
3128 /*************************************************************************
3129 Estimate of a matrix condition number (infinity-norm).
3130 
3131 The algorithm calculates a lower bound of the condition number. In this case,
3132 the algorithm does not return a lower bound of the condition number, but an
3133 inverse number (to avoid an overflow in case of a singular matrix).
3134 
3135 Input parameters:
3136  A - matrix. Array whose indexes range within [0..N-1, 0..N-1].
3137  N - size of matrix A.
3138 
3139 Result: 1/LowerBound(cond(A))
3140 
3141 NOTE:
3142  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
3143  0.0 is returned in such cases.
3144 *************************************************************************/
3146 {
3147  alglib_impl::ae_state _alglib_env_state;
3148  alglib_impl::ae_state_init(&_alglib_env_state);
3149  try
3150  {
3151  double result = alglib_impl::rmatrixrcondinf(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, &_alglib_env_state);
3152  alglib_impl::ae_state_clear(&_alglib_env_state);
3153  return *(reinterpret_cast<double*>(&result));
3154  }
3156  {
3157  throw ap_error(_alglib_env_state.error_msg);
3158  }
3159 }
3160 
3161 /*************************************************************************
3162 Condition number estimate of a symmetric positive definite matrix.
3163 
3164 The algorithm calculates a lower bound of the condition number. In this case,
3165 the algorithm does not return a lower bound of the condition number, but an
3166 inverse number (to avoid an overflow in case of a singular matrix).
3167 
3168 It should be noted that 1-norm and inf-norm of condition numbers of symmetric
3169 matrices are equal, so the algorithm doesn't take into account the
3170 differences between these types of norms.
3171 
3172 Input parameters:
3173  A - symmetric positive definite matrix which is given by its
3174  upper or lower triangle depending on the value of
3175  IsUpper. Array with elements [0..N-1, 0..N-1].
3176  N - size of matrix A.
3177  IsUpper - storage format.
3178 
3179 Result:
3180  1/LowerBound(cond(A)), if matrix A is positive definite,
3181  -1, if matrix A is not positive definite, and its condition number
3182  could not be found by this algorithm.
3183 
3184 NOTE:
3185  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
3186  0.0 is returned in such cases.
3187 *************************************************************************/
3188 double spdmatrixrcond(const real_2d_array &a, const ae_int_t n, const bool isupper)
3189 {
3190  alglib_impl::ae_state _alglib_env_state;
3191  alglib_impl::ae_state_init(&_alglib_env_state);
3192  try
3193  {
3194  double result = alglib_impl::spdmatrixrcond(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, &_alglib_env_state);
3195  alglib_impl::ae_state_clear(&_alglib_env_state);
3196  return *(reinterpret_cast<double*>(&result));
3197  }
3199  {
3200  throw ap_error(_alglib_env_state.error_msg);
3201  }
3202 }
3203 
3204 /*************************************************************************
3205 Triangular matrix: estimate of a condition number (1-norm)
3206 
3207 The algorithm calculates a lower bound of the condition number. In this case,
3208 the algorithm does not return a lower bound of the condition number, but an
3209 inverse number (to avoid an overflow in case of a singular matrix).
3210 
3211 Input parameters:
3212  A - matrix. Array[0..N-1, 0..N-1].
3213  N - size of A.
3214  IsUpper - True, if the matrix is upper triangular.
3215  IsUnit - True, if the matrix has a unit diagonal.
3216 
3217 Result: 1/LowerBound(cond(A))
3218 
3219 NOTE:
3220  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
3221  0.0 is returned in such cases.
3222 *************************************************************************/
3223 double rmatrixtrrcond1(const real_2d_array &a, const ae_int_t n, const bool isupper, const bool isunit)
3224 {
3225  alglib_impl::ae_state _alglib_env_state;
3226  alglib_impl::ae_state_init(&_alglib_env_state);
3227  try
3228  {
3229  double result = alglib_impl::rmatrixtrrcond1(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, isunit, &_alglib_env_state);
3230  alglib_impl::ae_state_clear(&_alglib_env_state);
3231  return *(reinterpret_cast<double*>(&result));
3232  }
3234  {
3235  throw ap_error(_alglib_env_state.error_msg);
3236  }
3237 }
3238 
3239 /*************************************************************************
3240 Triangular matrix: estimate of a matrix condition number (infinity-norm).
3241 
3242 The algorithm calculates a lower bound of the condition number. In this case,
3243 the algorithm does not return a lower bound of the condition number, but an
3244 inverse number (to avoid an overflow in case of a singular matrix).
3245 
3246 Input parameters:
3247  A - matrix. Array whose indexes range within [0..N-1, 0..N-1].
3248  N - size of matrix A.
3249  IsUpper - True, if the matrix is upper triangular.
3250  IsUnit - True, if the matrix has a unit diagonal.
3251 
3252 Result: 1/LowerBound(cond(A))
3253 
3254 NOTE:
3255  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
3256  0.0 is returned in such cases.
3257 *************************************************************************/
3258 double rmatrixtrrcondinf(const real_2d_array &a, const ae_int_t n, const bool isupper, const bool isunit)
3259 {
3260  alglib_impl::ae_state _alglib_env_state;
3261  alglib_impl::ae_state_init(&_alglib_env_state);
3262  try
3263  {
3264  double result = alglib_impl::rmatrixtrrcondinf(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, isunit, &_alglib_env_state);
3265  alglib_impl::ae_state_clear(&_alglib_env_state);
3266  return *(reinterpret_cast<double*>(&result));
3267  }
3269  {
3270  throw ap_error(_alglib_env_state.error_msg);
3271  }
3272 }
3273 
3274 /*************************************************************************
3275 Condition number estimate of a Hermitian positive definite matrix.
3276 
3277 The algorithm calculates a lower bound of the condition number. In this case,
3278 the algorithm does not return a lower bound of the condition number, but an
3279 inverse number (to avoid an overflow in case of a singular matrix).
3280 
3281 It should be noted that 1-norm and inf-norm of condition numbers of symmetric
3282 matrices are equal, so the algorithm doesn't take into account the
3283 differences between these types of norms.
3284 
3285 Input parameters:
3286  A - Hermitian positive definite matrix which is given by its
3287  upper or lower triangle depending on the value of
3288  IsUpper. Array with elements [0..N-1, 0..N-1].
3289  N - size of matrix A.
3290  IsUpper - storage format.
3291 
3292 Result:
3293  1/LowerBound(cond(A)), if matrix A is positive definite,
3294  -1, if matrix A is not positive definite, and its condition number
3295  could not be found by this algorithm.
3296 
3297 NOTE:
3298  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
3299  0.0 is returned in such cases.
3300 *************************************************************************/
3301 double hpdmatrixrcond(const complex_2d_array &a, const ae_int_t n, const bool isupper)
3302 {
3303  alglib_impl::ae_state _alglib_env_state;
3304  alglib_impl::ae_state_init(&_alglib_env_state);
3305  try
3306  {
3307  double result = alglib_impl::hpdmatrixrcond(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, &_alglib_env_state);
3308  alglib_impl::ae_state_clear(&_alglib_env_state);
3309  return *(reinterpret_cast<double*>(&result));
3310  }
3312  {
3313  throw ap_error(_alglib_env_state.error_msg);
3314  }
3315 }
3316 
3317 /*************************************************************************
3318 Estimate of a matrix condition number (1-norm)
3319 
3320 The algorithm calculates a lower bound of the condition number. In this case,
3321 the algorithm does not return a lower bound of the condition number, but an
3322 inverse number (to avoid an overflow in case of a singular matrix).
3323 
3324 Input parameters:
3325  A - matrix. Array whose indexes range within [0..N-1, 0..N-1].
3326  N - size of matrix A.
3327 
3328 Result: 1/LowerBound(cond(A))
3329 
3330 NOTE:
3331  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
3332  0.0 is returned in such cases.
3333 *************************************************************************/
3335 {
3336  alglib_impl::ae_state _alglib_env_state;
3337  alglib_impl::ae_state_init(&_alglib_env_state);
3338  try
3339  {
3340  double result = alglib_impl::cmatrixrcond1(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, &_alglib_env_state);
3341  alglib_impl::ae_state_clear(&_alglib_env_state);
3342  return *(reinterpret_cast<double*>(&result));
3343  }
3345  {
3346  throw ap_error(_alglib_env_state.error_msg);
3347  }
3348 }
3349 
3350 /*************************************************************************
3351 Estimate of a matrix condition number (infinity-norm).
3352 
3353 The algorithm calculates a lower bound of the condition number. In this case,
3354 the algorithm does not return a lower bound of the condition number, but an
3355 inverse number (to avoid an overflow in case of a singular matrix).
3356 
3357 Input parameters:
3358  A - matrix. Array whose indexes range within [0..N-1, 0..N-1].
3359  N - size of matrix A.
3360 
3361 Result: 1/LowerBound(cond(A))
3362 
3363 NOTE:
3364  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
3365  0.0 is returned in such cases.
3366 *************************************************************************/
3368 {
3369  alglib_impl::ae_state _alglib_env_state;
3370  alglib_impl::ae_state_init(&_alglib_env_state);
3371  try
3372  {
3373  double result = alglib_impl::cmatrixrcondinf(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, &_alglib_env_state);
3374  alglib_impl::ae_state_clear(&_alglib_env_state);
3375  return *(reinterpret_cast<double*>(&result));
3376  }
3378  {
3379  throw ap_error(_alglib_env_state.error_msg);
3380  }
3381 }
3382 
3383 /*************************************************************************
3384 Estimate of the condition number of a matrix given by its LU decomposition (1-norm)
3385 
3386 The algorithm calculates a lower bound of the condition number. In this case,
3387 the algorithm does not return a lower bound of the condition number, but an
3388 inverse number (to avoid an overflow in case of a singular matrix).
3389 
3390 Input parameters:
3391  LUA - LU decomposition of a matrix in compact form. Output of
3392  the RMatrixLU subroutine.
3393  N - size of matrix A.
3394 
3395 Result: 1/LowerBound(cond(A))
3396 
3397 NOTE:
3398  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
3399  0.0 is returned in such cases.
3400 *************************************************************************/
3401 double rmatrixlurcond1(const real_2d_array &lua, const ae_int_t n)
3402 {
3403  alglib_impl::ae_state _alglib_env_state;
3404  alglib_impl::ae_state_init(&_alglib_env_state);
3405  try
3406  {
3407  double result = alglib_impl::rmatrixlurcond1(const_cast<alglib_impl::ae_matrix*>(lua.c_ptr()), n, &_alglib_env_state);
3408  alglib_impl::ae_state_clear(&_alglib_env_state);
3409  return *(reinterpret_cast<double*>(&result));
3410  }
3412  {
3413  throw ap_error(_alglib_env_state.error_msg);
3414  }
3415 }
3416 
3417 /*************************************************************************
3418 Estimate of the condition number of a matrix given by its LU decomposition
3419 (infinity norm).
3420 
3421 The algorithm calculates a lower bound of the condition number. In this case,
3422 the algorithm does not return a lower bound of the condition number, but an
3423 inverse number (to avoid an overflow in case of a singular matrix).
3424 
3425 Input parameters:
3426  LUA - LU decomposition of a matrix in compact form. Output of
3427  the RMatrixLU subroutine.
3428  N - size of matrix A.
3429 
3430 Result: 1/LowerBound(cond(A))
3431 
3432 NOTE:
3433  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
3434  0.0 is returned in such cases.
3435 *************************************************************************/
3436 double rmatrixlurcondinf(const real_2d_array &lua, const ae_int_t n)
3437 {
3438  alglib_impl::ae_state _alglib_env_state;
3439  alglib_impl::ae_state_init(&_alglib_env_state);
3440  try
3441  {
3442  double result = alglib_impl::rmatrixlurcondinf(const_cast<alglib_impl::ae_matrix*>(lua.c_ptr()), n, &_alglib_env_state);
3443  alglib_impl::ae_state_clear(&_alglib_env_state);
3444  return *(reinterpret_cast<double*>(&result));
3445  }
3447  {
3448  throw ap_error(_alglib_env_state.error_msg);
3449  }
3450 }
3451 
3452 /*************************************************************************
3453 Condition number estimate of a symmetric positive definite matrix given by
3454 Cholesky decomposition.
3455 
3456 The algorithm calculates a lower bound of the condition number. In this
3457 case, the algorithm does not return a lower bound of the condition number,
3458 but an inverse number (to avoid an overflow in case of a singular matrix).
3459 
3460 It should be noted that 1-norm and inf-norm condition numbers of symmetric
3461 matrices are equal, so the algorithm doesn't take into account the
3462 differences between these types of norms.
3463 
3464 Input parameters:
3465  CD - Cholesky decomposition of matrix A,
3466  output of SMatrixCholesky subroutine.
3467  N - size of matrix A.
3468 
3469 Result: 1/LowerBound(cond(A))
3470 
3471 NOTE:
3472  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
3473  0.0 is returned in such cases.
3474 *************************************************************************/
3475 double spdmatrixcholeskyrcond(const real_2d_array &a, const ae_int_t n, const bool isupper)
3476 {
3477  alglib_impl::ae_state _alglib_env_state;
3478  alglib_impl::ae_state_init(&_alglib_env_state);
3479  try
3480  {
3481  double result = alglib_impl::spdmatrixcholeskyrcond(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, &_alglib_env_state);
3482  alglib_impl::ae_state_clear(&_alglib_env_state);
3483  return *(reinterpret_cast<double*>(&result));
3484  }
3486  {
3487  throw ap_error(_alglib_env_state.error_msg);
3488  }
3489 }
3490 
3491 /*************************************************************************
3492 Condition number estimate of a Hermitian positive definite matrix given by
3493 Cholesky decomposition.
3494 
3495 The algorithm calculates a lower bound of the condition number. In this
3496 case, the algorithm does not return a lower bound of the condition number,
3497 but an inverse number (to avoid an overflow in case of a singular matrix).
3498 
3499 It should be noted that 1-norm and inf-norm condition numbers of symmetric
3500 matrices are equal, so the algorithm doesn't take into account the
3501 differences between these types of norms.
3502 
3503 Input parameters:
3504  CD - Cholesky decomposition of matrix A,
3505  output of SMatrixCholesky subroutine.
3506  N - size of matrix A.
3507 
3508 Result: 1/LowerBound(cond(A))
3509 
3510 NOTE:
3511  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
3512  0.0 is returned in such cases.
3513 *************************************************************************/
3514 double hpdmatrixcholeskyrcond(const complex_2d_array &a, const ae_int_t n, const bool isupper)
3515 {
3516  alglib_impl::ae_state _alglib_env_state;
3517  alglib_impl::ae_state_init(&_alglib_env_state);
3518  try
3519  {
3520  double result = alglib_impl::hpdmatrixcholeskyrcond(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, &_alglib_env_state);
3521  alglib_impl::ae_state_clear(&_alglib_env_state);
3522  return *(reinterpret_cast<double*>(&result));
3523  }
3525  {
3526  throw ap_error(_alglib_env_state.error_msg);
3527  }
3528 }
3529 
3530 /*************************************************************************
3531 Estimate of the condition number of a matrix given by its LU decomposition (1-norm)
3532 
3533 The algorithm calculates a lower bound of the condition number. In this case,
3534 the algorithm does not return a lower bound of the condition number, but an
3535 inverse number (to avoid an overflow in case of a singular matrix).
3536 
3537 Input parameters:
3538  LUA - LU decomposition of a matrix in compact form. Output of
3539  the CMatrixLU subroutine.
3540  N - size of matrix A.
3541 
3542 Result: 1/LowerBound(cond(A))
3543 
3544 NOTE:
3545  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
3546  0.0 is returned in such cases.
3547 *************************************************************************/
3548 double cmatrixlurcond1(const complex_2d_array &lua, const ae_int_t n)
3549 {
3550  alglib_impl::ae_state _alglib_env_state;
3551  alglib_impl::ae_state_init(&_alglib_env_state);
3552  try
3553  {
3554  double result = alglib_impl::cmatrixlurcond1(const_cast<alglib_impl::ae_matrix*>(lua.c_ptr()), n, &_alglib_env_state);
3555  alglib_impl::ae_state_clear(&_alglib_env_state);
3556  return *(reinterpret_cast<double*>(&result));
3557  }
3559  {
3560  throw ap_error(_alglib_env_state.error_msg);
3561  }
3562 }
3563 
3564 /*************************************************************************
3565 Estimate of the condition number of a matrix given by its LU decomposition
3566 (infinity norm).
3567 
3568 The algorithm calculates a lower bound of the condition number. In this case,
3569 the algorithm does not return a lower bound of the condition number, but an
3570 inverse number (to avoid an overflow in case of a singular matrix).
3571 
3572 Input parameters:
3573  LUA - LU decomposition of a matrix in compact form. Output of
3574  the CMatrixLU subroutine.
3575  N - size of matrix A.
3576 
3577 Result: 1/LowerBound(cond(A))
3578 
3579 NOTE:
3580  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
3581  0.0 is returned in such cases.
3582 *************************************************************************/
3584 {
3585  alglib_impl::ae_state _alglib_env_state;
3586  alglib_impl::ae_state_init(&_alglib_env_state);
3587  try
3588  {
3589  double result = alglib_impl::cmatrixlurcondinf(const_cast<alglib_impl::ae_matrix*>(lua.c_ptr()), n, &_alglib_env_state);
3590  alglib_impl::ae_state_clear(&_alglib_env_state);
3591  return *(reinterpret_cast<double*>(&result));
3592  }
3594  {
3595  throw ap_error(_alglib_env_state.error_msg);
3596  }
3597 }
3598 
3599 /*************************************************************************
3600 Triangular matrix: estimate of a condition number (1-norm)
3601 
3602 The algorithm calculates a lower bound of the condition number. In this case,
3603 the algorithm does not return a lower bound of the condition number, but an
3604 inverse number (to avoid an overflow in case of a singular matrix).
3605 
3606 Input parameters:
3607  A - matrix. Array[0..N-1, 0..N-1].
3608  N - size of A.
3609  IsUpper - True, if the matrix is upper triangular.
3610  IsUnit - True, if the matrix has a unit diagonal.
3611 
3612 Result: 1/LowerBound(cond(A))
3613 
3614 NOTE:
3615  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
3616  0.0 is returned in such cases.
3617 *************************************************************************/
3618 double cmatrixtrrcond1(const complex_2d_array &a, const ae_int_t n, const bool isupper, const bool isunit)
3619 {
3620  alglib_impl::ae_state _alglib_env_state;
3621  alglib_impl::ae_state_init(&_alglib_env_state);
3622  try
3623  {
3624  double result = alglib_impl::cmatrixtrrcond1(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, isunit, &_alglib_env_state);
3625  alglib_impl::ae_state_clear(&_alglib_env_state);
3626  return *(reinterpret_cast<double*>(&result));
3627  }
3629  {
3630  throw ap_error(_alglib_env_state.error_msg);
3631  }
3632 }
3633 
3634 /*************************************************************************
3635 Triangular matrix: estimate of a matrix condition number (infinity-norm).
3636 
3637 The algorithm calculates a lower bound of the condition number. In this case,
3638 the algorithm does not return a lower bound of the condition number, but an
3639 inverse number (to avoid an overflow in case of a singular matrix).
3640 
3641 Input parameters:
3642  A - matrix. Array whose indexes range within [0..N-1, 0..N-1].
3643  N - size of matrix A.
3644  IsUpper - True, if the matrix is upper triangular.
3645  IsUnit - True, if the matrix has a unit diagonal.
3646 
3647 Result: 1/LowerBound(cond(A))
3648 
3649 NOTE:
3650  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
3651  0.0 is returned in such cases.
3652 *************************************************************************/
3653 double cmatrixtrrcondinf(const complex_2d_array &a, const ae_int_t n, const bool isupper, const bool isunit)
3654 {
3655  alglib_impl::ae_state _alglib_env_state;
3656  alglib_impl::ae_state_init(&_alglib_env_state);
3657  try
3658  {
3659  double result = alglib_impl::cmatrixtrrcondinf(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, isunit, &_alglib_env_state);
3660  alglib_impl::ae_state_clear(&_alglib_env_state);
3661  return *(reinterpret_cast<double*>(&result));
3662  }
3664  {
3665  throw ap_error(_alglib_env_state.error_msg);
3666  }
3667 }
3668 
3669 /*************************************************************************
3670 Matrix inverse report:
3671 * R1 reciprocal of condition number in 1-norm
3672 * RInf reciprocal of condition number in inf-norm
3673 *************************************************************************/
3674 _matinvreport_owner::_matinvreport_owner()
3675 {
3677  if( p_struct==NULL )
3678  throw ap_error("ALGLIB: malloc error");
3679  if( !alglib_impl::_matinvreport_init(p_struct, NULL, ae_false) )
3680  throw ap_error("ALGLIB: malloc error");
3681 }
3682 
3683 _matinvreport_owner::_matinvreport_owner(const _matinvreport_owner &rhs)
3684 {
3686  if( p_struct==NULL )
3687  throw ap_error("ALGLIB: malloc error");
3688  if( !alglib_impl::_matinvreport_init_copy(p_struct, const_cast<alglib_impl::matinvreport*>(rhs.p_struct), NULL, ae_false) )
3689  throw ap_error("ALGLIB: malloc error");
3690 }
3691 
3692 _matinvreport_owner& _matinvreport_owner::operator=(const _matinvreport_owner &rhs)
3693 {
3694  if( this==&rhs )
3695  return *this;
3697  if( !alglib_impl::_matinvreport_init_copy(p_struct, const_cast<alglib_impl::matinvreport*>(rhs.p_struct), NULL, ae_false) )
3698  throw ap_error("ALGLIB: malloc error");
3699  return *this;
3700 }
3701 
3702 _matinvreport_owner::~_matinvreport_owner()
3703 {
3705  ae_free(p_struct);
3706 }
3707 
3708 alglib_impl::matinvreport* _matinvreport_owner::c_ptr()
3709 {
3710  return p_struct;
3711 }
3712 
3713 alglib_impl::matinvreport* _matinvreport_owner::c_ptr() const
3714 {
3715  return const_cast<alglib_impl::matinvreport*>(p_struct);
3716 }
3717 matinvreport::matinvreport() : _matinvreport_owner() ,r1(p_struct->r1),rinf(p_struct->rinf)
3718 {
3719 }
3720 
3722 {
3723 }
3724 
3726 {
3727  if( this==&rhs )
3728  return *this;
3730  return *this;
3731 }
3732 
3734 {
3735 }
3736 
3737 /*************************************************************************
3738 Inversion of a matrix given by its LU decomposition.
3739 
3740 INPUT PARAMETERS:
3741  A - LU decomposition of the matrix
3742  (output of RMatrixLU subroutine).
3743  Pivots - table of permutations
3744  (the output of RMatrixLU subroutine).
3745  N - size of matrix A (optional) :
3746  * if given, only principal NxN submatrix is processed and
3747  overwritten. other elements are unchanged.
3748  * if not given, size is automatically determined from
3749  matrix size (A must be square matrix)
3750 
3751 OUTPUT PARAMETERS:
3752  Info - return code:
3753  * -3 A is singular, or VERY close to singular.
3754  it is filled by zeros in such cases.
3755  * 1 task is solved (but matrix A may be ill-conditioned,
3756  check R1/RInf parameters for condition numbers).
3757  Rep - solver report, see below for more info
3758  A - inverse of matrix A.
3759  Array whose indexes range within [0..N-1, 0..N-1].
3760 
3761 SOLVER REPORT
3762 
3763 Subroutine sets following fields of the Rep structure:
3764 * R1 reciprocal of condition number: 1/cond(A), 1-norm.
3765 * RInf reciprocal of condition number: 1/cond(A), inf-norm.
3766 
3767  -- ALGLIB routine --
3768  05.02.2010
3769  Bochkanov Sergey
3770 *************************************************************************/
3772 {
3773  alglib_impl::ae_state _alglib_env_state;
3774  alglib_impl::ae_state_init(&_alglib_env_state);
3775  try
3776  {
3777  alglib_impl::rmatrixluinverse(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), const_cast<alglib_impl::ae_vector*>(pivots.c_ptr()), n, &info, const_cast<alglib_impl::matinvreport*>(rep.c_ptr()), &_alglib_env_state);
3778  alglib_impl::ae_state_clear(&_alglib_env_state);
3779  return;
3780  }
3782  {
3783  throw ap_error(_alglib_env_state.error_msg);
3784  }
3785 }
3786 
3787 /*************************************************************************
3788 Inversion of a matrix given by its LU decomposition.
3789 
3790 INPUT PARAMETERS:
3791  A - LU decomposition of the matrix
3792  (output of RMatrixLU subroutine).
3793  Pivots - table of permutations
3794  (the output of RMatrixLU subroutine).
3795  N - size of matrix A (optional) :
3796  * if given, only principal NxN submatrix is processed and
3797  overwritten. other elements are unchanged.
3798  * if not given, size is automatically determined from
3799  matrix size (A must be square matrix)
3800 
3801 OUTPUT PARAMETERS:
3802  Info - return code:
3803  * -3 A is singular, or VERY close to singular.
3804  it is filled by zeros in such cases.
3805  * 1 task is solved (but matrix A may be ill-conditioned,
3806  check R1/RInf parameters for condition numbers).
3807  Rep - solver report, see below for more info
3808  A - inverse of matrix A.
3809  Array whose indexes range within [0..N-1, 0..N-1].
3810 
3811 SOLVER REPORT
3812 
3813 Subroutine sets following fields of the Rep structure:
3814 * R1 reciprocal of condition number: 1/cond(A), 1-norm.
3815 * RInf reciprocal of condition number: 1/cond(A), inf-norm.
3816 
3817  -- ALGLIB routine --
3818  05.02.2010
3819  Bochkanov Sergey
3820 *************************************************************************/
3822 {
3823  alglib_impl::ae_state _alglib_env_state;
3824  ae_int_t n;
3825  if( (a.cols()!=a.rows()) || (a.cols()!=pivots.length()))
3826  throw ap_error("Error while calling 'rmatrixluinverse': looks like one of arguments has wrong size");
3827  n = a.cols();
3828  alglib_impl::ae_state_init(&_alglib_env_state);
3829  try
3830  {
3831  alglib_impl::rmatrixluinverse(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), const_cast<alglib_impl::ae_vector*>(pivots.c_ptr()), n, &info, const_cast<alglib_impl::matinvreport*>(rep.c_ptr()), &_alglib_env_state);
3832 
3833  alglib_impl::ae_state_clear(&_alglib_env_state);
3834  return;
3835  }
3837  {
3838  throw ap_error(_alglib_env_state.error_msg);
3839  }
3840 }
3841 
3842 /*************************************************************************
3843 Inversion of a general matrix.
3844 
3845 Input parameters:
3846  A - matrix.
3847  N - size of matrix A (optional) :
3848  * if given, only principal NxN submatrix is processed and
3849  overwritten. other elements are unchanged.
3850  * if not given, size is automatically determined from
3851  matrix size (A must be square matrix)
3852 
3853 Output parameters:
3854  Info - return code, same as in RMatrixLUInverse
3855  Rep - solver report, same as in RMatrixLUInverse
3856  A - inverse of matrix A, same as in RMatrixLUInverse
3857 
3858 Result:
3859  True, if the matrix is not singular.
3860  False, if the matrix is singular.
3861 
3862  -- ALGLIB --
3863  Copyright 2005-2010 by Bochkanov Sergey
3864 *************************************************************************/
3866 {
3867  alglib_impl::ae_state _alglib_env_state;
3868  alglib_impl::ae_state_init(&_alglib_env_state);
3869  try
3870  {
3871  alglib_impl::rmatrixinverse(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, &info, const_cast<alglib_impl::matinvreport*>(rep.c_ptr()), &_alglib_env_state);
3872  alglib_impl::ae_state_clear(&_alglib_env_state);
3873  return;
3874  }
3876  {
3877  throw ap_error(_alglib_env_state.error_msg);
3878  }
3879 }
3880 
3881 /*************************************************************************
3882 Inversion of a general matrix.
3883 
3884 Input parameters:
3885  A - matrix.
3886  N - size of matrix A (optional) :
3887  * if given, only principal NxN submatrix is processed and
3888  overwritten. other elements are unchanged.
3889  * if not given, size is automatically determined from
3890  matrix size (A must be square matrix)
3891 
3892 Output parameters:
3893  Info - return code, same as in RMatrixLUInverse
3894  Rep - solver report, same as in RMatrixLUInverse
3895  A - inverse of matrix A, same as in RMatrixLUInverse
3896 
3897 Result:
3898  True, if the matrix is not singular.
3899  False, if the matrix is singular.
3900 
3901  -- ALGLIB --
3902  Copyright 2005-2010 by Bochkanov Sergey
3903 *************************************************************************/
3905 {
3906  alglib_impl::ae_state _alglib_env_state;
3907  ae_int_t n;
3908  if( (a.cols()!=a.rows()))
3909  throw ap_error("Error while calling 'rmatrixinverse': looks like one of arguments has wrong size");
3910  n = a.cols();
3911  alglib_impl::ae_state_init(&_alglib_env_state);
3912  try
3913  {
3914  alglib_impl::rmatrixinverse(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, &info, const_cast<alglib_impl::matinvreport*>(rep.c_ptr()), &_alglib_env_state);
3915 
3916  alglib_impl::ae_state_clear(&_alglib_env_state);
3917  return;
3918  }
3920  {
3921  throw ap_error(_alglib_env_state.error_msg);
3922  }
3923 }
3924 
3925 /*************************************************************************
3926 Inversion of a matrix given by its LU decomposition.
3927 
3928 INPUT PARAMETERS:
3929  A - LU decomposition of the matrix
3930  (output of CMatrixLU subroutine).
3931  Pivots - table of permutations
3932  (the output of CMatrixLU subroutine).
3933  N - size of matrix A (optional) :
3934  * if given, only principal NxN submatrix is processed and
3935  overwritten. other elements are unchanged.
3936  * if not given, size is automatically determined from
3937  matrix size (A must be square matrix)
3938 
3939 OUTPUT PARAMETERS:
3940  Info - return code, same as in RMatrixLUInverse
3941  Rep - solver report, same as in RMatrixLUInverse
3942  A - inverse of matrix A, same as in RMatrixLUInverse
3943 
3944  -- ALGLIB routine --
3945  05.02.2010
3946  Bochkanov Sergey
3947 *************************************************************************/
3949 {
3950  alglib_impl::ae_state _alglib_env_state;
3951  alglib_impl::ae_state_init(&_alglib_env_state);
3952  try
3953  {
3954  alglib_impl::cmatrixluinverse(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), const_cast<alglib_impl::ae_vector*>(pivots.c_ptr()), n, &info, const_cast<alglib_impl::matinvreport*>(rep.c_ptr()), &_alglib_env_state);
3955  alglib_impl::ae_state_clear(&_alglib_env_state);
3956  return;
3957  }
3959  {
3960  throw ap_error(_alglib_env_state.error_msg);
3961  }
3962 }
3963 
3964 /*************************************************************************
3965 Inversion of a matrix given by its LU decomposition.
3966 
3967 INPUT PARAMETERS:
3968  A - LU decomposition of the matrix
3969  (output of CMatrixLU subroutine).
3970  Pivots - table of permutations
3971  (the output of CMatrixLU subroutine).
3972  N - size of matrix A (optional) :
3973  * if given, only principal NxN submatrix is processed and
3974  overwritten. other elements are unchanged.
3975  * if not given, size is automatically determined from
3976  matrix size (A must be square matrix)
3977 
3978 OUTPUT PARAMETERS:
3979  Info - return code, same as in RMatrixLUInverse
3980  Rep - solver report, same as in RMatrixLUInverse
3981  A - inverse of matrix A, same as in RMatrixLUInverse
3982 
3983  -- ALGLIB routine --
3984  05.02.2010
3985  Bochkanov Sergey
3986 *************************************************************************/
3988 {
3989  alglib_impl::ae_state _alglib_env_state;
3990  ae_int_t n;
3991  if( (a.cols()!=a.rows()) || (a.cols()!=pivots.length()))
3992  throw ap_error("Error while calling 'cmatrixluinverse': looks like one of arguments has wrong size");
3993  n = a.cols();
3994  alglib_impl::ae_state_init(&_alglib_env_state);
3995  try
3996  {
3997  alglib_impl::cmatrixluinverse(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), const_cast<alglib_impl::ae_vector*>(pivots.c_ptr()), n, &info, const_cast<alglib_impl::matinvreport*>(rep.c_ptr()), &_alglib_env_state);
3998 
3999  alglib_impl::ae_state_clear(&_alglib_env_state);
4000  return;
4001  }
4003  {
4004  throw ap_error(_alglib_env_state.error_msg);
4005  }
4006 }
4007 
4008 /*************************************************************************
4009 Inversion of a general matrix.
4010 
4011 Input parameters:
4012  A - matrix
4013  N - size of matrix A (optional) :
4014  * if given, only principal NxN submatrix is processed and
4015  overwritten. other elements are unchanged.
4016  * if not given, size is automatically determined from
4017  matrix size (A must be square matrix)
4018 
4019 Output parameters:
4020  Info - return code, same as in RMatrixLUInverse
4021  Rep - solver report, same as in RMatrixLUInverse
4022  A - inverse of matrix A, same as in RMatrixLUInverse
4023 
4024  -- ALGLIB --
4025  Copyright 2005 by Bochkanov Sergey
4026 *************************************************************************/
4028 {
4029  alglib_impl::ae_state _alglib_env_state;
4030  alglib_impl::ae_state_init(&_alglib_env_state);
4031  try
4032  {
4033  alglib_impl::cmatrixinverse(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, &info, const_cast<alglib_impl::matinvreport*>(rep.c_ptr()), &_alglib_env_state);
4034  alglib_impl::ae_state_clear(&_alglib_env_state);
4035  return;
4036  }
4038  {
4039  throw ap_error(_alglib_env_state.error_msg);
4040  }
4041 }
4042 
4043 /*************************************************************************
4044 Inversion of a general matrix.
4045 
4046 Input parameters:
4047  A - matrix
4048  N - size of matrix A (optional) :
4049  * if given, only principal NxN submatrix is processed and
4050  overwritten. other elements are unchanged.
4051  * if not given, size is automatically determined from
4052  matrix size (A must be square matrix)
4053 
4054 Output parameters:
4055  Info - return code, same as in RMatrixLUInverse
4056  Rep - solver report, same as in RMatrixLUInverse
4057  A - inverse of matrix A, same as in RMatrixLUInverse
4058 
4059  -- ALGLIB --
4060  Copyright 2005 by Bochkanov Sergey
4061 *************************************************************************/
4063 {
4064  alglib_impl::ae_state _alglib_env_state;
4065  ae_int_t n;
4066  if( (a.cols()!=a.rows()))
4067  throw ap_error("Error while calling 'cmatrixinverse': looks like one of arguments has wrong size");
4068  n = a.cols();
4069  alglib_impl::ae_state_init(&_alglib_env_state);
4070  try
4071  {
4072  alglib_impl::cmatrixinverse(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, &info, const_cast<alglib_impl::matinvreport*>(rep.c_ptr()), &_alglib_env_state);
4073 
4074  alglib_impl::ae_state_clear(&_alglib_env_state);
4075  return;
4076  }
4078  {
4079  throw ap_error(_alglib_env_state.error_msg);
4080  }
4081 }
4082 
4083 /*************************************************************************
4084 Inversion of a symmetric positive definite matrix which is given
4085 by Cholesky decomposition.
4086 
4087 Input parameters:
4088  A - Cholesky decomposition of the matrix to be inverted:
4089  A=U’*U or A = L*L'.
4090  Output of SPDMatrixCholesky subroutine.
4091  N - size of matrix A (optional) :
4092  * if given, only principal NxN submatrix is processed and
4093  overwritten. other elements are unchanged.
4094  * if not given, size is automatically determined from
4095  matrix size (A must be square matrix)
4096  IsUpper - storage type (optional):
4097  * if True, symmetric matrix A is given by its upper
4098  triangle, and the lower triangle isn’t used/changed by
4099  function
4100  * if False, symmetric matrix A is given by its lower
4101  triangle, and the upper triangle isn’t used/changed by
4102  function
4103  * if not given, lower half is used.
4104 
4105 Output parameters:
4106  Info - return code, same as in RMatrixLUInverse
4107  Rep - solver report, same as in RMatrixLUInverse
4108  A - inverse of matrix A, same as in RMatrixLUInverse
4109 
4110  -- ALGLIB routine --
4111  10.02.2010
4112  Bochkanov Sergey
4113 *************************************************************************/
4114 void spdmatrixcholeskyinverse(real_2d_array &a, const ae_int_t n, const bool isupper, ae_int_t &info, matinvreport &rep)
4115 {
4116  alglib_impl::ae_state _alglib_env_state;
4117  alglib_impl::ae_state_init(&_alglib_env_state);
4118  try
4119  {
4120  alglib_impl::spdmatrixcholeskyinverse(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, &info, const_cast<alglib_impl::matinvreport*>(rep.c_ptr()), &_alglib_env_state);
4121  alglib_impl::ae_state_clear(&_alglib_env_state);
4122  return;
4123  }
4125  {
4126  throw ap_error(_alglib_env_state.error_msg);
4127  }
4128 }
4129 
4130 /*************************************************************************
4131 Inversion of a symmetric positive definite matrix which is given
4132 by Cholesky decomposition.
4133 
4134 Input parameters:
4135  A - Cholesky decomposition of the matrix to be inverted:
4136  A=U’*U or A = L*L'.
4137  Output of SPDMatrixCholesky subroutine.
4138  N - size of matrix A (optional) :
4139  * if given, only principal NxN submatrix is processed and
4140  overwritten. other elements are unchanged.
4141  * if not given, size is automatically determined from
4142  matrix size (A must be square matrix)
4143  IsUpper - storage type (optional):
4144  * if True, symmetric matrix A is given by its upper
4145  triangle, and the lower triangle isn’t used/changed by
4146  function
4147  * if False, symmetric matrix A is given by its lower
4148  triangle, and the upper triangle isn’t used/changed by
4149  function
4150  * if not given, lower half is used.
4151 
4152 Output parameters:
4153  Info - return code, same as in RMatrixLUInverse
4154  Rep - solver report, same as in RMatrixLUInverse
4155  A - inverse of matrix A, same as in RMatrixLUInverse
4156 
4157  -- ALGLIB routine --
4158  10.02.2010
4159  Bochkanov Sergey
4160 *************************************************************************/
4162 {
4163  alglib_impl::ae_state _alglib_env_state;
4164  ae_int_t n;
4165  bool isupper;
4166  if( (a.cols()!=a.rows()))
4167  throw ap_error("Error while calling 'spdmatrixcholeskyinverse': looks like one of arguments has wrong size");
4168  n = a.cols();
4169  isupper = false;
4170  alglib_impl::ae_state_init(&_alglib_env_state);
4171  try
4172  {
4173  alglib_impl::spdmatrixcholeskyinverse(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, &info, const_cast<alglib_impl::matinvreport*>(rep.c_ptr()), &_alglib_env_state);
4174 
4175  alglib_impl::ae_state_clear(&_alglib_env_state);
4176  return;
4177  }
4179  {
4180  throw ap_error(_alglib_env_state.error_msg);
4181  }
4182 }
4183 
4184 /*************************************************************************
4185 Inversion of a symmetric positive definite matrix.
4186 
4187 Given an upper or lower triangle of a symmetric positive definite matrix,
4188 the algorithm generates matrix A^-1 and saves the upper or lower triangle
4189 depending on the input.
4190 
4191 Input parameters:
4192  A - matrix to be inverted (upper or lower triangle).
4193  Array with elements [0..N-1,0..N-1].
4194  N - size of matrix A (optional) :
4195  * if given, only principal NxN submatrix is processed and
4196  overwritten. other elements are unchanged.
4197  * if not given, size is automatically determined from
4198  matrix size (A must be square matrix)
4199  IsUpper - storage type (optional):
4200  * if True, symmetric matrix A is given by its upper
4201  triangle, and the lower triangle isn’t used/changed by
4202  function
4203  * if False, symmetric matrix A is given by its lower
4204  triangle, and the upper triangle isn’t used/changed by
4205  function
4206  * if not given, both lower and upper triangles must be
4207  filled.
4208 
4209 Output parameters:
4210  Info - return code, same as in RMatrixLUInverse
4211  Rep - solver report, same as in RMatrixLUInverse
4212  A - inverse of matrix A, same as in RMatrixLUInverse
4213 
4214  -- ALGLIB routine --
4215  10.02.2010
4216  Bochkanov Sergey
4217 *************************************************************************/
4218 void spdmatrixinverse(real_2d_array &a, const ae_int_t n, const bool isupper, ae_int_t &info, matinvreport &rep)
4219 {
4220  alglib_impl::ae_state _alglib_env_state;
4221  alglib_impl::ae_state_init(&_alglib_env_state);
4222  try
4223  {
4224  alglib_impl::spdmatrixinverse(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, &info, const_cast<alglib_impl::matinvreport*>(rep.c_ptr()), &_alglib_env_state);
4225  alglib_impl::ae_state_clear(&_alglib_env_state);
4226  return;
4227  }
4229  {
4230  throw ap_error(_alglib_env_state.error_msg);
4231  }
4232 }
4233 
4234 /*************************************************************************
4235 Inversion of a symmetric positive definite matrix.
4236 
4237 Given an upper or lower triangle of a symmetric positive definite matrix,
4238 the algorithm generates matrix A^-1 and saves the upper or lower triangle
4239 depending on the input.
4240 
4241 Input parameters:
4242  A - matrix to be inverted (upper or lower triangle).
4243  Array with elements [0..N-1,0..N-1].
4244  N - size of matrix A (optional) :
4245  * if given, only principal NxN submatrix is processed and
4246  overwritten. other elements are unchanged.
4247  * if not given, size is automatically determined from
4248  matrix size (A must be square matrix)
4249  IsUpper - storage type (optional):
4250  * if True, symmetric matrix A is given by its upper
4251  triangle, and the lower triangle isn’t used/changed by
4252  function
4253  * if False, symmetric matrix A is given by its lower
4254  triangle, and the upper triangle isn’t used/changed by
4255  function
4256  * if not given, both lower and upper triangles must be
4257  filled.
4258 
4259 Output parameters:
4260  Info - return code, same as in RMatrixLUInverse
4261  Rep - solver report, same as in RMatrixLUInverse
4262  A - inverse of matrix A, same as in RMatrixLUInverse
4263 
4264  -- ALGLIB routine --
4265  10.02.2010
4266  Bochkanov Sergey
4267 *************************************************************************/
4269 {
4270  alglib_impl::ae_state _alglib_env_state;
4271  ae_int_t n;
4272  bool isupper;
4273  if( (a.cols()!=a.rows()))
4274  throw ap_error("Error while calling 'spdmatrixinverse': looks like one of arguments has wrong size");
4275  if( !alglib_impl::ae_is_symmetric(const_cast<alglib_impl::ae_matrix*>(a.c_ptr())) )
4276  throw ap_error("'a' parameter is not symmetric matrix");
4277  n = a.cols();
4278  isupper = false;
4279  alglib_impl::ae_state_init(&_alglib_env_state);
4280  try
4281  {
4282  alglib_impl::spdmatrixinverse(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, &info, const_cast<alglib_impl::matinvreport*>(rep.c_ptr()), &_alglib_env_state);
4283  if( !alglib_impl::ae_force_symmetric(const_cast<alglib_impl::ae_matrix*>(a.c_ptr())) )
4284  throw ap_error("Internal error while forcing symmetricity of 'a' parameter");
4285  alglib_impl::ae_state_clear(&_alglib_env_state);
4286  return;
4287  }
4289  {
4290  throw ap_error(_alglib_env_state.error_msg);
4291  }
4292 }
4293 
4294 /*************************************************************************
4295 Inversion of a Hermitian positive definite matrix which is given
4296 by Cholesky decomposition.
4297 
4298 Input parameters:
4299  A - Cholesky decomposition of the matrix to be inverted:
4300  A=U’*U or A = L*L'.
4301  Output of HPDMatrixCholesky subroutine.
4302  N - size of matrix A (optional) :
4303  * if given, only principal NxN submatrix is processed and
4304  overwritten. other elements are unchanged.
4305  * if not given, size is automatically determined from
4306  matrix size (A must be square matrix)
4307  IsUpper - storage type (optional):
4308  * if True, symmetric matrix A is given by its upper
4309  triangle, and the lower triangle isn’t used/changed by
4310  function
4311  * if False, symmetric matrix A is given by its lower
4312  triangle, and the upper triangle isn’t used/changed by
4313  function
4314  * if not given, lower half is used.
4315 
4316 Output parameters:
4317  Info - return code, same as in RMatrixLUInverse
4318  Rep - solver report, same as in RMatrixLUInverse
4319  A - inverse of matrix A, same as in RMatrixLUInverse
4320 
4321  -- ALGLIB routine --
4322  10.02.2010
4323  Bochkanov Sergey
4324 *************************************************************************/
4325 void hpdmatrixcholeskyinverse(complex_2d_array &a, const ae_int_t n, const bool isupper, ae_int_t &info, matinvreport &rep)
4326 {
4327  alglib_impl::ae_state _alglib_env_state;
4328  alglib_impl::ae_state_init(&_alglib_env_state);
4329  try
4330  {
4331  alglib_impl::hpdmatrixcholeskyinverse(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, &info, const_cast<alglib_impl::matinvreport*>(rep.c_ptr()), &_alglib_env_state);
4332  alglib_impl::ae_state_clear(&_alglib_env_state);
4333  return;
4334  }
4336  {
4337  throw ap_error(_alglib_env_state.error_msg);
4338  }
4339 }
4340 
4341 /*************************************************************************
4342 Inversion of a Hermitian positive definite matrix which is given
4343 by Cholesky decomposition.
4344 
4345 Input parameters:
4346  A - Cholesky decomposition of the matrix to be inverted:
4347  A=U’*U or A = L*L'.
4348  Output of HPDMatrixCholesky subroutine.
4349  N - size of matrix A (optional) :
4350  * if given, only principal NxN submatrix is processed and
4351  overwritten. other elements are unchanged.
4352  * if not given, size is automatically determined from
4353  matrix size (A must be square matrix)
4354  IsUpper - storage type (optional):
4355  * if True, symmetric matrix A is given by its upper
4356  triangle, and the lower triangle isn’t used/changed by
4357  function
4358  * if False, symmetric matrix A is given by its lower
4359  triangle, and the upper triangle isn’t used/changed by
4360  function
4361  * if not given, lower half is used.
4362 
4363 Output parameters:
4364  Info - return code, same as in RMatrixLUInverse
4365  Rep - solver report, same as in RMatrixLUInverse
4366  A - inverse of matrix A, same as in RMatrixLUInverse
4367 
4368  -- ALGLIB routine --
4369  10.02.2010
4370  Bochkanov Sergey
4371 *************************************************************************/
4373 {
4374  alglib_impl::ae_state _alglib_env_state;
4375  ae_int_t n;
4376  bool isupper;
4377  if( (a.cols()!=a.rows()))
4378  throw ap_error("Error while calling 'hpdmatrixcholeskyinverse': looks like one of arguments has wrong size");
4379  n = a.cols();
4380  isupper = false;
4381  alglib_impl::ae_state_init(&_alglib_env_state);
4382  try
4383  {
4384  alglib_impl::hpdmatrixcholeskyinverse(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, &info, const_cast<alglib_impl::matinvreport*>(rep.c_ptr()), &_alglib_env_state);
4385 
4386  alglib_impl::ae_state_clear(&_alglib_env_state);
4387  return;
4388  }
4390  {
4391  throw ap_error(_alglib_env_state.error_msg);
4392  }
4393 }
4394 
4395 /*************************************************************************
4396 Inversion of a Hermitian positive definite matrix.
4397 
4398 Given an upper or lower triangle of a Hermitian positive definite matrix,
4399 the algorithm generates matrix A^-1 and saves the upper or lower triangle
4400 depending on the input.
4401 
4402 Input parameters:
4403  A - matrix to be inverted (upper or lower triangle).
4404  Array with elements [0..N-1,0..N-1].
4405  N - size of matrix A (optional) :
4406  * if given, only principal NxN submatrix is processed and
4407  overwritten. other elements are unchanged.
4408  * if not given, size is automatically determined from
4409  matrix size (A must be square matrix)
4410  IsUpper - storage type (optional):
4411  * if True, symmetric matrix A is given by its upper
4412  triangle, and the lower triangle isn’t used/changed by
4413  function
4414  * if False, symmetric matrix A is given by its lower
4415  triangle, and the upper triangle isn’t used/changed by
4416  function
4417  * if not given, both lower and upper triangles must be
4418  filled.
4419 
4420 Output parameters:
4421  Info - return code, same as in RMatrixLUInverse
4422  Rep - solver report, same as in RMatrixLUInverse
4423  A - inverse of matrix A, same as in RMatrixLUInverse
4424 
4425  -- ALGLIB routine --
4426  10.02.2010
4427  Bochkanov Sergey
4428 *************************************************************************/
4429 void hpdmatrixinverse(complex_2d_array &a, const ae_int_t n, const bool isupper, ae_int_t &info, matinvreport &rep)
4430 {
4431  alglib_impl::ae_state _alglib_env_state;
4432  alglib_impl::ae_state_init(&_alglib_env_state);
4433  try
4434  {
4435  alglib_impl::hpdmatrixinverse(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, &info, const_cast<alglib_impl::matinvreport*>(rep.c_ptr()), &_alglib_env_state);
4436  alglib_impl::ae_state_clear(&_alglib_env_state);
4437  return;
4438  }
4440  {
4441  throw ap_error(_alglib_env_state.error_msg);
4442  }
4443 }
4444 
4445 /*************************************************************************
4446 Inversion of a Hermitian positive definite matrix.
4447 
4448 Given an upper or lower triangle of a Hermitian positive definite matrix,
4449 the algorithm generates matrix A^-1 and saves the upper or lower triangle
4450 depending on the input.
4451 
4452 Input parameters:
4453  A - matrix to be inverted (upper or lower triangle).
4454  Array with elements [0..N-1,0..N-1].
4455  N - size of matrix A (optional) :
4456  * if given, only principal NxN submatrix is processed and
4457  overwritten. other elements are unchanged.
4458  * if not given, size is automatically determined from
4459  matrix size (A must be square matrix)
4460  IsUpper - storage type (optional):
4461  * if True, symmetric matrix A is given by its upper
4462  triangle, and the lower triangle isn’t used/changed by
4463  function
4464  * if False, symmetric matrix A is given by its lower
4465  triangle, and the upper triangle isn’t used/changed by
4466  function
4467  * if not given, both lower and upper triangles must be
4468  filled.
4469 
4470 Output parameters:
4471  Info - return code, same as in RMatrixLUInverse
4472  Rep - solver report, same as in RMatrixLUInverse
4473  A - inverse of matrix A, same as in RMatrixLUInverse
4474 
4475  -- ALGLIB routine --
4476  10.02.2010
4477  Bochkanov Sergey
4478 *************************************************************************/
4480 {
4481  alglib_impl::ae_state _alglib_env_state;
4482  ae_int_t n;
4483  bool isupper;
4484  if( (a.cols()!=a.rows()))
4485  throw ap_error("Error while calling 'hpdmatrixinverse': looks like one of arguments has wrong size");
4486  if( !alglib_impl::ae_is_hermitian(const_cast<alglib_impl::ae_matrix*>(a.c_ptr())) )
4487  throw ap_error("'a' parameter is not Hermitian matrix");
4488  n = a.cols();
4489  isupper = false;
4490  alglib_impl::ae_state_init(&_alglib_env_state);
4491  try
4492  {
4493  alglib_impl::hpdmatrixinverse(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, &info, const_cast<alglib_impl::matinvreport*>(rep.c_ptr()), &_alglib_env_state);
4494  if( !alglib_impl::ae_force_hermitian(const_cast<alglib_impl::ae_matrix*>(a.c_ptr())) )
4495  throw ap_error("Internal error while forcing Hermitian properties of 'a' parameter");
4496  alglib_impl::ae_state_clear(&_alglib_env_state);
4497  return;
4498  }
4500  {
4501  throw ap_error(_alglib_env_state.error_msg);
4502  }
4503 }
4504 
4505 /*************************************************************************
4506 Triangular matrix inverse (real)
4507 
4508 The subroutine inverts the following types of matrices:
4509  * upper triangular
4510  * upper triangular with unit diagonal
4511  * lower triangular
4512  * lower triangular with unit diagonal
4513 
4514 In case of an upper (lower) triangular matrix, the inverse matrix will
4515 also be upper (lower) triangular, and after the end of the algorithm, the
4516 inverse matrix replaces the source matrix. The elements below (above) the
4517 main diagonal are not changed by the algorithm.
4518 
4519 If the matrix has a unit diagonal, the inverse matrix also has a unit
4520 diagonal, and the diagonal elements are not passed to the algorithm.
4521 
4522 Input parameters:
4523  A - matrix, array[0..N-1, 0..N-1].
4524  N - size of matrix A (optional) :
4525  * if given, only principal NxN submatrix is processed and
4526  overwritten. other elements are unchanged.
4527  * if not given, size is automatically determined from
4528  matrix size (A must be square matrix)
4529  IsUpper - True, if the matrix is upper triangular.
4530  IsUnit - diagonal type (optional):
4531  * if True, matrix has unit diagonal (a[i,i] are NOT used)
4532  * if False, matrix diagonal is arbitrary
4533  * if not given, False is assumed
4534 
4535 Output parameters:
4536  Info - same as for RMatrixLUInverse
4537  Rep - same as for RMatrixLUInverse
4538  A - same as for RMatrixLUInverse.
4539 
4540  -- ALGLIB --
4541  Copyright 05.02.2010 by Bochkanov Sergey
4542 *************************************************************************/
4543 void rmatrixtrinverse(real_2d_array &a, const ae_int_t n, const bool isupper, const bool isunit, ae_int_t &info, matinvreport &rep)
4544 {
4545  alglib_impl::ae_state _alglib_env_state;
4546  alglib_impl::ae_state_init(&_alglib_env_state);
4547  try
4548  {
4549  alglib_impl::rmatrixtrinverse(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, isunit, &info, const_cast<alglib_impl::matinvreport*>(rep.c_ptr()), &_alglib_env_state);
4550  alglib_impl::ae_state_clear(&_alglib_env_state);
4551  return;
4552  }
4554  {
4555  throw ap_error(_alglib_env_state.error_msg);
4556  }
4557 }
4558 
4559 /*************************************************************************
4560 Triangular matrix inverse (real)
4561 
4562 The subroutine inverts the following types of matrices:
4563  * upper triangular
4564  * upper triangular with unit diagonal
4565  * lower triangular
4566  * lower triangular with unit diagonal
4567 
4568 In case of an upper (lower) triangular matrix, the inverse matrix will
4569 also be upper (lower) triangular, and after the end of the algorithm, the
4570 inverse matrix replaces the source matrix. The elements below (above) the
4571 main diagonal are not changed by the algorithm.
4572 
4573 If the matrix has a unit diagonal, the inverse matrix also has a unit
4574 diagonal, and the diagonal elements are not passed to the algorithm.
4575 
4576 Input parameters:
4577  A - matrix, array[0..N-1, 0..N-1].
4578  N - size of matrix A (optional) :
4579  * if given, only principal NxN submatrix is processed and
4580  overwritten. other elements are unchanged.
4581  * if not given, size is automatically determined from
4582  matrix size (A must be square matrix)
4583  IsUpper - True, if the matrix is upper triangular.
4584  IsUnit - diagonal type (optional):
4585  * if True, matrix has unit diagonal (a[i,i] are NOT used)
4586  * if False, matrix diagonal is arbitrary
4587  * if not given, False is assumed
4588 
4589 Output parameters:
4590  Info - same as for RMatrixLUInverse
4591  Rep - same as for RMatrixLUInverse
4592  A - same as for RMatrixLUInverse.
4593 
4594  -- ALGLIB --
4595  Copyright 05.02.2010 by Bochkanov Sergey
4596 *************************************************************************/
4597 void rmatrixtrinverse(real_2d_array &a, const bool isupper, ae_int_t &info, matinvreport &rep)
4598 {
4599  alglib_impl::ae_state _alglib_env_state;
4600  ae_int_t n;
4601  bool isunit;
4602  if( (a.cols()!=a.rows()))
4603  throw ap_error("Error while calling 'rmatrixtrinverse': looks like one of arguments has wrong size");
4604  n = a.cols();
4605  isunit = false;
4606  alglib_impl::ae_state_init(&_alglib_env_state);
4607  try
4608  {
4609  alglib_impl::rmatrixtrinverse(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, isunit, &info, const_cast<alglib_impl::matinvreport*>(rep.c_ptr()), &_alglib_env_state);
4610 
4611  alglib_impl::ae_state_clear(&_alglib_env_state);
4612  return;
4613  }
4615  {
4616  throw ap_error(_alglib_env_state.error_msg);
4617  }
4618 }
4619 
4620 /*************************************************************************
4621 Triangular matrix inverse (complex)
4622 
4623 The subroutine inverts the following types of matrices:
4624  * upper triangular
4625  * upper triangular with unit diagonal
4626  * lower triangular
4627  * lower triangular with unit diagonal
4628 
4629 In case of an upper (lower) triangular matrix, the inverse matrix will
4630 also be upper (lower) triangular, and after the end of the algorithm, the
4631 inverse matrix replaces the source matrix. The elements below (above) the
4632 main diagonal are not changed by the algorithm.
4633 
4634 If the matrix has a unit diagonal, the inverse matrix also has a unit
4635 diagonal, and the diagonal elements are not passed to the algorithm.
4636 
4637 Input parameters:
4638  A - matrix, array[0..N-1, 0..N-1].
4639  N - size of matrix A (optional) :
4640  * if given, only principal NxN submatrix is processed and
4641  overwritten. other elements are unchanged.
4642  * if not given, size is automatically determined from
4643  matrix size (A must be square matrix)
4644  IsUpper - True, if the matrix is upper triangular.
4645  IsUnit - diagonal type (optional):
4646  * if True, matrix has unit diagonal (a[i,i] are NOT used)
4647  * if False, matrix diagonal is arbitrary
4648  * if not given, False is assumed
4649 
4650 Output parameters:
4651  Info - same as for RMatrixLUInverse
4652  Rep - same as for RMatrixLUInverse
4653  A - same as for RMatrixLUInverse.
4654 
4655  -- ALGLIB --
4656  Copyright 05.02.2010 by Bochkanov Sergey
4657 *************************************************************************/
4658 void cmatrixtrinverse(complex_2d_array &a, const ae_int_t n, const bool isupper, const bool isunit, ae_int_t &info, matinvreport &rep)
4659 {
4660  alglib_impl::ae_state _alglib_env_state;
4661  alglib_impl::ae_state_init(&_alglib_env_state);
4662  try
4663  {
4664  alglib_impl::cmatrixtrinverse(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, isunit, &info, const_cast<alglib_impl::matinvreport*>(rep.c_ptr()), &_alglib_env_state);
4665  alglib_impl::ae_state_clear(&_alglib_env_state);
4666  return;
4667  }
4669  {
4670  throw ap_error(_alglib_env_state.error_msg);
4671  }
4672 }
4673 
4674 /*************************************************************************
4675 Triangular matrix inverse (complex)
4676 
4677 The subroutine inverts the following types of matrices:
4678  * upper triangular
4679  * upper triangular with unit diagonal
4680  * lower triangular
4681  * lower triangular with unit diagonal
4682 
4683 In case of an upper (lower) triangular matrix, the inverse matrix will
4684 also be upper (lower) triangular, and after the end of the algorithm, the
4685 inverse matrix replaces the source matrix. The elements below (above) the
4686 main diagonal are not changed by the algorithm.
4687 
4688 If the matrix has a unit diagonal, the inverse matrix also has a unit
4689 diagonal, and the diagonal elements are not passed to the algorithm.
4690 
4691 Input parameters:
4692  A - matrix, array[0..N-1, 0..N-1].
4693  N - size of matrix A (optional) :
4694  * if given, only principal NxN submatrix is processed and
4695  overwritten. other elements are unchanged.
4696  * if not given, size is automatically determined from
4697  matrix size (A must be square matrix)
4698  IsUpper - True, if the matrix is upper triangular.
4699  IsUnit - diagonal type (optional):
4700  * if True, matrix has unit diagonal (a[i,i] are NOT used)
4701  * if False, matrix diagonal is arbitrary
4702  * if not given, False is assumed
4703 
4704 Output parameters:
4705  Info - same as for RMatrixLUInverse
4706  Rep - same as for RMatrixLUInverse
4707  A - same as for RMatrixLUInverse.
4708 
4709  -- ALGLIB --
4710  Copyright 05.02.2010 by Bochkanov Sergey
4711 *************************************************************************/
4712 void cmatrixtrinverse(complex_2d_array &a, const bool isupper, ae_int_t &info, matinvreport &rep)
4713 {
4714  alglib_impl::ae_state _alglib_env_state;
4715  ae_int_t n;
4716  bool isunit;
4717  if( (a.cols()!=a.rows()))
4718  throw ap_error("Error while calling 'cmatrixtrinverse': looks like one of arguments has wrong size");
4719  n = a.cols();
4720  isunit = false;
4721  alglib_impl::ae_state_init(&_alglib_env_state);
4722  try
4723  {
4724  alglib_impl::cmatrixtrinverse(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, isunit, &info, const_cast<alglib_impl::matinvreport*>(rep.c_ptr()), &_alglib_env_state);
4725 
4726  alglib_impl::ae_state_clear(&_alglib_env_state);
4727  return;
4728  }
4730  {
4731  throw ap_error(_alglib_env_state.error_msg);
4732  }
4733 }
4734 
4735 /*************************************************************************
4736 Sparse matrix
4737 
4738 You should use ALGLIB functions to work with sparse matrix.
4739 Never try to access its fields directly!
4740 *************************************************************************/
4742 {
4744  if( p_struct==NULL )
4745  throw ap_error("ALGLIB: malloc error");
4747  throw ap_error("ALGLIB: malloc error");
4748 }
4749 
4751 {
4753  if( p_struct==NULL )
4754  throw ap_error("ALGLIB: malloc error");
4755  if( !alglib_impl::_sparsematrix_init_copy(p_struct, const_cast<alglib_impl::sparsematrix*>(rhs.p_struct), NULL, ae_false) )
4756  throw ap_error("ALGLIB: malloc error");
4757 }
4758 
4760 {
4761  if( this==&rhs )
4762  return *this;
4764  if( !alglib_impl::_sparsematrix_init_copy(p_struct, const_cast<alglib_impl::sparsematrix*>(rhs.p_struct), NULL, ae_false) )
4765  throw ap_error("ALGLIB: malloc error");
4766  return *this;
4767 }
4768 
4770 {
4772  ae_free(p_struct);
4773 }
4774 
4776 {
4777  return p_struct;
4778 }
4779 
4781 {
4782  return const_cast<alglib_impl::sparsematrix*>(p_struct);
4783 }
4785 {
4786 }
4787 
4789 {
4790 }
4791 
4793 {
4794  if( this==&rhs )
4795  return *this;
4797  return *this;
4798 }
4799 
4801 {
4802 }
4803 
4804 /*************************************************************************
4805 This function creates sparse matrix in a Hash-Table format.
4806 
4807 This function creates Hast-Table matrix, which can be converted to CRS
4808 format after its initialization is over. Typical usage scenario for a
4809 sparse matrix is:
4810 1. creation in a Hash-Table format
4811 2. insertion of the matrix elements
4812 3. conversion to the CRS representation
4813 4. matrix is passed to some linear algebra algorithm
4814 
4815 Some information about different matrix formats can be found below, in
4816 the "NOTES" section.
4817 
4818 INPUT PARAMETERS
4819  M - number of rows in a matrix, M>=1
4820  N - number of columns in a matrix, N>=1
4821  K - K>=0, expected number of non-zero elements in a matrix.
4822  K can be inexact approximation, can be less than actual
4823  number of elements (table will grow when needed) or
4824  even zero).
4825  It is important to understand that although hash-table
4826  may grow automatically, it is better to provide good
4827  estimate of data size.
4828 
4829 OUTPUT PARAMETERS
4830  S - sparse M*N matrix in Hash-Table representation.
4831  All elements of the matrix are zero.
4832 
4833 NOTE 1.
4834 
4835 Sparse matrices can be stored using either Hash-Table representation or
4836 Compressed Row Storage representation. Hast-table is better suited for
4837 querying and dynamic operations (thus, it is used for matrix
4838 initialization), but it is inefficient when you want to make some linear
4839 algebra operations.
4840 
4841 From the other side, CRS is better suited for linear algebra operations,
4842 but initialization is less convenient - you have to tell row sizes at the
4843 initialization, and you can fill matrix only row by row, from left to
4844 right. CRS is also very inefficient when you want to find matrix element
4845 by its index.
4846 
4847 Thus, Hash-Table representation does not support linear algebra
4848 operations, while CRS format does not support modification of the table.
4849 Tables below outline information about these two formats:
4850 
4851  OPERATIONS WITH MATRIX HASH CRS
4852  create + +
4853  read element + +
4854  modify element +
4855  add value to element +
4856  A*x (dense vector) +
4857  A'*x (dense vector) +
4858  A*X (dense matrix) +
4859  A'*X (dense matrix) +
4860 
4861 NOTE 2.
4862 
4863 Hash-tables use memory inefficiently, and they have to keep some amount
4864 of the "spare memory" in order to have good performance. Hash table for
4865 matrix with K non-zero elements will need C*K*(8+2*sizeof(int)) bytes,
4866 where C is a small constant, about 1.5-2 in magnitude.
4867 
4868 CRS storage, from the other side, is more memory-efficient, and needs
4869 just K*(8+sizeof(int))+M*sizeof(int) bytes, where M is a number of rows
4870 in a matrix.
4871 
4872 When you convert from the Hash-Table to CRS representation, all unneeded
4873 memory will be freed.
4874 
4875  -- ALGLIB PROJECT --
4876  Copyright 14.10.2011 by Bochkanov Sergey
4877 *************************************************************************/
4878 void sparsecreate(const ae_int_t m, const ae_int_t n, const ae_int_t k, sparsematrix &s)
4879 {
4880  alglib_impl::ae_state _alglib_env_state;
4881  alglib_impl::ae_state_init(&_alglib_env_state);
4882  try
4883  {
4884  alglib_impl::sparsecreate(m, n, k, const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), &_alglib_env_state);
4885  alglib_impl::ae_state_clear(&_alglib_env_state);
4886  return;
4887  }
4889  {
4890  throw ap_error(_alglib_env_state.error_msg);
4891  }
4892 }
4893 
4894 /*************************************************************************
4895 This function creates sparse matrix in a Hash-Table format.
4896 
4897 This function creates Hast-Table matrix, which can be converted to CRS
4898 format after its initialization is over. Typical usage scenario for a
4899 sparse matrix is:
4900 1. creation in a Hash-Table format
4901 2. insertion of the matrix elements
4902 3. conversion to the CRS representation
4903 4. matrix is passed to some linear algebra algorithm
4904 
4905 Some information about different matrix formats can be found below, in
4906 the "NOTES" section.
4907 
4908 INPUT PARAMETERS
4909  M - number of rows in a matrix, M>=1
4910  N - number of columns in a matrix, N>=1
4911  K - K>=0, expected number of non-zero elements in a matrix.
4912  K can be inexact approximation, can be less than actual
4913  number of elements (table will grow when needed) or
4914  even zero).
4915  It is important to understand that although hash-table
4916  may grow automatically, it is better to provide good
4917  estimate of data size.
4918 
4919 OUTPUT PARAMETERS
4920  S - sparse M*N matrix in Hash-Table representation.
4921  All elements of the matrix are zero.
4922 
4923 NOTE 1.
4924 
4925 Sparse matrices can be stored using either Hash-Table representation or
4926 Compressed Row Storage representation. Hast-table is better suited for
4927 querying and dynamic operations (thus, it is used for matrix
4928 initialization), but it is inefficient when you want to make some linear
4929 algebra operations.
4930 
4931 From the other side, CRS is better suited for linear algebra operations,
4932 but initialization is less convenient - you have to tell row sizes at the
4933 initialization, and you can fill matrix only row by row, from left to
4934 right. CRS is also very inefficient when you want to find matrix element
4935 by its index.
4936 
4937 Thus, Hash-Table representation does not support linear algebra
4938 operations, while CRS format does not support modification of the table.
4939 Tables below outline information about these two formats:
4940 
4941  OPERATIONS WITH MATRIX HASH CRS
4942  create + +
4943  read element + +
4944  modify element +
4945  add value to element +
4946  A*x (dense vector) +
4947  A'*x (dense vector) +
4948  A*X (dense matrix) +
4949  A'*X (dense matrix) +
4950 
4951 NOTE 2.
4952 
4953 Hash-tables use memory inefficiently, and they have to keep some amount
4954 of the "spare memory" in order to have good performance. Hash table for
4955 matrix with K non-zero elements will need C*K*(8+2*sizeof(int)) bytes,
4956 where C is a small constant, about 1.5-2 in magnitude.
4957 
4958 CRS storage, from the other side, is more memory-efficient, and needs
4959 just K*(8+sizeof(int))+M*sizeof(int) bytes, where M is a number of rows
4960 in a matrix.
4961 
4962 When you convert from the Hash-Table to CRS representation, all unneeded
4963 memory will be freed.
4964 
4965  -- ALGLIB PROJECT --
4966  Copyright 14.10.2011 by Bochkanov Sergey
4967 *************************************************************************/
4969 {
4970  alglib_impl::ae_state _alglib_env_state;
4971  ae_int_t k;
4972 
4973  k = 0;
4974  alglib_impl::ae_state_init(&_alglib_env_state);
4975  try
4976  {
4977  alglib_impl::sparsecreate(m, n, k, const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), &_alglib_env_state);
4978 
4979  alglib_impl::ae_state_clear(&_alglib_env_state);
4980  return;
4981  }
4983  {
4984  throw ap_error(_alglib_env_state.error_msg);
4985  }
4986 }
4987 
4988 /*************************************************************************
4989 This function creates sparse matrix in a CRS format (expert function for
4990 situations when you are running out of memory).
4991 
4992 This function creates CRS matrix. Typical usage scenario for a CRS matrix
4993 is:
4994 1. creation (you have to tell number of non-zero elements at each row at
4995  this moment)
4996 2. insertion of the matrix elements (row by row, from left to right)
4997 3. matrix is passed to some linear algebra algorithm
4998 
4999 This function is a memory-efficient alternative to SparseCreate(), but it
5000 is more complex because it requires you to know in advance how large your
5001 matrix is. Some information about different matrix formats can be found
5002 below, in the "NOTES" section.
5003 
5004 INPUT PARAMETERS
5005  M - number of rows in a matrix, M>=1
5006  N - number of columns in a matrix, N>=1
5007  NER - number of elements at each row, array[M], NER[I]>=0
5008 
5009 OUTPUT PARAMETERS
5010  S - sparse M*N matrix in CRS representation.
5011  You have to fill ALL non-zero elements by calling
5012  SparseSet() BEFORE you try to use this matrix.
5013 
5014 NOTE 1.
5015 
5016 Sparse matrices can be stored using either Hash-Table representation or
5017 Compressed Row Storage representation. Hast-table is better suited for
5018 querying and dynamic operations (thus, it is used for matrix
5019 initialization), but it is inefficient when you want to make some linear
5020 algebra operations.
5021 
5022 From the other side, CRS is better suited for linear algebra operations,
5023 but initialization is less convenient - you have to tell row sizes at the
5024 initialization, and you can fill matrix only row by row, from left to
5025 right. CRS is also very inefficient when you want to find matrix element
5026 by its index.
5027 
5028 Thus, Hash-Table representation does not support linear algebra
5029 operations, while CRS format does not support modification of the table.
5030 Tables below outline information about these two formats:
5031 
5032  OPERATIONS WITH MATRIX HASH CRS
5033  create + +
5034  read element + +
5035  modify element +
5036  add value to element +
5037  A*x (dense vector) +
5038  A'*x (dense vector) +
5039  A*X (dense matrix) +
5040  A'*X (dense matrix) +
5041 
5042 NOTE 2.
5043 
5044 Hash-tables use memory inefficiently, and they have to keep some amount
5045 of the "spare memory" in order to have good performance. Hash table for
5046 matrix with K non-zero elements will need C*K*(8+2*sizeof(int)) bytes,
5047 where C is a small constant, about 1.5-2 in magnitude.
5048 
5049 CRS storage, from the other side, is more memory-efficient, and needs
5050 just K*(8+sizeof(int))+M*sizeof(int) bytes, where M is a number of rows
5051 in a matrix.
5052 
5053 When you convert from the Hash-Table to CRS representation, all unneeded
5054 memory will be freed.
5055 
5056  -- ALGLIB PROJECT --
5057  Copyright 14.10.2011 by Bochkanov Sergey
5058 *************************************************************************/
5060 {
5061  alglib_impl::ae_state _alglib_env_state;
5062  alglib_impl::ae_state_init(&_alglib_env_state);
5063  try
5064  {
5065  alglib_impl::sparsecreatecrs(m, n, const_cast<alglib_impl::ae_vector*>(ner.c_ptr()), const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), &_alglib_env_state);
5066  alglib_impl::ae_state_clear(&_alglib_env_state);
5067  return;
5068  }
5070  {
5071  throw ap_error(_alglib_env_state.error_msg);
5072  }
5073 }
5074 
5075 /*************************************************************************
5076 This function copies S0 to S1.
5077 
5078 NOTE: this function does not verify its arguments, it just copies all
5079 fields of the structure.
5080 
5081  -- ALGLIB PROJECT --
5082  Copyright 14.10.2011 by Bochkanov Sergey
5083 *************************************************************************/
5085 {
5086  alglib_impl::ae_state _alglib_env_state;
5087  alglib_impl::ae_state_init(&_alglib_env_state);
5088  try
5089  {
5090  alglib_impl::sparsecopy(const_cast<alglib_impl::sparsematrix*>(s0.c_ptr()), const_cast<alglib_impl::sparsematrix*>(s1.c_ptr()), &_alglib_env_state);
5091  alglib_impl::ae_state_clear(&_alglib_env_state);
5092  return;
5093  }
5095  {
5096  throw ap_error(_alglib_env_state.error_msg);
5097  }
5098 }
5099 
5100 /*************************************************************************
5101 This function adds value to S[i,j] - element of the sparse matrix. Matrix
5102 must be in a Hash-Table mode.
5103 
5104 In case S[i,j] already exists in the table, V i added to its value. In
5105 case S[i,j] is non-existent, it is inserted in the table. Table
5106 automatically grows when necessary.
5107 
5108 INPUT PARAMETERS
5109  S - sparse M*N matrix in Hash-Table representation.
5110  Exception will be thrown for CRS matrix.
5111  I - row index of the element to modify, 0<=I<M
5112  J - column index of the element to modify, 0<=J<N
5113  V - value to add, must be finite number
5114 
5115 OUTPUT PARAMETERS
5116  S - modified matrix
5117 
5118 NOTE 1: when S[i,j] is exactly zero after modification, it is deleted
5119 from the table.
5120 
5121  -- ALGLIB PROJECT --
5122  Copyright 14.10.2011 by Bochkanov Sergey
5123 *************************************************************************/
5124 void sparseadd(const sparsematrix &s, const ae_int_t i, const ae_int_t j, const double v)
5125 {
5126  alglib_impl::ae_state _alglib_env_state;
5127  alglib_impl::ae_state_init(&_alglib_env_state);
5128  try
5129  {
5130  alglib_impl::sparseadd(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), i, j, v, &_alglib_env_state);
5131  alglib_impl::ae_state_clear(&_alglib_env_state);
5132  return;
5133  }
5135  {
5136  throw ap_error(_alglib_env_state.error_msg);
5137  }
5138 }
5139 
5140 /*************************************************************************
5141 This function modifies S[i,j] - element of the sparse matrix.
5142 
5143 For Hash-based storage format:
5144 * new value can be zero or non-zero. In case new value of S[i,j] is zero,
5145  this element is deleted from the table.
5146 * this function has no effect when called with zero V for non-existent
5147  element.
5148 
5149 For CRS-bases storage format:
5150 * new value MUST be non-zero. Exception will be thrown for zero V.
5151 * elements must be initialized in correct order - from top row to bottom,
5152  within row - from left to right.
5153 
5154 INPUT PARAMETERS
5155  S - sparse M*N matrix in Hash-Table or CRS representation.
5156  I - row index of the element to modify, 0<=I<M
5157  J - column index of the element to modify, 0<=J<N
5158  V - value to set, must be finite number, can be zero
5159 
5160 OUTPUT PARAMETERS
5161  S - modified matrix
5162 
5163  -- ALGLIB PROJECT --
5164  Copyright 14.10.2011 by Bochkanov Sergey
5165 *************************************************************************/
5166 void sparseset(const sparsematrix &s, const ae_int_t i, const ae_int_t j, const double v)
5167 {
5168  alglib_impl::ae_state _alglib_env_state;
5169  alglib_impl::ae_state_init(&_alglib_env_state);
5170  try
5171  {
5172  alglib_impl::sparseset(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), i, j, v, &_alglib_env_state);
5173  alglib_impl::ae_state_clear(&_alglib_env_state);
5174  return;
5175  }
5177  {
5178  throw ap_error(_alglib_env_state.error_msg);
5179  }
5180 }
5181 
5182 /*************************************************************************
5183 This function returns S[i,j] - element of the sparse matrix. Matrix can
5184 be in any mode (Hash-Table or CRS), but this function is less efficient
5185 for CRS matrices. Hash-Table matrices can find element in O(1) time,
5186 while CRS matrices need O(log(RS)) time, where RS is an number of non-
5187 zero elements in a row.
5188 
5189 INPUT PARAMETERS
5190  S - sparse M*N matrix in Hash-Table representation.
5191  Exception will be thrown for CRS matrix.
5192  I - row index of the element to modify, 0<=I<M
5193  J - column index of the element to modify, 0<=J<N
5194 
5195 RESULT
5196  value of S[I,J] or zero (in case no element with such index is found)
5197 
5198  -- ALGLIB PROJECT --
5199  Copyright 14.10.2011 by Bochkanov Sergey
5200 *************************************************************************/
5201 double sparseget(const sparsematrix &s, const ae_int_t i, const ae_int_t j)
5202 {
5203  alglib_impl::ae_state _alglib_env_state;
5204  alglib_impl::ae_state_init(&_alglib_env_state);
5205  try
5206  {
5207  double result = alglib_impl::sparseget(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), i, j, &_alglib_env_state);
5208  alglib_impl::ae_state_clear(&_alglib_env_state);
5209  return *(reinterpret_cast<double*>(&result));
5210  }
5212  {
5213  throw ap_error(_alglib_env_state.error_msg);
5214  }
5215 }
5216 
5217 /*************************************************************************
5218 This function returns I-th diagonal element of the sparse matrix.
5219 
5220 Matrix can be in any mode (Hash-Table or CRS storage), but this function
5221 is most efficient for CRS matrices - it requires less than 50 CPU cycles
5222 to extract diagonal element. For Hash-Table matrices we still have O(1)
5223 query time, but function is many times slower.
5224 
5225 INPUT PARAMETERS
5226  S - sparse M*N matrix in Hash-Table representation.
5227  Exception will be thrown for CRS matrix.
5228  I - index of the element to modify, 0<=I<min(M,N)
5229 
5230 RESULT
5231  value of S[I,I] or zero (in case no element with such index is found)
5232 
5233  -- ALGLIB PROJECT --
5234  Copyright 14.10.2011 by Bochkanov Sergey
5235 *************************************************************************/
5236 double sparsegetdiagonal(const sparsematrix &s, const ae_int_t i)
5237 {
5238  alglib_impl::ae_state _alglib_env_state;
5239  alglib_impl::ae_state_init(&_alglib_env_state);
5240  try
5241  {
5242  double result = alglib_impl::sparsegetdiagonal(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), i, &_alglib_env_state);
5243  alglib_impl::ae_state_clear(&_alglib_env_state);
5244  return *(reinterpret_cast<double*>(&result));
5245  }
5247  {
5248  throw ap_error(_alglib_env_state.error_msg);
5249  }
5250 }
5251 
5252 /*************************************************************************
5253 This function converts matrix to CRS format.
5254 
5255 Some algorithms (linear algebra ones, for example) require matrices in
5256 CRS format.
5257 
5258 INPUT PARAMETERS
5259  S - sparse M*N matrix in any format
5260 
5261 OUTPUT PARAMETERS
5262  S - matrix in CRS format
5263 
5264 NOTE: this function has no effect when called with matrix which is
5265 already in CRS mode.
5266 
5267  -- ALGLIB PROJECT --
5268  Copyright 14.10.2011 by Bochkanov Sergey
5269 *************************************************************************/
5271 {
5272  alglib_impl::ae_state _alglib_env_state;
5273  alglib_impl::ae_state_init(&_alglib_env_state);
5274  try
5275  {
5276  alglib_impl::sparseconverttocrs(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), &_alglib_env_state);
5277  alglib_impl::ae_state_clear(&_alglib_env_state);
5278  return;
5279  }
5281  {
5282  throw ap_error(_alglib_env_state.error_msg);
5283  }
5284 }
5285 
5286 /*************************************************************************
5287 This function calculates matrix-vector product S*x. Matrix S must be
5288 stored in CRS format (exception will be thrown otherwise).
5289 
5290 INPUT PARAMETERS
5291  S - sparse M*N matrix in CRS format (you MUST convert it
5292  to CRS before calling this function).
5293  X - array[N], input vector. For performance reasons we
5294  make only quick checks - we check that array size is
5295  at least N, but we do not check for NAN's or INF's.
5296  Y - output buffer, possibly preallocated. In case buffer
5297  size is too small to store result, this buffer is
5298  automatically resized.
5299 
5300 OUTPUT PARAMETERS
5301  Y - array[M], S*x
5302 
5303 NOTE: this function throws exception when called for non-CRS matrix. You
5304 must convert your matrix with SparseConvertToCRS() before using this
5305 function.
5306 
5307  -- ALGLIB PROJECT --
5308  Copyright 14.10.2011 by Bochkanov Sergey
5309 *************************************************************************/
5311 {
5312  alglib_impl::ae_state _alglib_env_state;
5313  alglib_impl::ae_state_init(&_alglib_env_state);
5314  try
5315  {
5316  alglib_impl::sparsemv(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), const_cast<alglib_impl::ae_vector*>(x.c_ptr()), const_cast<alglib_impl::ae_vector*>(y.c_ptr()), &_alglib_env_state);
5317  alglib_impl::ae_state_clear(&_alglib_env_state);
5318  return;
5319  }
5321  {
5322  throw ap_error(_alglib_env_state.error_msg);
5323  }
5324 }
5325 
5326 /*************************************************************************
5327 This function calculates matrix-vector product S^T*x. Matrix S must be
5328 stored in CRS format (exception will be thrown otherwise).
5329 
5330 INPUT PARAMETERS
5331  S - sparse M*N matrix in CRS format (you MUST convert it
5332  to CRS before calling this function).
5333  X - array[M], input vector. For performance reasons we
5334  make only quick checks - we check that array size is
5335  at least M, but we do not check for NAN's or INF's.
5336  Y - output buffer, possibly preallocated. In case buffer
5337  size is too small to store result, this buffer is
5338  automatically resized.
5339 
5340 OUTPUT PARAMETERS
5341  Y - array[N], S^T*x
5342 
5343 NOTE: this function throws exception when called for non-CRS matrix. You
5344 must convert your matrix with SparseConvertToCRS() before using this
5345 function.
5346 
5347  -- ALGLIB PROJECT --
5348  Copyright 14.10.2011 by Bochkanov Sergey
5349 *************************************************************************/
5351 {
5352  alglib_impl::ae_state _alglib_env_state;
5353  alglib_impl::ae_state_init(&_alglib_env_state);
5354  try
5355  {
5356  alglib_impl::sparsemtv(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), const_cast<alglib_impl::ae_vector*>(x.c_ptr()), const_cast<alglib_impl::ae_vector*>(y.c_ptr()), &_alglib_env_state);
5357  alglib_impl::ae_state_clear(&_alglib_env_state);
5358  return;
5359  }
5361  {
5362  throw ap_error(_alglib_env_state.error_msg);
5363  }
5364 }
5365 
5366 /*************************************************************************
5367 This function simultaneously calculates two matrix-vector products:
5368  S*x and S^T*x.
5369 S must be square (non-rectangular) matrix stored in CRS format (exception
5370 will be thrown otherwise).
5371 
5372 INPUT PARAMETERS
5373  S - sparse N*N matrix in CRS format (you MUST convert it
5374  to CRS before calling this function).
5375  X - array[N], input vector. For performance reasons we
5376  make only quick checks - we check that array size is
5377  at least N, but we do not check for NAN's or INF's.
5378  Y0 - output buffer, possibly preallocated. In case buffer
5379  size is too small to store result, this buffer is
5380  automatically resized.
5381  Y1 - output buffer, possibly preallocated. In case buffer
5382  size is too small to store result, this buffer is
5383  automatically resized.
5384 
5385 OUTPUT PARAMETERS
5386  Y0 - array[N], S*x
5387  Y1 - array[N], S^T*x
5388 
5389 NOTE: this function throws exception when called for non-CRS matrix. You
5390 must convert your matrix with SparseConvertToCRS() before using this
5391 function. It also throws exception when S is non-square.
5392 
5393  -- ALGLIB PROJECT --
5394  Copyright 14.10.2011 by Bochkanov Sergey
5395 *************************************************************************/
5397 {
5398  alglib_impl::ae_state _alglib_env_state;
5399  alglib_impl::ae_state_init(&_alglib_env_state);
5400  try
5401  {
5402  alglib_impl::sparsemv2(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), const_cast<alglib_impl::ae_vector*>(x.c_ptr()), const_cast<alglib_impl::ae_vector*>(y0.c_ptr()), const_cast<alglib_impl::ae_vector*>(y1.c_ptr()), &_alglib_env_state);
5403  alglib_impl::ae_state_clear(&_alglib_env_state);
5404  return;
5405  }
5407  {
5408  throw ap_error(_alglib_env_state.error_msg);
5409  }
5410 }
5411 
5412 /*************************************************************************
5413 This function calculates matrix-vector product S*x, when S is symmetric
5414 matrix. Matrix S must be stored in CRS format (exception will be
5415 thrown otherwise).
5416 
5417 INPUT PARAMETERS
5418  S - sparse M*M matrix in CRS format (you MUST convert it
5419  to CRS before calling this function).
5420  IsUpper - whether upper or lower triangle of S is given:
5421  * if upper triangle is given, only S[i,j] for j>=i
5422  are used, and lower triangle is ignored (it can be
5423  empty - these elements are not referenced at all).
5424  * if lower triangle is given, only S[i,j] for j<=i
5425  are used, and upper triangle is ignored.
5426  X - array[N], input vector. For performance reasons we
5427  make only quick checks - we check that array size is
5428  at least N, but we do not check for NAN's or INF's.
5429  Y - output buffer, possibly preallocated. In case buffer
5430  size is too small to store result, this buffer is
5431  automatically resized.
5432 
5433 OUTPUT PARAMETERS
5434  Y - array[M], S*x
5435 
5436 NOTE: this function throws exception when called for non-CRS matrix. You
5437 must convert your matrix with SparseConvertToCRS() before using this
5438 function.
5439 
5440  -- ALGLIB PROJECT --
5441  Copyright 14.10.2011 by Bochkanov Sergey
5442 *************************************************************************/
5443 void sparsesmv(const sparsematrix &s, const bool isupper, const real_1d_array &x, real_1d_array &y)
5444 {
5445  alglib_impl::ae_state _alglib_env_state;
5446  alglib_impl::ae_state_init(&_alglib_env_state);
5447  try
5448  {
5449  alglib_impl::sparsesmv(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), isupper, const_cast<alglib_impl::ae_vector*>(x.c_ptr()), const_cast<alglib_impl::ae_vector*>(y.c_ptr()), &_alglib_env_state);
5450  alglib_impl::ae_state_clear(&_alglib_env_state);
5451  return;
5452  }
5454  {
5455  throw ap_error(_alglib_env_state.error_msg);
5456  }
5457 }
5458 
5459 /*************************************************************************
5460 This function calculates matrix-matrix product S*A. Matrix S must be
5461 stored in CRS format (exception will be thrown otherwise).
5462 
5463 INPUT PARAMETERS
5464  S - sparse M*N matrix in CRS format (you MUST convert it
5465  to CRS before calling this function).
5466  A - array[N][K], input dense matrix. For performance reasons
5467  we make only quick checks - we check that array size
5468  is at least N, but we do not check for NAN's or INF's.
5469  K - number of columns of matrix (A).
5470  B - output buffer, possibly preallocated. In case buffer
5471  size is too small to store result, this buffer is
5472  automatically resized.
5473 
5474 OUTPUT PARAMETERS
5475  B - array[M][K], S*A
5476 
5477 NOTE: this function throws exception when called for non-CRS matrix. You
5478 must convert your matrix with SparseConvertToCRS() before using this
5479 function.
5480 
5481  -- ALGLIB PROJECT --
5482  Copyright 14.10.2011 by Bochkanov Sergey
5483 *************************************************************************/
5485 {
5486  alglib_impl::ae_state _alglib_env_state;
5487  alglib_impl::ae_state_init(&_alglib_env_state);
5488  try
5489  {
5490  alglib_impl::sparsemm(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), k, const_cast<alglib_impl::ae_matrix*>(b.c_ptr()), &_alglib_env_state);
5491  alglib_impl::ae_state_clear(&_alglib_env_state);
5492  return;
5493  }
5495  {
5496  throw ap_error(_alglib_env_state.error_msg);
5497  }
5498 }
5499 
5500 /*************************************************************************
5501 This function calculates matrix-matrix product S^T*A. Matrix S must be
5502 stored in CRS format (exception will be thrown otherwise).
5503 
5504 INPUT PARAMETERS
5505  S - sparse M*N matrix in CRS format (you MUST convert it
5506  to CRS before calling this function).
5507  A - array[M][K], input dense matrix. For performance reasons
5508  we make only quick checks - we check that array size is
5509  at least M, but we do not check for NAN's or INF's.
5510  K - number of columns of matrix (A).
5511  B - output buffer, possibly preallocated. In case buffer
5512  size is too small to store result, this buffer is
5513  automatically resized.
5514 
5515 OUTPUT PARAMETERS
5516  B - array[N][K], S^T*A
5517 
5518 NOTE: this function throws exception when called for non-CRS matrix. You
5519 must convert your matrix with SparseConvertToCRS() before using this
5520 function.
5521 
5522  -- ALGLIB PROJECT --
5523  Copyright 14.10.2011 by Bochkanov Sergey
5524 *************************************************************************/
5526 {
5527  alglib_impl::ae_state _alglib_env_state;
5528  alglib_impl::ae_state_init(&_alglib_env_state);
5529  try
5530  {
5531  alglib_impl::sparsemtm(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), k, const_cast<alglib_impl::ae_matrix*>(b.c_ptr()), &_alglib_env_state);
5532  alglib_impl::ae_state_clear(&_alglib_env_state);
5533  return;
5534  }
5536  {
5537  throw ap_error(_alglib_env_state.error_msg);
5538  }
5539 }
5540 
5541 /*************************************************************************
5542 This function simultaneously calculates two matrix-matrix products:
5543  S*A and S^T*A.
5544 S must be square (non-rectangular) matrix stored in CRS format (exception
5545 will be thrown otherwise).
5546 
5547 INPUT PARAMETERS
5548  S - sparse N*N matrix in CRS format (you MUST convert it
5549  to CRS before calling this function).
5550  A - array[N][K], input dense matrix. For performance reasons
5551  we make only quick checks - we check that array size is
5552  at least N, but we do not check for NAN's or INF's.
5553  K - number of columns of matrix (A).
5554  B0 - output buffer, possibly preallocated. In case buffer
5555  size is too small to store result, this buffer is
5556  automatically resized.
5557  B1 - output buffer, possibly preallocated. In case buffer
5558  size is too small to store result, this buffer is
5559  automatically resized.
5560 
5561 OUTPUT PARAMETERS
5562  B0 - array[N][K], S*A
5563  B1 - array[N][K], S^T*A
5564 
5565 NOTE: this function throws exception when called for non-CRS matrix. You
5566 must convert your matrix with SparseConvertToCRS() before using this
5567 function. It also throws exception when S is non-square.
5568 
5569  -- ALGLIB PROJECT --
5570  Copyright 14.10.2011 by Bochkanov Sergey
5571 *************************************************************************/
5573 {
5574  alglib_impl::ae_state _alglib_env_state;
5575  alglib_impl::ae_state_init(&_alglib_env_state);
5576  try
5577  {
5578  alglib_impl::sparsemm2(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), k, const_cast<alglib_impl::ae_matrix*>(b0.c_ptr()), const_cast<alglib_impl::ae_matrix*>(b1.c_ptr()), &_alglib_env_state);
5579  alglib_impl::ae_state_clear(&_alglib_env_state);
5580  return;
5581  }
5583  {
5584  throw ap_error(_alglib_env_state.error_msg);
5585  }
5586 }
5587 
5588 /*************************************************************************
5589 This function calculates matrix-matrix product S*A, when S is symmetric
5590 matrix. Matrix S must be stored in CRS format (exception will be
5591 thrown otherwise).
5592 
5593 INPUT PARAMETERS
5594  S - sparse M*M matrix in CRS format (you MUST convert it
5595  to CRS before calling this function).
5596  IsUpper - whether upper or lower triangle of S is given:
5597  * if upper triangle is given, only S[i,j] for j>=i
5598  are used, and lower triangle is ignored (it can be
5599  empty - these elements are not referenced at all).
5600  * if lower triangle is given, only S[i,j] for j<=i
5601  are used, and upper triangle is ignored.
5602  A - array[N][K], input dense matrix. For performance reasons
5603  we make only quick checks - we check that array size is
5604  at least N, but we do not check for NAN's or INF's.
5605  K - number of columns of matrix (A).
5606  B - output buffer, possibly preallocated. In case buffer
5607  size is too small to store result, this buffer is
5608  automatically resized.
5609 
5610 OUTPUT PARAMETERS
5611  B - array[M][K], S*A
5612 
5613 NOTE: this function throws exception when called for non-CRS matrix. You
5614 must convert your matrix with SparseConvertToCRS() before using this
5615 function.
5616 
5617  -- ALGLIB PROJECT --
5618  Copyright 14.10.2011 by Bochkanov Sergey
5619 *************************************************************************/
5620 void sparsesmm(const sparsematrix &s, const bool isupper, const real_2d_array &a, const ae_int_t k, real_2d_array &b)
5621 {
5622  alglib_impl::ae_state _alglib_env_state;
5623  alglib_impl::ae_state_init(&_alglib_env_state);
5624  try
5625  {
5626  alglib_impl::sparsesmm(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), isupper, const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), k, const_cast<alglib_impl::ae_matrix*>(b.c_ptr()), &_alglib_env_state);
5627  alglib_impl::ae_state_clear(&_alglib_env_state);
5628  return;
5629  }
5631  {
5632  throw ap_error(_alglib_env_state.error_msg);
5633  }
5634 }
5635 
5636 /*************************************************************************
5637 This procedure resizes Hash-Table matrix. It can be called when you have
5638 deleted too many elements from the matrix, and you want to free unneeded
5639 memory.
5640 
5641  -- ALGLIB PROJECT --
5642  Copyright 14.10.2011 by Bochkanov Sergey
5643 *************************************************************************/
5645 {
5646  alglib_impl::ae_state _alglib_env_state;
5647  alglib_impl::ae_state_init(&_alglib_env_state);
5648  try
5649  {
5650  alglib_impl::sparseresizematrix(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), &_alglib_env_state);
5651  alglib_impl::ae_state_clear(&_alglib_env_state);
5652  return;
5653  }
5655  {
5656  throw ap_error(_alglib_env_state.error_msg);
5657  }
5658 }
5659 
5660 /*************************************************************************
5661 This function is used to enumerate all elements of the sparse matrix.
5662 Before first call user initializes T0 and T1 counters by zero. These
5663 counters are used to remember current position in a matrix; after each
5664 call they are updated by the function.
5665 
5666 Subsequent calls to this function return non-zero elements of the sparse
5667 matrix, one by one. If you enumerate CRS matrix, matrix is traversed from
5668 left to right, from top to bottom. In case you enumerate matrix stored as
5669 Hash table, elements are returned in random order.
5670 
5671 EXAMPLE
5672  > T0=0
5673  > T1=0
5674  > while SparseEnumerate(S,T0,T1,I,J,V) do
5675  > ....do something with I,J,V
5676 
5677 INPUT PARAMETERS
5678  S - sparse M*N matrix in Hash-Table or CRS representation.
5679  T0 - internal counter
5680  T1 - internal counter
5681 
5682 OUTPUT PARAMETERS
5683  T0 - new value of the internal counter
5684  T1 - new value of the internal counter
5685  I - row index of non-zero element, 0<=I<M.
5686  J - column index of non-zero element, 0<=J<N
5687  V - value of the T-th element
5688 
5689 RESULT
5690  True in case of success (next non-zero element was retrieved)
5691  False in case all non-zero elements were enumerated
5692 
5693  -- ALGLIB PROJECT --
5694  Copyright 14.03.2012 by Bochkanov Sergey
5695 *************************************************************************/
5696 bool sparseenumerate(const sparsematrix &s, ae_int_t &t0, ae_int_t &t1, ae_int_t &i, ae_int_t &j, double &v)
5697 {
5698  alglib_impl::ae_state _alglib_env_state;
5699  alglib_impl::ae_state_init(&_alglib_env_state);
5700  try
5701  {
5702  ae_bool result = alglib_impl::sparseenumerate(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), &t0, &t1, &i, &j, &v, &_alglib_env_state);
5703  alglib_impl::ae_state_clear(&_alglib_env_state);
5704  return *(reinterpret_cast<bool*>(&result));
5705  }
5707  {
5708  throw ap_error(_alglib_env_state.error_msg);
5709  }
5710 }
5711 
5712 /*************************************************************************
5713 This function rewrites existing (non-zero) element. It returns True if
5714 element exists or False, when it is called for non-existing (zero)
5715 element.
5716 
5717 The purpose of this function is to provide convenient thread-safe way to
5718 modify sparse matrix. Such modification (already existing element is
5719 rewritten) is guaranteed to be thread-safe without any synchronization, as
5720 long as different threads modify different elements.
5721 
5722 INPUT PARAMETERS
5723  S - sparse M*N matrix in Hash-Table or CRS representation.
5724  I - row index of non-zero element to modify, 0<=I<M
5725  J - column index of non-zero element to modify, 0<=J<N
5726  V - value to rewrite, must be finite number
5727 
5728 OUTPUT PARAMETERS
5729  S - modified matrix
5730 RESULT
5731  True in case when element exists
5732  False in case when element doesn't exist or it is zero
5733 
5734  -- ALGLIB PROJECT --
5735  Copyright 14.03.2012 by Bochkanov Sergey
5736 *************************************************************************/
5737 bool sparserewriteexisting(const sparsematrix &s, const ae_int_t i, const ae_int_t j, const double v)
5738 {
5739  alglib_impl::ae_state _alglib_env_state;
5740  alglib_impl::ae_state_init(&_alglib_env_state);
5741  try
5742  {
5743  ae_bool result = alglib_impl::sparserewriteexisting(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), i, j, v, &_alglib_env_state);
5744  alglib_impl::ae_state_clear(&_alglib_env_state);
5745  return *(reinterpret_cast<bool*>(&result));
5746  }
5748  {
5749  throw ap_error(_alglib_env_state.error_msg);
5750  }
5751 }
5752 
5753 /*************************************************************************
5754 This function returns I-th row of the sparse matrix stored in CRS format.
5755 
5756 NOTE: when incorrect I (outside of [0,M-1]) or matrix (non-CRS) are
5757  passed, this function throws exception.
5758 
5759 INPUT PARAMETERS:
5760  S - sparse M*N matrix in CRS format
5761  I - row index, 0<=I<M
5762  IRow - output buffer, can be preallocated. In case buffer
5763  size is too small to store I-th row, it is
5764  automatically reallocated.
5765 
5766 OUTPUT PARAMETERS:
5767  IRow - array[M], I-th row.
5768 
5769 
5770  -- ALGLIB PROJECT --
5771  Copyright 20.07.2012 by Bochkanov Sergey
5772 *************************************************************************/
5773 void sparsegetrow(const sparsematrix &s, const ae_int_t i, real_1d_array &irow)
5774 {
5775  alglib_impl::ae_state _alglib_env_state;
5776  alglib_impl::ae_state_init(&_alglib_env_state);
5777  try
5778  {
5779  alglib_impl::sparsegetrow(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), i, const_cast<alglib_impl::ae_vector*>(irow.c_ptr()), &_alglib_env_state);
5780  alglib_impl::ae_state_clear(&_alglib_env_state);
5781  return;
5782  }
5784  {
5785  throw ap_error(_alglib_env_state.error_msg);
5786  }
5787 }
5788 
5789 /*************************************************************************
5790 This function performs in-place conversion from CRS format to Hash table
5791 storage.
5792 
5793 INPUT PARAMETERS
5794  S - sparse matrix in CRS format.
5795 
5796 OUTPUT PARAMETERS
5797  S - sparse matrix in Hash table format.
5798 
5799 NOTE: this function has no effect when called with matrix which is
5800 already in Hash table mode.
5801 
5802  -- ALGLIB PROJECT --
5803  Copyright 20.07.2012 by Bochkanov Sergey
5804 *************************************************************************/
5806 {
5807  alglib_impl::ae_state _alglib_env_state;
5808  alglib_impl::ae_state_init(&_alglib_env_state);
5809  try
5810  {
5811  alglib_impl::sparseconverttohash(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), &_alglib_env_state);
5812  alglib_impl::ae_state_clear(&_alglib_env_state);
5813  return;
5814  }
5816  {
5817  throw ap_error(_alglib_env_state.error_msg);
5818  }
5819 }
5820 
5821 /*************************************************************************
5822 This function performs out-of-place conversion to Hash table storage
5823 format. S0 is copied to S1 and converted on-the-fly.
5824 
5825 INPUT PARAMETERS
5826  S0 - sparse matrix in any format.
5827 
5828 OUTPUT PARAMETERS
5829  S1 - sparse matrix in Hash table format.
5830 
5831 NOTE: if S0 is stored as Hash-table, it is just copied without conversion.
5832 
5833  -- ALGLIB PROJECT --
5834  Copyright 20.07.2012 by Bochkanov Sergey
5835 *************************************************************************/
5837 {
5838  alglib_impl::ae_state _alglib_env_state;
5839  alglib_impl::ae_state_init(&_alglib_env_state);
5840  try
5841  {
5842  alglib_impl::sparsecopytohash(const_cast<alglib_impl::sparsematrix*>(s0.c_ptr()), const_cast<alglib_impl::sparsematrix*>(s1.c_ptr()), &_alglib_env_state);
5843  alglib_impl::ae_state_clear(&_alglib_env_state);
5844  return;
5845  }
5847  {
5848  throw ap_error(_alglib_env_state.error_msg);
5849  }
5850 }
5851 
5852 /*************************************************************************
5853 This function performs out-of-place conversion to CRS format. S0 is
5854 copied to S1 and converted on-the-fly.
5855 
5856 INPUT PARAMETERS
5857  S0 - sparse matrix in any format.
5858 
5859 OUTPUT PARAMETERS
5860  S1 - sparse matrix in CRS format.
5861 
5862 NOTE: if S0 is stored as CRS, it is just copied without conversion.
5863 
5864  -- ALGLIB PROJECT --
5865  Copyright 20.07.2012 by Bochkanov Sergey
5866 *************************************************************************/
5868 {
5869  alglib_impl::ae_state _alglib_env_state;
5870  alglib_impl::ae_state_init(&_alglib_env_state);
5871  try
5872  {
5873  alglib_impl::sparsecopytocrs(const_cast<alglib_impl::sparsematrix*>(s0.c_ptr()), const_cast<alglib_impl::sparsematrix*>(s1.c_ptr()), &_alglib_env_state);
5874  alglib_impl::ae_state_clear(&_alglib_env_state);
5875  return;
5876  }
5878  {
5879  throw ap_error(_alglib_env_state.error_msg);
5880  }
5881 }
5882 
5883 /*************************************************************************
5884 This function returns type of the matrix storage format.
5885 
5886 INPUT PARAMETERS:
5887  S - sparse matrix.
5888 
5889 RESULT:
5890  sparse storage format used by matrix:
5891  0 - Hash-table
5892  1 - CRS-format
5893 
5894 NOTE: future versions of ALGLIB may include additional sparse storage
5895  formats.
5896 
5897 
5898  -- ALGLIB PROJECT --
5899  Copyright 20.07.2012 by Bochkanov Sergey
5900 *************************************************************************/
5902 {
5903  alglib_impl::ae_state _alglib_env_state;
5904  alglib_impl::ae_state_init(&_alglib_env_state);
5905  try
5906  {
5907  alglib_impl::ae_int_t result = alglib_impl::sparsegetmatrixtype(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), &_alglib_env_state);
5908  alglib_impl::ae_state_clear(&_alglib_env_state);
5909  return *(reinterpret_cast<ae_int_t*>(&result));
5910  }
5912  {
5913  throw ap_error(_alglib_env_state.error_msg);
5914  }
5915 }
5916 
5917 /*************************************************************************
5918 This function checks matrix storage format and returns True when matrix is
5919 stored using Hash table representation.
5920 
5921 INPUT PARAMETERS:
5922  S - sparse matrix.
5923 
5924 RESULT:
5925  True if matrix type is Hash table
5926  False if matrix type is not Hash table
5927 
5928  -- ALGLIB PROJECT --
5929  Copyright 20.07.2012 by Bochkanov Sergey
5930 *************************************************************************/
5932 {
5933  alglib_impl::ae_state _alglib_env_state;
5934  alglib_impl::ae_state_init(&_alglib_env_state);
5935  try
5936  {
5937  ae_bool result = alglib_impl::sparseishash(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), &_alglib_env_state);
5938  alglib_impl::ae_state_clear(&_alglib_env_state);
5939  return *(reinterpret_cast<bool*>(&result));
5940  }
5942  {
5943  throw ap_error(_alglib_env_state.error_msg);
5944  }
5945 }
5946 
5947 /*************************************************************************
5948 This function checks matrix storage format and returns True when matrix is
5949 stored using CRS representation.
5950 
5951 INPUT PARAMETERS:
5952  S - sparse matrix.
5953 
5954 RESULT:
5955  True if matrix type is CRS
5956  False if matrix type is not CRS
5957 
5958  -- ALGLIB PROJECT --
5959  Copyright 20.07.2012 by Bochkanov Sergey
5960 *************************************************************************/
5962 {
5963  alglib_impl::ae_state _alglib_env_state;
5964  alglib_impl::ae_state_init(&_alglib_env_state);
5965  try
5966  {
5967  ae_bool result = alglib_impl::sparseiscrs(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), &_alglib_env_state);
5968  alglib_impl::ae_state_clear(&_alglib_env_state);
5969  return *(reinterpret_cast<bool*>(&result));
5970  }
5972  {
5973  throw ap_error(_alglib_env_state.error_msg);
5974  }
5975 }
5976 
5977 /*************************************************************************
5978 The function frees all memory occupied by sparse matrix. Sparse matrix
5979 structure becomes unusable after this call.
5980 
5981 OUTPUT PARAMETERS
5982  S - sparse matrix to delete
5983 
5984  -- ALGLIB PROJECT --
5985  Copyright 24.07.2012 by Bochkanov Sergey
5986 *************************************************************************/
5988 {
5989  alglib_impl::ae_state _alglib_env_state;
5990  alglib_impl::ae_state_init(&_alglib_env_state);
5991  try
5992  {
5993  alglib_impl::sparsefree(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), &_alglib_env_state);
5994  alglib_impl::ae_state_clear(&_alglib_env_state);
5995  return;
5996  }
5998  {
5999  throw ap_error(_alglib_env_state.error_msg);
6000  }
6001 }
6002 
6003 /*************************************************************************
6004 The function returns number of rows of a sparse matrix.
6005 
6006 RESULT: number of rows of a sparse matrix.
6007 
6008  -- ALGLIB PROJECT --
6009  Copyright 23.08.2012 by Bochkanov Sergey
6010 *************************************************************************/
6012 {
6013  alglib_impl::ae_state _alglib_env_state;
6014  alglib_impl::ae_state_init(&_alglib_env_state);
6015  try
6016  {
6017  alglib_impl::ae_int_t result = alglib_impl::sparsegetnrows(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), &_alglib_env_state);
6018  alglib_impl::ae_state_clear(&_alglib_env_state);
6019  return *(reinterpret_cast<ae_int_t*>(&result));
6020  }
6022  {
6023  throw ap_error(_alglib_env_state.error_msg);
6024  }
6025 }
6026 
6027 /*************************************************************************
6028 The function returns number of columns of a sparse matrix.
6029 
6030 RESULT: number of columns of a sparse matrix.
6031 
6032  -- ALGLIB PROJECT --
6033  Copyright 23.08.2012 by Bochkanov Sergey
6034 *************************************************************************/
6036 {
6037  alglib_impl::ae_state _alglib_env_state;
6038  alglib_impl::ae_state_init(&_alglib_env_state);
6039  try
6040  {
6041  alglib_impl::ae_int_t result = alglib_impl::sparsegetncols(const_cast<alglib_impl::sparsematrix*>(s.c_ptr()), &_alglib_env_state);
6042  alglib_impl::ae_state_clear(&_alglib_env_state);
6043  return *(reinterpret_cast<ae_int_t*>(&result));
6044  }
6046  {
6047  throw ap_error(_alglib_env_state.error_msg);
6048  }
6049 }
6050 
6051 
6052 
6053 /*************************************************************************
6054 This object stores state of the iterative norm estimation algorithm.
6055 
6056 You should use ALGLIB functions to work with this object.
6057 *************************************************************************/
6059 {
6061  if( p_struct==NULL )
6062  throw ap_error("ALGLIB: malloc error");
6064  throw ap_error("ALGLIB: malloc error");
6065 }
6066 
6068 {
6070  if( p_struct==NULL )
6071  throw ap_error("ALGLIB: malloc error");
6072  if( !alglib_impl::_normestimatorstate_init_copy(p_struct, const_cast<alglib_impl::normestimatorstate*>(rhs.p_struct), NULL, ae_false) )
6073  throw ap_error("ALGLIB: malloc error");
6074 }
6075 
6077 {
6078  if( this==&rhs )
6079  return *this;
6081  if( !alglib_impl::_normestimatorstate_init_copy(p_struct, const_cast<alglib_impl::normestimatorstate*>(rhs.p_struct), NULL, ae_false) )
6082  throw ap_error("ALGLIB: malloc error");
6083  return *this;
6084 }
6085 
6087 {
6089  ae_free(p_struct);
6090 }
6091 
6093 {
6094  return p_struct;
6095 }
6096 
6098 {
6099  return const_cast<alglib_impl::normestimatorstate*>(p_struct);
6100 }
6102 {
6103 }
6104 
6106 {
6107 }
6108 
6110 {
6111  if( this==&rhs )
6112  return *this;
6114  return *this;
6115 }
6116 
6118 {
6119 }
6120 
6121 /*************************************************************************
6122 This procedure initializes matrix norm estimator.
6123 
6124 USAGE:
6125 1. User initializes algorithm state with NormEstimatorCreate() call
6126 2. User calls NormEstimatorEstimateSparse() (or NormEstimatorIteration())
6127 3. User calls NormEstimatorResults() to get solution.
6128 
6129 INPUT PARAMETERS:
6130  M - number of rows in the matrix being estimated, M>0
6131  N - number of columns in the matrix being estimated, N>0
6132  NStart - number of random starting vectors
6133  recommended value - at least 5.
6134  NIts - number of iterations to do with best starting vector
6135  recommended value - at least 5.
6136 
6137 OUTPUT PARAMETERS:
6138  State - structure which stores algorithm state
6139 
6140 
6141 NOTE: this algorithm is effectively deterministic, i.e. it always returns
6142 same result when repeatedly called for the same matrix. In fact, algorithm
6143 uses randomized starting vectors, but internal random numbers generator
6144 always generates same sequence of the random values (it is a feature, not
6145 bug).
6146 
6147 Algorithm can be made non-deterministic with NormEstimatorSetSeed(0) call.
6148 
6149  -- ALGLIB --
6150  Copyright 06.12.2011 by Bochkanov Sergey
6151 *************************************************************************/
6152 void normestimatorcreate(const ae_int_t m, const ae_int_t n, const ae_int_t nstart, const ae_int_t nits, normestimatorstate &state)
6153 {
6154  alglib_impl::ae_state _alglib_env_state;
6155  alglib_impl::ae_state_init(&_alglib_env_state);
6156  try
6157  {
6158  alglib_impl::normestimatorcreate(m, n, nstart, nits, const_cast<alglib_impl::normestimatorstate*>(state.c_ptr()), &_alglib_env_state);
6159  alglib_impl::ae_state_clear(&_alglib_env_state);
6160  return;
6161  }
6163  {
6164  throw ap_error(_alglib_env_state.error_msg);
6165  }
6166 }
6167 
6168 /*************************************************************************
6169 This function changes seed value used by algorithm. In some cases we need
6170 deterministic processing, i.e. subsequent calls must return equal results,
6171 in other cases we need non-deterministic algorithm which returns different
6172 results for the same matrix on every pass.
6173 
6174 Setting zero seed will lead to non-deterministic algorithm, while non-zero
6175 value will make our algorithm deterministic.
6176 
6177 INPUT PARAMETERS:
6178  State - norm estimator state, must be initialized with a call
6179  to NormEstimatorCreate()
6180  SeedVal - seed value, >=0. Zero value = non-deterministic algo.
6181 
6182  -- ALGLIB --
6183  Copyright 06.12.2011 by Bochkanov Sergey
6184 *************************************************************************/
6185 void normestimatorsetseed(const normestimatorstate &state, const ae_int_t seedval)
6186 {
6187  alglib_impl::ae_state _alglib_env_state;
6188  alglib_impl::ae_state_init(&_alglib_env_state);
6189  try
6190  {
6191  alglib_impl::normestimatorsetseed(const_cast<alglib_impl::normestimatorstate*>(state.c_ptr()), seedval, &_alglib_env_state);
6192  alglib_impl::ae_state_clear(&_alglib_env_state);
6193  return;
6194  }
6196  {
6197  throw ap_error(_alglib_env_state.error_msg);
6198  }
6199 }
6200 
6201 /*************************************************************************
6202 This function estimates norm of the sparse M*N matrix A.
6203 
6204 INPUT PARAMETERS:
6205  State - norm estimator state, must be initialized with a call
6206  to NormEstimatorCreate()
6207  A - sparse M*N matrix, must be converted to CRS format
6208  prior to calling this function.
6209 
6210 After this function is over you can call NormEstimatorResults() to get
6211 estimate of the norm(A).
6212 
6213  -- ALGLIB --
6214  Copyright 06.12.2011 by Bochkanov Sergey
6215 *************************************************************************/
6217 {
6218  alglib_impl::ae_state _alglib_env_state;
6219  alglib_impl::ae_state_init(&_alglib_env_state);
6220  try
6221  {
6222  alglib_impl::normestimatorestimatesparse(const_cast<alglib_impl::normestimatorstate*>(state.c_ptr()), const_cast<alglib_impl::sparsematrix*>(a.c_ptr()), &_alglib_env_state);
6223  alglib_impl::ae_state_clear(&_alglib_env_state);
6224  return;
6225  }
6227  {
6228  throw ap_error(_alglib_env_state.error_msg);
6229  }
6230 }
6231 
6232 /*************************************************************************
6233 Matrix norm estimation results
6234 
6235 INPUT PARAMETERS:
6236  State - algorithm state
6237 
6238 OUTPUT PARAMETERS:
6239  Nrm - estimate of the matrix norm, Nrm>=0
6240 
6241  -- ALGLIB --
6242  Copyright 06.12.2011 by Bochkanov Sergey
6243 *************************************************************************/
6244 void normestimatorresults(const normestimatorstate &state, double &nrm)
6245 {
6246  alglib_impl::ae_state _alglib_env_state;
6247  alglib_impl::ae_state_init(&_alglib_env_state);
6248  try
6249  {
6250  alglib_impl::normestimatorresults(const_cast<alglib_impl::normestimatorstate*>(state.c_ptr()), &nrm, &_alglib_env_state);
6251  alglib_impl::ae_state_clear(&_alglib_env_state);
6252  return;
6253  }
6255  {
6256  throw ap_error(_alglib_env_state.error_msg);
6257  }
6258 }
6259 
6260 /*************************************************************************
6261 Determinant calculation of the matrix given by its LU decomposition.
6262 
6263 Input parameters:
6264  A - LU decomposition of the matrix (output of
6265  RMatrixLU subroutine).
6266  Pivots - table of permutations which were made during
6267  the LU decomposition.
6268  Output of RMatrixLU subroutine.
6269  N - (optional) size of matrix A:
6270  * if given, only principal NxN submatrix is processed and
6271  overwritten. other elements are unchanged.
6272  * if not given, automatically determined from matrix size
6273  (A must be square matrix)
6274 
6275 Result: matrix determinant.
6276 
6277  -- ALGLIB --
6278  Copyright 2005 by Bochkanov Sergey
6279 *************************************************************************/
6280 double rmatrixludet(const real_2d_array &a, const integer_1d_array &pivots, const ae_int_t n)
6281 {
6282  alglib_impl::ae_state _alglib_env_state;
6283  alglib_impl::ae_state_init(&_alglib_env_state);
6284  try
6285  {
6286  double result = alglib_impl::rmatrixludet(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), const_cast<alglib_impl::ae_vector*>(pivots.c_ptr()), n, &_alglib_env_state);
6287  alglib_impl::ae_state_clear(&_alglib_env_state);
6288  return *(reinterpret_cast<double*>(&result));
6289  }
6291  {
6292  throw ap_error(_alglib_env_state.error_msg);
6293  }
6294 }
6295 
6296 /*************************************************************************
6297 Determinant calculation of the matrix given by its LU decomposition.
6298 
6299 Input parameters:
6300  A - LU decomposition of the matrix (output of
6301  RMatrixLU subroutine).
6302  Pivots - table of permutations which were made during
6303  the LU decomposition.
6304  Output of RMatrixLU subroutine.
6305  N - (optional) size of matrix A:
6306  * if given, only principal NxN submatrix is processed and
6307  overwritten. other elements are unchanged.
6308  * if not given, automatically determined from matrix size
6309  (A must be square matrix)
6310 
6311 Result: matrix determinant.
6312 
6313  -- ALGLIB --
6314  Copyright 2005 by Bochkanov Sergey
6315 *************************************************************************/
6316 double rmatrixludet(const real_2d_array &a, const integer_1d_array &pivots)
6317 {
6318  alglib_impl::ae_state _alglib_env_state;
6319  ae_int_t n;
6320  if( (a.rows()!=a.cols()) || (a.rows()!=pivots.length()))
6321  throw ap_error("Error while calling 'rmatrixludet': looks like one of arguments has wrong size");
6322  n = a.rows();
6323  alglib_impl::ae_state_init(&_alglib_env_state);
6324  try
6325  {
6326  double result = alglib_impl::rmatrixludet(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), const_cast<alglib_impl::ae_vector*>(pivots.c_ptr()), n, &_alglib_env_state);
6327 
6328  alglib_impl::ae_state_clear(&_alglib_env_state);
6329  return *(reinterpret_cast<double*>(&result));
6330  }
6332  {
6333  throw ap_error(_alglib_env_state.error_msg);
6334  }
6335 }
6336 
6337 /*************************************************************************
6338 Calculation of the determinant of a general matrix
6339 
6340 Input parameters:
6341  A - matrix, array[0..N-1, 0..N-1]
6342  N - (optional) size of matrix A:
6343  * if given, only principal NxN submatrix is processed and
6344  overwritten. other elements are unchanged.
6345  * if not given, automatically determined from matrix size
6346  (A must be square matrix)
6347 
6348 Result: determinant of matrix A.
6349 
6350  -- ALGLIB --
6351  Copyright 2005 by Bochkanov Sergey
6352 *************************************************************************/
6353 double rmatrixdet(const real_2d_array &a, const ae_int_t n)
6354 {
6355  alglib_impl::ae_state _alglib_env_state;
6356  alglib_impl::ae_state_init(&_alglib_env_state);
6357  try
6358  {
6359  double result = alglib_impl::rmatrixdet(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, &_alglib_env_state);
6360  alglib_impl::ae_state_clear(&_alglib_env_state);
6361  return *(reinterpret_cast<double*>(&result));
6362  }
6364  {
6365  throw ap_error(_alglib_env_state.error_msg);
6366  }
6367 }
6368 
6369 /*************************************************************************
6370 Calculation of the determinant of a general matrix
6371 
6372 Input parameters:
6373  A - matrix, array[0..N-1, 0..N-1]
6374  N - (optional) size of matrix A:
6375  * if given, only principal NxN submatrix is processed and
6376  overwritten. other elements are unchanged.
6377  * if not given, automatically determined from matrix size
6378  (A must be square matrix)
6379 
6380 Result: determinant of matrix A.
6381 
6382  -- ALGLIB --
6383  Copyright 2005 by Bochkanov Sergey
6384 *************************************************************************/
6386 {
6387  alglib_impl::ae_state _alglib_env_state;
6388  ae_int_t n;
6389  if( (a.rows()!=a.cols()))
6390  throw ap_error("Error while calling 'rmatrixdet': looks like one of arguments has wrong size");
6391  n = a.rows();
6392  alglib_impl::ae_state_init(&_alglib_env_state);
6393  try
6394  {
6395  double result = alglib_impl::rmatrixdet(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, &_alglib_env_state);
6396 
6397  alglib_impl::ae_state_clear(&_alglib_env_state);
6398  return *(reinterpret_cast<double*>(&result));
6399  }
6401  {
6402  throw ap_error(_alglib_env_state.error_msg);
6403  }
6404 }
6405 
6406 /*************************************************************************
6407 Determinant calculation of the matrix given by its LU decomposition.
6408 
6409 Input parameters:
6410  A - LU decomposition of the matrix (output of
6411  RMatrixLU subroutine).
6412  Pivots - table of permutations which were made during
6413  the LU decomposition.
6414  Output of RMatrixLU subroutine.
6415  N - (optional) size of matrix A:
6416  * if given, only principal NxN submatrix is processed and
6417  overwritten. other elements are unchanged.
6418  * if not given, automatically determined from matrix size
6419  (A must be square matrix)
6420 
6421 Result: matrix determinant.
6422 
6423  -- ALGLIB --
6424  Copyright 2005 by Bochkanov Sergey
6425 *************************************************************************/
6427 {
6428  alglib_impl::ae_state _alglib_env_state;
6429  alglib_impl::ae_state_init(&_alglib_env_state);
6430  try
6431  {
6432  alglib_impl::ae_complex result = alglib_impl::cmatrixludet(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), const_cast<alglib_impl::ae_vector*>(pivots.c_ptr()), n, &_alglib_env_state);
6433  alglib_impl::ae_state_clear(&_alglib_env_state);
6434  return *(reinterpret_cast<alglib::complex*>(&result));
6435  }
6437  {
6438  throw ap_error(_alglib_env_state.error_msg);
6439  }
6440 }
6441 
6442 /*************************************************************************
6443 Determinant calculation of the matrix given by its LU decomposition.
6444 
6445 Input parameters:
6446  A - LU decomposition of the matrix (output of
6447  RMatrixLU subroutine).
6448  Pivots - table of permutations which were made during
6449  the LU decomposition.
6450  Output of RMatrixLU subroutine.
6451  N - (optional) size of matrix A:
6452  * if given, only principal NxN submatrix is processed and
6453  overwritten. other elements are unchanged.
6454  * if not given, automatically determined from matrix size
6455  (A must be square matrix)
6456 
6457 Result: matrix determinant.
6458 
6459  -- ALGLIB --
6460  Copyright 2005 by Bochkanov Sergey
6461 *************************************************************************/
6463 {
6464  alglib_impl::ae_state _alglib_env_state;
6465  ae_int_t n;
6466  if( (a.rows()!=a.cols()) || (a.rows()!=pivots.length()))
6467  throw ap_error("Error while calling 'cmatrixludet': looks like one of arguments has wrong size");
6468  n = a.rows();
6469  alglib_impl::ae_state_init(&_alglib_env_state);
6470  try
6471  {
6472  alglib_impl::ae_complex result = alglib_impl::cmatrixludet(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), const_cast<alglib_impl::ae_vector*>(pivots.c_ptr()), n, &_alglib_env_state);
6473 
6474  alglib_impl::ae_state_clear(&_alglib_env_state);
6475  return *(reinterpret_cast<alglib::complex*>(&result));
6476  }
6478  {
6479  throw ap_error(_alglib_env_state.error_msg);
6480  }
6481 }
6482 
6483 /*************************************************************************
6484 Calculation of the determinant of a general matrix
6485 
6486 Input parameters:
6487  A - matrix, array[0..N-1, 0..N-1]
6488  N - (optional) size of matrix A:
6489  * if given, only principal NxN submatrix is processed and
6490  overwritten. other elements are unchanged.
6491  * if not given, automatically determined from matrix size
6492  (A must be square matrix)
6493 
6494 Result: determinant of matrix A.
6495 
6496  -- ALGLIB --
6497  Copyright 2005 by Bochkanov Sergey
6498 *************************************************************************/
6500 {
6501  alglib_impl::ae_state _alglib_env_state;
6502  alglib_impl::ae_state_init(&_alglib_env_state);
6503  try
6504  {
6505  alglib_impl::ae_complex result = alglib_impl::cmatrixdet(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, &_alglib_env_state);
6506  alglib_impl::ae_state_clear(&_alglib_env_state);
6507  return *(reinterpret_cast<alglib::complex*>(&result));
6508  }
6510  {
6511  throw ap_error(_alglib_env_state.error_msg);
6512  }
6513 }
6514 
6515 /*************************************************************************
6516 Calculation of the determinant of a general matrix
6517 
6518 Input parameters:
6519  A - matrix, array[0..N-1, 0..N-1]
6520  N - (optional) size of matrix A:
6521  * if given, only principal NxN submatrix is processed and
6522  overwritten. other elements are unchanged.
6523  * if not given, automatically determined from matrix size
6524  (A must be square matrix)
6525 
6526 Result: determinant of matrix A.
6527 
6528  -- ALGLIB --
6529  Copyright 2005 by Bochkanov Sergey
6530 *************************************************************************/
6532 {
6533  alglib_impl::ae_state _alglib_env_state;
6534  ae_int_t n;
6535  if( (a.rows()!=a.cols()))
6536  throw ap_error("Error while calling 'cmatrixdet': looks like one of arguments has wrong size");
6537  n = a.rows();
6538  alglib_impl::ae_state_init(&_alglib_env_state);
6539  try
6540  {
6541  alglib_impl::ae_complex result = alglib_impl::cmatrixdet(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, &_alglib_env_state);
6542 
6543  alglib_impl::ae_state_clear(&_alglib_env_state);
6544  return *(reinterpret_cast<alglib::complex*>(&result));
6545  }
6547  {
6548  throw ap_error(_alglib_env_state.error_msg);
6549  }
6550 }
6551 
6552 /*************************************************************************
6553 Determinant calculation of the matrix given by the Cholesky decomposition.
6554 
6555 Input parameters:
6556  A - Cholesky decomposition,
6557  output of SMatrixCholesky subroutine.
6558  N - (optional) size of matrix A:
6559  * if given, only principal NxN submatrix is processed and
6560  overwritten. other elements are unchanged.
6561  * if not given, automatically determined from matrix size
6562  (A must be square matrix)
6563 
6564 As the determinant is equal to the product of squares of diagonal elements,
6565 it’s not necessary to specify which triangle - lower or upper - the matrix
6566 is stored in.
6567 
6568 Result:
6569  matrix determinant.
6570 
6571  -- ALGLIB --
6572  Copyright 2005-2008 by Bochkanov Sergey
6573 *************************************************************************/
6575 {
6576  alglib_impl::ae_state _alglib_env_state;
6577  alglib_impl::ae_state_init(&_alglib_env_state);
6578  try
6579  {
6580  double result = alglib_impl::spdmatrixcholeskydet(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, &_alglib_env_state);
6581  alglib_impl::ae_state_clear(&_alglib_env_state);
6582  return *(reinterpret_cast<double*>(&result));
6583  }
6585  {
6586  throw ap_error(_alglib_env_state.error_msg);
6587  }
6588 }
6589 
6590 /*************************************************************************
6591 Determinant calculation of the matrix given by the Cholesky decomposition.
6592 
6593 Input parameters:
6594  A - Cholesky decomposition,
6595  output of SMatrixCholesky subroutine.
6596  N - (optional) size of matrix A:
6597  * if given, only principal NxN submatrix is processed and
6598  overwritten. other elements are unchanged.
6599  * if not given, automatically determined from matrix size
6600  (A must be square matrix)
6601 
6602 As the determinant is equal to the product of squares of diagonal elements,
6603 it’s not necessary to specify which triangle - lower or upper - the matrix
6604 is stored in.
6605 
6606 Result:
6607  matrix determinant.
6608 
6609  -- ALGLIB --
6610  Copyright 2005-2008 by Bochkanov Sergey
6611 *************************************************************************/
6613 {
6614  alglib_impl::ae_state _alglib_env_state;
6615  ae_int_t n;
6616  if( (a.rows()!=a.cols()))
6617  throw ap_error("Error while calling 'spdmatrixcholeskydet': looks like one of arguments has wrong size");
6618  n = a.rows();
6619  alglib_impl::ae_state_init(&_alglib_env_state);
6620  try
6621  {
6622  double result = alglib_impl::spdmatrixcholeskydet(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, &_alglib_env_state);
6623 
6624  alglib_impl::ae_state_clear(&_alglib_env_state);
6625  return *(reinterpret_cast<double*>(&result));
6626  }
6628  {
6629  throw ap_error(_alglib_env_state.error_msg);
6630  }
6631 }
6632 
6633 /*************************************************************************
6634 Determinant calculation of the symmetric positive definite matrix.
6635 
6636 Input parameters:
6637  A - matrix. Array with elements [0..N-1, 0..N-1].
6638  N - (optional) size of matrix A:
6639  * if given, only principal NxN submatrix is processed and
6640  overwritten. other elements are unchanged.
6641  * if not given, automatically determined from matrix size
6642  (A must be square matrix)
6643  IsUpper - (optional) storage type:
6644  * if True, symmetric matrix A is given by its upper
6645  triangle, and the lower triangle isn’t used/changed by
6646  function
6647  * if False, symmetric matrix A is given by its lower
6648  triangle, and the upper triangle isn’t used/changed by
6649  function
6650  * if not given, both lower and upper triangles must be
6651  filled.
6652 
6653 Result:
6654  determinant of matrix A.
6655  If matrix A is not positive definite, exception is thrown.
6656 
6657  -- ALGLIB --
6658  Copyright 2005-2008 by Bochkanov Sergey
6659 *************************************************************************/
6660 double spdmatrixdet(const real_2d_array &a, const ae_int_t n, const bool isupper)
6661 {
6662  alglib_impl::ae_state _alglib_env_state;
6663  alglib_impl::ae_state_init(&_alglib_env_state);
6664  try
6665  {
6666  double result = alglib_impl::spdmatrixdet(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, &_alglib_env_state);
6667  alglib_impl::ae_state_clear(&_alglib_env_state);
6668  return *(reinterpret_cast<double*>(&result));
6669  }
6671  {
6672  throw ap_error(_alglib_env_state.error_msg);
6673  }
6674 }
6675 
6676 /*************************************************************************
6677 Determinant calculation of the symmetric positive definite matrix.
6678 
6679 Input parameters:
6680  A - matrix. Array with elements [0..N-1, 0..N-1].
6681  N - (optional) size of matrix A:
6682  * if given, only principal NxN submatrix is processed and
6683  overwritten. other elements are unchanged.
6684  * if not given, automatically determined from matrix size
6685  (A must be square matrix)
6686  IsUpper - (optional) storage type:
6687  * if True, symmetric matrix A is given by its upper
6688  triangle, and the lower triangle isn’t used/changed by
6689  function
6690  * if False, symmetric matrix A is given by its lower
6691  triangle, and the upper triangle isn’t used/changed by
6692  function
6693  * if not given, both lower and upper triangles must be
6694  filled.
6695 
6696 Result:
6697  determinant of matrix A.
6698  If matrix A is not positive definite, exception is thrown.
6699 
6700  -- ALGLIB --
6701  Copyright 2005-2008 by Bochkanov Sergey
6702 *************************************************************************/
6704 {
6705  alglib_impl::ae_state _alglib_env_state;
6706  ae_int_t n;
6707  bool isupper;
6708  if( (a.rows()!=a.cols()))
6709  throw ap_error("Error while calling 'spdmatrixdet': looks like one of arguments has wrong size");
6710  if( !alglib_impl::ae_is_symmetric(const_cast<alglib_impl::ae_matrix*>(a.c_ptr())) )
6711  throw ap_error("'a' parameter is not symmetric matrix");
6712  n = a.rows();
6713  isupper = false;
6714  alglib_impl::ae_state_init(&_alglib_env_state);
6715  try
6716  {
6717  double result = alglib_impl::spdmatrixdet(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isupper, &_alglib_env_state);
6718 
6719  alglib_impl::ae_state_clear(&_alglib_env_state);
6720  return *(reinterpret_cast<double*>(&result));
6721  }
6723  {
6724  throw ap_error(_alglib_env_state.error_msg);
6725  }
6726 }
6727 
6728 /*************************************************************************
6729 Algorithm for solving the following generalized symmetric positive-definite
6730 eigenproblem:
6731  A*x = lambda*B*x (1) or
6732  A*B*x = lambda*x (2) or
6733  B*A*x = lambda*x (3).
6734 where A is a symmetric matrix, B - symmetric positive-definite matrix.
6735 The problem is solved by reducing it to an ordinary symmetric eigenvalue
6736 problem.
6737 
6738 Input parameters:
6739  A - symmetric matrix which is given by its upper or lower
6740  triangular part.
6741  Array whose indexes range within [0..N-1, 0..N-1].
6742  N - size of matrices A and B.
6743  IsUpperA - storage format of matrix A.
6744  B - symmetric positive-definite matrix which is given by
6745  its upper or lower triangular part.
6746  Array whose indexes range within [0..N-1, 0..N-1].
6747  IsUpperB - storage format of matrix B.
6748  ZNeeded - if ZNeeded is equal to:
6749  * 0, the eigenvectors are not returned;
6750  * 1, the eigenvectors are returned.
6751  ProblemType - if ProblemType is equal to:
6752  * 1, the following problem is solved: A*x = lambda*B*x;
6753  * 2, the following problem is solved: A*B*x = lambda*x;
6754  * 3, the following problem is solved: B*A*x = lambda*x.
6755 
6756 Output parameters:
6757  D - eigenvalues in ascending order.
6758  Array whose index ranges within [0..N-1].
6759  Z - if ZNeeded is equal to:
6760  * 0, Z hasn’t changed;
6761  * 1, Z contains eigenvectors.
6762  Array whose indexes range within [0..N-1, 0..N-1].
6763  The eigenvectors are stored in matrix columns. It should
6764  be noted that the eigenvectors in such problems do not
6765  form an orthogonal system.
6766 
6767 Result:
6768  True, if the problem was solved successfully.
6769  False, if the error occurred during the Cholesky decomposition of matrix
6770  B (the matrix isn’t positive-definite) or during the work of the iterative
6771  algorithm for solving the symmetric eigenproblem.
6772 
6773 See also the GeneralizedSymmetricDefiniteEVDReduce subroutine.
6774 
6775  -- ALGLIB --
6776  Copyright 1.28.2006 by Bochkanov Sergey
6777 *************************************************************************/
6778 bool smatrixgevd(const real_2d_array &a, const ae_int_t n, const bool isuppera, const real_2d_array &b, const bool isupperb, const ae_int_t zneeded, const ae_int_t problemtype, real_1d_array &d, real_2d_array &z)
6779 {
6780  alglib_impl::ae_state _alglib_env_state;
6781  alglib_impl::ae_state_init(&_alglib_env_state);
6782  try
6783  {
6784  ae_bool result = alglib_impl::smatrixgevd(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isuppera, const_cast<alglib_impl::ae_matrix*>(b.c_ptr()), isupperb, zneeded, problemtype, const_cast<alglib_impl::ae_vector*>(d.c_ptr()), const_cast<alglib_impl::ae_matrix*>(z.c_ptr()), &_alglib_env_state);
6785  alglib_impl::ae_state_clear(&_alglib_env_state);
6786  return *(reinterpret_cast<bool*>(&result));
6787  }
6789  {
6790  throw ap_error(_alglib_env_state.error_msg);
6791  }
6792 }
6793 
6794 /*************************************************************************
6795 Algorithm for reduction of the following generalized symmetric positive-
6796 definite eigenvalue problem:
6797  A*x = lambda*B*x (1) or
6798  A*B*x = lambda*x (2) or
6799  B*A*x = lambda*x (3)
6800 to the symmetric eigenvalues problem C*y = lambda*y (eigenvalues of this and
6801 the given problems are the same, and the eigenvectors of the given problem
6802 could be obtained by multiplying the obtained eigenvectors by the
6803 transformation matrix x = R*y).
6804 
6805 Here A is a symmetric matrix, B - symmetric positive-definite matrix.
6806 
6807 Input parameters:
6808  A - symmetric matrix which is given by its upper or lower
6809  triangular part.
6810  Array whose indexes range within [0..N-1, 0..N-1].
6811  N - size of matrices A and B.
6812  IsUpperA - storage format of matrix A.
6813  B - symmetric positive-definite matrix which is given by
6814  its upper or lower triangular part.
6815  Array whose indexes range within [0..N-1, 0..N-1].
6816  IsUpperB - storage format of matrix B.
6817  ProblemType - if ProblemType is equal to:
6818  * 1, the following problem is solved: A*x = lambda*B*x;
6819  * 2, the following problem is solved: A*B*x = lambda*x;
6820  * 3, the following problem is solved: B*A*x = lambda*x.
6821 
6822 Output parameters:
6823  A - symmetric matrix which is given by its upper or lower
6824  triangle depending on IsUpperA. Contains matrix C.
6825  Array whose indexes range within [0..N-1, 0..N-1].
6826  R - upper triangular or low triangular transformation matrix
6827  which is used to obtain the eigenvectors of a given problem
6828  as the product of eigenvectors of C (from the right) and
6829  matrix R (from the left). If the matrix is upper
6830  triangular, the elements below the main diagonal
6831  are equal to 0 (and vice versa). Thus, we can perform
6832  the multiplication without taking into account the
6833  internal structure (which is an easier though less
6834  effective way).
6835  Array whose indexes range within [0..N-1, 0..N-1].
6836  IsUpperR - type of matrix R (upper or lower triangular).
6837 
6838 Result:
6839  True, if the problem was reduced successfully.
6840  False, if the error occurred during the Cholesky decomposition of
6841  matrix B (the matrix is not positive-definite).
6842 
6843  -- ALGLIB --
6844  Copyright 1.28.2006 by Bochkanov Sergey
6845 *************************************************************************/
6846 bool smatrixgevdreduce(real_2d_array &a, const ae_int_t n, const bool isuppera, const real_2d_array &b, const bool isupperb, const ae_int_t problemtype, real_2d_array &r, bool &isupperr)
6847 {
6848  alglib_impl::ae_state _alglib_env_state;
6849  alglib_impl::ae_state_init(&_alglib_env_state);
6850  try
6851  {
6852  ae_bool result = alglib_impl::smatrixgevdreduce(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, isuppera, const_cast<alglib_impl::ae_matrix*>(b.c_ptr()), isupperb, problemtype, const_cast<alglib_impl::ae_matrix*>(r.c_ptr()), &isupperr, &_alglib_env_state);
6853  alglib_impl::ae_state_clear(&_alglib_env_state);
6854  return *(reinterpret_cast<bool*>(&result));
6855  }
6857  {
6858  throw ap_error(_alglib_env_state.error_msg);
6859  }
6860 }
6861 
6862 /*************************************************************************
6863 Inverse matrix update by the Sherman-Morrison formula
6864 
6865 The algorithm updates matrix A^-1 when adding a number to an element
6866 of matrix A.
6867 
6868 Input parameters:
6869  InvA - inverse of matrix A.
6870  Array whose indexes range within [0..N-1, 0..N-1].
6871  N - size of matrix A.
6872  UpdRow - row where the element to be updated is stored.
6873  UpdColumn - column where the element to be updated is stored.
6874  UpdVal - a number to be added to the element.
6875 
6876 
6877 Output parameters:
6878  InvA - inverse of modified matrix A.
6879 
6880  -- ALGLIB --
6881  Copyright 2005 by Bochkanov Sergey
6882 *************************************************************************/
6883 void rmatrixinvupdatesimple(real_2d_array &inva, const ae_int_t n, const ae_int_t updrow, const ae_int_t updcolumn, const double updval)
6884 {
6885  alglib_impl::ae_state _alglib_env_state;
6886  alglib_impl::ae_state_init(&_alglib_env_state);
6887  try
6888  {
6889  alglib_impl::rmatrixinvupdatesimple(const_cast<alglib_impl::ae_matrix*>(inva.c_ptr()), n, updrow, updcolumn, updval, &_alglib_env_state);
6890  alglib_impl::ae_state_clear(&_alglib_env_state);
6891  return;
6892  }
6894  {
6895  throw ap_error(_alglib_env_state.error_msg);
6896  }
6897 }
6898 
6899 /*************************************************************************
6900 Inverse matrix update by the Sherman-Morrison formula
6901 
6902 The algorithm updates matrix A^-1 when adding a vector to a row
6903 of matrix A.
6904 
6905 Input parameters:
6906  InvA - inverse of matrix A.
6907  Array whose indexes range within [0..N-1, 0..N-1].
6908  N - size of matrix A.
6909  UpdRow - the row of A whose vector V was added.
6910  0 <= Row <= N-1
6911  V - the vector to be added to a row.
6912  Array whose index ranges within [0..N-1].
6913 
6914 Output parameters:
6915  InvA - inverse of modified matrix A.
6916 
6917  -- ALGLIB --
6918  Copyright 2005 by Bochkanov Sergey
6919 *************************************************************************/
6920 void rmatrixinvupdaterow(real_2d_array &inva, const ae_int_t n, const ae_int_t updrow, const real_1d_array &v)
6921 {
6922  alglib_impl::ae_state _alglib_env_state;
6923  alglib_impl::ae_state_init(&_alglib_env_state);
6924  try
6925  {
6926  alglib_impl::rmatrixinvupdaterow(const_cast<alglib_impl::ae_matrix*>(inva.c_ptr()), n, updrow, const_cast<alglib_impl::ae_vector*>(v.c_ptr()), &_alglib_env_state);
6927  alglib_impl::ae_state_clear(&_alglib_env_state);
6928  return;
6929  }
6931  {
6932  throw ap_error(_alglib_env_state.error_msg);
6933  }
6934 }
6935 
6936 /*************************************************************************
6937 Inverse matrix update by the Sherman-Morrison formula
6938 
6939 The algorithm updates matrix A^-1 when adding a vector to a column
6940 of matrix A.
6941 
6942 Input parameters:
6943  InvA - inverse of matrix A.
6944  Array whose indexes range within [0..N-1, 0..N-1].
6945  N - size of matrix A.
6946  UpdColumn - the column of A whose vector U was added.
6947  0 <= UpdColumn <= N-1
6948  U - the vector to be added to a column.
6949  Array whose index ranges within [0..N-1].
6950 
6951 Output parameters:
6952  InvA - inverse of modified matrix A.
6953 
6954  -- ALGLIB --
6955  Copyright 2005 by Bochkanov Sergey
6956 *************************************************************************/
6957 void rmatrixinvupdatecolumn(real_2d_array &inva, const ae_int_t n, const ae_int_t updcolumn, const real_1d_array &u)
6958 {
6959  alglib_impl::ae_state _alglib_env_state;
6960  alglib_impl::ae_state_init(&_alglib_env_state);
6961  try
6962  {
6963  alglib_impl::rmatrixinvupdatecolumn(const_cast<alglib_impl::ae_matrix*>(inva.c_ptr()), n, updcolumn, const_cast<alglib_impl::ae_vector*>(u.c_ptr()), &_alglib_env_state);
6964  alglib_impl::ae_state_clear(&_alglib_env_state);
6965  return;
6966  }
6968  {
6969  throw ap_error(_alglib_env_state.error_msg);
6970  }
6971 }
6972 
6973 /*************************************************************************
6974 Inverse matrix update by the Sherman-Morrison formula
6975 
6976 The algorithm computes the inverse of matrix A+u*v’ by using the given matrix
6977 A^-1 and the vectors u and v.
6978 
6979 Input parameters:
6980  InvA - inverse of matrix A.
6981  Array whose indexes range within [0..N-1, 0..N-1].
6982  N - size of matrix A.
6983  U - the vector modifying the matrix.
6984  Array whose index ranges within [0..N-1].
6985  V - the vector modifying the matrix.
6986  Array whose index ranges within [0..N-1].
6987 
6988 Output parameters:
6989  InvA - inverse of matrix A + u*v'.
6990 
6991  -- ALGLIB --
6992  Copyright 2005 by Bochkanov Sergey
6993 *************************************************************************/
6995 {
6996  alglib_impl::ae_state _alglib_env_state;
6997  alglib_impl::ae_state_init(&_alglib_env_state);
6998  try
6999  {
7000  alglib_impl::rmatrixinvupdateuv(const_cast<alglib_impl::ae_matrix*>(inva.c_ptr()), n, const_cast<alglib_impl::ae_vector*>(u.c_ptr()), const_cast<alglib_impl::ae_vector*>(v.c_ptr()), &_alglib_env_state);
7001  alglib_impl::ae_state_clear(&_alglib_env_state);
7002  return;
7003  }
7005  {
7006  throw ap_error(_alglib_env_state.error_msg);
7007  }
7008 }
7009 
7010 /*************************************************************************
7011 Subroutine performing the Schur decomposition of a general matrix by using
7012 the QR algorithm with multiple shifts.
7013 
7014 The source matrix A is represented as S'*A*S = T, where S is an orthogonal
7015 matrix (Schur vectors), T - upper quasi-triangular matrix (with blocks of
7016 sizes 1x1 and 2x2 on the main diagonal).
7017 
7018 Input parameters:
7019  A - matrix to be decomposed.
7020  Array whose indexes range within [0..N-1, 0..N-1].
7021  N - size of A, N>=0.
7022 
7023 
7024 Output parameters:
7025  A - contains matrix T.
7026  Array whose indexes range within [0..N-1, 0..N-1].
7027  S - contains Schur vectors.
7028  Array whose indexes range within [0..N-1, 0..N-1].
7029 
7030 Note 1:
7031  The block structure of matrix T can be easily recognized: since all
7032  the elements below the blocks are zeros, the elements a[i+1,i] which
7033  are equal to 0 show the block border.
7034 
7035 Note 2:
7036  The algorithm performance depends on the value of the internal parameter
7037  NS of the InternalSchurDecomposition subroutine which defines the number
7038  of shifts in the QR algorithm (similarly to the block width in block-matrix
7039  algorithms in linear algebra). If you require maximum performance on
7040  your machine, it is recommended to adjust this parameter manually.
7041 
7042 Result:
7043  True,
7044  if the algorithm has converged and parameters A and S contain the result.
7045  False,
7046  if the algorithm has not converged.
7047 
7048 Algorithm implemented on the basis of the DHSEQR subroutine (LAPACK 3.0 library).
7049 *************************************************************************/
7051 {
7052  alglib_impl::ae_state _alglib_env_state;
7053  alglib_impl::ae_state_init(&_alglib_env_state);
7054  try
7055  {
7056  ae_bool result = alglib_impl::rmatrixschur(const_cast<alglib_impl::ae_matrix*>(a.c_ptr()), n, const_cast<alglib_impl::ae_matrix*>(s.c_ptr()), &_alglib_env_state);
7057  alglib_impl::ae_state_clear(&_alglib_env_state);
7058  return *(reinterpret_cast<bool*>(&result));
7059  }
7061  {
7062  throw ap_error(_alglib_env_state.error_msg);
7063  }
7064 }
7065 }
7066 
7068 //
7069 // THIS SECTION CONTAINS IMPLEMENTATION OF COMPUTATIONAL CORE
7070 //
7072 namespace alglib_impl
7073 {
7074 static ae_int_t ablas_rgemmparallelsize = 64;
7075 static ae_int_t ablas_cgemmparallelsize = 64;
7076 static void ablas_ablasinternalsplitlength(ae_int_t n,
7077  ae_int_t nb,
7078  ae_int_t* n1,
7079  ae_int_t* n2,
7080  ae_state *_state);
7081 static void ablas_cmatrixrighttrsm2(ae_int_t m,
7082  ae_int_t n,
7083  /* Complex */ ae_matrix* a,
7084  ae_int_t i1,
7085  ae_int_t j1,
7086  ae_bool isupper,
7087  ae_bool isunit,
7088  ae_int_t optype,
7089  /* Complex */ ae_matrix* x,
7090  ae_int_t i2,
7091  ae_int_t j2,
7092  ae_state *_state);
7093 static void ablas_cmatrixlefttrsm2(ae_int_t m,
7094  ae_int_t n,
7095  /* Complex */ ae_matrix* a,
7096  ae_int_t i1,
7097  ae_int_t j1,
7098  ae_bool isupper,
7099  ae_bool isunit,
7100  ae_int_t optype,
7101  /* Complex */ ae_matrix* x,
7102  ae_int_t i2,
7103  ae_int_t j2,
7104  ae_state *_state);
7105 static void ablas_rmatrixrighttrsm2(ae_int_t m,
7106  ae_int_t n,
7107  /* Real */ ae_matrix* a,
7108  ae_int_t i1,
7109  ae_int_t j1,
7110  ae_bool isupper,
7111  ae_bool isunit,
7112  ae_int_t optype,
7113  /* Real */ ae_matrix* x,
7114  ae_int_t i2,
7115  ae_int_t j2,
7116  ae_state *_state);
7117 static void ablas_rmatrixlefttrsm2(ae_int_t m,
7118  ae_int_t n,
7119  /* Real */ ae_matrix* a,
7120  ae_int_t i1,
7121  ae_int_t j1,
7122  ae_bool isupper,
7123  ae_bool isunit,
7124  ae_int_t optype,
7125  /* Real */ ae_matrix* x,
7126  ae_int_t i2,
7127  ae_int_t j2,
7128  ae_state *_state);
7129 static void ablas_cmatrixsyrk2(ae_int_t n,
7130  ae_int_t k,
7131  double alpha,
7132  /* Complex */ ae_matrix* a,
7133  ae_int_t ia,
7134  ae_int_t ja,
7135  ae_int_t optypea,
7136  double beta,
7137  /* Complex */ ae_matrix* c,
7138  ae_int_t ic,
7139  ae_int_t jc,
7140  ae_bool isupper,
7141  ae_state *_state);
7142 static void ablas_rmatrixsyrk2(ae_int_t n,
7143  ae_int_t k,
7144  double alpha,
7145  /* Real */ ae_matrix* a,
7146  ae_int_t ia,
7147  ae_int_t ja,
7148  ae_int_t optypea,
7149  double beta,
7150  /* Real */ ae_matrix* c,
7151  ae_int_t ic,
7152  ae_int_t jc,
7153  ae_bool isupper,
7154  ae_state *_state);
7155 
7156 
7157 static void ortfac_cmatrixqrbasecase(/* Complex */ ae_matrix* a,
7158  ae_int_t m,
7159  ae_int_t n,
7160  /* Complex */ ae_vector* work,
7161  /* Complex */ ae_vector* t,
7162  /* Complex */ ae_vector* tau,
7163  ae_state *_state);
7164 static void ortfac_cmatrixlqbasecase(/* Complex */ ae_matrix* a,
7165  ae_int_t m,
7166  ae_int_t n,
7167  /* Complex */ ae_vector* work,
7168  /* Complex */ ae_vector* t,
7169  /* Complex */ ae_vector* tau,
7170  ae_state *_state);
7171 static void ortfac_rmatrixblockreflector(/* Real */ ae_matrix* a,
7172  /* Real */ ae_vector* tau,
7173  ae_bool columnwisea,
7174  ae_int_t lengtha,
7175  ae_int_t blocksize,
7176  /* Real */ ae_matrix* t,
7177  /* Real */ ae_vector* work,
7178  ae_state *_state);
7179 static void ortfac_cmatrixblockreflector(/* Complex */ ae_matrix* a,
7180  /* Complex */ ae_vector* tau,
7181  ae_bool columnwisea,
7182  ae_int_t lengtha,
7183  ae_int_t blocksize,
7184  /* Complex */ ae_matrix* t,
7185  /* Complex */ ae_vector* work,
7186  ae_state *_state);
7187 
7188 
7189 static ae_bool bdsvd_bidiagonalsvddecompositioninternal(/* Real */ ae_vector* d,
7190  /* Real */ ae_vector* e,
7191  ae_int_t n,
7192  ae_bool isupper,
7193  ae_bool isfractionalaccuracyrequired,
7194  /* Real */ ae_matrix* u,
7195  ae_int_t ustart,
7196  ae_int_t nru,
7197  /* Real */ ae_matrix* c,
7198  ae_int_t cstart,
7199  ae_int_t ncc,
7200  /* Real */ ae_matrix* vt,
7201  ae_int_t vstart,
7202  ae_int_t ncvt,
7203  ae_state *_state);
7204 static double bdsvd_extsignbdsqr(double a, double b, ae_state *_state);
7205 static void bdsvd_svd2x2(double f,
7206  double g,
7207  double h,
7208  double* ssmin,
7209  double* ssmax,
7210  ae_state *_state);
7211 static void bdsvd_svdv2x2(double f,
7212  double g,
7213  double h,
7214  double* ssmin,
7215  double* ssmax,
7216  double* snr,
7217  double* csr,
7218  double* snl,
7219  double* csl,
7220  ae_state *_state);
7221 
7222 
7223 
7224 
7225 static ae_bool evd_tridiagonalevd(/* Real */ ae_vector* d,
7226  /* Real */ ae_vector* e,
7227  ae_int_t n,
7228  ae_int_t zneeded,
7229  /* Real */ ae_matrix* z,
7230  ae_state *_state);
7231 static void evd_tdevde2(double a,
7232  double b,
7233  double c,
7234  double* rt1,
7235  double* rt2,
7236  ae_state *_state);
7237 static void evd_tdevdev2(double a,
7238  double b,
7239  double c,
7240  double* rt1,
7241  double* rt2,
7242  double* cs1,
7243  double* sn1,
7244  ae_state *_state);
7245 static double evd_tdevdpythag(double a, double b, ae_state *_state);
7246 static double evd_tdevdextsign(double a, double b, ae_state *_state);
7247 static ae_bool evd_internalbisectioneigenvalues(/* Real */ ae_vector* d,
7248  /* Real */ ae_vector* e,
7249  ae_int_t n,
7250  ae_int_t irange,
7251  ae_int_t iorder,
7252  double vl,
7253  double vu,
7254  ae_int_t il,
7255  ae_int_t iu,
7256  double abstol,
7257  /* Real */ ae_vector* w,
7258  ae_int_t* m,
7259  ae_int_t* nsplit,
7260  /* Integer */ ae_vector* iblock,
7261  /* Integer */ ae_vector* isplit,
7262  ae_int_t* errorcode,
7263  ae_state *_state);
7264 static void evd_internaldstein(ae_int_t n,
7265  /* Real */ ae_vector* d,
7266  /* Real */ ae_vector* e,
7267  ae_int_t m,
7268  /* Real */ ae_vector* w,
7269  /* Integer */ ae_vector* iblock,
7270  /* Integer */ ae_vector* isplit,
7271  /* Real */ ae_matrix* z,
7272  /* Integer */ ae_vector* ifail,
7273  ae_int_t* info,
7274  ae_state *_state);
7275 static void evd_tdininternaldlagtf(ae_int_t n,
7276  /* Real */ ae_vector* a,
7277  double lambdav,
7278  /* Real */ ae_vector* b,
7279  /* Real */ ae_vector* c,
7280  double tol,
7281  /* Real */ ae_vector* d,
7282  /* Integer */ ae_vector* iin,
7283  ae_int_t* info,
7284  ae_state *_state);
7285 static void evd_tdininternaldlagts(ae_int_t n,
7286  /* Real */ ae_vector* a,
7287  /* Real */ ae_vector* b,
7288  /* Real */ ae_vector* c,
7289  /* Real */ ae_vector* d,
7290  /* Integer */ ae_vector* iin,
7291  /* Real */ ae_vector* y,
7292  double* tol,
7293  ae_int_t* info,
7294  ae_state *_state);
7295 static void evd_internaldlaebz(ae_int_t ijob,
7296  ae_int_t nitmax,
7297  ae_int_t n,
7298  ae_int_t mmax,
7299  ae_int_t minp,
7300  double abstol,
7301  double reltol,
7302  double pivmin,
7303  /* Real */ ae_vector* d,
7304  /* Real */ ae_vector* e,
7305  /* Real */ ae_vector* e2,
7306  /* Integer */ ae_vector* nval,
7307  /* Real */ ae_matrix* ab,
7308  /* Real */ ae_vector* c,
7309  ae_int_t* mout,
7310  /* Integer */ ae_matrix* nab,
7311  /* Real */ ae_vector* work,
7312  /* Integer */ ae_vector* iwork,
7313  ae_int_t* info,
7314  ae_state *_state);
7315 static void evd_internaltrevc(/* Real */ ae_matrix* t,
7316  ae_int_t n,
7317  ae_int_t side,
7318  ae_int_t howmny,
7319  /* Boolean */ ae_vector* vselect,
7320  /* Real */ ae_matrix* vl,
7321  /* Real */ ae_matrix* vr,
7322  ae_int_t* m,
7323  ae_int_t* info,
7324  ae_state *_state);
7325 static void evd_internalhsevdlaln2(ae_bool ltrans,
7326  ae_int_t na,
7327  ae_int_t nw,
7328  double smin,
7329  double ca,
7330  /* Real */ ae_matrix* a,
7331  double d1,
7332  double d2,
7333  /* Real */ ae_matrix* b,
7334  double wr,
7335  double wi,
7336  /* Boolean */ ae_vector* rswap4,
7337  /* Boolean */ ae_vector* zswap4,
7338  /* Integer */ ae_matrix* ipivot44,
7339  /* Real */ ae_vector* civ4,
7340  /* Real */ ae_vector* crv4,
7341  /* Real */ ae_matrix* x,
7342  double* scl,
7343  double* xnorm,
7344  ae_int_t* info,
7345  ae_state *_state);
7346 static void evd_internalhsevdladiv(double a,
7347  double b,
7348  double c,
7349  double d,
7350  double* p,
7351  double* q,
7352  ae_state *_state);
7353 static ae_bool evd_nonsymmetricevd(/* Real */ ae_matrix* a,
7354  ae_int_t n,
7355  ae_int_t vneeded,
7356  /* Real */ ae_vector* wr,
7357  /* Real */ ae_vector* wi,
7358  /* Real */ ae_matrix* vl,
7359  /* Real */ ae_matrix* vr,
7360  ae_state *_state);
7361 static void evd_toupperhessenberg(/* Real */ ae_matrix* a,
7362  ae_int_t n,
7363  /* Real */ ae_vector* tau,
7364  ae_state *_state);
7365 static void evd_unpackqfromupperhessenberg(/* Real */ ae_matrix* a,
7366  ae_int_t n,
7367  /* Real */ ae_vector* tau,
7368  /* Real */ ae_matrix* q,
7369  ae_state *_state);
7370 
7371 
7372 
7373 
7374 static void trfac_cmatrixluprec(/* Complex */ ae_matrix* a,
7375  ae_int_t offs,
7376  ae_int_t m,
7377  ae_int_t n,
7378  /* Integer */ ae_vector* pivots,
7379  /* Complex */ ae_vector* tmp,
7380  ae_state *_state);
7381 static void trfac_rmatrixluprec(/* Real */ ae_matrix* a,
7382  ae_int_t offs,
7383  ae_int_t m,
7384  ae_int_t n,
7385  /* Integer */ ae_vector* pivots,
7386  /* Real */ ae_vector* tmp,
7387  ae_state *_state);
7388 static void trfac_cmatrixplurec(/* Complex */ ae_matrix* a,
7389  ae_int_t offs,
7390  ae_int_t m,
7391  ae_int_t n,
7392  /* Integer */ ae_vector* pivots,
7393  /* Complex */ ae_vector* tmp,
7394  ae_state *_state);
7395 static void trfac_rmatrixplurec(/* Real */ ae_matrix* a,
7396  ae_int_t offs,
7397  ae_int_t m,
7398  ae_int_t n,
7399  /* Integer */ ae_vector* pivots,
7400  /* Real */ ae_vector* tmp,
7401  ae_state *_state);
7402 static void trfac_cmatrixlup2(/* Complex */ ae_matrix* a,
7403  ae_int_t offs,
7404  ae_int_t m,
7405  ae_int_t n,
7406  /* Integer */ ae_vector* pivots,
7407  /* Complex */ ae_vector* tmp,
7408  ae_state *_state);
7409 static void trfac_rmatrixlup2(/* Real */ ae_matrix* a,
7410  ae_int_t offs,
7411  ae_int_t m,
7412  ae_int_t n,
7413  /* Integer */ ae_vector* pivots,
7414  /* Real */ ae_vector* tmp,
7415  ae_state *_state);
7416 static void trfac_cmatrixplu2(/* Complex */ ae_matrix* a,
7417  ae_int_t offs,
7418  ae_int_t m,
7419  ae_int_t n,
7420  /* Integer */ ae_vector* pivots,
7421  /* Complex */ ae_vector* tmp,
7422  ae_state *_state);
7423 static void trfac_rmatrixplu2(/* Real */ ae_matrix* a,
7424  ae_int_t offs,
7425  ae_int_t m,
7426  ae_int_t n,
7427  /* Integer */ ae_vector* pivots,
7428  /* Real */ ae_vector* tmp,
7429  ae_state *_state);
7430 static ae_bool trfac_hpdmatrixcholeskyrec(/* Complex */ ae_matrix* a,
7431  ae_int_t offs,
7432  ae_int_t n,
7433  ae_bool isupper,
7434  /* Complex */ ae_vector* tmp,
7435  ae_state *_state);
7436 static ae_bool trfac_hpdmatrixcholesky2(/* Complex */ ae_matrix* aaa,
7437  ae_int_t offs,
7438  ae_int_t n,
7439  ae_bool isupper,
7440  /* Complex */ ae_vector* tmp,
7441  ae_state *_state);
7442 static ae_bool trfac_spdmatrixcholesky2(/* Real */ ae_matrix* aaa,
7443  ae_int_t offs,
7444  ae_int_t n,
7445  ae_bool isupper,
7446  /* Real */ ae_vector* tmp,
7447  ae_state *_state);
7448 
7449 
7450 static void rcond_rmatrixrcondtrinternal(/* Real */ ae_matrix* a,
7451  ae_int_t n,
7452  ae_bool isupper,
7453  ae_bool isunit,
7454  ae_bool onenorm,
7455  double anorm,
7456  double* rc,
7457  ae_state *_state);
7458 static void rcond_cmatrixrcondtrinternal(/* Complex */ ae_matrix* a,
7459  ae_int_t n,
7460  ae_bool isupper,
7461  ae_bool isunit,
7462  ae_bool onenorm,
7463  double anorm,
7464  double* rc,
7465  ae_state *_state);
7466 static void rcond_spdmatrixrcondcholeskyinternal(/* Real */ ae_matrix* cha,
7467  ae_int_t n,
7468  ae_bool isupper,
7469  ae_bool isnormprovided,
7470  double anorm,
7471  double* rc,
7472  ae_state *_state);
7473 static void rcond_hpdmatrixrcondcholeskyinternal(/* Complex */ ae_matrix* cha,
7474  ae_int_t n,
7475  ae_bool isupper,
7476  ae_bool isnormprovided,
7477  double anorm,
7478  double* rc,
7479  ae_state *_state);
7480 static void rcond_rmatrixrcondluinternal(/* Real */ ae_matrix* lua,
7481  ae_int_t n,
7482  ae_bool onenorm,
7483  ae_bool isanormprovided,
7484  double anorm,
7485  double* rc,
7486  ae_state *_state);
7487 static void rcond_cmatrixrcondluinternal(/* Complex */ ae_matrix* lua,
7488  ae_int_t n,
7489  ae_bool onenorm,
7490  ae_bool isanormprovided,
7491  double anorm,
7492  double* rc,
7493  ae_state *_state);
7494 static void rcond_rmatrixestimatenorm(ae_int_t n,
7495  /* Real */ ae_vector* v,
7496  /* Real */ ae_vector* x,
7497  /* Integer */ ae_vector* isgn,
7498  double* est,
7499  ae_int_t* kase,
7500  ae_state *_state);
7501 static void rcond_cmatrixestimatenorm(ae_int_t n,
7502  /* Complex */ ae_vector* v,
7503  /* Complex */ ae_vector* x,
7504  double* est,
7505  ae_int_t* kase,
7506  /* Integer */ ae_vector* isave,
7507  /* Real */ ae_vector* rsave,
7508  ae_state *_state);
7509 static double rcond_internalcomplexrcondscsum1(/* Complex */ ae_vector* x,
7510  ae_int_t n,
7511  ae_state *_state);
7512 static ae_int_t rcond_internalcomplexrcondicmax1(/* Complex */ ae_vector* x,
7513  ae_int_t n,
7514  ae_state *_state);
7515 static void rcond_internalcomplexrcondsaveall(/* Integer */ ae_vector* isave,
7516  /* Real */ ae_vector* rsave,
7517  ae_int_t* i,
7518  ae_int_t* iter,
7519  ae_int_t* j,
7520  ae_int_t* jlast,
7521  ae_int_t* jump,
7522  double* absxi,
7523  double* altsgn,
7524  double* estold,
7525  double* temp,
7526  ae_state *_state);
7527 static void rcond_internalcomplexrcondloadall(/* Integer */ ae_vector* isave,
7528  /* Real */ ae_vector* rsave,
7529  ae_int_t* i,
7530  ae_int_t* iter,
7531  ae_int_t* j,
7532  ae_int_t* jlast,
7533  ae_int_t* jump,
7534  double* absxi,
7535  double* altsgn,
7536  double* estold,
7537  double* temp,
7538  ae_state *_state);
7539 
7540 
7541 static void matinv_rmatrixtrinverserec(/* Real */ ae_matrix* a,
7542  ae_int_t offs,
7543  ae_int_t n,
7544  ae_bool isupper,
7545  ae_bool isunit,
7546  /* Real */ ae_vector* tmp,
7547  ae_int_t* info,
7548  matinvreport* rep,
7549  ae_state *_state);
7550 static void matinv_cmatrixtrinverserec(/* Complex */ ae_matrix* a,
7551  ae_int_t offs,
7552  ae_int_t n,
7553  ae_bool isupper,
7554  ae_bool isunit,
7555  /* Complex */ ae_vector* tmp,
7556  ae_int_t* info,
7557  matinvreport* rep,
7558  ae_state *_state);
7559 static void matinv_rmatrixluinverserec(/* Real */ ae_matrix* a,
7560  ae_int_t offs,
7561  ae_int_t n,
7562  /* Real */ ae_vector* work,
7563  ae_int_t* info,
7564  matinvreport* rep,
7565  ae_state *_state);
7566 static void matinv_cmatrixluinverserec(/* Complex */ ae_matrix* a,
7567  ae_int_t offs,
7568  ae_int_t n,
7569  /* Complex */ ae_vector* work,
7570  ae_int_t* info,
7571  matinvreport* rep,
7572  ae_state *_state);
7573 static void matinv_spdmatrixcholeskyinverserec(/* Real */ ae_matrix* a,
7574  ae_int_t offs,
7575  ae_int_t n,
7576  ae_bool isupper,
7577  /* Real */ ae_vector* tmp,
7578  ae_state *_state);
7579 static void matinv_hpdmatrixcholeskyinverserec(/* Complex */ ae_matrix* a,
7580  ae_int_t offs,
7581  ae_int_t n,
7582  ae_bool isupper,
7583  /* Complex */ ae_vector* tmp,
7584  ae_state *_state);
7585 
7586 
7587 static double sparse_desiredloadfactor = 0.66;
7588 static double sparse_maxloadfactor = 0.75;
7589 static double sparse_growfactor = 2.00;
7590 static ae_int_t sparse_additional = 10;
7591 static ae_int_t sparse_linalgswitch = 16;
7592 static void sparse_sparseinitduidx(sparsematrix* s, ae_state *_state);
7593 static ae_int_t sparse_hash(ae_int_t i,
7594  ae_int_t j,
7595  ae_int_t tabsize,
7596  ae_state *_state);
7597 
7598 
7599 
7600 
7601 
7602 
7603 
7604 
7605 
7606 
7607 
7608 
7609 
7610 
7611 
7612 
7613 
7614 /*************************************************************************
7615 Splits matrix length in two parts, left part should match ABLAS block size
7616 
7617 INPUT PARAMETERS
7618  A - real matrix, is passed to ensure that we didn't split
7619  complex matrix using real splitting subroutine.
7620  matrix itself is not changed.
7621  N - length, N>0
7622 
7623 OUTPUT PARAMETERS
7624  N1 - length
7625  N2 - length
7626 
7627 N1+N2=N, N1>=N2, N2 may be zero
7628 
7629  -- ALGLIB routine --
7630  15.12.2009
7631  Bochkanov Sergey
7632 *************************************************************************/
7633 void ablassplitlength(/* Real */ ae_matrix* a,
7634  ae_int_t n,
7635  ae_int_t* n1,
7636  ae_int_t* n2,
7637  ae_state *_state)
7638 {
7639 
7640  *n1 = 0;
7641  *n2 = 0;
7642 
7643  if( n>ablasblocksize(a, _state) )
7644  {
7645  ablas_ablasinternalsplitlength(n, ablasblocksize(a, _state), n1, n2, _state);
7646  }
7647  else
7648  {
7649  ablas_ablasinternalsplitlength(n, ablasmicroblocksize(_state), n1, n2, _state);
7650  }
7651 }
7652 
7653 
7654 /*************************************************************************
7655 Complex ABLASSplitLength
7656 
7657  -- ALGLIB routine --
7658  15.12.2009
7659  Bochkanov Sergey
7660 *************************************************************************/
7661 void ablascomplexsplitlength(/* Complex */ ae_matrix* a,
7662  ae_int_t n,
7663  ae_int_t* n1,
7664  ae_int_t* n2,
7665  ae_state *_state)
7666 {
7667 
7668  *n1 = 0;
7669  *n2 = 0;
7670 
7671  if( n>ablascomplexblocksize(a, _state) )
7672  {
7673  ablas_ablasinternalsplitlength(n, ablascomplexblocksize(a, _state), n1, n2, _state);
7674  }
7675  else
7676  {
7677  ablas_ablasinternalsplitlength(n, ablasmicroblocksize(_state), n1, n2, _state);
7678  }
7679 }
7680 
7681 
7682 /*************************************************************************
7683 Returns block size - subdivision size where cache-oblivious soubroutines
7684 switch to the optimized kernel.
7685 
7686 INPUT PARAMETERS
7687  A - real matrix, is passed to ensure that we didn't split
7688  complex matrix using real splitting subroutine.
7689  matrix itself is not changed.
7690 
7691  -- ALGLIB routine --
7692  15.12.2009
7693  Bochkanov Sergey
7694 *************************************************************************/
7696 {
7697  ae_int_t result;
7698 
7699 
7700  result = 32;
7701  return result;
7702 }
7703 
7704 
7705 /*************************************************************************
7706 Block size for complex subroutines.
7707 
7708  -- ALGLIB routine --
7709  15.12.2009
7710  Bochkanov Sergey
7711 *************************************************************************/
7713  ae_state *_state)
7714 {
7715  ae_int_t result;
7716 
7717 
7718  result = 24;
7719  return result;
7720 }
7721 
7722 
7723 /*************************************************************************
7724 Microblock size
7725 
7726  -- ALGLIB routine --
7727  15.12.2009
7728  Bochkanov Sergey
7729 *************************************************************************/
7731 {
7732  ae_int_t result;
7733 
7734 
7735  result = 8;
7736  return result;
7737 }
7738 
7739 
7740 /*************************************************************************
7741 Cache-oblivous complex "copy-and-transpose"
7742 
7743 Input parameters:
7744  M - number of rows
7745  N - number of columns
7746  A - source matrix, MxN submatrix is copied and transposed
7747  IA - submatrix offset (row index)
7748  JA - submatrix offset (column index)
7749  B - destination matrix, must be large enough to store result
7750  IB - submatrix offset (row index)
7751  JB - submatrix offset (column index)
7752 *************************************************************************/
7754  ae_int_t n,
7755  /* Complex */ ae_matrix* a,
7756  ae_int_t ia,
7757  ae_int_t ja,
7758  /* Complex */ ae_matrix* b,
7759  ae_int_t ib,
7760  ae_int_t jb,
7761  ae_state *_state)
7762 {
7763  ae_int_t i;
7764  ae_int_t s1;
7765  ae_int_t s2;
7766 
7767 
7768  if( m<=2*ablascomplexblocksize(a, _state)&&n<=2*ablascomplexblocksize(a, _state) )
7769  {
7770 
7771  /*
7772  * base case
7773  */
7774  for(i=0; i<=m-1; i++)
7775  {
7776  ae_v_cmove(&b->ptr.pp_complex[ib][jb+i], b->stride, &a->ptr.pp_complex[ia+i][ja], 1, "N", ae_v_len(ib,ib+n-1));
7777  }
7778  }
7779  else
7780  {
7781 
7782  /*
7783  * Cache-oblivious recursion
7784  */
7785  if( m>n )
7786  {
7787  ablascomplexsplitlength(a, m, &s1, &s2, _state);
7788  cmatrixtranspose(s1, n, a, ia, ja, b, ib, jb, _state);
7789  cmatrixtranspose(s2, n, a, ia+s1, ja, b, ib, jb+s1, _state);
7790  }
7791  else
7792  {
7793  ablascomplexsplitlength(a, n, &s1, &s2, _state);
7794  cmatrixtranspose(m, s1, a, ia, ja, b, ib, jb, _state);
7795  cmatrixtranspose(m, s2, a, ia, ja+s1, b, ib+s1, jb, _state);
7796  }
7797  }
7798 }
7799 
7800 
7801 /*************************************************************************
7802 Cache-oblivous real "copy-and-transpose"
7803 
7804 Input parameters:
7805  M - number of rows
7806  N - number of columns
7807  A - source matrix, MxN submatrix is copied and transposed
7808  IA - submatrix offset (row index)
7809  JA - submatrix offset (column index)
7810  B - destination matrix, must be large enough to store result
7811  IB - submatrix offset (row index)
7812  JB - submatrix offset (column index)
7813 *************************************************************************/
7815  ae_int_t n,
7816  /* Real */ ae_matrix* a,
7817  ae_int_t ia,
7818  ae_int_t ja,
7819  /* Real */ ae_matrix* b,
7820  ae_int_t ib,
7821  ae_int_t jb,
7822  ae_state *_state)
7823 {
7824  ae_int_t i;
7825  ae_int_t s1;
7826  ae_int_t s2;
7827 
7828 
7829  if( m<=2*ablasblocksize(a, _state)&&n<=2*ablasblocksize(a, _state) )
7830  {
7831 
7832  /*
7833  * base case
7834  */
7835  for(i=0; i<=m-1; i++)
7836  {
7837  ae_v_move(&b->ptr.pp_double[ib][jb+i], b->stride, &a->ptr.pp_double[ia+i][ja], 1, ae_v_len(ib,ib+n-1));
7838  }
7839  }
7840  else
7841  {
7842 
7843  /*
7844  * Cache-oblivious recursion
7845  */
7846  if( m>n )
7847  {
7848  ablassplitlength(a, m, &s1, &s2, _state);
7849  rmatrixtranspose(s1, n, a, ia, ja, b, ib, jb, _state);
7850  rmatrixtranspose(s2, n, a, ia+s1, ja, b, ib, jb+s1, _state);
7851  }
7852  else
7853  {
7854  ablassplitlength(a, n, &s1, &s2, _state);
7855  rmatrixtranspose(m, s1, a, ia, ja, b, ib, jb, _state);
7856  rmatrixtranspose(m, s2, a, ia, ja+s1, b, ib+s1, jb, _state);
7857  }
7858  }
7859 }
7860 
7861 
7862 /*************************************************************************
7863 This code enforces symmetricy of the matrix by copying Upper part to lower
7864 one (or vice versa).
7865 
7866 INPUT PARAMETERS:
7867  A - matrix
7868  N - number of rows/columns
7869  IsUpper - whether we want to copy upper triangle to lower one (True)
7870  or vice versa (False).
7871 *************************************************************************/
7873  ae_int_t n,
7874  ae_bool isupper,
7875  ae_state *_state)
7876 {
7877  ae_int_t i;
7878  ae_int_t j;
7879 
7880 
7881  if( isupper )
7882  {
7883  for(i=0; i<=n-1; i++)
7884  {
7885  for(j=i+1; j<=n-1; j++)
7886  {
7887  a->ptr.pp_double[j][i] = a->ptr.pp_double[i][j];
7888  }
7889  }
7890  }
7891  else
7892  {
7893  for(i=0; i<=n-1; i++)
7894  {
7895  for(j=i+1; j<=n-1; j++)
7896  {
7897  a->ptr.pp_double[i][j] = a->ptr.pp_double[j][i];
7898  }
7899  }
7900  }
7901 }
7902 
7903 
7904 /*************************************************************************
7905 Copy
7906 
7907 Input parameters:
7908  M - number of rows
7909  N - number of columns
7910  A - source matrix, MxN submatrix is copied and transposed
7911  IA - submatrix offset (row index)
7912  JA - submatrix offset (column index)
7913  B - destination matrix, must be large enough to store result
7914  IB - submatrix offset (row index)
7915  JB - submatrix offset (column index)
7916 *************************************************************************/
7918  ae_int_t n,
7919  /* Complex */ ae_matrix* a,
7920  ae_int_t ia,
7921  ae_int_t ja,
7922  /* Complex */ ae_matrix* b,
7923  ae_int_t ib,
7924  ae_int_t jb,
7925  ae_state *_state)
7926 {
7927  ae_int_t i;
7928 
7929 
7930  if( m==0||n==0 )
7931  {
7932  return;
7933  }
7934  for(i=0; i<=m-1; i++)
7935  {
7936  ae_v_cmove(&b->ptr.pp_complex[ib+i][jb], 1, &a->ptr.pp_complex[ia+i][ja], 1, "N", ae_v_len(jb,jb+n-1));
7937  }
7938 }
7939 
7940 
7941 /*************************************************************************
7942 Copy
7943 
7944 Input parameters:
7945  M - number of rows
7946  N - number of columns
7947  A - source matrix, MxN submatrix is copied and transposed
7948  IA - submatrix offset (row index)
7949  JA - submatrix offset (column index)
7950  B - destination matrix, must be large enough to store result
7951  IB - submatrix offset (row index)
7952  JB - submatrix offset (column index)
7953 *************************************************************************/
7955  ae_int_t n,
7956  /* Real */ ae_matrix* a,
7957  ae_int_t ia,
7958  ae_int_t ja,
7959  /* Real */ ae_matrix* b,
7960  ae_int_t ib,
7961  ae_int_t jb,
7962  ae_state *_state)
7963 {
7964  ae_int_t i;
7965 
7966 
7967  if( m==0||n==0 )
7968  {
7969  return;
7970  }
7971  for(i=0; i<=m-1; i++)
7972  {
7973  ae_v_move(&b->ptr.pp_double[ib+i][jb], 1, &a->ptr.pp_double[ia+i][ja], 1, ae_v_len(jb,jb+n-1));
7974  }
7975 }
7976 
7977 
7978 /*************************************************************************
7979 Rank-1 correction: A := A + u*v'
7980 
7981 INPUT PARAMETERS:
7982  M - number of rows
7983  N - number of columns
7984  A - target matrix, MxN submatrix is updated
7985  IA - submatrix offset (row index)
7986  JA - submatrix offset (column index)
7987  U - vector #1
7988  IU - subvector offset
7989  V - vector #2
7990  IV - subvector offset
7991 *************************************************************************/
7993  ae_int_t n,
7994  /* Complex */ ae_matrix* a,
7995  ae_int_t ia,
7996  ae_int_t ja,
7997  /* Complex */ ae_vector* u,
7998  ae_int_t iu,
7999  /* Complex */ ae_vector* v,
8000  ae_int_t iv,
8001  ae_state *_state)
8002 {
8003  ae_int_t i;
8004  ae_complex s;
8005 
8006 
8007  if( m==0||n==0 )
8008  {
8009  return;
8010  }
8011  if( cmatrixrank1f(m, n, a, ia, ja, u, iu, v, iv, _state) )
8012  {
8013  return;
8014  }
8015  for(i=0; i<=m-1; i++)
8016  {
8017  s = u->ptr.p_complex[iu+i];
8018  ae_v_caddc(&a->ptr.pp_complex[ia+i][ja], 1, &v->ptr.p_complex[iv], 1, "N", ae_v_len(ja,ja+n-1), s);
8019  }
8020 }
8021 
8022 
8023 /*************************************************************************
8024 Rank-1 correction: A := A + u*v'
8025 
8026 INPUT PARAMETERS:
8027  M - number of rows
8028  N - number of columns
8029  A - target matrix, MxN submatrix is updated
8030  IA - submatrix offset (row index)
8031  JA - submatrix offset (column index)
8032  U - vector #1
8033  IU - subvector offset
8034  V - vector #2
8035  IV - subvector offset
8036 *************************************************************************/
8038  ae_int_t n,
8039  /* Real */ ae_matrix* a,
8040  ae_int_t ia,
8041  ae_int_t ja,
8042  /* Real */ ae_vector* u,
8043  ae_int_t iu,
8044  /* Real */ ae_vector* v,
8045  ae_int_t iv,
8046  ae_state *_state)
8047 {
8048  ae_int_t i;
8049  double s;
8050 
8051 
8052  if( m==0||n==0 )
8053  {
8054  return;
8055  }
8056  if( rmatrixrank1f(m, n, a, ia, ja, u, iu, v, iv, _state) )
8057  {
8058  return;
8059  }
8060  for(i=0; i<=m-1; i++)
8061  {
8062  s = u->ptr.p_double[iu+i];
8063  ae_v_addd(&a->ptr.pp_double[ia+i][ja], 1, &v->ptr.p_double[iv], 1, ae_v_len(ja,ja+n-1), s);
8064  }
8065 }
8066 
8067 
8068 /*************************************************************************
8069 Matrix-vector product: y := op(A)*x
8070 
8071 INPUT PARAMETERS:
8072  M - number of rows of op(A)
8073  M>=0
8074  N - number of columns of op(A)
8075  N>=0
8076  A - target matrix
8077  IA - submatrix offset (row index)
8078  JA - submatrix offset (column index)
8079  OpA - operation type:
8080  * OpA=0 => op(A) = A
8081  * OpA=1 => op(A) = A^T
8082  * OpA=2 => op(A) = A^H
8083  X - input vector
8084  IX - subvector offset
8085  IY - subvector offset
8086  Y - preallocated matrix, must be large enough to store result
8087 
8088 OUTPUT PARAMETERS:
8089  Y - vector which stores result
8090 
8091 if M=0, then subroutine does nothing.
8092 if N=0, Y is filled by zeros.
8093 
8094 
8095  -- ALGLIB routine --
8096 
8097  28.01.2010
8098  Bochkanov Sergey
8099 *************************************************************************/
8101  ae_int_t n,
8102  /* Complex */ ae_matrix* a,
8103  ae_int_t ia,
8104  ae_int_t ja,
8105  ae_int_t opa,
8106  /* Complex */ ae_vector* x,
8107  ae_int_t ix,
8108  /* Complex */ ae_vector* y,
8109  ae_int_t iy,
8110  ae_state *_state)
8111 {
8112  ae_int_t i;
8113  ae_complex v;
8114 
8115 
8116  if( m==0 )
8117  {
8118  return;
8119  }
8120  if( n==0 )
8121  {
8122  for(i=0; i<=m-1; i++)
8123  {
8124  y->ptr.p_complex[iy+i] = ae_complex_from_d(0);
8125  }
8126  return;
8127  }
8128  if( cmatrixmvf(m, n, a, ia, ja, opa, x, ix, y, iy, _state) )
8129  {
8130  return;
8131  }
8132  if( opa==0 )
8133  {
8134 
8135  /*
8136  * y = A*x
8137  */
8138  for(i=0; i<=m-1; i++)
8139  {
8140  v = ae_v_cdotproduct(&a->ptr.pp_complex[ia+i][ja], 1, "N", &x->ptr.p_complex[ix], 1, "N", ae_v_len(ja,ja+n-1));
8141  y->ptr.p_complex[iy+i] = v;
8142  }
8143  return;
8144  }
8145  if( opa==1 )
8146  {
8147 
8148  /*
8149  * y = A^T*x
8150  */
8151  for(i=0; i<=m-1; i++)
8152  {
8153  y->ptr.p_complex[iy+i] = ae_complex_from_d(0);
8154  }
8155  for(i=0; i<=n-1; i++)
8156  {
8157  v = x->ptr.p_complex[ix+i];
8158  ae_v_caddc(&y->ptr.p_complex[iy], 1, &a->ptr.pp_complex[ia+i][ja], 1, "N", ae_v_len(iy,iy+m-1), v);
8159  }
8160  return;
8161  }
8162  if( opa==2 )
8163  {
8164 
8165  /*
8166  * y = A^H*x
8167  */
8168  for(i=0; i<=m-1; i++)
8169  {
8170  y->ptr.p_complex[iy+i] = ae_complex_from_d(0);
8171  }
8172  for(i=0; i<=n-1; i++)
8173  {
8174  v = x->ptr.p_complex[ix+i];
8175  ae_v_caddc(&y->ptr.p_complex[iy], 1, &a->ptr.pp_complex[ia+i][ja], 1, "Conj", ae_v_len(iy,iy+m-1), v);
8176  }
8177  return;
8178  }
8179 }
8180 
8181 
8182 /*************************************************************************
8183 Matrix-vector product: y := op(A)*x
8184 
8185 INPUT PARAMETERS:
8186  M - number of rows of op(A)
8187  N - number of columns of op(A)
8188  A - target matrix
8189  IA - submatrix offset (row index)
8190  JA - submatrix offset (column index)
8191  OpA - operation type:
8192  * OpA=0 => op(A) = A
8193  * OpA=1 => op(A) = A^T
8194  X - input vector
8195  IX - subvector offset
8196  IY - subvector offset
8197  Y - preallocated matrix, must be large enough to store result
8198 
8199 OUTPUT PARAMETERS:
8200  Y - vector which stores result
8201 
8202 if M=0, then subroutine does nothing.
8203 if N=0, Y is filled by zeros.
8204 
8205 
8206  -- ALGLIB routine --
8207 
8208  28.01.2010
8209  Bochkanov Sergey
8210 *************************************************************************/
8212  ae_int_t n,
8213  /* Real */ ae_matrix* a,
8214  ae_int_t ia,
8215  ae_int_t ja,
8216  ae_int_t opa,
8217  /* Real */ ae_vector* x,
8218  ae_int_t ix,
8219  /* Real */ ae_vector* y,
8220  ae_int_t iy,
8221  ae_state *_state)
8222 {
8223  ae_int_t i;
8224  double v;
8225 
8226 
8227  if( m==0 )
8228  {
8229  return;
8230  }
8231  if( n==0 )
8232  {
8233  for(i=0; i<=m-1; i++)
8234  {
8235  y->ptr.p_double[iy+i] = 0;
8236  }
8237  return;
8238  }
8239  if( rmatrixmvf(m, n, a, ia, ja, opa, x, ix, y, iy, _state) )
8240  {
8241  return;
8242  }
8243  if( opa==0 )
8244  {
8245 
8246  /*
8247  * y = A*x
8248  */
8249  for(i=0; i<=m-1; i++)
8250  {
8251  v = ae_v_dotproduct(&a->ptr.pp_double[ia+i][ja], 1, &x->ptr.p_double[ix], 1, ae_v_len(ja,ja+n-1));
8252  y->ptr.p_double[iy+i] = v;
8253  }
8254  return;
8255  }
8256  if( opa==1 )
8257  {
8258 
8259  /*
8260  * y = A^T*x
8261  */
8262  for(i=0; i<=m-1; i++)
8263  {
8264  y->ptr.p_double[iy+i] = 0;
8265  }
8266  for(i=0; i<=n-1; i++)
8267  {
8268  v = x->ptr.p_double[ix+i];
8269  ae_v_addd(&y->ptr.p_double[iy], 1, &a->ptr.pp_double[ia+i][ja], 1, ae_v_len(iy,iy+m-1), v);
8270  }
8271  return;
8272  }
8273 }
8274 
8275 
8277  ae_int_t n,
8278  /* Complex */ ae_matrix* a,
8279  ae_int_t i1,
8280  ae_int_t j1,
8281  ae_bool isupper,
8282  ae_bool isunit,
8283  ae_int_t optype,
8284  /* Complex */ ae_matrix* x,
8285  ae_int_t i2,
8286  ae_int_t j2,
8287  ae_state *_state)
8288 {
8289  ae_int_t s1;
8290  ae_int_t s2;
8291  ae_int_t bs;
8292 
8293 
8294  bs = ablascomplexblocksize(a, _state);
8295  if( m<=bs&&n<=bs )
8296  {
8297  ablas_cmatrixrighttrsm2(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8298  return;
8299  }
8300  if( m>=n )
8301  {
8302 
8303  /*
8304  * Split X: X*A = (X1 X2)^T*A
8305  */
8306  ablascomplexsplitlength(a, m, &s1, &s2, _state);
8307  cmatrixrighttrsm(s1, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8308  cmatrixrighttrsm(s2, n, a, i1, j1, isupper, isunit, optype, x, i2+s1, j2, _state);
8309  return;
8310  }
8311  else
8312  {
8313 
8314  /*
8315  * Split A:
8316  * (A1 A12)
8317  * X*op(A) = X*op( )
8318  * ( A2)
8319  *
8320  * Different variants depending on
8321  * IsUpper/OpType combinations
8322  */
8323  ablascomplexsplitlength(a, n, &s1, &s2, _state);
8324  if( isupper&&optype==0 )
8325  {
8326 
8327  /*
8328  * (A1 A12)-1
8329  * X*A^-1 = (X1 X2)*( )
8330  * ( A2)
8331  */
8332  cmatrixrighttrsm(m, s1, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8333  cmatrixgemm(m, s2, s1, ae_complex_from_d(-1.0), x, i2, j2, 0, a, i1, j1+s1, 0, ae_complex_from_d(1.0), x, i2, j2+s1, _state);
8334  cmatrixrighttrsm(m, s2, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2, j2+s1, _state);
8335  return;
8336  }
8337  if( isupper&&optype!=0 )
8338  {
8339 
8340  /*
8341  * (A1' )-1
8342  * X*A^-1 = (X1 X2)*( )
8343  * (A12' A2')
8344  */
8345  cmatrixrighttrsm(m, s2, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2, j2+s1, _state);
8346  cmatrixgemm(m, s1, s2, ae_complex_from_d(-1.0), x, i2, j2+s1, 0, a, i1, j1+s1, optype, ae_complex_from_d(1.0), x, i2, j2, _state);
8347  cmatrixrighttrsm(m, s1, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8348  return;
8349  }
8350  if( !isupper&&optype==0 )
8351  {
8352 
8353  /*
8354  * (A1 )-1
8355  * X*A^-1 = (X1 X2)*( )
8356  * (A21 A2)
8357  */
8358  cmatrixrighttrsm(m, s2, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2, j2+s1, _state);
8359  cmatrixgemm(m, s1, s2, ae_complex_from_d(-1.0), x, i2, j2+s1, 0, a, i1+s1, j1, 0, ae_complex_from_d(1.0), x, i2, j2, _state);
8360  cmatrixrighttrsm(m, s1, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8361  return;
8362  }
8363  if( !isupper&&optype!=0 )
8364  {
8365 
8366  /*
8367  * (A1' A21')-1
8368  * X*A^-1 = (X1 X2)*( )
8369  * ( A2')
8370  */
8371  cmatrixrighttrsm(m, s1, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8372  cmatrixgemm(m, s2, s1, ae_complex_from_d(-1.0), x, i2, j2, 0, a, i1+s1, j1, optype, ae_complex_from_d(1.0), x, i2, j2+s1, _state);
8373  cmatrixrighttrsm(m, s2, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2, j2+s1, _state);
8374  return;
8375  }
8376  }
8377 }
8378 
8379 
8380 /*************************************************************************
8381 Single-threaded stub. HPC ALGLIB replaces it by multithreaded code.
8382 *************************************************************************/
8384  ae_int_t n,
8385  /* Complex */ ae_matrix* a,
8386  ae_int_t i1,
8387  ae_int_t j1,
8388  ae_bool isupper,
8389  ae_bool isunit,
8390  ae_int_t optype,
8391  /* Complex */ ae_matrix* x,
8392  ae_int_t i2,
8393  ae_int_t j2, ae_state *_state)
8394 {
8395  cmatrixrighttrsm(m,n,a,i1,j1,isupper,isunit,optype,x,i2,j2, _state);
8396 }
8397 
8398 
8400  ae_int_t n,
8401  /* Complex */ ae_matrix* a,
8402  ae_int_t i1,
8403  ae_int_t j1,
8404  ae_bool isupper,
8405  ae_bool isunit,
8406  ae_int_t optype,
8407  /* Complex */ ae_matrix* x,
8408  ae_int_t i2,
8409  ae_int_t j2,
8410  ae_state *_state)
8411 {
8412  ae_int_t s1;
8413  ae_int_t s2;
8414  ae_int_t bs;
8415 
8416 
8417  bs = ablascomplexblocksize(a, _state);
8418  if( m<=bs&&n<=bs )
8419  {
8420  ablas_cmatrixlefttrsm2(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8421  return;
8422  }
8423  if( n>=m )
8424  {
8425 
8426  /*
8427  * Split X: op(A)^-1*X = op(A)^-1*(X1 X2)
8428  */
8429  ablascomplexsplitlength(x, n, &s1, &s2, _state);
8430  cmatrixlefttrsm(m, s1, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8431  cmatrixlefttrsm(m, s2, a, i1, j1, isupper, isunit, optype, x, i2, j2+s1, _state);
8432  return;
8433  }
8434  else
8435  {
8436 
8437  /*
8438  * Split A
8439  */
8440  ablascomplexsplitlength(a, m, &s1, &s2, _state);
8441  if( isupper&&optype==0 )
8442  {
8443 
8444  /*
8445  * (A1 A12)-1 ( X1 )
8446  * A^-1*X* = ( ) *( )
8447  * ( A2) ( X2 )
8448  */
8449  cmatrixlefttrsm(s2, n, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2+s1, j2, _state);
8450  cmatrixgemm(s1, n, s2, ae_complex_from_d(-1.0), a, i1, j1+s1, 0, x, i2+s1, j2, 0, ae_complex_from_d(1.0), x, i2, j2, _state);
8451  cmatrixlefttrsm(s1, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8452  return;
8453  }
8454  if( isupper&&optype!=0 )
8455  {
8456 
8457  /*
8458  * (A1' )-1 ( X1 )
8459  * A^-1*X = ( ) *( )
8460  * (A12' A2') ( X2 )
8461  */
8462  cmatrixlefttrsm(s1, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8463  cmatrixgemm(s2, n, s1, ae_complex_from_d(-1.0), a, i1, j1+s1, optype, x, i2, j2, 0, ae_complex_from_d(1.0), x, i2+s1, j2, _state);
8464  cmatrixlefttrsm(s2, n, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2+s1, j2, _state);
8465  return;
8466  }
8467  if( !isupper&&optype==0 )
8468  {
8469 
8470  /*
8471  * (A1 )-1 ( X1 )
8472  * A^-1*X = ( ) *( )
8473  * (A21 A2) ( X2 )
8474  */
8475  cmatrixlefttrsm(s1, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8476  cmatrixgemm(s2, n, s1, ae_complex_from_d(-1.0), a, i1+s1, j1, 0, x, i2, j2, 0, ae_complex_from_d(1.0), x, i2+s1, j2, _state);
8477  cmatrixlefttrsm(s2, n, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2+s1, j2, _state);
8478  return;
8479  }
8480  if( !isupper&&optype!=0 )
8481  {
8482 
8483  /*
8484  * (A1' A21')-1 ( X1 )
8485  * A^-1*X = ( ) *( )
8486  * ( A2') ( X2 )
8487  */
8488  cmatrixlefttrsm(s2, n, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2+s1, j2, _state);
8489  cmatrixgemm(s1, n, s2, ae_complex_from_d(-1.0), a, i1+s1, j1, optype, x, i2+s1, j2, 0, ae_complex_from_d(1.0), x, i2, j2, _state);
8490  cmatrixlefttrsm(s1, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8491  return;
8492  }
8493  }
8494 }
8495 
8496 
8497 /*************************************************************************
8498 Single-threaded stub. HPC ALGLIB replaces it by multithreaded code.
8499 *************************************************************************/
8501  ae_int_t n,
8502  /* Complex */ ae_matrix* a,
8503  ae_int_t i1,
8504  ae_int_t j1,
8505  ae_bool isupper,
8506  ae_bool isunit,
8507  ae_int_t optype,
8508  /* Complex */ ae_matrix* x,
8509  ae_int_t i2,
8510  ae_int_t j2, ae_state *_state)
8511 {
8512  cmatrixlefttrsm(m,n,a,i1,j1,isupper,isunit,optype,x,i2,j2, _state);
8513 }
8514 
8515 
8517  ae_int_t n,
8518  /* Real */ ae_matrix* a,
8519  ae_int_t i1,
8520  ae_int_t j1,
8521  ae_bool isupper,
8522  ae_bool isunit,
8523  ae_int_t optype,
8524  /* Real */ ae_matrix* x,
8525  ae_int_t i2,
8526  ae_int_t j2,
8527  ae_state *_state)
8528 {
8529  ae_int_t s1;
8530  ae_int_t s2;
8531  ae_int_t bs;
8532 
8533 
8534  bs = ablasblocksize(a, _state);
8535  if( m<=bs&&n<=bs )
8536  {
8537  ablas_rmatrixrighttrsm2(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8538  return;
8539  }
8540  if( m>=n )
8541  {
8542 
8543  /*
8544  * Split X: X*A = (X1 X2)^T*A
8545  */
8546  ablassplitlength(a, m, &s1, &s2, _state);
8547  rmatrixrighttrsm(s1, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8548  rmatrixrighttrsm(s2, n, a, i1, j1, isupper, isunit, optype, x, i2+s1, j2, _state);
8549  return;
8550  }
8551  else
8552  {
8553 
8554  /*
8555  * Split A:
8556  * (A1 A12)
8557  * X*op(A) = X*op( )
8558  * ( A2)
8559  *
8560  * Different variants depending on
8561  * IsUpper/OpType combinations
8562  */
8563  ablassplitlength(a, n, &s1, &s2, _state);
8564  if( isupper&&optype==0 )
8565  {
8566 
8567  /*
8568  * (A1 A12)-1
8569  * X*A^-1 = (X1 X2)*( )
8570  * ( A2)
8571  */
8572  rmatrixrighttrsm(m, s1, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8573  rmatrixgemm(m, s2, s1, -1.0, x, i2, j2, 0, a, i1, j1+s1, 0, 1.0, x, i2, j2+s1, _state);
8574  rmatrixrighttrsm(m, s2, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2, j2+s1, _state);
8575  return;
8576  }
8577  if( isupper&&optype!=0 )
8578  {
8579 
8580  /*
8581  * (A1' )-1
8582  * X*A^-1 = (X1 X2)*( )
8583  * (A12' A2')
8584  */
8585  rmatrixrighttrsm(m, s2, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2, j2+s1, _state);
8586  rmatrixgemm(m, s1, s2, -1.0, x, i2, j2+s1, 0, a, i1, j1+s1, optype, 1.0, x, i2, j2, _state);
8587  rmatrixrighttrsm(m, s1, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8588  return;
8589  }
8590  if( !isupper&&optype==0 )
8591  {
8592 
8593  /*
8594  * (A1 )-1
8595  * X*A^-1 = (X1 X2)*( )
8596  * (A21 A2)
8597  */
8598  rmatrixrighttrsm(m, s2, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2, j2+s1, _state);
8599  rmatrixgemm(m, s1, s2, -1.0, x, i2, j2+s1, 0, a, i1+s1, j1, 0, 1.0, x, i2, j2, _state);
8600  rmatrixrighttrsm(m, s1, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8601  return;
8602  }
8603  if( !isupper&&optype!=0 )
8604  {
8605 
8606  /*
8607  * (A1' A21')-1
8608  * X*A^-1 = (X1 X2)*( )
8609  * ( A2')
8610  */
8611  rmatrixrighttrsm(m, s1, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8612  rmatrixgemm(m, s2, s1, -1.0, x, i2, j2, 0, a, i1+s1, j1, optype, 1.0, x, i2, j2+s1, _state);
8613  rmatrixrighttrsm(m, s2, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2, j2+s1, _state);
8614  return;
8615  }
8616  }
8617 }
8618 
8619 
8620 /*************************************************************************
8621 Single-threaded stub. HPC ALGLIB replaces it by multithreaded code.
8622 *************************************************************************/
8624  ae_int_t n,
8625  /* Real */ ae_matrix* a,
8626  ae_int_t i1,
8627  ae_int_t j1,
8628  ae_bool isupper,
8629  ae_bool isunit,
8630  ae_int_t optype,
8631  /* Real */ ae_matrix* x,
8632  ae_int_t i2,
8633  ae_int_t j2, ae_state *_state)
8634 {
8635  rmatrixrighttrsm(m,n,a,i1,j1,isupper,isunit,optype,x,i2,j2, _state);
8636 }
8637 
8638 
8640  ae_int_t n,
8641  /* Real */ ae_matrix* a,
8642  ae_int_t i1,
8643  ae_int_t j1,
8644  ae_bool isupper,
8645  ae_bool isunit,
8646  ae_int_t optype,
8647  /* Real */ ae_matrix* x,
8648  ae_int_t i2,
8649  ae_int_t j2,
8650  ae_state *_state)
8651 {
8652  ae_int_t s1;
8653  ae_int_t s2;
8654  ae_int_t bs;
8655 
8656 
8657  bs = ablasblocksize(a, _state);
8658  if( m<=bs&&n<=bs )
8659  {
8660  ablas_rmatrixlefttrsm2(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8661  return;
8662  }
8663  if( n>=m )
8664  {
8665 
8666  /*
8667  * Split X: op(A)^-1*X = op(A)^-1*(X1 X2)
8668  */
8669  ablassplitlength(x, n, &s1, &s2, _state);
8670  rmatrixlefttrsm(m, s1, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8671  rmatrixlefttrsm(m, s2, a, i1, j1, isupper, isunit, optype, x, i2, j2+s1, _state);
8672  }
8673  else
8674  {
8675 
8676  /*
8677  * Split A
8678  */
8679  ablassplitlength(a, m, &s1, &s2, _state);
8680  if( isupper&&optype==0 )
8681  {
8682 
8683  /*
8684  * (A1 A12)-1 ( X1 )
8685  * A^-1*X* = ( ) *( )
8686  * ( A2) ( X2 )
8687  */
8688  rmatrixlefttrsm(s2, n, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2+s1, j2, _state);
8689  rmatrixgemm(s1, n, s2, -1.0, a, i1, j1+s1, 0, x, i2+s1, j2, 0, 1.0, x, i2, j2, _state);
8690  rmatrixlefttrsm(s1, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8691  return;
8692  }
8693  if( isupper&&optype!=0 )
8694  {
8695 
8696  /*
8697  * (A1' )-1 ( X1 )
8698  * A^-1*X = ( ) *( )
8699  * (A12' A2') ( X2 )
8700  */
8701  rmatrixlefttrsm(s1, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8702  rmatrixgemm(s2, n, s1, -1.0, a, i1, j1+s1, optype, x, i2, j2, 0, 1.0, x, i2+s1, j2, _state);
8703  rmatrixlefttrsm(s2, n, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2+s1, j2, _state);
8704  return;
8705  }
8706  if( !isupper&&optype==0 )
8707  {
8708 
8709  /*
8710  * (A1 )-1 ( X1 )
8711  * A^-1*X = ( ) *( )
8712  * (A21 A2) ( X2 )
8713  */
8714  rmatrixlefttrsm(s1, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8715  rmatrixgemm(s2, n, s1, -1.0, a, i1+s1, j1, 0, x, i2, j2, 0, 1.0, x, i2+s1, j2, _state);
8716  rmatrixlefttrsm(s2, n, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2+s1, j2, _state);
8717  return;
8718  }
8719  if( !isupper&&optype!=0 )
8720  {
8721 
8722  /*
8723  * (A1' A21')-1 ( X1 )
8724  * A^-1*X = ( ) *( )
8725  * ( A2') ( X2 )
8726  */
8727  rmatrixlefttrsm(s2, n, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2+s1, j2, _state);
8728  rmatrixgemm(s1, n, s2, -1.0, a, i1+s1, j1, optype, x, i2+s1, j2, 0, 1.0, x, i2, j2, _state);
8729  rmatrixlefttrsm(s1, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8730  return;
8731  }
8732  }
8733 }
8734 
8735 
8736 /*************************************************************************
8737 Single-threaded stub. HPC ALGLIB replaces it by multithreaded code.
8738 *************************************************************************/
8740  ae_int_t n,
8741  /* Real */ ae_matrix* a,
8742  ae_int_t i1,
8743  ae_int_t j1,
8744  ae_bool isupper,
8745  ae_bool isunit,
8746  ae_int_t optype,
8747  /* Real */ ae_matrix* x,
8748  ae_int_t i2,
8749  ae_int_t j2, ae_state *_state)
8750 {
8751  rmatrixlefttrsm(m,n,a,i1,j1,isupper,isunit,optype,x,i2,j2, _state);
8752 }
8753 
8754 
8756  ae_int_t k,
8757  double alpha,
8758  /* Complex */ ae_matrix* a,
8759  ae_int_t ia,
8760  ae_int_t ja,
8761  ae_int_t optypea,
8762  double beta,
8763  /* Complex */ ae_matrix* c,
8764  ae_int_t ic,
8765  ae_int_t jc,
8766  ae_bool isupper,
8767  ae_state *_state)
8768 {
8769  ae_int_t s1;
8770  ae_int_t s2;
8771  ae_int_t bs;
8772 
8773 
8774  bs = ablascomplexblocksize(a, _state);
8775  if( n<=bs&&k<=bs )
8776  {
8777  ablas_cmatrixsyrk2(n, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8778  return;
8779  }
8780  if( k>=n )
8781  {
8782 
8783  /*
8784  * Split K
8785  */
8786  ablascomplexsplitlength(a, k, &s1, &s2, _state);
8787  if( optypea==0 )
8788  {
8789  cmatrixsyrk(n, s1, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8790  cmatrixsyrk(n, s2, alpha, a, ia, ja+s1, optypea, 1.0, c, ic, jc, isupper, _state);
8791  }
8792  else
8793  {
8794  cmatrixsyrk(n, s1, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8795  cmatrixsyrk(n, s2, alpha, a, ia+s1, ja, optypea, 1.0, c, ic, jc, isupper, _state);
8796  }
8797  }
8798  else
8799  {
8800 
8801  /*
8802  * Split N
8803  */
8804  ablascomplexsplitlength(a, n, &s1, &s2, _state);
8805  if( optypea==0&&isupper )
8806  {
8807  cmatrixsyrk(s1, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8808  cmatrixgemm(s1, s2, k, ae_complex_from_d(alpha), a, ia, ja, 0, a, ia+s1, ja, 2, ae_complex_from_d(beta), c, ic, jc+s1, _state);
8809  cmatrixsyrk(s2, k, alpha, a, ia+s1, ja, optypea, beta, c, ic+s1, jc+s1, isupper, _state);
8810  return;
8811  }
8812  if( optypea==0&&!isupper )
8813  {
8814  cmatrixsyrk(s1, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8815  cmatrixgemm(s2, s1, k, ae_complex_from_d(alpha), a, ia+s1, ja, 0, a, ia, ja, 2, ae_complex_from_d(beta), c, ic+s1, jc, _state);
8816  cmatrixsyrk(s2, k, alpha, a, ia+s1, ja, optypea, beta, c, ic+s1, jc+s1, isupper, _state);
8817  return;
8818  }
8819  if( optypea!=0&&isupper )
8820  {
8821  cmatrixsyrk(s1, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8822  cmatrixgemm(s1, s2, k, ae_complex_from_d(alpha), a, ia, ja, 2, a, ia, ja+s1, 0, ae_complex_from_d(beta), c, ic, jc+s1, _state);
8823  cmatrixsyrk(s2, k, alpha, a, ia, ja+s1, optypea, beta, c, ic+s1, jc+s1, isupper, _state);
8824  return;
8825  }
8826  if( optypea!=0&&!isupper )
8827  {
8828  cmatrixsyrk(s1, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8829  cmatrixgemm(s2, s1, k, ae_complex_from_d(alpha), a, ia, ja+s1, 2, a, ia, ja, 0, ae_complex_from_d(beta), c, ic+s1, jc, _state);
8830  cmatrixsyrk(s2, k, alpha, a, ia, ja+s1, optypea, beta, c, ic+s1, jc+s1, isupper, _state);
8831  return;
8832  }
8833  }
8834 }
8835 
8836 
8837 /*************************************************************************
8838 Single-threaded stub. HPC ALGLIB replaces it by multithreaded code.
8839 *************************************************************************/
8841  ae_int_t k,
8842  double alpha,
8843  /* Complex */ ae_matrix* a,
8844  ae_int_t ia,
8845  ae_int_t ja,
8846  ae_int_t optypea,
8847  double beta,
8848  /* Complex */ ae_matrix* c,
8849  ae_int_t ic,
8850  ae_int_t jc,
8851  ae_bool isupper, ae_state *_state)
8852 {
8853  cmatrixsyrk(n,k,alpha,a,ia,ja,optypea,beta,c,ic,jc,isupper, _state);
8854 }
8855 
8856 
8858  ae_int_t k,
8859  double alpha,
8860  /* Real */ ae_matrix* a,
8861  ae_int_t ia,
8862  ae_int_t ja,
8863  ae_int_t optypea,
8864  double beta,
8865  /* Real */ ae_matrix* c,
8866  ae_int_t ic,
8867  ae_int_t jc,
8868  ae_bool isupper,
8869  ae_state *_state)
8870 {
8871  ae_int_t s1;
8872  ae_int_t s2;
8873  ae_int_t bs;
8874 
8875 
8876  bs = ablasblocksize(a, _state);
8877 
8878  /*
8879  * Use MKL or generic basecase code
8880  */
8881  if( rmatrixsyrkmkl(n, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state) )
8882  {
8883  return;
8884  }
8885  if( n<=bs&&k<=bs )
8886  {
8887  ablas_rmatrixsyrk2(n, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8888  return;
8889  }
8890 
8891  /*
8892  * Recursive subdivision of the problem
8893  */
8894  if( k>=n )
8895  {
8896 
8897  /*
8898  * Split K
8899  */
8900  ablassplitlength(a, k, &s1, &s2, _state);
8901  if( optypea==0 )
8902  {
8903  rmatrixsyrk(n, s1, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8904  rmatrixsyrk(n, s2, alpha, a, ia, ja+s1, optypea, 1.0, c, ic, jc, isupper, _state);
8905  }
8906  else
8907  {
8908  rmatrixsyrk(n, s1, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8909  rmatrixsyrk(n, s2, alpha, a, ia+s1, ja, optypea, 1.0, c, ic, jc, isupper, _state);
8910  }
8911  }
8912  else
8913  {
8914 
8915  /*
8916  * Split N
8917  */
8918  ablassplitlength(a, n, &s1, &s2, _state);
8919  if( optypea==0&&isupper )
8920  {
8921  rmatrixsyrk(s1, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8922  rmatrixgemm(s1, s2, k, alpha, a, ia, ja, 0, a, ia+s1, ja, 1, beta, c, ic, jc+s1, _state);
8923  rmatrixsyrk(s2, k, alpha, a, ia+s1, ja, optypea, beta, c, ic+s1, jc+s1, isupper, _state);
8924  return;
8925  }
8926  if( optypea==0&&!isupper )
8927  {
8928  rmatrixsyrk(s1, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8929  rmatrixgemm(s2, s1, k, alpha, a, ia+s1, ja, 0, a, ia, ja, 1, beta, c, ic+s1, jc, _state);
8930  rmatrixsyrk(s2, k, alpha, a, ia+s1, ja, optypea, beta, c, ic+s1, jc+s1, isupper, _state);
8931  return;
8932  }
8933  if( optypea!=0&&isupper )
8934  {
8935  rmatrixsyrk(s1, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8936  rmatrixgemm(s1, s2, k, alpha, a, ia, ja, 1, a, ia, ja+s1, 0, beta, c, ic, jc+s1, _state);
8937  rmatrixsyrk(s2, k, alpha, a, ia, ja+s1, optypea, beta, c, ic+s1, jc+s1, isupper, _state);
8938  return;
8939  }
8940  if( optypea!=0&&!isupper )
8941  {
8942  rmatrixsyrk(s1, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8943  rmatrixgemm(s2, s1, k, alpha, a, ia, ja+s1, 1, a, ia, ja, 0, beta, c, ic+s1, jc, _state);
8944  rmatrixsyrk(s2, k, alpha, a, ia, ja+s1, optypea, beta, c, ic+s1, jc+s1, isupper, _state);
8945  return;
8946  }
8947  }
8948 }
8949 
8950 
8951 /*************************************************************************
8952 Single-threaded stub. HPC ALGLIB replaces it by multithreaded code.
8953 *************************************************************************/
8955  ae_int_t k,
8956  double alpha,
8957  /* Real */ ae_matrix* a,
8958  ae_int_t ia,
8959  ae_int_t ja,
8960  ae_int_t optypea,
8961  double beta,
8962  /* Real */ ae_matrix* c,
8963  ae_int_t ic,
8964  ae_int_t jc,
8965  ae_bool isupper, ae_state *_state)
8966 {
8967  rmatrixsyrk(n,k,alpha,a,ia,ja,optypea,beta,c,ic,jc,isupper, _state);
8968 }
8969 
8970 
8972  ae_int_t n,
8973  ae_int_t k,
8974  ae_complex alpha,
8975  /* Complex */ ae_matrix* a,
8976  ae_int_t ia,
8977  ae_int_t ja,
8978  ae_int_t optypea,
8979  /* Complex */ ae_matrix* b,
8980  ae_int_t ib,
8981  ae_int_t jb,
8982  ae_int_t optypeb,
8983  ae_complex beta,
8984  /* Complex */ ae_matrix* c,
8985  ae_int_t ic,
8986  ae_int_t jc,
8987  ae_state *_state)
8988 {
8989  ae_int_t s1;
8990  ae_int_t s2;
8991  ae_int_t bs;
8992 
8993 
8994  bs = ablascomplexblocksize(a, _state);
8995  if( (m<=bs&&n<=bs)&&k<=bs )
8996  {
8997  cmatrixgemmk(m, n, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
8998  return;
8999  }
9000 
9001  /*
9002  * SMP support is turned on when M or N are larger than some boundary value.
9003  * Magnitude of K is not taken into account because splitting on K does not
9004  * allow us to spawn child tasks.
9005  */
9006 
9007  /*
9008  * Recursive algorithm: parallel splitting on M/N
9009  */
9010  if( m>=n&&m>=k )
9011  {
9012 
9013  /*
9014  * A*B = (A1 A2)^T*B
9015  */
9016  ablascomplexsplitlength(a, m, &s1, &s2, _state);
9017  cmatrixgemm(s1, n, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9018  if( optypea==0 )
9019  {
9020  cmatrixgemm(s2, n, k, alpha, a, ia+s1, ja, optypea, b, ib, jb, optypeb, beta, c, ic+s1, jc, _state);
9021  }
9022  else
9023  {
9024  cmatrixgemm(s2, n, k, alpha, a, ia, ja+s1, optypea, b, ib, jb, optypeb, beta, c, ic+s1, jc, _state);
9025  }
9026  return;
9027  }
9028  if( n>=m&&n>=k )
9029  {
9030 
9031  /*
9032  * A*B = A*(B1 B2)
9033  */
9034  ablascomplexsplitlength(a, n, &s1, &s2, _state);
9035  if( optypeb==0 )
9036  {
9037  cmatrixgemm(m, s1, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9038  cmatrixgemm(m, s2, k, alpha, a, ia, ja, optypea, b, ib, jb+s1, optypeb, beta, c, ic, jc+s1, _state);
9039  }
9040  else
9041  {
9042  cmatrixgemm(m, s1, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9043  cmatrixgemm(m, s2, k, alpha, a, ia, ja, optypea, b, ib+s1, jb, optypeb, beta, c, ic, jc+s1, _state);
9044  }
9045  return;
9046  }
9047 
9048  /*
9049  * Recursive algorithm: serial splitting on K
9050  */
9051 
9052  /*
9053  * A*B = (A1 A2)*(B1 B2)^T
9054  */
9055  ablascomplexsplitlength(a, k, &s1, &s2, _state);
9056  if( optypea==0&&optypeb==0 )
9057  {
9058  cmatrixgemm(m, n, s1, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9059  cmatrixgemm(m, n, s2, alpha, a, ia, ja+s1, optypea, b, ib+s1, jb, optypeb, ae_complex_from_d(1.0), c, ic, jc, _state);
9060  }
9061  if( optypea==0&&optypeb!=0 )
9062  {
9063  cmatrixgemm(m, n, s1, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9064  cmatrixgemm(m, n, s2, alpha, a, ia, ja+s1, optypea, b, ib, jb+s1, optypeb, ae_complex_from_d(1.0), c, ic, jc, _state);
9065  }
9066  if( optypea!=0&&optypeb==0 )
9067  {
9068  cmatrixgemm(m, n, s1, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9069  cmatrixgemm(m, n, s2, alpha, a, ia+s1, ja, optypea, b, ib+s1, jb, optypeb, ae_complex_from_d(1.0), c, ic, jc, _state);
9070  }
9071  if( optypea!=0&&optypeb!=0 )
9072  {
9073  cmatrixgemm(m, n, s1, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9074  cmatrixgemm(m, n, s2, alpha, a, ia+s1, ja, optypea, b, ib, jb+s1, optypeb, ae_complex_from_d(1.0), c, ic, jc, _state);
9075  }
9076  return;
9077 }
9078 
9079 
9080 /*************************************************************************
9081 Single-threaded stub. HPC ALGLIB replaces it by multithreaded code.
9082 *************************************************************************/
9084  ae_int_t n,
9085  ae_int_t k,
9086  ae_complex alpha,
9087  /* Complex */ ae_matrix* a,
9088  ae_int_t ia,
9089  ae_int_t ja,
9090  ae_int_t optypea,
9091  /* Complex */ ae_matrix* b,
9092  ae_int_t ib,
9093  ae_int_t jb,
9094  ae_int_t optypeb,
9095  ae_complex beta,
9096  /* Complex */ ae_matrix* c,
9097  ae_int_t ic,
9098  ae_int_t jc, ae_state *_state)
9099 {
9100  cmatrixgemm(m,n,k,alpha,a,ia,ja,optypea,b,ib,jb,optypeb,beta,c,ic,jc, _state);
9101 }
9102 
9103 
9105  ae_int_t n,
9106  ae_int_t k,
9107  double alpha,
9108  /* Real */ ae_matrix* a,
9109  ae_int_t ia,
9110  ae_int_t ja,
9111  ae_int_t optypea,
9112  /* Real */ ae_matrix* b,
9113  ae_int_t ib,
9114  ae_int_t jb,
9115  ae_int_t optypeb,
9116  double beta,
9117  /* Real */ ae_matrix* c,
9118  ae_int_t ic,
9119  ae_int_t jc,
9120  ae_state *_state)
9121 {
9122  ae_int_t s1;
9123  ae_int_t s2;
9124  ae_int_t bs;
9125 
9126 
9127  bs = ablasblocksize(a, _state);
9128 
9129  /*
9130  * Check input sizes for correctness
9131  */
9132  ae_assert(optypea==0||optypea==1, "RMatrixGEMM: incorrect OpTypeA (must be 0 or 1)", _state);
9133  ae_assert(optypeb==0||optypeb==1, "RMatrixGEMM: incorrect OpTypeB (must be 0 or 1)", _state);
9134  ae_assert(ic+m<=c->rows, "RMatrixGEMM: incorect size of output matrix C", _state);
9135  ae_assert(jc+n<=c->cols, "RMatrixGEMM: incorect size of output matrix C", _state);
9136 
9137  /*
9138  * Use MKL or ALGLIB basecase code
9139  */
9140  if( rmatrixgemmmkl(m, n, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state) )
9141  {
9142  return;
9143  }
9144  if( (m<=bs&&n<=bs)&&k<=bs )
9145  {
9146  rmatrixgemmk(m, n, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9147  return;
9148  }
9149 
9150  /*
9151  * SMP support is turned on when M or N are larger than some boundary value.
9152  * Magnitude of K is not taken into account because splitting on K does not
9153  * allow us to spawn child tasks.
9154  */
9155 
9156  /*
9157  * Recursive algorithm: split on M or N
9158  */
9159  if( m>=n&&m>=k )
9160  {
9161 
9162  /*
9163  * A*B = (A1 A2)^T*B
9164  */
9165  ablassplitlength(a, m, &s1, &s2, _state);
9166  if( optypea==0 )
9167  {
9168  rmatrixgemm(s1, n, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9169  rmatrixgemm(s2, n, k, alpha, a, ia+s1, ja, optypea, b, ib, jb, optypeb, beta, c, ic+s1, jc, _state);
9170  }
9171  else
9172  {
9173  rmatrixgemm(s1, n, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9174  rmatrixgemm(s2, n, k, alpha, a, ia, ja+s1, optypea, b, ib, jb, optypeb, beta, c, ic+s1, jc, _state);
9175  }
9176  return;
9177  }
9178  if( n>=m&&n>=k )
9179  {
9180 
9181  /*
9182  * A*B = A*(B1 B2)
9183  */
9184  ablassplitlength(a, n, &s1, &s2, _state);
9185  if( optypeb==0 )
9186  {
9187  rmatrixgemm(m, s1, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9188  rmatrixgemm(m, s2, k, alpha, a, ia, ja, optypea, b, ib, jb+s1, optypeb, beta, c, ic, jc+s1, _state);
9189  }
9190  else
9191  {
9192  rmatrixgemm(m, s1, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9193  rmatrixgemm(m, s2, k, alpha, a, ia, ja, optypea, b, ib+s1, jb, optypeb, beta, c, ic, jc+s1, _state);
9194  }
9195  return;
9196  }
9197 
9198  /*
9199  * Recursive algorithm: split on K
9200  */
9201 
9202  /*
9203  * A*B = (A1 A2)*(B1 B2)^T
9204  */
9205  ablassplitlength(a, k, &s1, &s2, _state);
9206  if( optypea==0&&optypeb==0 )
9207  {
9208  rmatrixgemm(m, n, s1, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9209  rmatrixgemm(m, n, s2, alpha, a, ia, ja+s1, optypea, b, ib+s1, jb, optypeb, 1.0, c, ic, jc, _state);
9210  }
9211  if( optypea==0&&optypeb!=0 )
9212  {
9213  rmatrixgemm(m, n, s1, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9214  rmatrixgemm(m, n, s2, alpha, a, ia, ja+s1, optypea, b, ib, jb+s1, optypeb, 1.0, c, ic, jc, _state);
9215  }
9216  if( optypea!=0&&optypeb==0 )
9217  {
9218  rmatrixgemm(m, n, s1, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9219  rmatrixgemm(m, n, s2, alpha, a, ia+s1, ja, optypea, b, ib+s1, jb, optypeb, 1.0, c, ic, jc, _state);
9220  }
9221  if( optypea!=0&&optypeb!=0 )
9222  {
9223  rmatrixgemm(m, n, s1, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9224  rmatrixgemm(m, n, s2, alpha, a, ia+s1, ja, optypea, b, ib, jb+s1, optypeb, 1.0, c, ic, jc, _state);
9225  }
9226  return;
9227 }
9228 
9229 
9230 /*************************************************************************
9231 Single-threaded stub. HPC ALGLIB replaces it by multithreaded code.
9232 *************************************************************************/
9234  ae_int_t n,
9235  ae_int_t k,
9236  double alpha,
9237  /* Real */ ae_matrix* a,
9238  ae_int_t ia,
9239  ae_int_t ja,
9240  ae_int_t optypea,
9241  /* Real */ ae_matrix* b,
9242  ae_int_t ib,
9243  ae_int_t jb,
9244  ae_int_t optypeb,
9245  double beta,
9246  /* Real */ ae_matrix* c,
9247  ae_int_t ic,
9248  ae_int_t jc, ae_state *_state)
9249 {
9250  rmatrixgemm(m,n,k,alpha,a,ia,ja,optypea,b,ib,jb,optypeb,beta,c,ic,jc, _state);
9251 }
9252 
9253 
9254 /*************************************************************************
9255 Complex ABLASSplitLength
9256 
9257  -- ALGLIB routine --
9258  15.12.2009
9259  Bochkanov Sergey
9260 *************************************************************************/
9261 static void ablas_ablasinternalsplitlength(ae_int_t n,
9262  ae_int_t nb,
9263  ae_int_t* n1,
9264  ae_int_t* n2,
9265  ae_state *_state)
9266 {
9267  ae_int_t r;
9268 
9269  *n1 = 0;
9270  *n2 = 0;
9271 
9272  if( n<=nb )
9273  {
9274 
9275  /*
9276  * Block size, no further splitting
9277  */
9278  *n1 = n;
9279  *n2 = 0;
9280  }
9281  else
9282  {
9283 
9284  /*
9285  * Greater than block size
9286  */
9287  if( n%nb!=0 )
9288  {
9289 
9290  /*
9291  * Split remainder
9292  */
9293  *n2 = n%nb;
9294  *n1 = n-(*n2);
9295  }
9296  else
9297  {
9298 
9299  /*
9300  * Split on block boundaries
9301  */
9302  *n2 = n/2;
9303  *n1 = n-(*n2);
9304  if( *n1%nb==0 )
9305  {
9306  return;
9307  }
9308  r = nb-*n1%nb;
9309  *n1 = *n1+r;
9310  *n2 = *n2-r;
9311  }
9312  }
9313 }
9314 
9315 
9316 /*************************************************************************
9317 Level 2 variant of CMatrixRightTRSM
9318 *************************************************************************/
9319 static void ablas_cmatrixrighttrsm2(ae_int_t m,
9320  ae_int_t n,
9321  /* Complex */ ae_matrix* a,
9322  ae_int_t i1,
9323  ae_int_t j1,
9324  ae_bool isupper,
9325  ae_bool isunit,
9326  ae_int_t optype,
9327  /* Complex */ ae_matrix* x,
9328  ae_int_t i2,
9329  ae_int_t j2,
9330  ae_state *_state)
9331 {
9332  ae_int_t i;
9333  ae_int_t j;
9334  ae_complex vc;
9335  ae_complex vd;
9336 
9337 
9338 
9339  /*
9340  * Special case
9341  */
9342  if( n*m==0 )
9343  {
9344  return;
9345  }
9346 
9347  /*
9348  * Try to call fast TRSM
9349  */
9350  if( cmatrixrighttrsmf(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state) )
9351  {
9352  return;
9353  }
9354 
9355  /*
9356  * General case
9357  */
9358  if( isupper )
9359  {
9360 
9361  /*
9362  * Upper triangular matrix
9363  */
9364  if( optype==0 )
9365  {
9366 
9367  /*
9368  * X*A^(-1)
9369  */
9370  for(i=0; i<=m-1; i++)
9371  {
9372  for(j=0; j<=n-1; j++)
9373  {
9374  if( isunit )
9375  {
9376  vd = ae_complex_from_d(1);
9377  }
9378  else
9379  {
9380  vd = a->ptr.pp_complex[i1+j][j1+j];
9381  }
9382  x->ptr.pp_complex[i2+i][j2+j] = ae_c_div(x->ptr.pp_complex[i2+i][j2+j],vd);
9383  if( j<n-1 )
9384  {
9385  vc = x->ptr.pp_complex[i2+i][j2+j];
9386  ae_v_csubc(&x->ptr.pp_complex[i2+i][j2+j+1], 1, &a->ptr.pp_complex[i1+j][j1+j+1], 1, "N", ae_v_len(j2+j+1,j2+n-1), vc);
9387  }
9388  }
9389  }
9390  return;
9391  }
9392  if( optype==1 )
9393  {
9394 
9395  /*
9396  * X*A^(-T)
9397  */
9398  for(i=0; i<=m-1; i++)
9399  {
9400  for(j=n-1; j>=0; j--)
9401  {
9402  vc = ae_complex_from_d(0);
9403  vd = ae_complex_from_d(1);
9404  if( j<n-1 )
9405  {
9406  vc = ae_v_cdotproduct(&x->ptr.pp_complex[i2+i][j2+j+1], 1, "N", &a->ptr.pp_complex[i1+j][j1+j+1], 1, "N", ae_v_len(j2+j+1,j2+n-1));
9407  }
9408  if( !isunit )
9409  {
9410  vd = a->ptr.pp_complex[i1+j][j1+j];
9411  }
9412  x->ptr.pp_complex[i2+i][j2+j] = ae_c_div(ae_c_sub(x->ptr.pp_complex[i2+i][j2+j],vc),vd);
9413  }
9414  }
9415  return;
9416  }
9417  if( optype==2 )
9418  {
9419 
9420  /*
9421  * X*A^(-H)
9422  */
9423  for(i=0; i<=m-1; i++)
9424  {
9425  for(j=n-1; j>=0; j--)
9426  {
9427  vc = ae_complex_from_d(0);
9428  vd = ae_complex_from_d(1);
9429  if( j<n-1 )
9430  {
9431  vc = ae_v_cdotproduct(&x->ptr.pp_complex[i2+i][j2+j+1], 1, "N", &a->ptr.pp_complex[i1+j][j1+j+1], 1, "Conj", ae_v_len(j2+j+1,j2+n-1));
9432  }
9433  if( !isunit )
9434  {
9435  vd = ae_c_conj(a->ptr.pp_complex[i1+j][j1+j], _state);
9436  }
9437  x->ptr.pp_complex[i2+i][j2+j] = ae_c_div(ae_c_sub(x->ptr.pp_complex[i2+i][j2+j],vc),vd);
9438  }
9439  }
9440  return;
9441  }
9442  }
9443  else
9444  {
9445 
9446  /*
9447  * Lower triangular matrix
9448  */
9449  if( optype==0 )
9450  {
9451 
9452  /*
9453  * X*A^(-1)
9454  */
9455  for(i=0; i<=m-1; i++)
9456  {
9457  for(j=n-1; j>=0; j--)
9458  {
9459  if( isunit )
9460  {
9461  vd = ae_complex_from_d(1);
9462  }
9463  else
9464  {
9465  vd = a->ptr.pp_complex[i1+j][j1+j];
9466  }
9467  x->ptr.pp_complex[i2+i][j2+j] = ae_c_div(x->ptr.pp_complex[i2+i][j2+j],vd);
9468  if( j>0 )
9469  {
9470  vc = x->ptr.pp_complex[i2+i][j2+j];
9471  ae_v_csubc(&x->ptr.pp_complex[i2+i][j2], 1, &a->ptr.pp_complex[i1+j][j1], 1, "N", ae_v_len(j2,j2+j-1), vc);
9472  }
9473  }
9474  }
9475  return;
9476  }
9477  if( optype==1 )
9478  {
9479 
9480  /*
9481  * X*A^(-T)
9482  */
9483  for(i=0; i<=m-1; i++)
9484  {
9485  for(j=0; j<=n-1; j++)
9486  {
9487  vc = ae_complex_from_d(0);
9488  vd = ae_complex_from_d(1);
9489  if( j>0 )
9490  {
9491  vc = ae_v_cdotproduct(&x->ptr.pp_complex[i2+i][j2], 1, "N", &a->ptr.pp_complex[i1+j][j1], 1, "N", ae_v_len(j2,j2+j-1));
9492  }
9493  if( !isunit )
9494  {
9495  vd = a->ptr.pp_complex[i1+j][j1+j];
9496  }
9497  x->ptr.pp_complex[i2+i][j2+j] = ae_c_div(ae_c_sub(x->ptr.pp_complex[i2+i][j2+j],vc),vd);
9498  }
9499  }
9500  return;
9501  }
9502  if( optype==2 )
9503  {
9504 
9505  /*
9506  * X*A^(-H)
9507  */
9508  for(i=0; i<=m-1; i++)
9509  {
9510  for(j=0; j<=n-1; j++)
9511  {
9512  vc = ae_complex_from_d(0);
9513  vd = ae_complex_from_d(1);
9514  if( j>0 )
9515  {
9516  vc = ae_v_cdotproduct(&x->ptr.pp_complex[i2+i][j2], 1, "N", &a->ptr.pp_complex[i1+j][j1], 1, "Conj", ae_v_len(j2,j2+j-1));
9517  }
9518  if( !isunit )
9519  {
9520  vd = ae_c_conj(a->ptr.pp_complex[i1+j][j1+j], _state);
9521  }
9522  x->ptr.pp_complex[i2+i][j2+j] = ae_c_div(ae_c_sub(x->ptr.pp_complex[i2+i][j2+j],vc),vd);
9523  }
9524  }
9525  return;
9526  }
9527  }
9528 }
9529 
9530 
9531 /*************************************************************************
9532 Level-2 subroutine
9533 *************************************************************************/
9534 static void ablas_cmatrixlefttrsm2(ae_int_t m,
9535  ae_int_t n,
9536  /* Complex */ ae_matrix* a,
9537  ae_int_t i1,
9538  ae_int_t j1,
9539  ae_bool isupper,
9540  ae_bool isunit,
9541  ae_int_t optype,
9542  /* Complex */ ae_matrix* x,
9543  ae_int_t i2,
9544  ae_int_t j2,
9545  ae_state *_state)
9546 {
9547  ae_int_t i;
9548  ae_int_t j;
9549  ae_complex vc;
9550  ae_complex vd;
9551 
9552 
9553 
9554  /*
9555  * Special case
9556  */
9557  if( n*m==0 )
9558  {
9559  return;
9560  }
9561 
9562  /*
9563  * Try to call fast TRSM
9564  */
9565  if( cmatrixlefttrsmf(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state) )
9566  {
9567  return;
9568  }
9569 
9570  /*
9571  * General case
9572  */
9573  if( isupper )
9574  {
9575 
9576  /*
9577  * Upper triangular matrix
9578  */
9579  if( optype==0 )
9580  {
9581 
9582  /*
9583  * A^(-1)*X
9584  */
9585  for(i=m-1; i>=0; i--)
9586  {
9587  for(j=i+1; j<=m-1; j++)
9588  {
9589  vc = a->ptr.pp_complex[i1+i][j1+j];
9590  ae_v_csubc(&x->ptr.pp_complex[i2+i][j2], 1, &x->ptr.pp_complex[i2+j][j2], 1, "N", ae_v_len(j2,j2+n-1), vc);
9591  }
9592  if( !isunit )
9593  {
9594  vd = ae_c_d_div(1,a->ptr.pp_complex[i1+i][j1+i]);
9595  ae_v_cmulc(&x->ptr.pp_complex[i2+i][j2], 1, ae_v_len(j2,j2+n-1), vd);
9596  }
9597  }
9598  return;
9599  }
9600  if( optype==1 )
9601  {
9602 
9603  /*
9604  * A^(-T)*X
9605  */
9606  for(i=0; i<=m-1; i++)
9607  {
9608  if( isunit )
9609  {
9610  vd = ae_complex_from_d(1);
9611  }
9612  else
9613  {
9614  vd = ae_c_d_div(1,a->ptr.pp_complex[i1+i][j1+i]);
9615  }
9616  ae_v_cmulc(&x->ptr.pp_complex[i2+i][j2], 1, ae_v_len(j2,j2+n-1), vd);
9617  for(j=i+1; j<=m-1; j++)
9618  {
9619  vc = a->ptr.pp_complex[i1+i][j1+j];
9620  ae_v_csubc(&x->ptr.pp_complex[i2+j][j2], 1, &x->ptr.pp_complex[i2+i][j2], 1, "N", ae_v_len(j2,j2+n-1), vc);
9621  }
9622  }
9623  return;
9624  }
9625  if( optype==2 )
9626  {
9627 
9628  /*
9629  * A^(-H)*X
9630  */
9631  for(i=0; i<=m-1; i++)
9632  {
9633  if( isunit )
9634  {
9635  vd = ae_complex_from_d(1);
9636  }
9637  else
9638  {
9639  vd = ae_c_d_div(1,ae_c_conj(a->ptr.pp_complex[i1+i][j1+i], _state));
9640  }
9641  ae_v_cmulc(&x->ptr.pp_complex[i2+i][j2], 1, ae_v_len(j2,j2+n-1), vd);
9642  for(j=i+1; j<=m-1; j++)
9643  {
9644  vc = ae_c_conj(a->ptr.pp_complex[i1+i][j1+j], _state);
9645  ae_v_csubc(&x->ptr.pp_complex[i2+j][j2], 1, &x->ptr.pp_complex[i2+i][j2], 1, "N", ae_v_len(j2,j2+n-1), vc);
9646  }
9647  }
9648  return;
9649  }
9650  }
9651  else
9652  {
9653 
9654  /*
9655  * Lower triangular matrix
9656  */
9657  if( optype==0 )
9658  {
9659 
9660  /*
9661  * A^(-1)*X
9662  */
9663  for(i=0; i<=m-1; i++)
9664  {
9665  for(j=0; j<=i-1; j++)
9666  {
9667  vc = a->ptr.pp_complex[i1+i][j1+j];
9668  ae_v_csubc(&x->ptr.pp_complex[i2+i][j2], 1, &x->ptr.pp_complex[i2+j][j2], 1, "N", ae_v_len(j2,j2+n-1), vc);
9669  }
9670  if( isunit )
9671  {
9672  vd = ae_complex_from_d(1);
9673  }
9674  else
9675  {
9676  vd = ae_c_d_div(1,a->ptr.pp_complex[i1+j][j1+j]);
9677  }
9678  ae_v_cmulc(&x->ptr.pp_complex[i2+i][j2], 1, ae_v_len(j2,j2+n-1), vd);
9679  }
9680  return;
9681  }
9682  if( optype==1 )
9683  {
9684 
9685  /*
9686  * A^(-T)*X
9687  */
9688  for(i=m-1; i>=0; i--)
9689  {
9690  if( isunit )
9691  {
9692  vd = ae_complex_from_d(1);
9693  }
9694  else
9695  {
9696  vd = ae_c_d_div(1,a->ptr.pp_complex[i1+i][j1+i]);
9697  }
9698  ae_v_cmulc(&x->ptr.pp_complex[i2+i][j2], 1, ae_v_len(j2,j2+n-1), vd);
9699  for(j=i-1; j>=0; j--)
9700  {
9701  vc = a->ptr.pp_complex[i1+i][j1+j];
9702  ae_v_csubc(&x->ptr.pp_complex[i2+j][j2], 1, &x->ptr.pp_complex[i2+i][j2], 1, "N", ae_v_len(j2,j2+n-1), vc);
9703  }
9704  }
9705  return;
9706  }
9707  if( optype==2 )
9708  {
9709 
9710  /*
9711  * A^(-H)*X
9712  */
9713  for(i=m-1; i>=0; i--)
9714  {
9715  if( isunit )
9716  {
9717  vd = ae_complex_from_d(1);
9718  }
9719  else
9720  {
9721  vd = ae_c_d_div(1,ae_c_conj(a->ptr.pp_complex[i1+i][j1+i], _state));
9722  }
9723  ae_v_cmulc(&x->ptr.pp_complex[i2+i][j2], 1, ae_v_len(j2,j2+n-1), vd);
9724  for(j=i-1; j>=0; j--)
9725  {
9726  vc = ae_c_conj(a->ptr.pp_complex[i1+i][j1+j], _state);
9727  ae_v_csubc(&x->ptr.pp_complex[i2+j][j2], 1, &x->ptr.pp_complex[i2+i][j2], 1, "N", ae_v_len(j2,j2+n-1), vc);
9728  }
9729  }
9730  return;
9731  }
9732  }
9733 }
9734 
9735 
9736 /*************************************************************************
9737 Level 2 subroutine
9738 
9739  -- ALGLIB routine --
9740  15.12.2009
9741  Bochkanov Sergey
9742 *************************************************************************/
9743 static void ablas_rmatrixrighttrsm2(ae_int_t m,
9744  ae_int_t n,
9745  /* Real */ ae_matrix* a,
9746  ae_int_t i1,
9747  ae_int_t j1,
9748  ae_bool isupper,
9749  ae_bool isunit,
9750  ae_int_t optype,
9751  /* Real */ ae_matrix* x,
9752  ae_int_t i2,
9753  ae_int_t j2,
9754  ae_state *_state)
9755 {
9756  ae_int_t i;
9757  ae_int_t j;
9758  double vr;
9759  double vd;
9760 
9761 
9762 
9763  /*
9764  * Special case
9765  */
9766  if( n*m==0 )
9767  {
9768  return;
9769  }
9770 
9771  /*
9772  * Try to use "fast" code
9773  */
9774  if( rmatrixrighttrsmf(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state) )
9775  {
9776  return;
9777  }
9778 
9779  /*
9780  * General case
9781  */
9782  if( isupper )
9783  {
9784 
9785  /*
9786  * Upper triangular matrix
9787  */
9788  if( optype==0 )
9789  {
9790 
9791  /*
9792  * X*A^(-1)
9793  */
9794  for(i=0; i<=m-1; i++)
9795  {
9796  for(j=0; j<=n-1; j++)
9797  {
9798  if( isunit )
9799  {
9800  vd = 1;
9801  }
9802  else
9803  {
9804  vd = a->ptr.pp_double[i1+j][j1+j];
9805  }
9806  x->ptr.pp_double[i2+i][j2+j] = x->ptr.pp_double[i2+i][j2+j]/vd;
9807  if( j<n-1 )
9808  {
9809  vr = x->ptr.pp_double[i2+i][j2+j];
9810  ae_v_subd(&x->ptr.pp_double[i2+i][j2+j+1], 1, &a->ptr.pp_double[i1+j][j1+j+1], 1, ae_v_len(j2+j+1,j2+n-1), vr);
9811  }
9812  }
9813  }
9814  return;
9815  }
9816  if( optype==1 )
9817  {
9818 
9819  /*
9820  * X*A^(-T)
9821  */
9822  for(i=0; i<=m-1; i++)
9823  {
9824  for(j=n-1; j>=0; j--)
9825  {
9826  vr = 0;
9827  vd = 1;
9828  if( j<n-1 )
9829  {
9830  vr = ae_v_dotproduct(&x->ptr.pp_double[i2+i][j2+j+1], 1, &a->ptr.pp_double[i1+j][j1+j+1], 1, ae_v_len(j2+j+1,j2+n-1));
9831  }
9832  if( !isunit )
9833  {
9834  vd = a->ptr.pp_double[i1+j][j1+j];
9835  }
9836  x->ptr.pp_double[i2+i][j2+j] = (x->ptr.pp_double[i2+i][j2+j]-vr)/vd;
9837  }
9838  }
9839  return;
9840  }
9841  }
9842  else
9843  {
9844 
9845  /*
9846  * Lower triangular matrix
9847  */
9848  if( optype==0 )
9849  {
9850 
9851  /*
9852  * X*A^(-1)
9853  */
9854  for(i=0; i<=m-1; i++)
9855  {
9856  for(j=n-1; j>=0; j--)
9857  {
9858  if( isunit )
9859  {
9860  vd = 1;
9861  }
9862  else
9863  {
9864  vd = a->ptr.pp_double[i1+j][j1+j];
9865  }
9866  x->ptr.pp_double[i2+i][j2+j] = x->ptr.pp_double[i2+i][j2+j]/vd;
9867  if( j>0 )
9868  {
9869  vr = x->ptr.pp_double[i2+i][j2+j];
9870  ae_v_subd(&x->ptr.pp_double[i2+i][j2], 1, &a->ptr.pp_double[i1+j][j1], 1, ae_v_len(j2,j2+j-1), vr);
9871  }
9872  }
9873  }
9874  return;
9875  }
9876  if( optype==1 )
9877  {
9878 
9879  /*
9880  * X*A^(-T)
9881  */
9882  for(i=0; i<=m-1; i++)
9883  {
9884  for(j=0; j<=n-1; j++)
9885  {
9886  vr = 0;
9887  vd = 1;
9888  if( j>0 )
9889  {
9890  vr = ae_v_dotproduct(&x->ptr.pp_double[i2+i][j2], 1, &a->ptr.pp_double[i1+j][j1], 1, ae_v_len(j2,j2+j-1));
9891  }
9892  if( !isunit )
9893  {
9894  vd = a->ptr.pp_double[i1+j][j1+j];
9895  }
9896  x->ptr.pp_double[i2+i][j2+j] = (x->ptr.pp_double[i2+i][j2+j]-vr)/vd;
9897  }
9898  }
9899  return;
9900  }
9901  }
9902 }
9903 
9904 
9905 /*************************************************************************
9906 Level 2 subroutine
9907 *************************************************************************/
9908 static void ablas_rmatrixlefttrsm2(ae_int_t m,
9909  ae_int_t n,
9910  /* Real */ ae_matrix* a,
9911  ae_int_t i1,
9912  ae_int_t j1,
9913  ae_bool isupper,
9914  ae_bool isunit,
9915  ae_int_t optype,
9916  /* Real */ ae_matrix* x,
9917  ae_int_t i2,
9918  ae_int_t j2,
9919  ae_state *_state)
9920 {
9921  ae_int_t i;
9922  ae_int_t j;
9923  double vr;
9924  double vd;
9925 
9926 
9927 
9928  /*
9929  * Special case
9930  */
9931  if( n==0||m==0 )
9932  {
9933  return;
9934  }
9935 
9936  /*
9937  * Try fast code
9938  */
9939  if( rmatrixlefttrsmf(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state) )
9940  {
9941  return;
9942  }
9943 
9944  /*
9945  * General case
9946  */
9947  if( isupper )
9948  {
9949 
9950  /*
9951  * Upper triangular matrix
9952  */
9953  if( optype==0 )
9954  {
9955 
9956  /*
9957  * A^(-1)*X
9958  */
9959  for(i=m-1; i>=0; i--)
9960  {
9961  for(j=i+1; j<=m-1; j++)
9962  {
9963  vr = a->ptr.pp_double[i1+i][j1+j];
9964  ae_v_subd(&x->ptr.pp_double[i2+i][j2], 1, &x->ptr.pp_double[i2+j][j2], 1, ae_v_len(j2,j2+n-1), vr);
9965  }
9966  if( !isunit )
9967  {
9968  vd = 1/a->ptr.pp_double[i1+i][j1+i];
9969  ae_v_muld(&x->ptr.pp_double[i2+i][j2], 1, ae_v_len(j2,j2+n-1), vd);
9970  }
9971  }
9972  return;
9973  }
9974  if( optype==1 )
9975  {
9976 
9977  /*
9978  * A^(-T)*X
9979  */
9980  for(i=0; i<=m-1; i++)
9981  {
9982  if( isunit )
9983  {
9984  vd = 1;
9985  }
9986  else
9987  {
9988  vd = 1/a->ptr.pp_double[i1+i][j1+i];
9989  }
9990  ae_v_muld(&x->ptr.pp_double[i2+i][j2], 1, ae_v_len(j2,j2+n-1), vd);
9991  for(j=i+1; j<=m-1; j++)
9992  {
9993  vr = a->ptr.pp_double[i1+i][j1+j];
9994  ae_v_subd(&x->ptr.pp_double[i2+j][j2], 1, &x->ptr.pp_double[i2+i][j2], 1, ae_v_len(j2,j2+n-1), vr);
9995  }
9996  }
9997  return;
9998  }
9999  }
10000  else
10001  {
10002 
10003  /*
10004  * Lower triangular matrix
10005  */
10006  if( optype==0 )
10007  {
10008 
10009  /*
10010  * A^(-1)*X
10011  */
10012  for(i=0; i<=m-1; i++)
10013  {
10014  for(j=0; j<=i-1; j++)
10015  {
10016  vr = a->ptr.pp_double[i1+i][j1+j];
10017  ae_v_subd(&x->ptr.pp_double[i2+i][j2], 1, &x->ptr.pp_double[i2+j][j2], 1, ae_v_len(j2,j2+n-1), vr);
10018  }
10019  if( isunit )
10020  {
10021  vd = 1;
10022  }
10023  else
10024  {
10025  vd = 1/a->ptr.pp_double[i1+j][j1+j];
10026  }
10027  ae_v_muld(&x->ptr.pp_double[i2+i][j2], 1, ae_v_len(j2,j2+n-1), vd);
10028  }
10029  return;
10030  }
10031  if( optype==1 )
10032  {
10033 
10034  /*
10035  * A^(-T)*X
10036  */
10037  for(i=m-1; i>=0; i--)
10038  {
10039  if( isunit )
10040  {
10041  vd = 1;
10042  }
10043  else
10044  {
10045  vd = 1/a->ptr.pp_double[i1+i][j1+i];
10046  }
10047  ae_v_muld(&x->ptr.pp_double[i2+i][j2], 1, ae_v_len(j2,j2+n-1), vd);
10048  for(j=i-1; j>=0; j--)
10049  {
10050  vr = a->ptr.pp_double[i1+i][j1+j];
10051  ae_v_subd(&x->ptr.pp_double[i2+j][j2], 1, &x->ptr.pp_double[i2+i][j2], 1, ae_v_len(j2,j2+n-1), vr);
10052  }
10053  }
10054  return;
10055  }
10056  }
10057 }
10058 
10059 
10060 /*************************************************************************
10061 Level 2 subroutine
10062 *************************************************************************/
10063 static void ablas_cmatrixsyrk2(ae_int_t n,
10064  ae_int_t k,
10065  double alpha,
10066  /* Complex */ ae_matrix* a,
10067  ae_int_t ia,
10068  ae_int_t ja,
10069  ae_int_t optypea,
10070  double beta,
10071  /* Complex */ ae_matrix* c,
10072  ae_int_t ic,
10073  ae_int_t jc,
10074  ae_bool isupper,
10075  ae_state *_state)
10076 {
10077  ae_int_t i;
10078  ae_int_t j;
10079  ae_int_t j1;
10080  ae_int_t j2;
10081  ae_complex v;
10082 
10083 
10084 
10085  /*
10086  * Fast exit (nothing to be done)
10087  */
10088  if( (ae_fp_eq(alpha,0)||k==0)&&ae_fp_eq(beta,1) )
10089  {
10090  return;
10091  }
10092 
10093  /*
10094  * Try to call fast SYRK
10095  */
10096  if( cmatrixsyrkf(n, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state) )
10097  {
10098  return;
10099  }
10100 
10101  /*
10102  * SYRK
10103  */
10104  if( optypea==0 )
10105  {
10106 
10107  /*
10108  * C=alpha*A*A^H+beta*C
10109  */
10110  for(i=0; i<=n-1; i++)
10111  {
10112  if( isupper )
10113  {
10114  j1 = i;
10115  j2 = n-1;
10116  }
10117  else
10118  {
10119  j1 = 0;
10120  j2 = i;
10121  }
10122  for(j=j1; j<=j2; j++)
10123  {
10124  if( ae_fp_neq(alpha,0)&&k>0 )
10125  {
10126  v = ae_v_cdotproduct(&a->ptr.pp_complex[ia+i][ja], 1, "N", &a->ptr.pp_complex[ia+j][ja], 1, "Conj", ae_v_len(ja,ja+k-1));
10127  }
10128  else
10129  {
10130  v = ae_complex_from_d(0);
10131  }
10132  if( ae_fp_eq(beta,0) )
10133  {
10134  c->ptr.pp_complex[ic+i][jc+j] = ae_c_mul_d(v,alpha);
10135  }
10136  else
10137  {
10138  c->ptr.pp_complex[ic+i][jc+j] = ae_c_add(ae_c_mul_d(c->ptr.pp_complex[ic+i][jc+j],beta),ae_c_mul_d(v,alpha));
10139  }
10140  }
10141  }
10142  return;
10143  }
10144  else
10145  {
10146 
10147  /*
10148  * C=alpha*A^H*A+beta*C
10149  */
10150  for(i=0; i<=n-1; i++)
10151  {
10152  if( isupper )
10153  {
10154  j1 = i;
10155  j2 = n-1;
10156  }
10157  else
10158  {
10159  j1 = 0;
10160  j2 = i;
10161  }
10162  if( ae_fp_eq(beta,0) )
10163  {
10164  for(j=j1; j<=j2; j++)
10165  {
10166  c->ptr.pp_complex[ic+i][jc+j] = ae_complex_from_d(0);
10167  }
10168  }
10169  else
10170  {
10171  ae_v_cmuld(&c->ptr.pp_complex[ic+i][jc+j1], 1, ae_v_len(jc+j1,jc+j2), beta);
10172  }
10173  }
10174  for(i=0; i<=k-1; i++)
10175  {
10176  for(j=0; j<=n-1; j++)
10177  {
10178  if( isupper )
10179  {
10180  j1 = j;
10181  j2 = n-1;
10182  }
10183  else
10184  {
10185  j1 = 0;
10186  j2 = j;
10187  }
10188  v = ae_c_mul_d(ae_c_conj(a->ptr.pp_complex[ia+i][ja+j], _state),alpha);
10189  ae_v_caddc(&c->ptr.pp_complex[ic+j][jc+j1], 1, &a->ptr.pp_complex[ia+i][ja+j1], 1, "N", ae_v_len(jc+j1,jc+j2), v);
10190  }
10191  }
10192  return;
10193  }
10194 }
10195 
10196 
10197 /*************************************************************************
10198 Level 2 subrotuine
10199 *************************************************************************/
10200 static void ablas_rmatrixsyrk2(ae_int_t n,
10201  ae_int_t k,
10202  double alpha,
10203  /* Real */ ae_matrix* a,
10204  ae_int_t ia,
10205  ae_int_t ja,
10206  ae_int_t optypea,
10207  double beta,
10208  /* Real */ ae_matrix* c,
10209  ae_int_t ic,
10210  ae_int_t jc,
10211  ae_bool isupper,
10212  ae_state *_state)
10213 {
10214  ae_int_t i;
10215  ae_int_t j;
10216  ae_int_t j1;
10217  ae_int_t j2;
10218  double v;
10219 
10220 
10221 
10222  /*
10223  * Fast exit (nothing to be done)
10224  */
10225  if( (ae_fp_eq(alpha,0)||k==0)&&ae_fp_eq(beta,1) )
10226  {
10227  return;
10228  }
10229 
10230  /*
10231  * Try to call fast SYRK
10232  */
10233  if( rmatrixsyrkf(n, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state) )
10234  {
10235  return;
10236  }
10237 
10238  /*
10239  * SYRK
10240  */
10241  if( optypea==0 )
10242  {
10243 
10244  /*
10245  * C=alpha*A*A^H+beta*C
10246  */
10247  for(i=0; i<=n-1; i++)
10248  {
10249  if( isupper )
10250  {
10251  j1 = i;
10252  j2 = n-1;
10253  }
10254  else
10255  {
10256  j1 = 0;
10257  j2 = i;
10258  }
10259  for(j=j1; j<=j2; j++)
10260  {
10261  if( ae_fp_neq(alpha,0)&&k>0 )
10262  {
10263  v = ae_v_dotproduct(&a->ptr.pp_double[ia+i][ja], 1, &a->ptr.pp_double[ia+j][ja], 1, ae_v_len(ja,ja+k-1));
10264  }
10265  else
10266  {
10267  v = 0;
10268  }
10269  if( ae_fp_eq(beta,0) )
10270  {
10271  c->ptr.pp_double[ic+i][jc+j] = alpha*v;
10272  }
10273  else
10274  {
10275  c->ptr.pp_double[ic+i][jc+j] = beta*c->ptr.pp_double[ic+i][jc+j]+alpha*v;
10276  }
10277  }
10278  }
10279  return;
10280  }
10281  else
10282  {
10283 
10284  /*
10285  * C=alpha*A^H*A+beta*C
10286  */
10287  for(i=0; i<=n-1; i++)
10288  {
10289  if( isupper )
10290  {
10291  j1 = i;
10292  j2 = n-1;
10293  }
10294  else
10295  {
10296  j1 = 0;
10297  j2 = i;
10298  }
10299  if( ae_fp_eq(beta,0) )
10300  {
10301  for(j=j1; j<=j2; j++)
10302  {
10303  c->ptr.pp_double[ic+i][jc+j] = 0;
10304  }
10305  }
10306  else
10307  {
10308  ae_v_muld(&c->ptr.pp_double[ic+i][jc+j1], 1, ae_v_len(jc+j1,jc+j2), beta);
10309  }
10310  }
10311  for(i=0; i<=k-1; i++)
10312  {
10313  for(j=0; j<=n-1; j++)
10314  {
10315  if( isupper )
10316  {
10317  j1 = j;
10318  j2 = n-1;
10319  }
10320  else
10321  {
10322  j1 = 0;
10323  j2 = j;
10324  }
10325  v = alpha*a->ptr.pp_double[ia+i][ja+j];
10326  ae_v_addd(&c->ptr.pp_double[ic+j][jc+j1], 1, &a->ptr.pp_double[ia+i][ja+j1], 1, ae_v_len(jc+j1,jc+j2), v);
10327  }
10328  }
10329  return;
10330  }
10331 }
10332 
10333 
10334 
10335 
10336 /*************************************************************************
10337 QR decomposition of a rectangular matrix of size MxN
10338 
10339 Input parameters:
10340  A - matrix A whose indexes range within [0..M-1, 0..N-1].
10341  M - number of rows in matrix A.
10342  N - number of columns in matrix A.
10343 
10344 Output parameters:
10345  A - matrices Q and R in compact form (see below).
10346  Tau - array of scalar factors which are used to form
10347  matrix Q. Array whose index ranges within [0.. Min(M-1,N-1)].
10348 
10349 Matrix A is represented as A = QR, where Q is an orthogonal matrix of size
10350 MxM, R - upper triangular (or upper trapezoid) matrix of size M x N.
10351 
10352 The elements of matrix R are located on and above the main diagonal of
10353 matrix A. The elements which are located in Tau array and below the main
10354 diagonal of matrix A are used to form matrix Q as follows:
10355 
10356 Matrix Q is represented as a product of elementary reflections
10357 
10358 Q = H(0)*H(2)*...*H(k-1),
10359 
10360 where k = min(m,n), and each H(i) is in the form
10361 
10362 H(i) = 1 - tau * v * (v^T)
10363 
10364 where tau is a scalar stored in Tau[I]; v - real vector,
10365 so that v(0:i-1) = 0, v(i) = 1, v(i+1:m-1) stored in A(i+1:m-1,i).
10366 
10367  -- ALGLIB routine --
10368  17.02.2010
10369  Bochkanov Sergey
10370 *************************************************************************/
10371 void rmatrixqr(/* Real */ ae_matrix* a,
10372  ae_int_t m,
10373  ae_int_t n,
10374  /* Real */ ae_vector* tau,
10375  ae_state *_state)
10376 {
10377  ae_frame _frame_block;
10378  ae_vector work;
10379  ae_vector t;
10380  ae_vector taubuf;
10381  ae_int_t minmn;
10382  ae_matrix tmpa;
10383  ae_matrix tmpt;
10384  ae_matrix tmpr;
10385  ae_int_t blockstart;
10386  ae_int_t blocksize;
10387  ae_int_t rowscount;
10388  ae_int_t i;
10389 
10390  ae_frame_make(_state, &_frame_block);
10391  ae_vector_clear(tau);
10392  ae_vector_init(&work, 0, DT_REAL, _state, ae_true);
10393  ae_vector_init(&t, 0, DT_REAL, _state, ae_true);
10394  ae_vector_init(&taubuf, 0, DT_REAL, _state, ae_true);
10395  ae_matrix_init(&tmpa, 0, 0, DT_REAL, _state, ae_true);
10396  ae_matrix_init(&tmpt, 0, 0, DT_REAL, _state, ae_true);
10397  ae_matrix_init(&tmpr, 0, 0, DT_REAL, _state, ae_true);
10398 
10399  if( m<=0||n<=0 )
10400  {
10401  ae_frame_leave(_state);
10402  return;
10403  }
10404  minmn = ae_minint(m, n, _state);
10405  ae_vector_set_length(&work, ae_maxint(m, n, _state)+1, _state);
10406  ae_vector_set_length(&t, ae_maxint(m, n, _state)+1, _state);
10407  ae_vector_set_length(tau, minmn, _state);
10408  ae_vector_set_length(&taubuf, minmn, _state);
10409  ae_matrix_set_length(&tmpa, m, ablasblocksize(a, _state), _state);
10410  ae_matrix_set_length(&tmpt, ablasblocksize(a, _state), 2*ablasblocksize(a, _state), _state);
10411  ae_matrix_set_length(&tmpr, 2*ablasblocksize(a, _state), n, _state);
10412 
10413  /*
10414  * Blocked code
10415  */
10416  blockstart = 0;
10417  while(blockstart!=minmn)
10418  {
10419 
10420  /*
10421  * Determine block size
10422  */
10423  blocksize = minmn-blockstart;
10424  if( blocksize>ablasblocksize(a, _state) )
10425  {
10426  blocksize = ablasblocksize(a, _state);
10427  }
10428  rowscount = m-blockstart;
10429 
10430  /*
10431  * QR decomposition of submatrix.
10432  * Matrix is copied to temporary storage to solve
10433  * some TLB issues arising from non-contiguous memory
10434  * access pattern.
10435  */
10436  rmatrixcopy(rowscount, blocksize, a, blockstart, blockstart, &tmpa, 0, 0, _state);
10437  rmatrixqrbasecase(&tmpa, rowscount, blocksize, &work, &t, &taubuf, _state);
10438  rmatrixcopy(rowscount, blocksize, &tmpa, 0, 0, a, blockstart, blockstart, _state);
10439  ae_v_move(&tau->ptr.p_double[blockstart], 1, &taubuf.ptr.p_double[0], 1, ae_v_len(blockstart,blockstart+blocksize-1));
10440 
10441  /*
10442  * Update the rest, choose between:
10443  * a) Level 2 algorithm (when the rest of the matrix is small enough)
10444  * b) blocked algorithm, see algorithm 5 from 'A storage efficient WY
10445  * representation for products of Householder transformations',
10446  * by R. Schreiber and C. Van Loan.
10447  */
10448  if( blockstart+blocksize<=n-1 )
10449  {
10450  if( n-blockstart-blocksize>=2*ablasblocksize(a, _state)||rowscount>=4*ablasblocksize(a, _state) )
10451  {
10452 
10453  /*
10454  * Prepare block reflector
10455  */
10456  ortfac_rmatrixblockreflector(&tmpa, &taubuf, ae_true, rowscount, blocksize, &tmpt, &work, _state);
10457 
10458  /*
10459  * Multiply the rest of A by Q'.
10460  *
10461  * Q = E + Y*T*Y' = E + TmpA*TmpT*TmpA'
10462  * Q' = E + Y*T'*Y' = E + TmpA*TmpT'*TmpA'
10463  */
10464  rmatrixgemm(blocksize, n-blockstart-blocksize, rowscount, 1.0, &tmpa, 0, 0, 1, a, blockstart, blockstart+blocksize, 0, 0.0, &tmpr, 0, 0, _state);
10465  rmatrixgemm(blocksize, n-blockstart-blocksize, blocksize, 1.0, &tmpt, 0, 0, 1, &tmpr, 0, 0, 0, 0.0, &tmpr, blocksize, 0, _state);
10466  rmatrixgemm(rowscount, n-blockstart-blocksize, blocksize, 1.0, &tmpa, 0, 0, 0, &tmpr, blocksize, 0, 0, 1.0, a, blockstart, blockstart+blocksize, _state);
10467  }
10468  else
10469  {
10470 
10471  /*
10472  * Level 2 algorithm
10473  */
10474  for(i=0; i<=blocksize-1; i++)
10475  {
10476  ae_v_move(&t.ptr.p_double[1], 1, &tmpa.ptr.pp_double[i][i], tmpa.stride, ae_v_len(1,rowscount-i));
10477  t.ptr.p_double[1] = 1;
10478  applyreflectionfromtheleft(a, taubuf.ptr.p_double[i], &t, blockstart+i, m-1, blockstart+blocksize, n-1, &work, _state);
10479  }
10480  }
10481  }
10482 
10483  /*
10484  * Advance
10485  */
10486  blockstart = blockstart+blocksize;
10487  }
10488  ae_frame_leave(_state);
10489 }
10490 
10491 
10492 /*************************************************************************
10493 LQ decomposition of a rectangular matrix of size MxN
10494 
10495 Input parameters:
10496  A - matrix A whose indexes range within [0..M-1, 0..N-1].
10497  M - number of rows in matrix A.
10498  N - number of columns in matrix A.
10499 
10500 Output parameters:
10501  A - matrices L and Q in compact form (see below)
10502  Tau - array of scalar factors which are used to form
10503  matrix Q. Array whose index ranges within [0..Min(M,N)-1].
10504 
10505 Matrix A is represented as A = LQ, where Q is an orthogonal matrix of size
10506 MxM, L - lower triangular (or lower trapezoid) matrix of size M x N.
10507 
10508 The elements of matrix L are located on and below the main diagonal of
10509 matrix A. The elements which are located in Tau array and above the main
10510 diagonal of matrix A are used to form matrix Q as follows:
10511 
10512 Matrix Q is represented as a product of elementary reflections
10513 
10514 Q = H(k-1)*H(k-2)*...*H(1)*H(0),
10515 
10516 where k = min(m,n), and each H(i) is of the form
10517 
10518 H(i) = 1 - tau * v * (v^T)
10519 
10520 where tau is a scalar stored in Tau[I]; v - real vector, so that v(0:i-1)=0,
10521 v(i) = 1, v(i+1:n-1) stored in A(i,i+1:n-1).
10522 
10523  -- ALGLIB routine --
10524  17.02.2010
10525  Bochkanov Sergey
10526 *************************************************************************/
10527 void rmatrixlq(/* Real */ ae_matrix* a,
10528  ae_int_t m,
10529  ae_int_t n,
10530  /* Real */ ae_vector* tau,
10531  ae_state *_state)
10532 {
10533  ae_frame _frame_block;
10534  ae_vector work;
10535  ae_vector t;
10536  ae_vector taubuf;
10537  ae_int_t minmn;
10538  ae_matrix tmpa;
10539  ae_matrix tmpt;
10540  ae_matrix tmpr;
10541  ae_int_t blockstart;
10542  ae_int_t blocksize;
10543  ae_int_t columnscount;
10544  ae_int_t i;
10545 
10546  ae_frame_make(_state, &_frame_block);
10547  ae_vector_clear(tau);
10548  ae_vector_init(&work, 0, DT_REAL, _state, ae_true);
10549  ae_vector_init(&t, 0, DT_REAL, _state, ae_true);
10550  ae_vector_init(&taubuf, 0, DT_REAL, _state, ae_true);
10551  ae_matrix_init(&tmpa, 0, 0, DT_REAL, _state, ae_true);
10552  ae_matrix_init(&tmpt, 0, 0, DT_REAL, _state, ae_true);
10553  ae_matrix_init(&tmpr, 0, 0, DT_REAL, _state, ae_true);
10554 
10555  if( m<=0||n<=0 )
10556  {
10557  ae_frame_leave(_state);
10558  return;
10559  }
10560  minmn = ae_minint(m, n, _state);
10561  ae_vector_set_length(&work, ae_maxint(m, n, _state)+1, _state);
10562  ae_vector_set_length(&t, ae_maxint(m, n, _state)+1, _state);
10563  ae_vector_set_length(tau, minmn, _state);
10564  ae_vector_set_length(&taubuf, minmn, _state);
10565  ae_matrix_set_length(&tmpa, ablasblocksize(a, _state), n, _state);
10566  ae_matrix_set_length(&tmpt, ablasblocksize(a, _state), 2*ablasblocksize(a, _state), _state);
10567  ae_matrix_set_length(&tmpr, m, 2*ablasblocksize(a, _state), _state);
10568 
10569  /*
10570  * Blocked code
10571  */
10572  blockstart = 0;
10573  while(blockstart!=minmn)
10574  {
10575 
10576  /*
10577  * Determine block size
10578  */
10579  blocksize = minmn-blockstart;
10580  if( blocksize>ablasblocksize(a, _state) )
10581  {
10582  blocksize = ablasblocksize(a, _state);
10583  }
10584  columnscount = n-blockstart;
10585 
10586  /*
10587  * LQ decomposition of submatrix.
10588  * Matrix is copied to temporary storage to solve
10589  * some TLB issues arising from non-contiguous memory
10590  * access pattern.
10591  */
10592  rmatrixcopy(blocksize, columnscount, a, blockstart, blockstart, &tmpa, 0, 0, _state);
10593  rmatrixlqbasecase(&tmpa, blocksize, columnscount, &work, &t, &taubuf, _state);
10594  rmatrixcopy(blocksize, columnscount, &tmpa, 0, 0, a, blockstart, blockstart, _state);
10595  ae_v_move(&tau->ptr.p_double[blockstart], 1, &taubuf.ptr.p_double[0], 1, ae_v_len(blockstart,blockstart+blocksize-1));
10596 
10597  /*
10598  * Update the rest, choose between:
10599  * a) Level 2 algorithm (when the rest of the matrix is small enough)
10600  * b) blocked algorithm, see algorithm 5 from 'A storage efficient WY
10601  * representation for products of Householder transformations',
10602  * by R. Schreiber and C. Van Loan.
10603  */
10604  if( blockstart+blocksize<=m-1 )
10605  {
10606  if( m-blockstart-blocksize>=2*ablasblocksize(a, _state) )
10607  {
10608 
10609  /*
10610  * Prepare block reflector
10611  */
10612  ortfac_rmatrixblockreflector(&tmpa, &taubuf, ae_false, columnscount, blocksize, &tmpt, &work, _state);
10613 
10614  /*
10615  * Multiply the rest of A by Q.
10616  *
10617  * Q = E + Y*T*Y' = E + TmpA'*TmpT*TmpA
10618  */
10619  rmatrixgemm(m-blockstart-blocksize, blocksize, columnscount, 1.0, a, blockstart+blocksize, blockstart, 0, &tmpa, 0, 0, 1, 0.0, &tmpr, 0, 0, _state);
10620  rmatrixgemm(m-blockstart-blocksize, blocksize, blocksize, 1.0, &tmpr, 0, 0, 0, &tmpt, 0, 0, 0, 0.0, &tmpr, 0, blocksize, _state);
10621  rmatrixgemm(m-blockstart-blocksize, columnscount, blocksize, 1.0, &tmpr, 0, blocksize, 0, &tmpa, 0, 0, 0, 1.0, a, blockstart+blocksize, blockstart, _state);
10622  }
10623  else
10624  {
10625 
10626  /*
10627  * Level 2 algorithm
10628  */
10629  for(i=0; i<=blocksize-1; i++)
10630  {
10631  ae_v_move(&t.ptr.p_double[1], 1, &tmpa.ptr.pp_double[i][i], 1, ae_v_len(1,columnscount-i));
10632  t.ptr.p_double[1] = 1;
10633  applyreflectionfromtheright(a, taubuf.ptr.p_double[i], &t, blockstart+blocksize, m-1, blockstart+i, n-1, &work, _state);
10634  }
10635  }
10636  }
10637 
10638  /*
10639  * Advance
10640  */
10641  blockstart = blockstart+blocksize;
10642  }
10643  ae_frame_leave(_state);
10644 }
10645 
10646 
10647 /*************************************************************************
10648 QR decomposition of a rectangular complex matrix of size MxN
10649 
10650 Input parameters:
10651  A - matrix A whose indexes range within [0..M-1, 0..N-1]
10652  M - number of rows in matrix A.
10653  N - number of columns in matrix A.
10654 
10655 Output parameters:
10656  A - matrices Q and R in compact form
10657  Tau - array of scalar factors which are used to form matrix Q. Array
10658  whose indexes range within [0.. Min(M,N)-1]
10659 
10660 Matrix A is represented as A = QR, where Q is an orthogonal matrix of size
10661 MxM, R - upper triangular (or upper trapezoid) matrix of size MxN.
10662 
10663  -- LAPACK routine (version 3.0) --
10664  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
10665  Courant Institute, Argonne National Lab, and Rice University
10666  September 30, 1994
10667 *************************************************************************/
10668 void cmatrixqr(/* Complex */ ae_matrix* a,
10669  ae_int_t m,
10670  ae_int_t n,
10671  /* Complex */ ae_vector* tau,
10672  ae_state *_state)
10673 {
10674  ae_frame _frame_block;
10675  ae_vector work;
10676  ae_vector t;
10677  ae_vector taubuf;
10678  ae_int_t minmn;
10679  ae_matrix tmpa;
10680  ae_matrix tmpt;
10681  ae_matrix tmpr;
10682  ae_int_t blockstart;
10683  ae_int_t blocksize;
10684  ae_int_t rowscount;
10685  ae_int_t i;
10686 
10687  ae_frame_make(_state, &_frame_block);
10688  ae_vector_clear(tau);
10689  ae_vector_init(&work, 0, DT_COMPLEX, _state, ae_true);
10690  ae_vector_init(&t, 0, DT_COMPLEX, _state, ae_true);
10691  ae_vector_init(&taubuf, 0, DT_COMPLEX, _state, ae_true);
10692  ae_matrix_init(&tmpa, 0, 0, DT_COMPLEX, _state, ae_true);
10693  ae_matrix_init(&tmpt, 0, 0, DT_COMPLEX, _state, ae_true);
10694  ae_matrix_init(&tmpr, 0, 0, DT_COMPLEX, _state, ae_true);
10695 
10696  if( m<=0||n<=0 )
10697  {
10698  ae_frame_leave(_state);
10699  return;
10700  }
10701  minmn = ae_minint(m, n, _state);
10702  ae_vector_set_length(&work, ae_maxint(m, n, _state)+1, _state);
10703  ae_vector_set_length(&t, ae_maxint(m, n, _state)+1, _state);
10704  ae_vector_set_length(tau, minmn, _state);
10705  ae_vector_set_length(&taubuf, minmn, _state);
10706  ae_matrix_set_length(&tmpa, m, ablascomplexblocksize(a, _state), _state);
10707  ae_matrix_set_length(&tmpt, ablascomplexblocksize(a, _state), ablascomplexblocksize(a, _state), _state);
10708  ae_matrix_set_length(&tmpr, 2*ablascomplexblocksize(a, _state), n, _state);
10709 
10710  /*
10711  * Blocked code
10712  */
10713  blockstart = 0;
10714  while(blockstart!=minmn)
10715  {
10716 
10717  /*
10718  * Determine block size
10719  */
10720  blocksize = minmn-blockstart;
10721  if( blocksize>ablascomplexblocksize(a, _state) )
10722  {
10723  blocksize = ablascomplexblocksize(a, _state);
10724  }
10725  rowscount = m-blockstart;
10726 
10727  /*
10728  * QR decomposition of submatrix.
10729  * Matrix is copied to temporary storage to solve
10730  * some TLB issues arising from non-contiguous memory
10731  * access pattern.
10732  */
10733  cmatrixcopy(rowscount, blocksize, a, blockstart, blockstart, &tmpa, 0, 0, _state);
10734  ortfac_cmatrixqrbasecase(&tmpa, rowscount, blocksize, &work, &t, &taubuf, _state);
10735  cmatrixcopy(rowscount, blocksize, &tmpa, 0, 0, a, blockstart, blockstart, _state);
10736  ae_v_cmove(&tau->ptr.p_complex[blockstart], 1, &taubuf.ptr.p_complex[0], 1, "N", ae_v_len(blockstart,blockstart+blocksize-1));
10737 
10738  /*
10739  * Update the rest, choose between:
10740  * a) Level 2 algorithm (when the rest of the matrix is small enough)
10741  * b) blocked algorithm, see algorithm 5 from 'A storage efficient WY
10742  * representation for products of Householder transformations',
10743  * by R. Schreiber and C. Van Loan.
10744  */
10745  if( blockstart+blocksize<=n-1 )
10746  {
10747  if( n-blockstart-blocksize>=2*ablascomplexblocksize(a, _state) )
10748  {
10749 
10750  /*
10751  * Prepare block reflector
10752  */
10753  ortfac_cmatrixblockreflector(&tmpa, &taubuf, ae_true, rowscount, blocksize, &tmpt, &work, _state);
10754 
10755  /*
10756  * Multiply the rest of A by Q'.
10757  *
10758  * Q = E + Y*T*Y' = E + TmpA*TmpT*TmpA'
10759  * Q' = E + Y*T'*Y' = E + TmpA*TmpT'*TmpA'
10760  */
10761  cmatrixgemm(blocksize, n-blockstart-blocksize, rowscount, ae_complex_from_d(1.0), &tmpa, 0, 0, 2, a, blockstart, blockstart+blocksize, 0, ae_complex_from_d(0.0), &tmpr, 0, 0, _state);
10762  cmatrixgemm(blocksize, n-blockstart-blocksize, blocksize, ae_complex_from_d(1.0), &tmpt, 0, 0, 2, &tmpr, 0, 0, 0, ae_complex_from_d(0.0), &tmpr, blocksize, 0, _state);
10763  cmatrixgemm(rowscount, n-blockstart-blocksize, blocksize, ae_complex_from_d(1.0), &tmpa, 0, 0, 0, &tmpr, blocksize, 0, 0, ae_complex_from_d(1.0), a, blockstart, blockstart+blocksize, _state);
10764  }
10765  else
10766  {
10767 
10768  /*
10769  * Level 2 algorithm
10770  */
10771  for(i=0; i<=blocksize-1; i++)
10772  {
10773  ae_v_cmove(&t.ptr.p_complex[1], 1, &tmpa.ptr.pp_complex[i][i], tmpa.stride, "N", ae_v_len(1,rowscount-i));
10774  t.ptr.p_complex[1] = ae_complex_from_d(1);
10775  complexapplyreflectionfromtheleft(a, ae_c_conj(taubuf.ptr.p_complex[i], _state), &t, blockstart+i, m-1, blockstart+blocksize, n-1, &work, _state);
10776  }
10777  }
10778  }
10779 
10780  /*
10781  * Advance
10782  */
10783  blockstart = blockstart+blocksize;
10784  }
10785  ae_frame_leave(_state);
10786 }
10787 
10788 
10789 /*************************************************************************
10790 LQ decomposition of a rectangular complex matrix of size MxN
10791 
10792 Input parameters:
10793  A - matrix A whose indexes range within [0..M-1, 0..N-1]
10794  M - number of rows in matrix A.
10795  N - number of columns in matrix A.
10796 
10797 Output parameters:
10798  A - matrices Q and L in compact form
10799  Tau - array of scalar factors which are used to form matrix Q. Array
10800  whose indexes range within [0.. Min(M,N)-1]
10801 
10802 Matrix A is represented as A = LQ, where Q is an orthogonal matrix of size
10803 MxM, L - lower triangular (or lower trapezoid) matrix of size MxN.
10804 
10805  -- LAPACK routine (version 3.0) --
10806  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
10807  Courant Institute, Argonne National Lab, and Rice University
10808  September 30, 1994
10809 *************************************************************************/
10810 void cmatrixlq(/* Complex */ ae_matrix* a,
10811  ae_int_t m,
10812  ae_int_t n,
10813  /* Complex */ ae_vector* tau,
10814  ae_state *_state)
10815 {
10816  ae_frame _frame_block;
10817  ae_vector work;
10818  ae_vector t;
10819  ae_vector taubuf;
10820  ae_int_t minmn;
10821  ae_matrix tmpa;
10822  ae_matrix tmpt;
10823  ae_matrix tmpr;
10824  ae_int_t blockstart;
10825  ae_int_t blocksize;
10826  ae_int_t columnscount;
10827  ae_int_t i;
10828 
10829  ae_frame_make(_state, &_frame_block);
10830  ae_vector_clear(tau);
10831  ae_vector_init(&work, 0, DT_COMPLEX, _state, ae_true);
10832  ae_vector_init(&t, 0, DT_COMPLEX, _state, ae_true);
10833  ae_vector_init(&taubuf, 0, DT_COMPLEX, _state, ae_true);
10834  ae_matrix_init(&tmpa, 0, 0, DT_COMPLEX, _state, ae_true);
10835  ae_matrix_init(&tmpt, 0, 0, DT_COMPLEX, _state, ae_true);
10836  ae_matrix_init(&tmpr, 0, 0, DT_COMPLEX, _state, ae_true);
10837 
10838  if( m<=0||n<=0 )
10839  {
10840  ae_frame_leave(_state);
10841  return;
10842  }
10843  minmn = ae_minint(m, n, _state);
10844  ae_vector_set_length(&work, ae_maxint(m, n, _state)+1, _state);
10845  ae_vector_set_length(&t, ae_maxint(m, n, _state)+1, _state);
10846  ae_vector_set_length(tau, minmn, _state);
10847  ae_vector_set_length(&taubuf, minmn, _state);
10848  ae_matrix_set_length(&tmpa, ablascomplexblocksize(a, _state), n, _state);
10849  ae_matrix_set_length(&tmpt, ablascomplexblocksize(a, _state), ablascomplexblocksize(a, _state), _state);
10850  ae_matrix_set_length(&tmpr, m, 2*ablascomplexblocksize(a, _state), _state);
10851 
10852  /*
10853  * Blocked code
10854  */
10855  blockstart = 0;
10856  while(blockstart!=minmn)
10857  {
10858 
10859  /*
10860  * Determine block size
10861  */
10862  blocksize = minmn-blockstart;
10863  if( blocksize>ablascomplexblocksize(a, _state) )
10864  {
10865  blocksize = ablascomplexblocksize(a, _state);
10866  }
10867  columnscount = n-blockstart;
10868 
10869  /*
10870  * LQ decomposition of submatrix.
10871  * Matrix is copied to temporary storage to solve
10872  * some TLB issues arising from non-contiguous memory
10873  * access pattern.
10874  */
10875  cmatrixcopy(blocksize, columnscount, a, blockstart, blockstart, &tmpa, 0, 0, _state);
10876  ortfac_cmatrixlqbasecase(&tmpa, blocksize, columnscount, &work, &t, &taubuf, _state);
10877  cmatrixcopy(blocksize, columnscount, &tmpa, 0, 0, a, blockstart, blockstart, _state);
10878  ae_v_cmove(&tau->ptr.p_complex[blockstart], 1, &taubuf.ptr.p_complex[0], 1, "N", ae_v_len(blockstart,blockstart+blocksize-1));
10879 
10880  /*
10881  * Update the rest, choose between:
10882  * a) Level 2 algorithm (when the rest of the matrix is small enough)
10883  * b) blocked algorithm, see algorithm 5 from 'A storage efficient WY
10884  * representation for products of Householder transformations',
10885  * by R. Schreiber and C. Van Loan.
10886  */
10887  if( blockstart+blocksize<=m-1 )
10888  {
10889  if( m-blockstart-blocksize>=2*ablascomplexblocksize(a, _state) )
10890  {
10891 
10892  /*
10893  * Prepare block reflector
10894  */
10895  ortfac_cmatrixblockreflector(&tmpa, &taubuf, ae_false, columnscount, blocksize, &tmpt, &work, _state);
10896 
10897  /*
10898  * Multiply the rest of A by Q.
10899  *
10900  * Q = E + Y*T*Y' = E + TmpA'*TmpT*TmpA
10901  */
10902  cmatrixgemm(m-blockstart-blocksize, blocksize, columnscount, ae_complex_from_d(1.0), a, blockstart+blocksize, blockstart, 0, &tmpa, 0, 0, 2, ae_complex_from_d(0.0), &tmpr, 0, 0, _state);
10903  cmatrixgemm(m-blockstart-blocksize, blocksize, blocksize, ae_complex_from_d(1.0), &tmpr, 0, 0, 0, &tmpt, 0, 0, 0, ae_complex_from_d(0.0), &tmpr, 0, blocksize, _state);
10904  cmatrixgemm(m-blockstart-blocksize, columnscount, blocksize, ae_complex_from_d(1.0), &tmpr, 0, blocksize, 0, &tmpa, 0, 0, 0, ae_complex_from_d(1.0), a, blockstart+blocksize, blockstart, _state);
10905  }
10906  else
10907  {
10908 
10909  /*
10910  * Level 2 algorithm
10911  */
10912  for(i=0; i<=blocksize-1; i++)
10913  {
10914  ae_v_cmove(&t.ptr.p_complex[1], 1, &tmpa.ptr.pp_complex[i][i], 1, "Conj", ae_v_len(1,columnscount-i));
10915  t.ptr.p_complex[1] = ae_complex_from_d(1);
10916  complexapplyreflectionfromtheright(a, taubuf.ptr.p_complex[i], &t, blockstart+blocksize, m-1, blockstart+i, n-1, &work, _state);
10917  }
10918  }
10919  }
10920 
10921  /*
10922  * Advance
10923  */
10924  blockstart = blockstart+blocksize;
10925  }
10926  ae_frame_leave(_state);
10927 }
10928 
10929 
10930 /*************************************************************************
10931 Partial unpacking of matrix Q from the QR decomposition of a matrix A
10932 
10933 Input parameters:
10934  A - matrices Q and R in compact form.
10935  Output of RMatrixQR subroutine.
10936  M - number of rows in given matrix A. M>=0.
10937  N - number of columns in given matrix A. N>=0.
10938  Tau - scalar factors which are used to form Q.
10939  Output of the RMatrixQR subroutine.
10940  QColumns - required number of columns of matrix Q. M>=QColumns>=0.
10941 
10942 Output parameters:
10943  Q - first QColumns columns of matrix Q.
10944  Array whose indexes range within [0..M-1, 0..QColumns-1].
10945  If QColumns=0, the array remains unchanged.
10946 
10947  -- ALGLIB routine --
10948  17.02.2010
10949  Bochkanov Sergey
10950 *************************************************************************/
10951 void rmatrixqrunpackq(/* Real */ ae_matrix* a,
10952  ae_int_t m,
10953  ae_int_t n,
10954  /* Real */ ae_vector* tau,
10955  ae_int_t qcolumns,
10956  /* Real */ ae_matrix* q,
10957  ae_state *_state)
10958 {
10959  ae_frame _frame_block;
10960  ae_vector work;
10961  ae_vector t;
10962  ae_vector taubuf;
10963  ae_int_t minmn;
10964  ae_int_t refcnt;
10965  ae_matrix tmpa;
10966  ae_matrix tmpt;
10967  ae_matrix tmpr;
10968  ae_int_t blockstart;
10969  ae_int_t blocksize;
10970  ae_int_t rowscount;
10971  ae_int_t i;
10972  ae_int_t j;
10973 
10974  ae_frame_make(_state, &_frame_block);
10975  ae_matrix_clear(q);
10976  ae_vector_init(&work, 0, DT_REAL, _state, ae_true);
10977  ae_vector_init(&t, 0, DT_REAL, _state, ae_true);
10978  ae_vector_init(&taubuf, 0, DT_REAL, _state, ae_true);
10979  ae_matrix_init(&tmpa, 0, 0, DT_REAL, _state, ae_true);
10980  ae_matrix_init(&tmpt, 0, 0, DT_REAL, _state, ae_true);
10981  ae_matrix_init(&tmpr, 0, 0, DT_REAL, _state, ae_true);
10982 
10983  ae_assert(qcolumns<=m, "UnpackQFromQR: QColumns>M!", _state);
10984  if( (m<=0||n<=0)||qcolumns<=0 )
10985  {
10986  ae_frame_leave(_state);
10987  return;
10988  }
10989 
10990  /*
10991  * init
10992  */
10993  minmn = ae_minint(m, n, _state);
10994  refcnt = ae_minint(minmn, qcolumns, _state);
10995  ae_matrix_set_length(q, m, qcolumns, _state);
10996  for(i=0; i<=m-1; i++)
10997  {
10998  for(j=0; j<=qcolumns-1; j++)
10999  {
11000  if( i==j )
11001  {
11002  q->ptr.pp_double[i][j] = 1;
11003  }
11004  else
11005  {
11006  q->ptr.pp_double[i][j] = 0;
11007  }
11008  }
11009  }
11010  ae_vector_set_length(&work, ae_maxint(m, qcolumns, _state)+1, _state);
11011  ae_vector_set_length(&t, ae_maxint(m, qcolumns, _state)+1, _state);
11012  ae_vector_set_length(&taubuf, minmn, _state);
11013  ae_matrix_set_length(&tmpa, m, ablasblocksize(a, _state), _state);
11014  ae_matrix_set_length(&tmpt, ablasblocksize(a, _state), 2*ablasblocksize(a, _state), _state);
11015  ae_matrix_set_length(&tmpr, 2*ablasblocksize(a, _state), qcolumns, _state);
11016 
11017  /*
11018  * Blocked code
11019  */
11020  blockstart = ablasblocksize(a, _state)*(refcnt/ablasblocksize(a, _state));
11021  blocksize = refcnt-blockstart;
11022  while(blockstart>=0)
11023  {
11024  rowscount = m-blockstart;
11025  if( blocksize>0 )
11026  {
11027 
11028  /*
11029  * Copy current block
11030  */
11031  rmatrixcopy(rowscount, blocksize, a, blockstart, blockstart, &tmpa, 0, 0, _state);
11032  ae_v_move(&taubuf.ptr.p_double[0], 1, &tau->ptr.p_double[blockstart], 1, ae_v_len(0,blocksize-1));
11033 
11034  /*
11035  * Update, choose between:
11036  * a) Level 2 algorithm (when the rest of the matrix is small enough)
11037  * b) blocked algorithm, see algorithm 5 from 'A storage efficient WY
11038  * representation for products of Householder transformations',
11039  * by R. Schreiber and C. Van Loan.
11040  */
11041  if( qcolumns>=2*ablasblocksize(a, _state) )
11042  {
11043 
11044  /*
11045  * Prepare block reflector
11046  */
11047  ortfac_rmatrixblockreflector(&tmpa, &taubuf, ae_true, rowscount, blocksize, &tmpt, &work, _state);
11048 
11049  /*
11050  * Multiply matrix by Q.
11051  *
11052  * Q = E + Y*T*Y' = E + TmpA*TmpT*TmpA'
11053  */
11054  rmatrixgemm(blocksize, qcolumns, rowscount, 1.0, &tmpa, 0, 0, 1, q, blockstart, 0, 0, 0.0, &tmpr, 0, 0, _state);
11055  rmatrixgemm(blocksize, qcolumns, blocksize, 1.0, &tmpt, 0, 0, 0, &tmpr, 0, 0, 0, 0.0, &tmpr, blocksize, 0, _state);
11056  rmatrixgemm(rowscount, qcolumns, blocksize, 1.0, &tmpa, 0, 0, 0, &tmpr, blocksize, 0, 0, 1.0, q, blockstart, 0, _state);
11057  }
11058  else
11059  {
11060 
11061  /*
11062  * Level 2 algorithm
11063  */
11064  for(i=blocksize-1; i>=0; i--)
11065  {
11066  ae_v_move(&t.ptr.p_double[1], 1, &tmpa.ptr.pp_double[i][i], tmpa.stride, ae_v_len(1,rowscount-i));
11067  t.ptr.p_double[1] = 1;
11068  applyreflectionfromtheleft(q, taubuf.ptr.p_double[i], &t, blockstart+i, m-1, 0, qcolumns-1, &work, _state);
11069  }
11070  }
11071  }
11072 
11073  /*
11074  * Advance
11075  */
11076  blockstart = blockstart-ablasblocksize(a, _state);
11077  blocksize = ablasblocksize(a, _state);
11078  }
11079  ae_frame_leave(_state);
11080 }
11081 
11082 
11083 /*************************************************************************
11084 Unpacking of matrix R from the QR decomposition of a matrix A
11085 
11086 Input parameters:
11087  A - matrices Q and R in compact form.
11088  Output of RMatrixQR subroutine.
11089  M - number of rows in given matrix A. M>=0.
11090  N - number of columns in given matrix A. N>=0.
11091 
11092 Output parameters:
11093  R - matrix R, array[0..M-1, 0..N-1].
11094 
11095  -- ALGLIB routine --
11096  17.02.2010
11097  Bochkanov Sergey
11098 *************************************************************************/
11099 void rmatrixqrunpackr(/* Real */ ae_matrix* a,
11100  ae_int_t m,
11101  ae_int_t n,
11102  /* Real */ ae_matrix* r,
11103  ae_state *_state)
11104 {
11105  ae_int_t i;
11106  ae_int_t k;
11107 
11108  ae_matrix_clear(r);
11109 
11110  if( m<=0||n<=0 )
11111  {
11112  return;
11113  }
11114  k = ae_minint(m, n, _state);
11115  ae_matrix_set_length(r, m, n, _state);
11116  for(i=0; i<=n-1; i++)
11117  {
11118  r->ptr.pp_double[0][i] = 0;
11119  }
11120  for(i=1; i<=m-1; i++)
11121  {
11122  ae_v_move(&r->ptr.pp_double[i][0], 1, &r->ptr.pp_double[0][0], 1, ae_v_len(0,n-1));
11123  }
11124  for(i=0; i<=k-1; i++)
11125  {
11126  ae_v_move(&r->ptr.pp_double[i][i], 1, &a->ptr.pp_double[i][i], 1, ae_v_len(i,n-1));
11127  }
11128 }
11129 
11130 
11131 /*************************************************************************
11132 Partial unpacking of matrix Q from the LQ decomposition of a matrix A
11133 
11134 Input parameters:
11135  A - matrices L and Q in compact form.
11136  Output of RMatrixLQ subroutine.
11137  M - number of rows in given matrix A. M>=0.
11138  N - number of columns in given matrix A. N>=0.
11139  Tau - scalar factors which are used to form Q.
11140  Output of the RMatrixLQ subroutine.
11141  QRows - required number of rows in matrix Q. N>=QRows>=0.
11142 
11143 Output parameters:
11144  Q - first QRows rows of matrix Q. Array whose indexes range
11145  within [0..QRows-1, 0..N-1]. If QRows=0, the array remains
11146  unchanged.
11147 
11148  -- ALGLIB routine --
11149  17.02.2010
11150  Bochkanov Sergey
11151 *************************************************************************/
11152 void rmatrixlqunpackq(/* Real */ ae_matrix* a,
11153  ae_int_t m,
11154  ae_int_t n,
11155  /* Real */ ae_vector* tau,
11156  ae_int_t qrows,
11157  /* Real */ ae_matrix* q,
11158  ae_state *_state)
11159 {
11160  ae_frame _frame_block;
11161  ae_vector work;
11162  ae_vector t;
11163  ae_vector taubuf;
11164  ae_int_t minmn;
11165  ae_int_t refcnt;
11166  ae_matrix tmpa;
11167  ae_matrix tmpt;
11168  ae_matrix tmpr;
11169  ae_int_t blockstart;
11170  ae_int_t blocksize;
11171  ae_int_t columnscount;
11172  ae_int_t i;
11173  ae_int_t j;
11174 
11175  ae_frame_make(_state, &_frame_block);
11176  ae_matrix_clear(q);
11177  ae_vector_init(&work, 0, DT_REAL, _state, ae_true);
11178  ae_vector_init(&t, 0, DT_REAL, _state, ae_true);
11179  ae_vector_init(&taubuf, 0, DT_REAL, _state, ae_true);
11180  ae_matrix_init(&tmpa, 0, 0, DT_REAL, _state, ae_true);
11181  ae_matrix_init(&tmpt, 0, 0, DT_REAL, _state, ae_true);
11182  ae_matrix_init(&tmpr, 0, 0, DT_REAL, _state, ae_true);
11183 
11184  ae_assert(qrows<=n, "RMatrixLQUnpackQ: QRows>N!", _state);
11185  if( (m<=0||n<=0)||qrows<=0 )
11186  {
11187  ae_frame_leave(_state);
11188  return;
11189  }
11190 
11191  /*
11192  * init
11193  */
11194  minmn = ae_minint(m, n, _state);
11195  refcnt = ae_minint(minmn, qrows, _state);
11196  ae_vector_set_length(&work, ae_maxint(m, n, _state)+1, _state);
11197  ae_vector_set_length(&t, ae_maxint(m, n, _state)+1, _state);
11198  ae_vector_set_length(&taubuf, minmn, _state);
11199  ae_matrix_set_length(&tmpa, ablasblocksize(a, _state), n, _state);
11200  ae_matrix_set_length(&tmpt, ablasblocksize(a, _state), 2*ablasblocksize(a, _state), _state);
11201  ae_matrix_set_length(&tmpr, qrows, 2*ablasblocksize(a, _state), _state);
11202  ae_matrix_set_length(q, qrows, n, _state);
11203  for(i=0; i<=qrows-1; i++)
11204  {
11205  for(j=0; j<=n-1; j++)
11206  {
11207  if( i==j )
11208  {
11209  q->ptr.pp_double[i][j] = 1;
11210  }
11211  else
11212  {
11213  q->ptr.pp_double[i][j] = 0;
11214  }
11215  }
11216  }
11217 
11218  /*
11219  * Blocked code
11220  */
11221  blockstart = ablasblocksize(a, _state)*(refcnt/ablasblocksize(a, _state));
11222  blocksize = refcnt-blockstart;
11223  while(blockstart>=0)
11224  {
11225  columnscount = n-blockstart;
11226  if( blocksize>0 )
11227  {
11228 
11229  /*
11230  * Copy submatrix
11231  */
11232  rmatrixcopy(blocksize, columnscount, a, blockstart, blockstart, &tmpa, 0, 0, _state);
11233  ae_v_move(&taubuf.ptr.p_double[0], 1, &tau->ptr.p_double[blockstart], 1, ae_v_len(0,blocksize-1));
11234 
11235  /*
11236  * Update matrix, choose between:
11237  * a) Level 2 algorithm (when the rest of the matrix is small enough)
11238  * b) blocked algorithm, see algorithm 5 from 'A storage efficient WY
11239  * representation for products of Householder transformations',
11240  * by R. Schreiber and C. Van Loan.
11241  */
11242  if( qrows>=2*ablasblocksize(a, _state) )
11243  {
11244 
11245  /*
11246  * Prepare block reflector
11247  */
11248  ortfac_rmatrixblockreflector(&tmpa, &taubuf, ae_false, columnscount, blocksize, &tmpt, &work, _state);
11249 
11250  /*
11251  * Multiply the rest of A by Q'.
11252  *
11253  * Q' = E + Y*T'*Y' = E + TmpA'*TmpT'*TmpA
11254  */
11255  rmatrixgemm(qrows, blocksize, columnscount, 1.0, q, 0, blockstart, 0, &tmpa, 0, 0, 1, 0.0, &tmpr, 0, 0, _state);
11256  rmatrixgemm(qrows, blocksize, blocksize, 1.0, &tmpr, 0, 0, 0, &tmpt, 0, 0, 1, 0.0, &tmpr, 0, blocksize, _state);
11257  rmatrixgemm(qrows, columnscount, blocksize, 1.0, &tmpr, 0, blocksize, 0, &tmpa, 0, 0, 0, 1.0, q, 0, blockstart, _state);
11258  }
11259  else
11260  {
11261 
11262  /*
11263  * Level 2 algorithm
11264  */
11265  for(i=blocksize-1; i>=0; i--)
11266  {
11267  ae_v_move(&t.ptr.p_double[1], 1, &tmpa.ptr.pp_double[i][i], 1, ae_v_len(1,columnscount-i));
11268  t.ptr.p_double[1] = 1;
11269  applyreflectionfromtheright(q, taubuf.ptr.p_double[i], &t, 0, qrows-1, blockstart+i, n-1, &work, _state);
11270  }
11271  }
11272  }
11273 
11274  /*
11275  * Advance
11276  */
11277  blockstart = blockstart-ablasblocksize(a, _state);
11278  blocksize = ablasblocksize(a, _state);
11279  }
11280  ae_frame_leave(_state);
11281 }
11282 
11283 
11284 /*************************************************************************
11285 Unpacking of matrix L from the LQ decomposition of a matrix A
11286 
11287 Input parameters:
11288  A - matrices Q and L in compact form.
11289  Output of RMatrixLQ subroutine.
11290  M - number of rows in given matrix A. M>=0.
11291  N - number of columns in given matrix A. N>=0.
11292 
11293 Output parameters:
11294  L - matrix L, array[0..M-1, 0..N-1].
11295 
11296  -- ALGLIB routine --
11297  17.02.2010
11298  Bochkanov Sergey
11299 *************************************************************************/
11300 void rmatrixlqunpackl(/* Real */ ae_matrix* a,
11301  ae_int_t m,
11302  ae_int_t n,
11303  /* Real */ ae_matrix* l,
11304  ae_state *_state)
11305 {
11306  ae_int_t i;
11307  ae_int_t k;
11308 
11309  ae_matrix_clear(l);
11310 
11311  if( m<=0||n<=0 )
11312  {
11313  return;
11314  }
11315  ae_matrix_set_length(l, m, n, _state);
11316  for(i=0; i<=n-1; i++)
11317  {
11318  l->ptr.pp_double[0][i] = 0;
11319  }
11320  for(i=1; i<=m-1; i++)
11321  {
11322  ae_v_move(&l->ptr.pp_double[i][0], 1, &l->ptr.pp_double[0][0], 1, ae_v_len(0,n-1));
11323  }
11324  for(i=0; i<=m-1; i++)
11325  {
11326  k = ae_minint(i, n-1, _state);
11327  ae_v_move(&l->ptr.pp_double[i][0], 1, &a->ptr.pp_double[i][0], 1, ae_v_len(0,k));
11328  }
11329 }
11330 
11331 
11332 /*************************************************************************
11333 Partial unpacking of matrix Q from QR decomposition of a complex matrix A.
11334 
11335 Input parameters:
11336  A - matrices Q and R in compact form.
11337  Output of CMatrixQR subroutine .
11338  M - number of rows in matrix A. M>=0.
11339  N - number of columns in matrix A. N>=0.
11340  Tau - scalar factors which are used to form Q.
11341  Output of CMatrixQR subroutine .
11342  QColumns - required number of columns in matrix Q. M>=QColumns>=0.
11343 
11344 Output parameters:
11345  Q - first QColumns columns of matrix Q.
11346  Array whose index ranges within [0..M-1, 0..QColumns-1].
11347  If QColumns=0, array isn't changed.
11348 
11349  -- ALGLIB routine --
11350  17.02.2010
11351  Bochkanov Sergey
11352 *************************************************************************/
11353 void cmatrixqrunpackq(/* Complex */ ae_matrix* a,
11354  ae_int_t m,
11355  ae_int_t n,
11356  /* Complex */ ae_vector* tau,
11357  ae_int_t qcolumns,
11358  /* Complex */ ae_matrix* q,
11359  ae_state *_state)
11360 {
11361  ae_frame _frame_block;
11362  ae_vector work;
11363  ae_vector t;
11364  ae_vector taubuf;
11365  ae_int_t minmn;
11366  ae_int_t refcnt;
11367  ae_matrix tmpa;
11368  ae_matrix tmpt;
11369  ae_matrix tmpr;
11370  ae_int_t blockstart;
11371  ae_int_t blocksize;
11372  ae_int_t rowscount;
11373  ae_int_t i;
11374  ae_int_t j;
11375 
11376  ae_frame_make(_state, &_frame_block);
11377  ae_matrix_clear(q);
11378  ae_vector_init(&work, 0, DT_COMPLEX, _state, ae_true);
11379  ae_vector_init(&t, 0, DT_COMPLEX, _state, ae_true);
11380  ae_vector_init(&taubuf, 0, DT_COMPLEX, _state, ae_true);
11381  ae_matrix_init(&tmpa, 0, 0, DT_COMPLEX, _state, ae_true);
11382  ae_matrix_init(&tmpt, 0, 0, DT_COMPLEX, _state, ae_true);
11383  ae_matrix_init(&tmpr, 0, 0, DT_COMPLEX, _state, ae_true);
11384 
11385  ae_assert(qcolumns<=m, "UnpackQFromQR: QColumns>M!", _state);
11386  if( m<=0||n<=0 )
11387  {
11388  ae_frame_leave(_state);
11389  return;
11390  }
11391 
11392  /*
11393  * init
11394  */
11395  minmn = ae_minint(m, n, _state);
11396  refcnt = ae_minint(minmn, qcolumns, _state);
11397  ae_vector_set_length(&work, ae_maxint(m, n, _state)+1, _state);
11398  ae_vector_set_length(&t, ae_maxint(m, n, _state)+1, _state);
11399  ae_vector_set_length(&taubuf, minmn, _state);
11400  ae_matrix_set_length(&tmpa, m, ablascomplexblocksize(a, _state), _state);
11401  ae_matrix_set_length(&tmpt, ablascomplexblocksize(a, _state), ablascomplexblocksize(a, _state), _state);
11402  ae_matrix_set_length(&tmpr, 2*ablascomplexblocksize(a, _state), qcolumns, _state);
11403  ae_matrix_set_length(q, m, qcolumns, _state);
11404  for(i=0; i<=m-1; i++)
11405  {
11406  for(j=0; j<=qcolumns-1; j++)
11407  {
11408  if( i==j )
11409  {
11410  q->ptr.pp_complex[i][j] = ae_complex_from_d(1);
11411  }
11412  else
11413  {
11414  q->ptr.pp_complex[i][j] = ae_complex_from_d(0);
11415  }
11416  }
11417  }
11418 
11419  /*
11420  * Blocked code
11421  */
11422  blockstart = ablascomplexblocksize(a, _state)*(refcnt/ablascomplexblocksize(a, _state));
11423  blocksize = refcnt-blockstart;
11424  while(blockstart>=0)
11425  {
11426  rowscount = m-blockstart;
11427  if( blocksize>0 )
11428  {
11429 
11430  /*
11431  * QR decomposition of submatrix.
11432  * Matrix is copied to temporary storage to solve
11433  * some TLB issues arising from non-contiguous memory
11434  * access pattern.
11435  */
11436  cmatrixcopy(rowscount, blocksize, a, blockstart, blockstart, &tmpa, 0, 0, _state);
11437  ae_v_cmove(&taubuf.ptr.p_complex[0], 1, &tau->ptr.p_complex[blockstart], 1, "N", ae_v_len(0,blocksize-1));
11438 
11439  /*
11440  * Update matrix, choose between:
11441  * a) Level 2 algorithm (when the rest of the matrix is small enough)
11442  * b) blocked algorithm, see algorithm 5 from 'A storage efficient WY
11443  * representation for products of Householder transformations',
11444  * by R. Schreiber and C. Van Loan.
11445  */
11446  if( qcolumns>=2*ablascomplexblocksize(a, _state) )
11447  {
11448 
11449  /*
11450  * Prepare block reflector
11451  */
11452  ortfac_cmatrixblockreflector(&tmpa, &taubuf, ae_true, rowscount, blocksize, &tmpt, &work, _state);
11453 
11454  /*
11455  * Multiply the rest of A by Q.
11456  *
11457  * Q = E + Y*T*Y' = E + TmpA*TmpT*TmpA'
11458  */
11459  cmatrixgemm(blocksize, qcolumns, rowscount, ae_complex_from_d(1.0), &tmpa, 0, 0, 2, q, blockstart, 0, 0, ae_complex_from_d(0.0), &tmpr, 0, 0, _state);
11460  cmatrixgemm(blocksize, qcolumns, blocksize, ae_complex_from_d(1.0), &tmpt, 0, 0, 0, &tmpr, 0, 0, 0, ae_complex_from_d(0.0), &tmpr, blocksize, 0, _state);
11461  cmatrixgemm(rowscount, qcolumns, blocksize, ae_complex_from_d(1.0), &tmpa, 0, 0, 0, &tmpr, blocksize, 0, 0, ae_complex_from_d(1.0), q, blockstart, 0, _state);
11462  }
11463  else
11464  {
11465 
11466  /*
11467  * Level 2 algorithm
11468  */
11469  for(i=blocksize-1; i>=0; i--)
11470  {
11471  ae_v_cmove(&t.ptr.p_complex[1], 1, &tmpa.ptr.pp_complex[i][i], tmpa.stride, "N", ae_v_len(1,rowscount-i));
11472  t.ptr.p_complex[1] = ae_complex_from_d(1);
11473  complexapplyreflectionfromtheleft(q, taubuf.ptr.p_complex[i], &t, blockstart+i, m-1, 0, qcolumns-1, &work, _state);
11474  }
11475  }
11476  }
11477 
11478  /*
11479  * Advance
11480  */
11481  blockstart = blockstart-ablascomplexblocksize(a, _state);
11482  blocksize = ablascomplexblocksize(a, _state);
11483  }
11484  ae_frame_leave(_state);
11485 }
11486 
11487 
11488 /*************************************************************************
11489 Unpacking of matrix R from the QR decomposition of a matrix A
11490 
11491 Input parameters:
11492  A - matrices Q and R in compact form.
11493  Output of CMatrixQR subroutine.
11494  M - number of rows in given matrix A. M>=0.
11495  N - number of columns in given matrix A. N>=0.
11496 
11497 Output parameters:
11498  R - matrix R, array[0..M-1, 0..N-1].
11499 
11500  -- ALGLIB routine --
11501  17.02.2010
11502  Bochkanov Sergey
11503 *************************************************************************/
11504 void cmatrixqrunpackr(/* Complex */ ae_matrix* a,
11505  ae_int_t m,
11506  ae_int_t n,
11507  /* Complex */ ae_matrix* r,
11508  ae_state *_state)
11509 {
11510  ae_int_t i;
11511  ae_int_t k;
11512 
11513  ae_matrix_clear(r);
11514 
11515  if( m<=0||n<=0 )
11516  {
11517  return;
11518  }
11519  k = ae_minint(m, n, _state);
11520  ae_matrix_set_length(r, m, n, _state);
11521  for(i=0; i<=n-1; i++)
11522  {
11523  r->ptr.pp_complex[0][i] = ae_complex_from_d(0);
11524  }
11525  for(i=1; i<=m-1; i++)
11526  {
11527  ae_v_cmove(&r->ptr.pp_complex[i][0], 1, &r->ptr.pp_complex[0][0], 1, "N", ae_v_len(0,n-1));
11528  }
11529  for(i=0; i<=k-1; i++)
11530  {
11531  ae_v_cmove(&r->ptr.pp_complex[i][i], 1, &a->ptr.pp_complex[i][i], 1, "N", ae_v_len(i,n-1));
11532  }
11533 }
11534 
11535 
11536 /*************************************************************************
11537 Partial unpacking of matrix Q from LQ decomposition of a complex matrix A.
11538 
11539 Input parameters:
11540  A - matrices Q and R in compact form.
11541  Output of CMatrixLQ subroutine .
11542  M - number of rows in matrix A. M>=0.
11543  N - number of columns in matrix A. N>=0.
11544  Tau - scalar factors which are used to form Q.
11545  Output of CMatrixLQ subroutine .
11546  QRows - required number of rows in matrix Q. N>=QColumns>=0.
11547 
11548 Output parameters:
11549  Q - first QRows rows of matrix Q.
11550  Array whose index ranges within [0..QRows-1, 0..N-1].
11551  If QRows=0, array isn't changed.
11552 
11553  -- ALGLIB routine --
11554  17.02.2010
11555  Bochkanov Sergey
11556 *************************************************************************/
11557 void cmatrixlqunpackq(/* Complex */ ae_matrix* a,
11558  ae_int_t m,
11559  ae_int_t n,
11560  /* Complex */ ae_vector* tau,
11561  ae_int_t qrows,
11562  /* Complex */ ae_matrix* q,
11563  ae_state *_state)
11564 {
11565  ae_frame _frame_block;
11566  ae_vector work;
11567  ae_vector t;
11568  ae_vector taubuf;
11569  ae_int_t minmn;
11570  ae_int_t refcnt;
11571  ae_matrix tmpa;
11572  ae_matrix tmpt;
11573  ae_matrix tmpr;
11574  ae_int_t blockstart;
11575  ae_int_t blocksize;
11576  ae_int_t columnscount;
11577  ae_int_t i;
11578  ae_int_t j;
11579 
11580  ae_frame_make(_state, &_frame_block);
11581  ae_matrix_clear(q);
11582  ae_vector_init(&work, 0, DT_COMPLEX, _state, ae_true);
11583  ae_vector_init(&t, 0, DT_COMPLEX, _state, ae_true);
11584  ae_vector_init(&taubuf, 0, DT_COMPLEX, _state, ae_true);
11585  ae_matrix_init(&tmpa, 0, 0, DT_COMPLEX, _state, ae_true);
11586  ae_matrix_init(&tmpt, 0, 0, DT_COMPLEX, _state, ae_true);
11587  ae_matrix_init(&tmpr, 0, 0, DT_COMPLEX, _state, ae_true);
11588 
11589  if( m<=0||n<=0 )
11590  {
11591  ae_frame_leave(_state);
11592  return;
11593  }
11594 
11595  /*
11596  * Init
11597  */
11598  minmn = ae_minint(m, n, _state);
11599  refcnt = ae_minint(minmn, qrows, _state);
11600  ae_vector_set_length(&work, ae_maxint(m, n, _state)+1, _state);
11601  ae_vector_set_length(&t, ae_maxint(m, n, _state)+1, _state);
11602  ae_vector_set_length(&taubuf, minmn, _state);
11603  ae_matrix_set_length(&tmpa, ablascomplexblocksize(a, _state), n, _state);
11604  ae_matrix_set_length(&tmpt, ablascomplexblocksize(a, _state), ablascomplexblocksize(a, _state), _state);
11605  ae_matrix_set_length(&tmpr, qrows, 2*ablascomplexblocksize(a, _state), _state);
11606  ae_matrix_set_length(q, qrows, n, _state);
11607  for(i=0; i<=qrows-1; i++)
11608  {
11609  for(j=0; j<=n-1; j++)
11610  {
11611  if( i==j )
11612  {
11613  q->ptr.pp_complex[i][j] = ae_complex_from_d(1);
11614  }
11615  else
11616  {
11617  q->ptr.pp_complex[i][j] = ae_complex_from_d(0);
11618  }
11619  }
11620  }
11621 
11622  /*
11623  * Blocked code
11624  */
11625  blockstart = ablascomplexblocksize(a, _state)*(refcnt/ablascomplexblocksize(a, _state));
11626  blocksize = refcnt-blockstart;
11627  while(blockstart>=0)
11628  {
11629  columnscount = n-blockstart;
11630  if( blocksize>0 )
11631  {
11632 
11633  /*
11634  * LQ decomposition of submatrix.
11635  * Matrix is copied to temporary storage to solve
11636  * some TLB issues arising from non-contiguous memory
11637  * access pattern.
11638  */
11639  cmatrixcopy(blocksize, columnscount, a, blockstart, blockstart, &tmpa, 0, 0, _state);
11640  ae_v_cmove(&taubuf.ptr.p_complex[0], 1, &tau->ptr.p_complex[blockstart], 1, "N", ae_v_len(0,blocksize-1));
11641 
11642  /*
11643  * Update matrix, choose between:
11644  * a) Level 2 algorithm (when the rest of the matrix is small enough)
11645  * b) blocked algorithm, see algorithm 5 from 'A storage efficient WY
11646  * representation for products of Householder transformations',
11647  * by R. Schreiber and C. Van Loan.
11648  */
11649  if( qrows>=2*ablascomplexblocksize(a, _state) )
11650  {
11651 
11652  /*
11653  * Prepare block reflector
11654  */
11655  ortfac_cmatrixblockreflector(&tmpa, &taubuf, ae_false, columnscount, blocksize, &tmpt, &work, _state);
11656 
11657  /*
11658  * Multiply the rest of A by Q'.
11659  *
11660  * Q' = E + Y*T'*Y' = E + TmpA'*TmpT'*TmpA
11661  */
11662  cmatrixgemm(qrows, blocksize, columnscount, ae_complex_from_d(1.0), q, 0, blockstart, 0, &tmpa, 0, 0, 2, ae_complex_from_d(0.0), &tmpr, 0, 0, _state);
11663  cmatrixgemm(qrows, blocksize, blocksize, ae_complex_from_d(1.0), &tmpr, 0, 0, 0, &tmpt, 0, 0, 2, ae_complex_from_d(0.0), &tmpr, 0, blocksize, _state);
11664  cmatrixgemm(qrows, columnscount, blocksize, ae_complex_from_d(1.0), &tmpr, 0, blocksize, 0, &tmpa, 0, 0, 0, ae_complex_from_d(1.0), q, 0, blockstart, _state);
11665  }
11666  else
11667  {
11668 
11669  /*
11670  * Level 2 algorithm
11671  */
11672  for(i=blocksize-1; i>=0; i--)
11673  {
11674  ae_v_cmove(&t.ptr.p_complex[1], 1, &tmpa.ptr.pp_complex[i][i], 1, "Conj", ae_v_len(1,columnscount-i));
11675  t.ptr.p_complex[1] = ae_complex_from_d(1);
11676  complexapplyreflectionfromtheright(q, ae_c_conj(taubuf.ptr.p_complex[i], _state), &t, 0, qrows-1, blockstart+i, n-1, &work, _state);
11677  }
11678  }
11679  }
11680 
11681  /*
11682  * Advance
11683  */
11684  blockstart = blockstart-ablascomplexblocksize(a, _state);
11685  blocksize = ablascomplexblocksize(a, _state);
11686  }
11687  ae_frame_leave(_state);
11688 }
11689 
11690 
11691 /*************************************************************************
11692 Unpacking of matrix L from the LQ decomposition of a matrix A
11693 
11694 Input parameters:
11695  A - matrices Q and L in compact form.
11696  Output of CMatrixLQ subroutine.
11697  M - number of rows in given matrix A. M>=0.
11698  N - number of columns in given matrix A. N>=0.
11699 
11700 Output parameters:
11701  L - matrix L, array[0..M-1, 0..N-1].
11702 
11703  -- ALGLIB routine --
11704  17.02.2010
11705  Bochkanov Sergey
11706 *************************************************************************/
11707 void cmatrixlqunpackl(/* Complex */ ae_matrix* a,
11708  ae_int_t m,
11709  ae_int_t n,
11710  /* Complex */ ae_matrix* l,
11711  ae_state *_state)
11712 {
11713  ae_int_t i;
11714  ae_int_t k;
11715 
11716  ae_matrix_clear(l);
11717 
11718  if( m<=0||n<=0 )
11719  {
11720  return;
11721  }
11722  ae_matrix_set_length(l, m, n, _state);
11723  for(i=0; i<=n-1; i++)
11724  {
11725  l->ptr.pp_complex[0][i] = ae_complex_from_d(0);
11726  }
11727  for(i=1; i<=m-1; i++)
11728  {
11729  ae_v_cmove(&l->ptr.pp_complex[i][0], 1, &l->ptr.pp_complex[0][0], 1, "N", ae_v_len(0,n-1));
11730  }
11731  for(i=0; i<=m-1; i++)
11732  {
11733  k = ae_minint(i, n-1, _state);
11734  ae_v_cmove(&l->ptr.pp_complex[i][0], 1, &a->ptr.pp_complex[i][0], 1, "N", ae_v_len(0,k));
11735  }
11736 }
11737 
11738 
11739 /*************************************************************************
11740 Base case for real QR
11741 
11742  -- LAPACK routine (version 3.0) --
11743  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
11744  Courant Institute, Argonne National Lab, and Rice University
11745  September 30, 1994.
11746  Sergey Bochkanov, ALGLIB project, translation from FORTRAN to
11747  pseudocode, 2007-2010.
11748 *************************************************************************/
11749 void rmatrixqrbasecase(/* Real */ ae_matrix* a,
11750  ae_int_t m,
11751  ae_int_t n,
11752  /* Real */ ae_vector* work,
11753  /* Real */ ae_vector* t,
11754  /* Real */ ae_vector* tau,
11755  ae_state *_state)
11756 {
11757  ae_int_t i;
11758  ae_int_t k;
11759  ae_int_t minmn;
11760  double tmp;
11761 
11762 
11763  minmn = ae_minint(m, n, _state);
11764 
11765  /*
11766  * Test the input arguments
11767  */
11768  k = minmn;
11769  for(i=0; i<=k-1; i++)
11770  {
11771 
11772  /*
11773  * Generate elementary reflector H(i) to annihilate A(i+1:m,i)
11774  */
11775  ae_v_move(&t->ptr.p_double[1], 1, &a->ptr.pp_double[i][i], a->stride, ae_v_len(1,m-i));
11776  generatereflection(t, m-i, &tmp, _state);
11777  tau->ptr.p_double[i] = tmp;
11778  ae_v_move(&a->ptr.pp_double[i][i], a->stride, &t->ptr.p_double[1], 1, ae_v_len(i,m-1));
11779  t->ptr.p_double[1] = 1;
11780  if( i<n )
11781  {
11782 
11783  /*
11784  * Apply H(i) to A(i:m-1,i+1:n-1) from the left
11785  */
11786  applyreflectionfromtheleft(a, tau->ptr.p_double[i], t, i, m-1, i+1, n-1, work, _state);
11787  }
11788  }
11789 }
11790 
11791 
11792 /*************************************************************************
11793 Base case for real LQ
11794 
11795  -- LAPACK routine (version 3.0) --
11796  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
11797  Courant Institute, Argonne National Lab, and Rice University
11798  September 30, 1994.
11799  Sergey Bochkanov, ALGLIB project, translation from FORTRAN to
11800  pseudocode, 2007-2010.
11801 *************************************************************************/
11802 void rmatrixlqbasecase(/* Real */ ae_matrix* a,
11803  ae_int_t m,
11804  ae_int_t n,
11805  /* Real */ ae_vector* work,
11806  /* Real */ ae_vector* t,
11807  /* Real */ ae_vector* tau,
11808  ae_state *_state)
11809 {
11810  ae_int_t i;
11811  ae_int_t k;
11812  double tmp;
11813 
11814 
11815  k = ae_minint(m, n, _state);
11816  for(i=0; i<=k-1; i++)
11817  {
11818 
11819  /*
11820  * Generate elementary reflector H(i) to annihilate A(i,i+1:n-1)
11821  */
11822  ae_v_move(&t->ptr.p_double[1], 1, &a->ptr.pp_double[i][i], 1, ae_v_len(1,n-i));
11823  generatereflection(t, n-i, &tmp, _state);
11824  tau->ptr.p_double[i] = tmp;
11825  ae_v_move(&a->ptr.pp_double[i][i], 1, &t->ptr.p_double[1], 1, ae_v_len(i,n-1));
11826  t->ptr.p_double[1] = 1;
11827  if( i<n )
11828  {
11829 
11830  /*
11831  * Apply H(i) to A(i+1:m,i:n) from the right
11832  */
11833  applyreflectionfromtheright(a, tau->ptr.p_double[i], t, i+1, m-1, i, n-1, work, _state);
11834  }
11835  }
11836 }
11837 
11838 
11839 /*************************************************************************
11840 Reduction of a rectangular matrix to bidiagonal form
11841 
11842 The algorithm reduces the rectangular matrix A to bidiagonal form by
11843 orthogonal transformations P and Q: A = Q*B*P.
11844 
11845 Input parameters:
11846  A - source matrix. array[0..M-1, 0..N-1]
11847  M - number of rows in matrix A.
11848  N - number of columns in matrix A.
11849 
11850 Output parameters:
11851  A - matrices Q, B, P in compact form (see below).
11852  TauQ - scalar factors which are used to form matrix Q.
11853  TauP - scalar factors which are used to form matrix P.
11854 
11855 The main diagonal and one of the secondary diagonals of matrix A are
11856 replaced with bidiagonal matrix B. Other elements contain elementary
11857 reflections which form MxM matrix Q and NxN matrix P, respectively.
11858 
11859 If M>=N, B is the upper bidiagonal MxN matrix and is stored in the
11860 corresponding elements of matrix A. Matrix Q is represented as a
11861 product of elementary reflections Q = H(0)*H(1)*...*H(n-1), where
11862 H(i) = 1-tau*v*v'. Here tau is a scalar which is stored in TauQ[i], and
11863 vector v has the following structure: v(0:i-1)=0, v(i)=1, v(i+1:m-1) is
11864 stored in elements A(i+1:m-1,i). Matrix P is as follows: P =
11865 G(0)*G(1)*...*G(n-2), where G(i) = 1 - tau*u*u'. Tau is stored in TauP[i],
11866 u(0:i)=0, u(i+1)=1, u(i+2:n-1) is stored in elements A(i,i+2:n-1).
11867 
11868 If M<N, B is the lower bidiagonal MxN matrix and is stored in the
11869 corresponding elements of matrix A. Q = H(0)*H(1)*...*H(m-2), where
11870 H(i) = 1 - tau*v*v', tau is stored in TauQ, v(0:i)=0, v(i+1)=1, v(i+2:m-1)
11871 is stored in elements A(i+2:m-1,i). P = G(0)*G(1)*...*G(m-1),
11872 G(i) = 1-tau*u*u', tau is stored in TauP, u(0:i-1)=0, u(i)=1, u(i+1:n-1)
11873 is stored in A(i,i+1:n-1).
11874 
11875 EXAMPLE:
11876 
11877 m=6, n=5 (m > n): m=5, n=6 (m < n):
11878 
11879 ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
11880 ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
11881 ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
11882 ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
11883 ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
11884 ( v1 v2 v3 v4 v5 )
11885 
11886 Here vi and ui are vectors which form H(i) and G(i), and d and e -
11887 are the diagonal and off-diagonal elements of matrix B.
11888 
11889  -- LAPACK routine (version 3.0) --
11890  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
11891  Courant Institute, Argonne National Lab, and Rice University
11892  September 30, 1994.
11893  Sergey Bochkanov, ALGLIB project, translation from FORTRAN to
11894  pseudocode, 2007-2010.
11895 *************************************************************************/
11896 void rmatrixbd(/* Real */ ae_matrix* a,
11897  ae_int_t m,
11898  ae_int_t n,
11899  /* Real */ ae_vector* tauq,
11900  /* Real */ ae_vector* taup,
11901  ae_state *_state)
11902 {
11903  ae_frame _frame_block;
11904  ae_vector work;
11905  ae_vector t;
11906  ae_int_t maxmn;
11907  ae_int_t i;
11908  double ltau;
11909 
11910  ae_frame_make(_state, &_frame_block);
11911  ae_vector_clear(tauq);
11912  ae_vector_clear(taup);
11913  ae_vector_init(&work, 0, DT_REAL, _state, ae_true);
11914  ae_vector_init(&t, 0, DT_REAL, _state, ae_true);
11915 
11916 
11917  /*
11918  * Prepare
11919  */
11920  if( n<=0||m<=0 )
11921  {
11922  ae_frame_leave(_state);
11923  return;
11924  }
11925  maxmn = ae_maxint(m, n, _state);
11926  ae_vector_set_length(&work, maxmn+1, _state);
11927  ae_vector_set_length(&t, maxmn+1, _state);
11928  if( m>=n )
11929  {
11930  ae_vector_set_length(tauq, n, _state);
11931  ae_vector_set_length(taup, n, _state);
11932  }
11933  else
11934  {
11935  ae_vector_set_length(tauq, m, _state);
11936  ae_vector_set_length(taup, m, _state);
11937  }
11938  if( m>=n )
11939  {
11940 
11941  /*
11942  * Reduce to upper bidiagonal form
11943  */
11944  for(i=0; i<=n-1; i++)
11945  {
11946 
11947  /*
11948  * Generate elementary reflector H(i) to annihilate A(i+1:m-1,i)
11949  */
11950  ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[i][i], a->stride, ae_v_len(1,m-i));
11951  generatereflection(&t, m-i, &ltau, _state);
11952  tauq->ptr.p_double[i] = ltau;
11953  ae_v_move(&a->ptr.pp_double[i][i], a->stride, &t.ptr.p_double[1], 1, ae_v_len(i,m-1));
11954  t.ptr.p_double[1] = 1;
11955 
11956  /*
11957  * Apply H(i) to A(i:m-1,i+1:n-1) from the left
11958  */
11959  applyreflectionfromtheleft(a, ltau, &t, i, m-1, i+1, n-1, &work, _state);
11960  if( i<n-1 )
11961  {
11962 
11963  /*
11964  * Generate elementary reflector G(i) to annihilate
11965  * A(i,i+2:n-1)
11966  */
11967  ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[i][i+1], 1, ae_v_len(1,n-i-1));
11968  generatereflection(&t, n-1-i, &ltau, _state);
11969  taup->ptr.p_double[i] = ltau;
11970  ae_v_move(&a->ptr.pp_double[i][i+1], 1, &t.ptr.p_double[1], 1, ae_v_len(i+1,n-1));
11971  t.ptr.p_double[1] = 1;
11972 
11973  /*
11974  * Apply G(i) to A(i+1:m-1,i+1:n-1) from the right
11975  */
11976  applyreflectionfromtheright(a, ltau, &t, i+1, m-1, i+1, n-1, &work, _state);
11977  }
11978  else
11979  {
11980  taup->ptr.p_double[i] = 0;
11981  }
11982  }
11983  }
11984  else
11985  {
11986 
11987  /*
11988  * Reduce to lower bidiagonal form
11989  */
11990  for(i=0; i<=m-1; i++)
11991  {
11992 
11993  /*
11994  * Generate elementary reflector G(i) to annihilate A(i,i+1:n-1)
11995  */
11996  ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[i][i], 1, ae_v_len(1,n-i));
11997  generatereflection(&t, n-i, &ltau, _state);
11998  taup->ptr.p_double[i] = ltau;
11999  ae_v_move(&a->ptr.pp_double[i][i], 1, &t.ptr.p_double[1], 1, ae_v_len(i,n-1));
12000  t.ptr.p_double[1] = 1;
12001 
12002  /*
12003  * Apply G(i) to A(i+1:m-1,i:n-1) from the right
12004  */
12005  applyreflectionfromtheright(a, ltau, &t, i+1, m-1, i, n-1, &work, _state);
12006  if( i<m-1 )
12007  {
12008 
12009  /*
12010  * Generate elementary reflector H(i) to annihilate
12011  * A(i+2:m-1,i)
12012  */
12013  ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[i+1][i], a->stride, ae_v_len(1,m-1-i));
12014  generatereflection(&t, m-1-i, &ltau, _state);
12015  tauq->ptr.p_double[i] = ltau;
12016  ae_v_move(&a->ptr.pp_double[i+1][i], a->stride, &t.ptr.p_double[1], 1, ae_v_len(i+1,m-1));
12017  t.ptr.p_double[1] = 1;
12018 
12019  /*
12020  * Apply H(i) to A(i+1:m-1,i+1:n-1) from the left
12021  */
12022  applyreflectionfromtheleft(a, ltau, &t, i+1, m-1, i+1, n-1, &work, _state);
12023  }
12024  else
12025  {
12026  tauq->ptr.p_double[i] = 0;
12027  }
12028  }
12029  }
12030  ae_frame_leave(_state);
12031 }
12032 
12033 
12034 /*************************************************************************
12035 Unpacking matrix Q which reduces a matrix to bidiagonal form.
12036 
12037 Input parameters:
12038  QP - matrices Q and P in compact form.
12039  Output of ToBidiagonal subroutine.
12040  M - number of rows in matrix A.
12041  N - number of columns in matrix A.
12042  TAUQ - scalar factors which are used to form Q.
12043  Output of ToBidiagonal subroutine.
12044  QColumns - required number of columns in matrix Q.
12045  M>=QColumns>=0.
12046 
12047 Output parameters:
12048  Q - first QColumns columns of matrix Q.
12049  Array[0..M-1, 0..QColumns-1]
12050  If QColumns=0, the array is not modified.
12051 
12052  -- ALGLIB --
12053  2005-2010
12054  Bochkanov Sergey
12055 *************************************************************************/
12056 void rmatrixbdunpackq(/* Real */ ae_matrix* qp,
12057  ae_int_t m,
12058  ae_int_t n,
12059  /* Real */ ae_vector* tauq,
12060  ae_int_t qcolumns,
12061  /* Real */ ae_matrix* q,
12062  ae_state *_state)
12063 {
12064  ae_int_t i;
12065  ae_int_t j;
12066 
12067  ae_matrix_clear(q);
12068 
12069  ae_assert(qcolumns<=m, "RMatrixBDUnpackQ: QColumns>M!", _state);
12070  ae_assert(qcolumns>=0, "RMatrixBDUnpackQ: QColumns<0!", _state);
12071  if( (m==0||n==0)||qcolumns==0 )
12072  {
12073  return;
12074  }
12075 
12076  /*
12077  * prepare Q
12078  */
12079  ae_matrix_set_length(q, m, qcolumns, _state);
12080  for(i=0; i<=m-1; i++)
12081  {
12082  for(j=0; j<=qcolumns-1; j++)
12083  {
12084  if( i==j )
12085  {
12086  q->ptr.pp_double[i][j] = 1;
12087  }
12088  else
12089  {
12090  q->ptr.pp_double[i][j] = 0;
12091  }
12092  }
12093  }
12094 
12095  /*
12096  * Calculate
12097  */
12098  rmatrixbdmultiplybyq(qp, m, n, tauq, q, m, qcolumns, ae_false, ae_false, _state);
12099 }
12100 
12101 
12102 /*************************************************************************
12103 Multiplication by matrix Q which reduces matrix A to bidiagonal form.
12104 
12105 The algorithm allows pre- or post-multiply by Q or Q'.
12106 
12107 Input parameters:
12108  QP - matrices Q and P in compact form.
12109  Output of ToBidiagonal subroutine.
12110  M - number of rows in matrix A.
12111  N - number of columns in matrix A.
12112  TAUQ - scalar factors which are used to form Q.
12113  Output of ToBidiagonal subroutine.
12114  Z - multiplied matrix.
12115  array[0..ZRows-1,0..ZColumns-1]
12116  ZRows - number of rows in matrix Z. If FromTheRight=False,
12117  ZRows=M, otherwise ZRows can be arbitrary.
12118  ZColumns - number of columns in matrix Z. If FromTheRight=True,
12119  ZColumns=M, otherwise ZColumns can be arbitrary.
12120  FromTheRight - pre- or post-multiply.
12121  DoTranspose - multiply by Q or Q'.
12122 
12123 Output parameters:
12124  Z - product of Z and Q.
12125  Array[0..ZRows-1,0..ZColumns-1]
12126  If ZRows=0 or ZColumns=0, the array is not modified.
12127 
12128  -- ALGLIB --
12129  2005-2010
12130  Bochkanov Sergey
12131 *************************************************************************/
12132 void rmatrixbdmultiplybyq(/* Real */ ae_matrix* qp,
12133  ae_int_t m,
12134  ae_int_t n,
12135  /* Real */ ae_vector* tauq,
12136  /* Real */ ae_matrix* z,
12137  ae_int_t zrows,
12138  ae_int_t zcolumns,
12139  ae_bool fromtheright,
12140  ae_bool dotranspose,
12141  ae_state *_state)
12142 {
12143  ae_frame _frame_block;
12144  ae_int_t i;
12145  ae_int_t i1;
12146  ae_int_t i2;
12147  ae_int_t istep;
12148  ae_vector v;
12149  ae_vector work;
12150  ae_int_t mx;
12151 
12152  ae_frame_make(_state, &_frame_block);
12153  ae_vector_init(&v, 0, DT_REAL, _state, ae_true);
12154  ae_vector_init(&work, 0, DT_REAL, _state, ae_true);
12155 
12156  if( ((m<=0||n<=0)||zrows<=0)||zcolumns<=0 )
12157  {
12158  ae_frame_leave(_state);
12159  return;
12160  }
12161  ae_assert((fromtheright&&zcolumns==m)||(!fromtheright&&zrows==m), "RMatrixBDMultiplyByQ: incorrect Z size!", _state);
12162 
12163  /*
12164  * init
12165  */
12166  mx = ae_maxint(m, n, _state);
12167  mx = ae_maxint(mx, zrows, _state);
12168  mx = ae_maxint(mx, zcolumns, _state);
12169  ae_vector_set_length(&v, mx+1, _state);
12170  ae_vector_set_length(&work, mx+1, _state);
12171  if( m>=n )
12172  {
12173 
12174  /*
12175  * setup
12176  */
12177  if( fromtheright )
12178  {
12179  i1 = 0;
12180  i2 = n-1;
12181  istep = 1;
12182  }
12183  else
12184  {
12185  i1 = n-1;
12186  i2 = 0;
12187  istep = -1;
12188  }
12189  if( dotranspose )
12190  {
12191  i = i1;
12192  i1 = i2;
12193  i2 = i;
12194  istep = -istep;
12195  }
12196 
12197  /*
12198  * Process
12199  */
12200  i = i1;
12201  do
12202  {
12203  ae_v_move(&v.ptr.p_double[1], 1, &qp->ptr.pp_double[i][i], qp->stride, ae_v_len(1,m-i));
12204  v.ptr.p_double[1] = 1;
12205  if( fromtheright )
12206  {
12207  applyreflectionfromtheright(z, tauq->ptr.p_double[i], &v, 0, zrows-1, i, m-1, &work, _state);
12208  }
12209  else
12210  {
12211  applyreflectionfromtheleft(z, tauq->ptr.p_double[i], &v, i, m-1, 0, zcolumns-1, &work, _state);
12212  }
12213  i = i+istep;
12214  }
12215  while(i!=i2+istep);
12216  }
12217  else
12218  {
12219 
12220  /*
12221  * setup
12222  */
12223  if( fromtheright )
12224  {
12225  i1 = 0;
12226  i2 = m-2;
12227  istep = 1;
12228  }
12229  else
12230  {
12231  i1 = m-2;
12232  i2 = 0;
12233  istep = -1;
12234  }
12235  if( dotranspose )
12236  {
12237  i = i1;
12238  i1 = i2;
12239  i2 = i;
12240  istep = -istep;
12241  }
12242 
12243  /*
12244  * Process
12245  */
12246  if( m-1>0 )
12247  {
12248  i = i1;
12249  do
12250  {
12251  ae_v_move(&v.ptr.p_double[1], 1, &qp->ptr.pp_double[i+1][i], qp->stride, ae_v_len(1,m-i-1));
12252  v.ptr.p_double[1] = 1;
12253  if( fromtheright )
12254  {
12255  applyreflectionfromtheright(z, tauq->ptr.p_double[i], &v, 0, zrows-1, i+1, m-1, &work, _state);
12256  }
12257  else
12258  {
12259  applyreflectionfromtheleft(z, tauq->ptr.p_double[i], &v, i+1, m-1, 0, zcolumns-1, &work, _state);
12260  }
12261  i = i+istep;
12262  }
12263  while(i!=i2+istep);
12264  }
12265  }
12266  ae_frame_leave(_state);
12267 }
12268 
12269 
12270 /*************************************************************************
12271 Unpacking matrix P which reduces matrix A to bidiagonal form.
12272 The subroutine returns transposed matrix P.
12273 
12274 Input parameters:
12275  QP - matrices Q and P in compact form.
12276  Output of ToBidiagonal subroutine.
12277  M - number of rows in matrix A.
12278  N - number of columns in matrix A.
12279  TAUP - scalar factors which are used to form P.
12280  Output of ToBidiagonal subroutine.
12281  PTRows - required number of rows of matrix P^T. N >= PTRows >= 0.
12282 
12283 Output parameters:
12284  PT - first PTRows columns of matrix P^T
12285  Array[0..PTRows-1, 0..N-1]
12286  If PTRows=0, the array is not modified.
12287 
12288  -- ALGLIB --
12289  2005-2010
12290  Bochkanov Sergey
12291 *************************************************************************/
12292 void rmatrixbdunpackpt(/* Real */ ae_matrix* qp,
12293  ae_int_t m,
12294  ae_int_t n,
12295  /* Real */ ae_vector* taup,
12296  ae_int_t ptrows,
12297  /* Real */ ae_matrix* pt,
12298  ae_state *_state)
12299 {
12300  ae_int_t i;
12301  ae_int_t j;
12302 
12303  ae_matrix_clear(pt);
12304 
12305  ae_assert(ptrows<=n, "RMatrixBDUnpackPT: PTRows>N!", _state);
12306  ae_assert(ptrows>=0, "RMatrixBDUnpackPT: PTRows<0!", _state);
12307  if( (m==0||n==0)||ptrows==0 )
12308  {
12309  return;
12310  }
12311 
12312  /*
12313  * prepare PT
12314  */
12315  ae_matrix_set_length(pt, ptrows, n, _state);
12316  for(i=0; i<=ptrows-1; i++)
12317  {
12318  for(j=0; j<=n-1; j++)
12319  {
12320  if( i==j )
12321  {
12322  pt->ptr.pp_double[i][j] = 1;
12323  }
12324  else
12325  {
12326  pt->ptr.pp_double[i][j] = 0;
12327  }
12328  }
12329  }
12330 
12331  /*
12332  * Calculate
12333  */
12334  rmatrixbdmultiplybyp(qp, m, n, taup, pt, ptrows, n, ae_true, ae_true, _state);
12335 }
12336 
12337 
12338 /*************************************************************************
12339 Multiplication by matrix P which reduces matrix A to bidiagonal form.
12340 
12341 The algorithm allows pre- or post-multiply by P or P'.
12342 
12343 Input parameters:
12344  QP - matrices Q and P in compact form.
12345  Output of RMatrixBD subroutine.
12346  M - number of rows in matrix A.
12347  N - number of columns in matrix A.
12348  TAUP - scalar factors which are used to form P.
12349  Output of RMatrixBD subroutine.
12350  Z - multiplied matrix.
12351  Array whose indexes range within [0..ZRows-1,0..ZColumns-1].
12352  ZRows - number of rows in matrix Z. If FromTheRight=False,
12353  ZRows=N, otherwise ZRows can be arbitrary.
12354  ZColumns - number of columns in matrix Z. If FromTheRight=True,
12355  ZColumns=N, otherwise ZColumns can be arbitrary.
12356  FromTheRight - pre- or post-multiply.
12357  DoTranspose - multiply by P or P'.
12358 
12359 Output parameters:
12360  Z - product of Z and P.
12361  Array whose indexes range within [0..ZRows-1,0..ZColumns-1].
12362  If ZRows=0 or ZColumns=0, the array is not modified.
12363 
12364  -- ALGLIB --
12365  2005-2010
12366  Bochkanov Sergey
12367 *************************************************************************/
12368 void rmatrixbdmultiplybyp(/* Real */ ae_matrix* qp,
12369  ae_int_t m,
12370  ae_int_t n,
12371  /* Real */ ae_vector* taup,
12372  /* Real */ ae_matrix* z,
12373  ae_int_t zrows,
12374  ae_int_t zcolumns,
12375  ae_bool fromtheright,
12376  ae_bool dotranspose,
12377  ae_state *_state)
12378 {
12379  ae_frame _frame_block;
12380  ae_int_t i;
12381  ae_vector v;
12382  ae_vector work;
12383  ae_int_t mx;
12384  ae_int_t i1;
12385  ae_int_t i2;
12386  ae_int_t istep;
12387 
12388  ae_frame_make(_state, &_frame_block);
12389  ae_vector_init(&v, 0, DT_REAL, _state, ae_true);
12390  ae_vector_init(&work, 0, DT_REAL, _state, ae_true);
12391 
12392  if( ((m<=0||n<=0)||zrows<=0)||zcolumns<=0 )
12393  {
12394  ae_frame_leave(_state);
12395  return;
12396  }
12397  ae_assert((fromtheright&&zcolumns==n)||(!fromtheright&&zrows==n), "RMatrixBDMultiplyByP: incorrect Z size!", _state);
12398 
12399  /*
12400  * init
12401  */
12402  mx = ae_maxint(m, n, _state);
12403  mx = ae_maxint(mx, zrows, _state);
12404  mx = ae_maxint(mx, zcolumns, _state);
12405  ae_vector_set_length(&v, mx+1, _state);
12406  ae_vector_set_length(&work, mx+1, _state);
12407  if( m>=n )
12408  {
12409 
12410  /*
12411  * setup
12412  */
12413  if( fromtheright )
12414  {
12415  i1 = n-2;
12416  i2 = 0;
12417  istep = -1;
12418  }
12419  else
12420  {
12421  i1 = 0;
12422  i2 = n-2;
12423  istep = 1;
12424  }
12425  if( !dotranspose )
12426  {
12427  i = i1;
12428  i1 = i2;
12429  i2 = i;
12430  istep = -istep;
12431  }
12432 
12433  /*
12434  * Process
12435  */
12436  if( n-1>0 )
12437  {
12438  i = i1;
12439  do
12440  {
12441  ae_v_move(&v.ptr.p_double[1], 1, &qp->ptr.pp_double[i][i+1], 1, ae_v_len(1,n-1-i));
12442  v.ptr.p_double[1] = 1;
12443  if( fromtheright )
12444  {
12445  applyreflectionfromtheright(z, taup->ptr.p_double[i], &v, 0, zrows-1, i+1, n-1, &work, _state);
12446  }
12447  else
12448  {
12449  applyreflectionfromtheleft(z, taup->ptr.p_double[i], &v, i+1, n-1, 0, zcolumns-1, &work, _state);
12450  }
12451  i = i+istep;
12452  }
12453  while(i!=i2+istep);
12454  }
12455  }
12456  else
12457  {
12458 
12459  /*
12460  * setup
12461  */
12462  if( fromtheright )
12463  {
12464  i1 = m-1;
12465  i2 = 0;
12466  istep = -1;
12467  }
12468  else
12469  {
12470  i1 = 0;
12471  i2 = m-1;
12472  istep = 1;
12473  }
12474  if( !dotranspose )
12475  {
12476  i = i1;
12477  i1 = i2;
12478  i2 = i;
12479  istep = -istep;
12480  }
12481 
12482  /*
12483  * Process
12484  */
12485  i = i1;
12486  do
12487  {
12488  ae_v_move(&v.ptr.p_double[1], 1, &qp->ptr.pp_double[i][i], 1, ae_v_len(1,n-i));
12489  v.ptr.p_double[1] = 1;
12490  if( fromtheright )
12491  {
12492  applyreflectionfromtheright(z, taup->ptr.p_double[i], &v, 0, zrows-1, i, n-1, &work, _state);
12493  }
12494  else
12495  {
12496  applyreflectionfromtheleft(z, taup->ptr.p_double[i], &v, i, n-1, 0, zcolumns-1, &work, _state);
12497  }
12498  i = i+istep;
12499  }
12500  while(i!=i2+istep);
12501  }
12502  ae_frame_leave(_state);
12503 }
12504 
12505 
12506 /*************************************************************************
12507 Unpacking of the main and secondary diagonals of bidiagonal decomposition
12508 of matrix A.
12509 
12510 Input parameters:
12511  B - output of RMatrixBD subroutine.
12512  M - number of rows in matrix B.
12513  N - number of columns in matrix B.
12514 
12515 Output parameters:
12516  IsUpper - True, if the matrix is upper bidiagonal.
12517  otherwise IsUpper is False.
12518  D - the main diagonal.
12519  Array whose index ranges within [0..Min(M,N)-1].
12520  E - the secondary diagonal (upper or lower, depending on
12521  the value of IsUpper).
12522  Array index ranges within [0..Min(M,N)-1], the last
12523  element is not used.
12524 
12525  -- ALGLIB --
12526  2005-2010
12527  Bochkanov Sergey
12528 *************************************************************************/
12529 void rmatrixbdunpackdiagonals(/* Real */ ae_matrix* b,
12530  ae_int_t m,
12531  ae_int_t n,
12532  ae_bool* isupper,
12533  /* Real */ ae_vector* d,
12534  /* Real */ ae_vector* e,
12535  ae_state *_state)
12536 {
12537  ae_int_t i;
12538 
12539  *isupper = ae_false;
12540  ae_vector_clear(d);
12541  ae_vector_clear(e);
12542 
12543  *isupper = m>=n;
12544  if( m<=0||n<=0 )
12545  {
12546  return;
12547  }
12548  if( *isupper )
12549  {
12550  ae_vector_set_length(d, n, _state);
12551  ae_vector_set_length(e, n, _state);
12552  for(i=0; i<=n-2; i++)
12553  {
12554  d->ptr.p_double[i] = b->ptr.pp_double[i][i];
12555  e->ptr.p_double[i] = b->ptr.pp_double[i][i+1];
12556  }
12557  d->ptr.p_double[n-1] = b->ptr.pp_double[n-1][n-1];
12558  }
12559  else
12560  {
12561  ae_vector_set_length(d, m, _state);
12562  ae_vector_set_length(e, m, _state);
12563  for(i=0; i<=m-2; i++)
12564  {
12565  d->ptr.p_double[i] = b->ptr.pp_double[i][i];
12566  e->ptr.p_double[i] = b->ptr.pp_double[i+1][i];
12567  }
12568  d->ptr.p_double[m-1] = b->ptr.pp_double[m-1][m-1];
12569  }
12570 }
12571 
12572 
12573 /*************************************************************************
12574 Reduction of a square matrix to upper Hessenberg form: Q'*A*Q = H,
12575 where Q is an orthogonal matrix, H - Hessenberg matrix.
12576 
12577 Input parameters:
12578  A - matrix A with elements [0..N-1, 0..N-1]
12579  N - size of matrix A.
12580 
12581 Output parameters:
12582  A - matrices Q and P in compact form (see below).
12583  Tau - array of scalar factors which are used to form matrix Q.
12584  Array whose index ranges within [0..N-2]
12585 
12586 Matrix H is located on the main diagonal, on the lower secondary diagonal
12587 and above the main diagonal of matrix A. The elements which are used to
12588 form matrix Q are situated in array Tau and below the lower secondary
12589 diagonal of matrix A as follows:
12590 
12591 Matrix Q is represented as a product of elementary reflections
12592 
12593 Q = H(0)*H(2)*...*H(n-2),
12594 
12595 where each H(i) is given by
12596 
12597 H(i) = 1 - tau * v * (v^T)
12598 
12599 where tau is a scalar stored in Tau[I]; v - is a real vector,
12600 so that v(0:i) = 0, v(i+1) = 1, v(i+2:n-1) stored in A(i+2:n-1,i).
12601 
12602  -- LAPACK routine (version 3.0) --
12603  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
12604  Courant Institute, Argonne National Lab, and Rice University
12605  October 31, 1992
12606 *************************************************************************/
12607 void rmatrixhessenberg(/* Real */ ae_matrix* a,
12608  ae_int_t n,
12609  /* Real */ ae_vector* tau,
12610  ae_state *_state)
12611 {
12612  ae_frame _frame_block;
12613  ae_int_t i;
12614  double v;
12615  ae_vector t;
12616  ae_vector work;
12617 
12618  ae_frame_make(_state, &_frame_block);
12619  ae_vector_clear(tau);
12620  ae_vector_init(&t, 0, DT_REAL, _state, ae_true);
12621  ae_vector_init(&work, 0, DT_REAL, _state, ae_true);
12622 
12623  ae_assert(n>=0, "RMatrixHessenberg: incorrect N!", _state);
12624 
12625  /*
12626  * Quick return if possible
12627  */
12628  if( n<=1 )
12629  {
12630  ae_frame_leave(_state);
12631  return;
12632  }
12633  ae_vector_set_length(tau, n-2+1, _state);
12634  ae_vector_set_length(&t, n+1, _state);
12635  ae_vector_set_length(&work, n-1+1, _state);
12636  for(i=0; i<=n-2; i++)
12637  {
12638 
12639  /*
12640  * Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
12641  */
12642  ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[i+1][i], a->stride, ae_v_len(1,n-i-1));
12643  generatereflection(&t, n-i-1, &v, _state);
12644  ae_v_move(&a->ptr.pp_double[i+1][i], a->stride, &t.ptr.p_double[1], 1, ae_v_len(i+1,n-1));
12645  tau->ptr.p_double[i] = v;
12646  t.ptr.p_double[1] = 1;
12647 
12648  /*
12649  * Apply H(i) to A(1:ihi,i+1:ihi) from the right
12650  */
12651  applyreflectionfromtheright(a, v, &t, 0, n-1, i+1, n-1, &work, _state);
12652 
12653  /*
12654  * Apply H(i) to A(i+1:ihi,i+1:n) from the left
12655  */
12656  applyreflectionfromtheleft(a, v, &t, i+1, n-1, i+1, n-1, &work, _state);
12657  }
12658  ae_frame_leave(_state);
12659 }
12660 
12661 
12662 /*************************************************************************
12663 Unpacking matrix Q which reduces matrix A to upper Hessenberg form
12664 
12665 Input parameters:
12666  A - output of RMatrixHessenberg subroutine.
12667  N - size of matrix A.
12668  Tau - scalar factors which are used to form Q.
12669  Output of RMatrixHessenberg subroutine.
12670 
12671 Output parameters:
12672  Q - matrix Q.
12673  Array whose indexes range within [0..N-1, 0..N-1].
12674 
12675  -- ALGLIB --
12676  2005-2010
12677  Bochkanov Sergey
12678 *************************************************************************/
12679 void rmatrixhessenbergunpackq(/* Real */ ae_matrix* a,
12680  ae_int_t n,
12681  /* Real */ ae_vector* tau,
12682  /* Real */ ae_matrix* q,
12683  ae_state *_state)
12684 {
12685  ae_frame _frame_block;
12686  ae_int_t i;
12687  ae_int_t j;
12688  ae_vector v;
12689  ae_vector work;
12690 
12691  ae_frame_make(_state, &_frame_block);
12692  ae_matrix_clear(q);
12693  ae_vector_init(&v, 0, DT_REAL, _state, ae_true);
12694  ae_vector_init(&work, 0, DT_REAL, _state, ae_true);
12695 
12696  if( n==0 )
12697  {
12698  ae_frame_leave(_state);
12699  return;
12700  }
12701 
12702  /*
12703  * init
12704  */
12705  ae_matrix_set_length(q, n-1+1, n-1+1, _state);
12706  ae_vector_set_length(&v, n-1+1, _state);
12707  ae_vector_set_length(&work, n-1+1, _state);
12708  for(i=0; i<=n-1; i++)
12709  {
12710  for(j=0; j<=n-1; j++)
12711  {
12712  if( i==j )
12713  {
12714  q->ptr.pp_double[i][j] = 1;
12715  }
12716  else
12717  {
12718  q->ptr.pp_double[i][j] = 0;
12719  }
12720  }
12721  }
12722 
12723  /*
12724  * unpack Q
12725  */
12726  for(i=0; i<=n-2; i++)
12727  {
12728 
12729  /*
12730  * Apply H(i)
12731  */
12732  ae_v_move(&v.ptr.p_double[1], 1, &a->ptr.pp_double[i+1][i], a->stride, ae_v_len(1,n-i-1));
12733  v.ptr.p_double[1] = 1;
12734  applyreflectionfromtheright(q, tau->ptr.p_double[i], &v, 0, n-1, i+1, n-1, &work, _state);
12735  }
12736  ae_frame_leave(_state);
12737 }
12738 
12739 
12740 /*************************************************************************
12741 Unpacking matrix H (the result of matrix A reduction to upper Hessenberg form)
12742 
12743 Input parameters:
12744  A - output of RMatrixHessenberg subroutine.
12745  N - size of matrix A.
12746 
12747 Output parameters:
12748  H - matrix H. Array whose indexes range within [0..N-1, 0..N-1].
12749 
12750  -- ALGLIB --
12751  2005-2010
12752  Bochkanov Sergey
12753 *************************************************************************/
12754 void rmatrixhessenbergunpackh(/* Real */ ae_matrix* a,
12755  ae_int_t n,
12756  /* Real */ ae_matrix* h,
12757  ae_state *_state)
12758 {
12759  ae_frame _frame_block;
12760  ae_int_t i;
12761  ae_int_t j;
12762  ae_vector v;
12763  ae_vector work;
12764 
12765  ae_frame_make(_state, &_frame_block);
12766  ae_matrix_clear(h);
12767  ae_vector_init(&v, 0, DT_REAL, _state, ae_true);
12768  ae_vector_init(&work, 0, DT_REAL, _state, ae_true);
12769 
12770  if( n==0 )
12771  {
12772  ae_frame_leave(_state);
12773  return;
12774  }
12775  ae_matrix_set_length(h, n-1+1, n-1+1, _state);
12776  for(i=0; i<=n-1; i++)
12777  {
12778  for(j=0; j<=i-2; j++)
12779  {
12780  h->ptr.pp_double[i][j] = 0;
12781  }
12782  j = ae_maxint(0, i-1, _state);
12783  ae_v_move(&h->ptr.pp_double[i][j], 1, &a->ptr.pp_double[i][j], 1, ae_v_len(j,n-1));
12784  }
12785  ae_frame_leave(_state);
12786 }
12787 
12788 
12789 /*************************************************************************
12790 Reduction of a symmetric matrix which is given by its higher or lower
12791 triangular part to a tridiagonal matrix using orthogonal similarity
12792 transformation: Q'*A*Q=T.
12793 
12794 Input parameters:
12795  A - matrix to be transformed
12796  array with elements [0..N-1, 0..N-1].
12797  N - size of matrix A.
12798  IsUpper - storage format. If IsUpper = True, then matrix A is given
12799  by its upper triangle, and the lower triangle is not used
12800  and not modified by the algorithm, and vice versa
12801  if IsUpper = False.
12802 
12803 Output parameters:
12804  A - matrices T and Q in compact form (see lower)
12805  Tau - array of factors which are forming matrices H(i)
12806  array with elements [0..N-2].
12807  D - main diagonal of symmetric matrix T.
12808  array with elements [0..N-1].
12809  E - secondary diagonal of symmetric matrix T.
12810  array with elements [0..N-2].
12811 
12812 
12813  If IsUpper=True, the matrix Q is represented as a product of elementary
12814  reflectors
12815 
12816  Q = H(n-2) . . . H(2) H(0).
12817 
12818  Each H(i) has the form
12819 
12820  H(i) = I - tau * v * v'
12821 
12822  where tau is a real scalar, and v is a real vector with
12823  v(i+1:n-1) = 0, v(i) = 1, v(0:i-1) is stored on exit in
12824  A(0:i-1,i+1), and tau in TAU(i).
12825 
12826  If IsUpper=False, the matrix Q is represented as a product of elementary
12827  reflectors
12828 
12829  Q = H(0) H(2) . . . H(n-2).
12830 
12831  Each H(i) has the form
12832 
12833  H(i) = I - tau * v * v'
12834 
12835  where tau is a real scalar, and v is a real vector with
12836  v(0:i) = 0, v(i+1) = 1, v(i+2:n-1) is stored on exit in A(i+2:n-1,i),
12837  and tau in TAU(i).
12838 
12839  The contents of A on exit are illustrated by the following examples
12840  with n = 5:
12841 
12842  if UPLO = 'U': if UPLO = 'L':
12843 
12844  ( d e v1 v2 v3 ) ( d )
12845  ( d e v2 v3 ) ( e d )
12846  ( d e v3 ) ( v0 e d )
12847  ( d e ) ( v0 v1 e d )
12848  ( d ) ( v0 v1 v2 e d )
12849 
12850  where d and e denote diagonal and off-diagonal elements of T, and vi
12851  denotes an element of the vector defining H(i).
12852 
12853  -- LAPACK routine (version 3.0) --
12854  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
12855  Courant Institute, Argonne National Lab, and Rice University
12856  October 31, 1992
12857 *************************************************************************/
12858 void smatrixtd(/* Real */ ae_matrix* a,
12859  ae_int_t n,
12860  ae_bool isupper,
12861  /* Real */ ae_vector* tau,
12862  /* Real */ ae_vector* d,
12863  /* Real */ ae_vector* e,
12864  ae_state *_state)
12865 {
12866  ae_frame _frame_block;
12867  ae_int_t i;
12868  double alpha;
12869  double taui;
12870  double v;
12871  ae_vector t;
12872  ae_vector t2;
12873  ae_vector t3;
12874 
12875  ae_frame_make(_state, &_frame_block);
12876  ae_vector_clear(tau);
12877  ae_vector_clear(d);
12878  ae_vector_clear(e);
12879  ae_vector_init(&t, 0, DT_REAL, _state, ae_true);
12880  ae_vector_init(&t2, 0, DT_REAL, _state, ae_true);
12881  ae_vector_init(&t3, 0, DT_REAL, _state, ae_true);
12882 
12883  if( n<=0 )
12884  {
12885  ae_frame_leave(_state);
12886  return;
12887  }
12888  ae_vector_set_length(&t, n+1, _state);
12889  ae_vector_set_length(&t2, n+1, _state);
12890  ae_vector_set_length(&t3, n+1, _state);
12891  if( n>1 )
12892  {
12893  ae_vector_set_length(tau, n-2+1, _state);
12894  }
12895  ae_vector_set_length(d, n-1+1, _state);
12896  if( n>1 )
12897  {
12898  ae_vector_set_length(e, n-2+1, _state);
12899  }
12900  if( isupper )
12901  {
12902 
12903  /*
12904  * Reduce the upper triangle of A
12905  */
12906  for(i=n-2; i>=0; i--)
12907  {
12908 
12909  /*
12910  * Generate elementary reflector H() = E - tau * v * v'
12911  */
12912  if( i>=1 )
12913  {
12914  ae_v_move(&t.ptr.p_double[2], 1, &a->ptr.pp_double[0][i+1], a->stride, ae_v_len(2,i+1));
12915  }
12916  t.ptr.p_double[1] = a->ptr.pp_double[i][i+1];
12917  generatereflection(&t, i+1, &taui, _state);
12918  if( i>=1 )
12919  {
12920  ae_v_move(&a->ptr.pp_double[0][i+1], a->stride, &t.ptr.p_double[2], 1, ae_v_len(0,i-1));
12921  }
12922  a->ptr.pp_double[i][i+1] = t.ptr.p_double[1];
12923  e->ptr.p_double[i] = a->ptr.pp_double[i][i+1];
12924  if( ae_fp_neq(taui,0) )
12925  {
12926 
12927  /*
12928  * Apply H from both sides to A
12929  */
12930  a->ptr.pp_double[i][i+1] = 1;
12931 
12932  /*
12933  * Compute x := tau * A * v storing x in TAU
12934  */
12935  ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[0][i+1], a->stride, ae_v_len(1,i+1));
12936  symmetricmatrixvectormultiply(a, isupper, 0, i, &t, taui, &t3, _state);
12937  ae_v_move(&tau->ptr.p_double[0], 1, &t3.ptr.p_double[1], 1, ae_v_len(0,i));
12938 
12939  /*
12940  * Compute w := x - 1/2 * tau * (x'*v) * v
12941  */
12942  v = ae_v_dotproduct(&tau->ptr.p_double[0], 1, &a->ptr.pp_double[0][i+1], a->stride, ae_v_len(0,i));
12943  alpha = -0.5*taui*v;
12944  ae_v_addd(&tau->ptr.p_double[0], 1, &a->ptr.pp_double[0][i+1], a->stride, ae_v_len(0,i), alpha);
12945 
12946  /*
12947  * Apply the transformation as a rank-2 update:
12948  * A := A - v * w' - w * v'
12949  */
12950  ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[0][i+1], a->stride, ae_v_len(1,i+1));
12951  ae_v_move(&t3.ptr.p_double[1], 1, &tau->ptr.p_double[0], 1, ae_v_len(1,i+1));
12952  symmetricrank2update(a, isupper, 0, i, &t, &t3, &t2, -1, _state);
12953  a->ptr.pp_double[i][i+1] = e->ptr.p_double[i];
12954  }
12955  d->ptr.p_double[i+1] = a->ptr.pp_double[i+1][i+1];
12956  tau->ptr.p_double[i] = taui;
12957  }
12958  d->ptr.p_double[0] = a->ptr.pp_double[0][0];
12959  }
12960  else
12961  {
12962 
12963  /*
12964  * Reduce the lower triangle of A
12965  */
12966  for(i=0; i<=n-2; i++)
12967  {
12968 
12969  /*
12970  * Generate elementary reflector H = E - tau * v * v'
12971  */
12972  ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[i+1][i], a->stride, ae_v_len(1,n-i-1));
12973  generatereflection(&t, n-i-1, &taui, _state);
12974  ae_v_move(&a->ptr.pp_double[i+1][i], a->stride, &t.ptr.p_double[1], 1, ae_v_len(i+1,n-1));
12975  e->ptr.p_double[i] = a->ptr.pp_double[i+1][i];
12976  if( ae_fp_neq(taui,0) )
12977  {
12978 
12979  /*
12980  * Apply H from both sides to A
12981  */
12982  a->ptr.pp_double[i+1][i] = 1;
12983 
12984  /*
12985  * Compute x := tau * A * v storing y in TAU
12986  */
12987  ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[i+1][i], a->stride, ae_v_len(1,n-i-1));
12988  symmetricmatrixvectormultiply(a, isupper, i+1, n-1, &t, taui, &t2, _state);
12989  ae_v_move(&tau->ptr.p_double[i], 1, &t2.ptr.p_double[1], 1, ae_v_len(i,n-2));
12990 
12991  /*
12992  * Compute w := x - 1/2 * tau * (x'*v) * v
12993  */
12994  v = ae_v_dotproduct(&tau->ptr.p_double[i], 1, &a->ptr.pp_double[i+1][i], a->stride, ae_v_len(i,n-2));
12995  alpha = -0.5*taui*v;
12996  ae_v_addd(&tau->ptr.p_double[i], 1, &a->ptr.pp_double[i+1][i], a->stride, ae_v_len(i,n-2), alpha);
12997 
12998  /*
12999  * Apply the transformation as a rank-2 update:
13000  * A := A - v * w' - w * v'
13001  *
13002  */
13003  ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[i+1][i], a->stride, ae_v_len(1,n-i-1));
13004  ae_v_move(&t2.ptr.p_double[1], 1, &tau->ptr.p_double[i], 1, ae_v_len(1,n-i-1));
13005  symmetricrank2update(a, isupper, i+1, n-1, &t, &t2, &t3, -1, _state);
13006  a->ptr.pp_double[i+1][i] = e->ptr.p_double[i];
13007  }
13008  d->ptr.p_double[i] = a->ptr.pp_double[i][i];
13009  tau->ptr.p_double[i] = taui;
13010  }
13011  d->ptr.p_double[n-1] = a->ptr.pp_double[n-1][n-1];
13012  }
13013  ae_frame_leave(_state);
13014 }
13015 
13016 
13017 /*************************************************************************
13018 Unpacking matrix Q which reduces symmetric matrix to a tridiagonal
13019 form.
13020 
13021 Input parameters:
13022  A - the result of a SMatrixTD subroutine
13023  N - size of matrix A.
13024  IsUpper - storage format (a parameter of SMatrixTD subroutine)
13025  Tau - the result of a SMatrixTD subroutine
13026 
13027 Output parameters:
13028  Q - transformation matrix.
13029  array with elements [0..N-1, 0..N-1].
13030 
13031  -- ALGLIB --
13032  Copyright 2005-2010 by Bochkanov Sergey
13033 *************************************************************************/
13034 void smatrixtdunpackq(/* Real */ ae_matrix* a,
13035  ae_int_t n,
13036  ae_bool isupper,
13037  /* Real */ ae_vector* tau,
13038  /* Real */ ae_matrix* q,
13039  ae_state *_state)
13040 {
13041  ae_frame _frame_block;
13042  ae_int_t i;
13043  ae_int_t j;
13044  ae_vector v;
13045  ae_vector work;
13046 
13047  ae_frame_make(_state, &_frame_block);
13048  ae_matrix_clear(q);
13049  ae_vector_init(&v, 0, DT_REAL, _state, ae_true);
13050  ae_vector_init(&work, 0, DT_REAL, _state, ae_true);
13051 
13052  if( n==0 )
13053  {
13054  ae_frame_leave(_state);
13055  return;
13056  }
13057 
13058  /*
13059  * init
13060  */
13061  ae_matrix_set_length(q, n-1+1, n-1+1, _state);
13062  ae_vector_set_length(&v, n+1, _state);
13063  ae_vector_set_length(&work, n-1+1, _state);
13064  for(i=0; i<=n-1; i++)
13065  {
13066  for(j=0; j<=n-1; j++)
13067  {
13068  if( i==j )
13069  {
13070  q->ptr.pp_double[i][j] = 1;
13071  }
13072  else
13073  {
13074  q->ptr.pp_double[i][j] = 0;
13075  }
13076  }
13077  }
13078 
13079  /*
13080  * unpack Q
13081  */
13082  if( isupper )
13083  {
13084  for(i=0; i<=n-2; i++)
13085  {
13086 
13087  /*
13088  * Apply H(i)
13089  */
13090  ae_v_move(&v.ptr.p_double[1], 1, &a->ptr.pp_double[0][i+1], a->stride, ae_v_len(1,i+1));
13091  v.ptr.p_double[i+1] = 1;
13092  applyreflectionfromtheleft(q, tau->ptr.p_double[i], &v, 0, i, 0, n-1, &work, _state);
13093  }
13094  }
13095  else
13096  {
13097  for(i=n-2; i>=0; i--)
13098  {
13099 
13100  /*
13101  * Apply H(i)
13102  */
13103  ae_v_move(&v.ptr.p_double[1], 1, &a->ptr.pp_double[i+1][i], a->stride, ae_v_len(1,n-i-1));
13104  v.ptr.p_double[1] = 1;
13105  applyreflectionfromtheleft(q, tau->ptr.p_double[i], &v, i+1, n-1, 0, n-1, &work, _state);
13106  }
13107  }
13108  ae_frame_leave(_state);
13109 }
13110 
13111 
13112 /*************************************************************************
13113 Reduction of a Hermitian matrix which is given by its higher or lower
13114 triangular part to a real tridiagonal matrix using unitary similarity
13115 transformation: Q'*A*Q = T.
13116 
13117 Input parameters:
13118  A - matrix to be transformed
13119  array with elements [0..N-1, 0..N-1].
13120  N - size of matrix A.
13121  IsUpper - storage format. If IsUpper = True, then matrix A is given
13122  by its upper triangle, and the lower triangle is not used
13123  and not modified by the algorithm, and vice versa
13124  if IsUpper = False.
13125 
13126 Output parameters:
13127  A - matrices T and Q in compact form (see lower)
13128  Tau - array of factors which are forming matrices H(i)
13129  array with elements [0..N-2].
13130  D - main diagonal of real symmetric matrix T.
13131  array with elements [0..N-1].
13132  E - secondary diagonal of real symmetric matrix T.
13133  array with elements [0..N-2].
13134 
13135 
13136  If IsUpper=True, the matrix Q is represented as a product of elementary
13137  reflectors
13138 
13139  Q = H(n-2) . . . H(2) H(0).
13140 
13141  Each H(i) has the form
13142 
13143  H(i) = I - tau * v * v'
13144 
13145  where tau is a complex scalar, and v is a complex vector with
13146  v(i+1:n-1) = 0, v(i) = 1, v(0:i-1) is stored on exit in
13147  A(0:i-1,i+1), and tau in TAU(i).
13148 
13149  If IsUpper=False, the matrix Q is represented as a product of elementary
13150  reflectors
13151 
13152  Q = H(0) H(2) . . . H(n-2).
13153 
13154  Each H(i) has the form
13155 
13156  H(i) = I - tau * v * v'
13157 
13158  where tau is a complex scalar, and v is a complex vector with
13159  v(0:i) = 0, v(i+1) = 1, v(i+2:n-1) is stored on exit in A(i+2:n-1,i),
13160  and tau in TAU(i).
13161 
13162  The contents of A on exit are illustrated by the following examples
13163  with n = 5:
13164 
13165  if UPLO = 'U': if UPLO = 'L':
13166 
13167  ( d e v1 v2 v3 ) ( d )
13168  ( d e v2 v3 ) ( e d )
13169  ( d e v3 ) ( v0 e d )
13170  ( d e ) ( v0 v1 e d )
13171  ( d ) ( v0 v1 v2 e d )
13172 
13173 where d and e denote diagonal and off-diagonal elements of T, and vi
13174 denotes an element of the vector defining H(i).
13175 
13176  -- LAPACK routine (version 3.0) --
13177  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
13178  Courant Institute, Argonne National Lab, and Rice University
13179  October 31, 1992
13180 *************************************************************************/
13181 void hmatrixtd(/* Complex */ ae_matrix* a,
13182  ae_int_t n,
13183  ae_bool isupper,
13184  /* Complex */ ae_vector* tau,
13185  /* Real */ ae_vector* d,
13186  /* Real */ ae_vector* e,
13187  ae_state *_state)
13188 {
13189  ae_frame _frame_block;
13190  ae_int_t i;
13191  ae_complex alpha;
13192  ae_complex taui;
13193  ae_complex v;
13194  ae_vector t;
13195  ae_vector t2;
13196  ae_vector t3;
13197 
13198  ae_frame_make(_state, &_frame_block);
13199  ae_vector_clear(tau);
13200  ae_vector_clear(d);
13201  ae_vector_clear(e);
13202  ae_vector_init(&t, 0, DT_COMPLEX, _state, ae_true);
13203  ae_vector_init(&t2, 0, DT_COMPLEX, _state, ae_true);
13204  ae_vector_init(&t3, 0, DT_COMPLEX, _state, ae_true);
13205 
13206  if( n<=0 )
13207  {
13208  ae_frame_leave(_state);
13209  return;
13210  }
13211  for(i=0; i<=n-1; i++)
13212  {
13213  ae_assert(ae_fp_eq(a->ptr.pp_complex[i][i].y,0), "Assertion failed", _state);
13214  }
13215  if( n>1 )
13216  {
13217  ae_vector_set_length(tau, n-2+1, _state);
13218  ae_vector_set_length(e, n-2+1, _state);
13219  }
13220  ae_vector_set_length(d, n-1+1, _state);
13221  ae_vector_set_length(&t, n-1+1, _state);
13222  ae_vector_set_length(&t2, n-1+1, _state);
13223  ae_vector_set_length(&t3, n-1+1, _state);
13224  if( isupper )
13225  {
13226 
13227  /*
13228  * Reduce the upper triangle of A
13229  */
13230  a->ptr.pp_complex[n-1][n-1] = ae_complex_from_d(a->ptr.pp_complex[n-1][n-1].x);
13231  for(i=n-2; i>=0; i--)
13232  {
13233 
13234  /*
13235  * Generate elementary reflector H = I+1 - tau * v * v'
13236  */
13237  alpha = a->ptr.pp_complex[i][i+1];
13238  t.ptr.p_complex[1] = alpha;
13239  if( i>=1 )
13240  {
13241  ae_v_cmove(&t.ptr.p_complex[2], 1, &a->ptr.pp_complex[0][i+1], a->stride, "N", ae_v_len(2,i+1));
13242  }
13243  complexgeneratereflection(&t, i+1, &taui, _state);
13244  if( i>=1 )
13245  {
13246  ae_v_cmove(&a->ptr.pp_complex[0][i+1], a->stride, &t.ptr.p_complex[2], 1, "N", ae_v_len(0,i-1));
13247  }
13248  alpha = t.ptr.p_complex[1];
13249  e->ptr.p_double[i] = alpha.x;
13250  if( ae_c_neq_d(taui,0) )
13251  {
13252 
13253  /*
13254  * Apply H(I+1) from both sides to A
13255  */
13256  a->ptr.pp_complex[i][i+1] = ae_complex_from_d(1);
13257 
13258  /*
13259  * Compute x := tau * A * v storing x in TAU
13260  */
13261  ae_v_cmove(&t.ptr.p_complex[1], 1, &a->ptr.pp_complex[0][i+1], a->stride, "N", ae_v_len(1,i+1));
13262  hermitianmatrixvectormultiply(a, isupper, 0, i, &t, taui, &t2, _state);
13263  ae_v_cmove(&tau->ptr.p_complex[0], 1, &t2.ptr.p_complex[1], 1, "N", ae_v_len(0,i));
13264 
13265  /*
13266  * Compute w := x - 1/2 * tau * (x'*v) * v
13267  */
13268  v = ae_v_cdotproduct(&tau->ptr.p_complex[0], 1, "Conj", &a->ptr.pp_complex[0][i+1], a->stride, "N", ae_v_len(0,i));
13269  alpha = ae_c_neg(ae_c_mul(ae_c_mul_d(taui,0.5),v));
13270  ae_v_caddc(&tau->ptr.p_complex[0], 1, &a->ptr.pp_complex[0][i+1], a->stride, "N", ae_v_len(0,i), alpha);
13271 
13272  /*
13273  * Apply the transformation as a rank-2 update:
13274  * A := A - v * w' - w * v'
13275  */
13276  ae_v_cmove(&t.ptr.p_complex[1], 1, &a->ptr.pp_complex[0][i+1], a->stride, "N", ae_v_len(1,i+1));
13277  ae_v_cmove(&t3.ptr.p_complex[1], 1, &tau->ptr.p_complex[0], 1, "N", ae_v_len(1,i+1));
13278  hermitianrank2update(a, isupper, 0, i, &t, &t3, &t2, ae_complex_from_d(-1), _state);
13279  }
13280  else
13281  {
13282  a->ptr.pp_complex[i][i] = ae_complex_from_d(a->ptr.pp_complex[i][i].x);
13283  }
13284  a->ptr.pp_complex[i][i+1] = ae_complex_from_d(e->ptr.p_double[i]);
13285  d->ptr.p_double[i+1] = a->ptr.pp_complex[i+1][i+1].x;
13286  tau->ptr.p_complex[i] = taui;
13287  }
13288  d->ptr.p_double[0] = a->ptr.pp_complex[0][0].x;
13289  }
13290  else
13291  {
13292 
13293  /*
13294  * Reduce the lower triangle of A
13295  */
13296  a->ptr.pp_complex[0][0] = ae_complex_from_d(a->ptr.pp_complex[0][0].x);
13297  for(i=0; i<=n-2; i++)
13298  {
13299 
13300  /*
13301  * Generate elementary reflector H = I - tau * v * v'
13302  */
13303  ae_v_cmove(&t.ptr.p_complex[1], 1, &a->ptr.pp_complex[i+1][i], a->stride, "N", ae_v_len(1,n-i-1));
13304  complexgeneratereflection(&t, n-i-1, &taui, _state);
13305  ae_v_cmove(&a->ptr.pp_complex[i+1][i], a->stride, &t.ptr.p_complex[1], 1, "N", ae_v_len(i+1,n-1));
13306  e->ptr.p_double[i] = a->ptr.pp_complex[i+1][i].x;
13307  if( ae_c_neq_d(taui,0) )
13308  {
13309 
13310  /*
13311  * Apply H(i) from both sides to A(i+1:n,i+1:n)
13312  */
13313  a->ptr.pp_complex[i+1][i] = ae_complex_from_d(1);
13314 
13315  /*
13316  * Compute x := tau * A * v storing y in TAU
13317  */
13318  ae_v_cmove(&t.ptr.p_complex[1], 1, &a->ptr.pp_complex[i+1][i], a->stride, "N", ae_v_len(1,n-i-1));
13319  hermitianmatrixvectormultiply(a, isupper, i+1, n-1, &t, taui, &t2, _state);
13320  ae_v_cmove(&tau->ptr.p_complex[i], 1, &t2.ptr.p_complex[1], 1, "N", ae_v_len(i,n-2));
13321 
13322  /*
13323  * Compute w := x - 1/2 * tau * (x'*v) * v
13324  */
13325  v = ae_v_cdotproduct(&tau->ptr.p_complex[i], 1, "Conj", &a->ptr.pp_complex[i+1][i], a->stride, "N", ae_v_len(i,n-2));
13326  alpha = ae_c_neg(ae_c_mul(ae_c_mul_d(taui,0.5),v));
13327  ae_v_caddc(&tau->ptr.p_complex[i], 1, &a->ptr.pp_complex[i+1][i], a->stride, "N", ae_v_len(i,n-2), alpha);
13328 
13329  /*
13330  * Apply the transformation as a rank-2 update:
13331  * A := A - v * w' - w * v'
13332  */
13333  ae_v_cmove(&t.ptr.p_complex[1], 1, &a->ptr.pp_complex[i+1][i], a->stride, "N", ae_v_len(1,n-i-1));
13334  ae_v_cmove(&t2.ptr.p_complex[1], 1, &tau->ptr.p_complex[i], 1, "N", ae_v_len(1,n-i-1));
13335  hermitianrank2update(a, isupper, i+1, n-1, &t, &t2, &t3, ae_complex_from_d(-1), _state);
13336  }
13337  else
13338  {
13339  a->ptr.pp_complex[i+1][i+1] = ae_complex_from_d(a->ptr.pp_complex[i+1][i+1].x);
13340  }
13341  a->ptr.pp_complex[i+1][i] = ae_complex_from_d(e->ptr.p_double[i]);
13342  d->ptr.p_double[i] = a->ptr.pp_complex[i][i].x;
13343  tau->ptr.p_complex[i] = taui;
13344  }
13345  d->ptr.p_double[n-1] = a->ptr.pp_complex[n-1][n-1].x;
13346  }
13347  ae_frame_leave(_state);
13348 }
13349 
13350 
13351 /*************************************************************************
13352 Unpacking matrix Q which reduces a Hermitian matrix to a real tridiagonal
13353 form.
13354 
13355 Input parameters:
13356  A - the result of a HMatrixTD subroutine
13357  N - size of matrix A.
13358  IsUpper - storage format (a parameter of HMatrixTD subroutine)
13359  Tau - the result of a HMatrixTD subroutine
13360 
13361 Output parameters:
13362  Q - transformation matrix.
13363  array with elements [0..N-1, 0..N-1].
13364 
13365  -- ALGLIB --
13366  Copyright 2005-2010 by Bochkanov Sergey
13367 *************************************************************************/
13368 void hmatrixtdunpackq(/* Complex */ ae_matrix* a,
13369  ae_int_t n,
13370  ae_bool isupper,
13371  /* Complex */ ae_vector* tau,
13372  /* Complex */ ae_matrix* q,
13373  ae_state *_state)
13374 {
13375  ae_frame _frame_block;
13376  ae_int_t i;
13377  ae_int_t j;
13378  ae_vector v;
13379  ae_vector work;
13380 
13381  ae_frame_make(_state, &_frame_block);
13382  ae_matrix_clear(q);
13383  ae_vector_init(&v, 0, DT_COMPLEX, _state, ae_true);
13384  ae_vector_init(&work, 0, DT_COMPLEX, _state, ae_true);
13385 
13386  if( n==0 )
13387  {
13388  ae_frame_leave(_state);
13389  return;
13390  }
13391 
13392  /*
13393  * init
13394  */
13395  ae_matrix_set_length(q, n-1+1, n-1+1, _state);
13396  ae_vector_set_length(&v, n+1, _state);
13397  ae_vector_set_length(&work, n-1+1, _state);
13398  for(i=0; i<=n-1; i++)
13399  {
13400  for(j=0; j<=n-1; j++)
13401  {
13402  if( i==j )
13403  {
13404  q->ptr.pp_complex[i][j] = ae_complex_from_d(1);
13405  }
13406  else
13407  {
13408  q->ptr.pp_complex[i][j] = ae_complex_from_d(0);
13409  }
13410  }
13411  }
13412 
13413  /*
13414  * unpack Q
13415  */
13416  if( isupper )
13417  {
13418  for(i=0; i<=n-2; i++)
13419  {
13420 
13421  /*
13422  * Apply H(i)
13423  */
13424  ae_v_cmove(&v.ptr.p_complex[1], 1, &a->ptr.pp_complex[0][i+1], a->stride, "N", ae_v_len(1,i+1));
13425  v.ptr.p_complex[i+1] = ae_complex_from_d(1);
13426  complexapplyreflectionfromtheleft(q, tau->ptr.p_complex[i], &v, 0, i, 0, n-1, &work, _state);
13427  }
13428  }
13429  else
13430  {
13431  for(i=n-2; i>=0; i--)
13432  {
13433 
13434  /*
13435  * Apply H(i)
13436  */
13437  ae_v_cmove(&v.ptr.p_complex[1], 1, &a->ptr.pp_complex[i+1][i], a->stride, "N", ae_v_len(1,n-i-1));
13438  v.ptr.p_complex[1] = ae_complex_from_d(1);
13439  complexapplyreflectionfromtheleft(q, tau->ptr.p_complex[i], &v, i+1, n-1, 0, n-1, &work, _state);
13440  }
13441  }
13442  ae_frame_leave(_state);
13443 }
13444 
13445 
13446 /*************************************************************************
13447 Base case for complex QR
13448 
13449  -- LAPACK routine (version 3.0) --
13450  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
13451  Courant Institute, Argonne National Lab, and Rice University
13452  September 30, 1994.
13453  Sergey Bochkanov, ALGLIB project, translation from FORTRAN to
13454  pseudocode, 2007-2010.
13455 *************************************************************************/
13456 static void ortfac_cmatrixqrbasecase(/* Complex */ ae_matrix* a,
13457  ae_int_t m,
13458  ae_int_t n,
13459  /* Complex */ ae_vector* work,
13460  /* Complex */ ae_vector* t,
13461  /* Complex */ ae_vector* tau,
13462  ae_state *_state)
13463 {
13464  ae_int_t i;
13465  ae_int_t k;
13466  ae_int_t mmi;
13467  ae_int_t minmn;
13468  ae_complex tmp;
13469 
13470 
13471  minmn = ae_minint(m, n, _state);
13472  if( minmn<=0 )
13473  {
13474  return;
13475  }
13476 
13477  /*
13478  * Test the input arguments
13479  */
13480  k = ae_minint(m, n, _state);
13481  for(i=0; i<=k-1; i++)
13482  {
13483 
13484  /*
13485  * Generate elementary reflector H(i) to annihilate A(i+1:m,i)
13486  */
13487  mmi = m-i;
13488  ae_v_cmove(&t->ptr.p_complex[1], 1, &a->ptr.pp_complex[i][i], a->stride, "N", ae_v_len(1,mmi));
13489  complexgeneratereflection(t, mmi, &tmp, _state);
13490  tau->ptr.p_complex[i] = tmp;
13491  ae_v_cmove(&a->ptr.pp_complex[i][i], a->stride, &t->ptr.p_complex[1], 1, "N", ae_v_len(i,m-1));
13492  t->ptr.p_complex[1] = ae_complex_from_d(1);
13493  if( i<n-1 )
13494  {
13495 
13496  /*
13497  * Apply H'(i) to A(i:m,i+1:n) from the left
13498  */
13499  complexapplyreflectionfromtheleft(a, ae_c_conj(tau->ptr.p_complex[i], _state), t, i, m-1, i+1, n-1, work, _state);
13500  }
13501  }
13502 }
13503 
13504 
13505 /*************************************************************************
13506 Base case for complex LQ
13507 
13508  -- LAPACK routine (version 3.0) --
13509  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
13510  Courant Institute, Argonne National Lab, and Rice University
13511  September 30, 1994.
13512  Sergey Bochkanov, ALGLIB project, translation from FORTRAN to
13513  pseudocode, 2007-2010.
13514 *************************************************************************/
13515 static void ortfac_cmatrixlqbasecase(/* Complex */ ae_matrix* a,
13516  ae_int_t m,
13517  ae_int_t n,
13518  /* Complex */ ae_vector* work,
13519  /* Complex */ ae_vector* t,
13520  /* Complex */ ae_vector* tau,
13521  ae_state *_state)
13522 {
13523  ae_int_t i;
13524  ae_int_t minmn;
13525  ae_complex tmp;
13526 
13527 
13528  minmn = ae_minint(m, n, _state);
13529  if( minmn<=0 )
13530  {
13531  return;
13532  }
13533 
13534  /*
13535  * Test the input arguments
13536  */
13537  for(i=0; i<=minmn-1; i++)
13538  {
13539 
13540  /*
13541  * Generate elementary reflector H(i)
13542  *
13543  * NOTE: ComplexGenerateReflection() generates left reflector,
13544  * i.e. H which reduces x by applyiong from the left, but we
13545  * need RIGHT reflector. So we replace H=E-tau*v*v' by H^H,
13546  * which changes v to conj(v).
13547  */
13548  ae_v_cmove(&t->ptr.p_complex[1], 1, &a->ptr.pp_complex[i][i], 1, "Conj", ae_v_len(1,n-i));
13549  complexgeneratereflection(t, n-i, &tmp, _state);
13550  tau->ptr.p_complex[i] = tmp;
13551  ae_v_cmove(&a->ptr.pp_complex[i][i], 1, &t->ptr.p_complex[1], 1, "Conj", ae_v_len(i,n-1));
13552  t->ptr.p_complex[1] = ae_complex_from_d(1);
13553  if( i<m-1 )
13554  {
13555 
13556  /*
13557  * Apply H'(i)
13558  */
13559  complexapplyreflectionfromtheright(a, tau->ptr.p_complex[i], t, i+1, m-1, i, n-1, work, _state);
13560  }
13561  }
13562 }
13563 
13564 
13565 /*************************************************************************
13566 Generate block reflector:
13567 * fill unused parts of reflectors matrix by zeros
13568 * fill diagonal of reflectors matrix by ones
13569 * generate triangular factor T
13570 
13571 PARAMETERS:
13572  A - either LengthA*BlockSize (if ColumnwiseA) or
13573  BlockSize*LengthA (if not ColumnwiseA) matrix of
13574  elementary reflectors.
13575  Modified on exit.
13576  Tau - scalar factors
13577  ColumnwiseA - reflectors are stored in rows or in columns
13578  LengthA - length of largest reflector
13579  BlockSize - number of reflectors
13580  T - array[BlockSize,2*BlockSize]. Left BlockSize*BlockSize
13581  submatrix stores triangular factor on exit.
13582  WORK - array[BlockSize]
13583 
13584  -- ALGLIB routine --
13585  17.02.2010
13586  Bochkanov Sergey
13587 *************************************************************************/
13588 static void ortfac_rmatrixblockreflector(/* Real */ ae_matrix* a,
13589  /* Real */ ae_vector* tau,
13590  ae_bool columnwisea,
13591  ae_int_t lengtha,
13592  ae_int_t blocksize,
13593  /* Real */ ae_matrix* t,
13594  /* Real */ ae_vector* work,
13595  ae_state *_state)
13596 {
13597  ae_int_t i;
13598  ae_int_t j;
13599  ae_int_t k;
13600  double v;
13601 
13602 
13603 
13604  /*
13605  * fill beginning of new column with zeros,
13606  * load 1.0 in the first non-zero element
13607  */
13608  for(k=0; k<=blocksize-1; k++)
13609  {
13610  if( columnwisea )
13611  {
13612  for(i=0; i<=k-1; i++)
13613  {
13614  a->ptr.pp_double[i][k] = 0;
13615  }
13616  }
13617  else
13618  {
13619  for(i=0; i<=k-1; i++)
13620  {
13621  a->ptr.pp_double[k][i] = 0;
13622  }
13623  }
13624  a->ptr.pp_double[k][k] = 1;
13625  }
13626 
13627  /*
13628  * Calculate Gram matrix of A
13629  */
13630  for(i=0; i<=blocksize-1; i++)
13631  {
13632  for(j=0; j<=blocksize-1; j++)
13633  {
13634  t->ptr.pp_double[i][blocksize+j] = 0;
13635  }
13636  }
13637  for(k=0; k<=lengtha-1; k++)
13638  {
13639  for(j=1; j<=blocksize-1; j++)
13640  {
13641  if( columnwisea )
13642  {
13643  v = a->ptr.pp_double[k][j];
13644  if( ae_fp_neq(v,0) )
13645  {
13646  ae_v_addd(&t->ptr.pp_double[j][blocksize], 1, &a->ptr.pp_double[k][0], 1, ae_v_len(blocksize,blocksize+j-1), v);
13647  }
13648  }
13649  else
13650  {
13651  v = a->ptr.pp_double[j][k];
13652  if( ae_fp_neq(v,0) )
13653  {
13654  ae_v_addd(&t->ptr.pp_double[j][blocksize], 1, &a->ptr.pp_double[0][k], a->stride, ae_v_len(blocksize,blocksize+j-1), v);
13655  }
13656  }
13657  }
13658  }
13659 
13660  /*
13661  * Prepare Y (stored in TmpA) and T (stored in TmpT)
13662  */
13663  for(k=0; k<=blocksize-1; k++)
13664  {
13665 
13666  /*
13667  * fill non-zero part of T, use pre-calculated Gram matrix
13668  */
13669  ae_v_move(&work->ptr.p_double[0], 1, &t->ptr.pp_double[k][blocksize], 1, ae_v_len(0,k-1));
13670  for(i=0; i<=k-1; i++)
13671  {
13672  v = ae_v_dotproduct(&t->ptr.pp_double[i][i], 1, &work->ptr.p_double[i], 1, ae_v_len(i,k-1));
13673  t->ptr.pp_double[i][k] = -tau->ptr.p_double[k]*v;
13674  }
13675  t->ptr.pp_double[k][k] = -tau->ptr.p_double[k];
13676 
13677  /*
13678  * Rest of T is filled by zeros
13679  */
13680  for(i=k+1; i<=blocksize-1; i++)
13681  {
13682  t->ptr.pp_double[i][k] = 0;
13683  }
13684  }
13685 }
13686 
13687 
13688 /*************************************************************************
13689 Generate block reflector (complex):
13690 * fill unused parts of reflectors matrix by zeros
13691 * fill diagonal of reflectors matrix by ones
13692 * generate triangular factor T
13693 
13694 
13695  -- ALGLIB routine --
13696  17.02.2010
13697  Bochkanov Sergey
13698 *************************************************************************/
13699 static void ortfac_cmatrixblockreflector(/* Complex */ ae_matrix* a,
13700  /* Complex */ ae_vector* tau,
13701  ae_bool columnwisea,
13702  ae_int_t lengtha,
13703  ae_int_t blocksize,
13704  /* Complex */ ae_matrix* t,
13705  /* Complex */ ae_vector* work,
13706  ae_state *_state)
13707 {
13708  ae_int_t i;
13709  ae_int_t k;
13710  ae_complex v;
13711 
13712 
13713 
13714  /*
13715  * Prepare Y (stored in TmpA) and T (stored in TmpT)
13716  */
13717  for(k=0; k<=blocksize-1; k++)
13718  {
13719 
13720  /*
13721  * fill beginning of new column with zeros,
13722  * load 1.0 in the first non-zero element
13723  */
13724  if( columnwisea )
13725  {
13726  for(i=0; i<=k-1; i++)
13727  {
13728  a->ptr.pp_complex[i][k] = ae_complex_from_d(0);
13729  }
13730  }
13731  else
13732  {
13733  for(i=0; i<=k-1; i++)
13734  {
13735  a->ptr.pp_complex[k][i] = ae_complex_from_d(0);
13736  }
13737  }
13738  a->ptr.pp_complex[k][k] = ae_complex_from_d(1);
13739 
13740  /*
13741  * fill non-zero part of T,
13742  */
13743  for(i=0; i<=k-1; i++)
13744  {
13745  if( columnwisea )
13746  {
13747  v = ae_v_cdotproduct(&a->ptr.pp_complex[k][i], a->stride, "Conj", &a->ptr.pp_complex[k][k], a->stride, "N", ae_v_len(k,lengtha-1));
13748  }
13749  else
13750  {
13751  v = ae_v_cdotproduct(&a->ptr.pp_complex[i][k], 1, "N", &a->ptr.pp_complex[k][k], 1, "Conj", ae_v_len(k,lengtha-1));
13752  }
13753  work->ptr.p_complex[i] = v;
13754  }
13755  for(i=0; i<=k-1; i++)
13756  {
13757  v = ae_v_cdotproduct(&t->ptr.pp_complex[i][i], 1, "N", &work->ptr.p_complex[i], 1, "N", ae_v_len(i,k-1));
13758  t->ptr.pp_complex[i][k] = ae_c_neg(ae_c_mul(tau->ptr.p_complex[k],v));
13759  }
13760  t->ptr.pp_complex[k][k] = ae_c_neg(tau->ptr.p_complex[k]);
13761 
13762  /*
13763  * Rest of T is filled by zeros
13764  */
13765  for(i=k+1; i<=blocksize-1; i++)
13766  {
13767  t->ptr.pp_complex[i][k] = ae_complex_from_d(0);
13768  }
13769  }
13770 }
13771 
13772 
13773 
13774 
13775 /*************************************************************************
13776 Singular value decomposition of a bidiagonal matrix (extended algorithm)
13777 
13778 The algorithm performs the singular value decomposition of a bidiagonal
13779 matrix B (upper or lower) representing it as B = Q*S*P^T, where Q and P -
13780 orthogonal matrices, S - diagonal matrix with non-negative elements on the
13781 main diagonal, in descending order.
13782 
13783 The algorithm finds singular values. In addition, the algorithm can
13784 calculate matrices Q and P (more precisely, not the matrices, but their
13785 product with given matrices U and VT - U*Q and (P^T)*VT)). Of course,
13786 matrices U and VT can be of any type, including identity. Furthermore, the
13787 algorithm can calculate Q'*C (this product is calculated more effectively
13788 than U*Q, because this calculation operates with rows instead of matrix
13789 columns).
13790 
13791 The feature of the algorithm is its ability to find all singular values
13792 including those which are arbitrarily close to 0 with relative accuracy
13793 close to machine precision. If the parameter IsFractionalAccuracyRequired
13794 is set to True, all singular values will have high relative accuracy close
13795 to machine precision. If the parameter is set to False, only the biggest
13796 singular value will have relative accuracy close to machine precision.
13797 The absolute error of other singular values is equal to the absolute error
13798 of the biggest singular value.
13799 
13800 Input parameters:
13801  D - main diagonal of matrix B.
13802  Array whose index ranges within [0..N-1].
13803  E - superdiagonal (or subdiagonal) of matrix B.
13804  Array whose index ranges within [0..N-2].
13805  N - size of matrix B.
13806  IsUpper - True, if the matrix is upper bidiagonal.
13807  IsFractionalAccuracyRequired -
13808  THIS PARAMETER IS IGNORED SINCE ALGLIB 3.5.0
13809  SINGULAR VALUES ARE ALWAYS SEARCHED WITH HIGH ACCURACY.
13810  U - matrix to be multiplied by Q.
13811  Array whose indexes range within [0..NRU-1, 0..N-1].
13812  The matrix can be bigger, in that case only the submatrix
13813  [0..NRU-1, 0..N-1] will be multiplied by Q.
13814  NRU - number of rows in matrix U.
13815  C - matrix to be multiplied by Q'.
13816  Array whose indexes range within [0..N-1, 0..NCC-1].
13817  The matrix can be bigger, in that case only the submatrix
13818  [0..N-1, 0..NCC-1] will be multiplied by Q'.
13819  NCC - number of columns in matrix C.
13820  VT - matrix to be multiplied by P^T.
13821  Array whose indexes range within [0..N-1, 0..NCVT-1].
13822  The matrix can be bigger, in that case only the submatrix
13823  [0..N-1, 0..NCVT-1] will be multiplied by P^T.
13824  NCVT - number of columns in matrix VT.
13825 
13826 Output parameters:
13827  D - singular values of matrix B in descending order.
13828  U - if NRU>0, contains matrix U*Q.
13829  VT - if NCVT>0, contains matrix (P^T)*VT.
13830  C - if NCC>0, contains matrix Q'*C.
13831 
13832 Result:
13833  True, if the algorithm has converged.
13834  False, if the algorithm hasn't converged (rare case).
13835 
13836 Additional information:
13837  The type of convergence is controlled by the internal parameter TOL.
13838  If the parameter is greater than 0, the singular values will have
13839  relative accuracy TOL. If TOL<0, the singular values will have
13840  absolute accuracy ABS(TOL)*norm(B).
13841  By default, |TOL| falls within the range of 10*Epsilon and 100*Epsilon,
13842  where Epsilon is the machine precision. It is not recommended to use
13843  TOL less than 10*Epsilon since this will considerably slow down the
13844  algorithm and may not lead to error decreasing.
13845 History:
13846  * 31 March, 2007.
13847  changed MAXITR from 6 to 12.
13848 
13849  -- LAPACK routine (version 3.0) --
13850  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
13851  Courant Institute, Argonne National Lab, and Rice University
13852  October 31, 1999.
13853 *************************************************************************/
13854 ae_bool rmatrixbdsvd(/* Real */ ae_vector* d,
13855  /* Real */ ae_vector* e,
13856  ae_int_t n,
13857  ae_bool isupper,
13858  ae_bool isfractionalaccuracyrequired,
13859  /* Real */ ae_matrix* u,
13860  ae_int_t nru,
13861  /* Real */ ae_matrix* c,
13862  ae_int_t ncc,
13863  /* Real */ ae_matrix* vt,
13864  ae_int_t ncvt,
13865  ae_state *_state)
13866 {
13867  ae_frame _frame_block;
13868  ae_vector _e;
13869  ae_vector d1;
13870  ae_vector e1;
13871  ae_bool result;
13872 
13873  ae_frame_make(_state, &_frame_block);
13874  ae_vector_init_copy(&_e, e, _state, ae_true);
13875  e = &_e;
13876  ae_vector_init(&d1, 0, DT_REAL, _state, ae_true);
13877  ae_vector_init(&e1, 0, DT_REAL, _state, ae_true);
13878 
13879  ae_vector_set_length(&d1, n+1, _state);
13880  ae_v_move(&d1.ptr.p_double[1], 1, &d->ptr.p_double[0], 1, ae_v_len(1,n));
13881  if( n>1 )
13882  {
13883  ae_vector_set_length(&e1, n-1+1, _state);
13884  ae_v_move(&e1.ptr.p_double[1], 1, &e->ptr.p_double[0], 1, ae_v_len(1,n-1));
13885  }
13886  result = bdsvd_bidiagonalsvddecompositioninternal(&d1, &e1, n, isupper, isfractionalaccuracyrequired, u, 0, nru, c, 0, ncc, vt, 0, ncvt, _state);
13887  ae_v_move(&d->ptr.p_double[0], 1, &d1.ptr.p_double[1], 1, ae_v_len(0,n-1));
13888  ae_frame_leave(_state);
13889  return result;
13890 }
13891 
13892 
13893 ae_bool bidiagonalsvddecomposition(/* Real */ ae_vector* d,
13894  /* Real */ ae_vector* e,
13895  ae_int_t n,
13896  ae_bool isupper,
13897  ae_bool isfractionalaccuracyrequired,
13898  /* Real */ ae_matrix* u,
13899  ae_int_t nru,
13900  /* Real */ ae_matrix* c,
13901  ae_int_t ncc,
13902  /* Real */ ae_matrix* vt,
13903  ae_int_t ncvt,
13904  ae_state *_state)
13905 {
13906  ae_frame _frame_block;
13907  ae_vector _e;
13908  ae_bool result;
13909 
13910  ae_frame_make(_state, &_frame_block);
13911  ae_vector_init_copy(&_e, e, _state, ae_true);
13912  e = &_e;
13913 
13914  result = bdsvd_bidiagonalsvddecompositioninternal(d, e, n, isupper, isfractionalaccuracyrequired, u, 1, nru, c, 1, ncc, vt, 1, ncvt, _state);
13915  ae_frame_leave(_state);
13916  return result;
13917 }
13918 
13919 
13920 /*************************************************************************
13921 Internal working subroutine for bidiagonal decomposition
13922 *************************************************************************/
13923 static ae_bool bdsvd_bidiagonalsvddecompositioninternal(/* Real */ ae_vector* d,
13924  /* Real */ ae_vector* e,
13925  ae_int_t n,
13926  ae_bool isupper,
13927  ae_bool isfractionalaccuracyrequired,
13928  /* Real */ ae_matrix* u,
13929  ae_int_t ustart,
13930  ae_int_t nru,
13931  /* Real */ ae_matrix* c,
13932  ae_int_t cstart,
13933  ae_int_t ncc,
13934  /* Real */ ae_matrix* vt,
13935  ae_int_t vstart,
13936  ae_int_t ncvt,
13937  ae_state *_state)
13938 {
13939  ae_frame _frame_block;
13940  ae_vector _e;
13941  ae_int_t i;
13942  ae_int_t idir;
13943  ae_int_t isub;
13944  ae_int_t iter;
13945  ae_int_t j;
13946  ae_int_t ll;
13947  ae_int_t lll;
13948  ae_int_t m;
13949  ae_int_t maxit;
13950  ae_int_t oldll;
13951  ae_int_t oldm;
13952  double abse;
13953  double abss;
13954  double cosl;
13955  double cosr;
13956  double cs;
13957  double eps;
13958  double f;
13959  double g;
13960  double h;
13961  double mu;
13962  double oldcs;
13963  double oldsn;
13964  double r;
13965  double shift;
13966  double sigmn;
13967  double sigmx;
13968  double sinl;
13969  double sinr;
13970  double sll;
13971  double smax;
13972  double smin;
13973  double sminl;
13974  double sminoa;
13975  double sn;
13976  double thresh;
13977  double tol;
13978  double tolmul;
13979  double unfl;
13980  ae_vector work0;
13981  ae_vector work1;
13982  ae_vector work2;
13983  ae_vector work3;
13984  ae_int_t maxitr;
13985  ae_bool matrixsplitflag;
13986  ae_bool iterflag;
13987  ae_vector utemp;
13988  ae_vector vttemp;
13989  ae_vector ctemp;
13990  ae_vector etemp;
13991  ae_bool fwddir;
13992  double tmp;
13993  ae_int_t mm1;
13994  ae_int_t mm0;
13995  ae_bool bchangedir;
13996  ae_int_t uend;
13997  ae_int_t cend;
13998  ae_int_t vend;
13999  ae_bool result;
14000 
14001  ae_frame_make(_state, &_frame_block);
14002  ae_vector_init_copy(&_e, e, _state, ae_true);
14003  e = &_e;
14004  ae_vector_init(&work0, 0, DT_REAL, _state, ae_true);
14005  ae_vector_init(&work1, 0, DT_REAL, _state, ae_true);
14006  ae_vector_init(&work2, 0, DT_REAL, _state, ae_true);
14007  ae_vector_init(&work3, 0, DT_REAL, _state, ae_true);
14008  ae_vector_init(&utemp, 0, DT_REAL, _state, ae_true);
14009  ae_vector_init(&vttemp, 0, DT_REAL, _state, ae_true);
14010  ae_vector_init(&ctemp, 0, DT_REAL, _state, ae_true);
14011  ae_vector_init(&etemp, 0, DT_REAL, _state, ae_true);
14012 
14013  result = ae_true;
14014  if( n==0 )
14015  {
14016  ae_frame_leave(_state);
14017  return result;
14018  }
14019  if( n==1 )
14020  {
14021  if( ae_fp_less(d->ptr.p_double[1],0) )
14022  {
14023  d->ptr.p_double[1] = -d->ptr.p_double[1];
14024  if( ncvt>0 )
14025  {
14026  ae_v_muld(&vt->ptr.pp_double[vstart][vstart], 1, ae_v_len(vstart,vstart+ncvt-1), -1);
14027  }
14028  }
14029  ae_frame_leave(_state);
14030  return result;
14031  }
14032 
14033  /*
14034  * these initializers are not really necessary,
14035  * but without them compiler complains about uninitialized locals
14036  */
14037  ll = 0;
14038  oldsn = 0;
14039 
14040  /*
14041  * init
14042  */
14043  ae_vector_set_length(&work0, n-1+1, _state);
14044  ae_vector_set_length(&work1, n-1+1, _state);
14045  ae_vector_set_length(&work2, n-1+1, _state);
14046  ae_vector_set_length(&work3, n-1+1, _state);
14047  uend = ustart+ae_maxint(nru-1, 0, _state);
14048  vend = vstart+ae_maxint(ncvt-1, 0, _state);
14049  cend = cstart+ae_maxint(ncc-1, 0, _state);
14050  ae_vector_set_length(&utemp, uend+1, _state);
14051  ae_vector_set_length(&vttemp, vend+1, _state);
14052  ae_vector_set_length(&ctemp, cend+1, _state);
14053  maxitr = 12;
14054  fwddir = ae_true;
14055 
14056  /*
14057  * resize E from N-1 to N
14058  */
14059  ae_vector_set_length(&etemp, n+1, _state);
14060  for(i=1; i<=n-1; i++)
14061  {
14062  etemp.ptr.p_double[i] = e->ptr.p_double[i];
14063  }
14064  ae_vector_set_length(e, n+1, _state);
14065  for(i=1; i<=n-1; i++)
14066  {
14067  e->ptr.p_double[i] = etemp.ptr.p_double[i];
14068  }
14069  e->ptr.p_double[n] = 0;
14070  idir = 0;
14071 
14072  /*
14073  * Get machine constants
14074  */
14075  eps = ae_machineepsilon;
14076  unfl = ae_minrealnumber;
14077 
14078  /*
14079  * If matrix lower bidiagonal, rotate to be upper bidiagonal
14080  * by applying Givens rotations on the left
14081  */
14082  if( !isupper )
14083  {
14084  for(i=1; i<=n-1; i++)
14085  {
14086  generaterotation(d->ptr.p_double[i], e->ptr.p_double[i], &cs, &sn, &r, _state);
14087  d->ptr.p_double[i] = r;
14088  e->ptr.p_double[i] = sn*d->ptr.p_double[i+1];
14089  d->ptr.p_double[i+1] = cs*d->ptr.p_double[i+1];
14090  work0.ptr.p_double[i] = cs;
14091  work1.ptr.p_double[i] = sn;
14092  }
14093 
14094  /*
14095  * Update singular vectors if desired
14096  */
14097  if( nru>0 )
14098  {
14099  applyrotationsfromtheright(fwddir, ustart, uend, 1+ustart-1, n+ustart-1, &work0, &work1, u, &utemp, _state);
14100  }
14101  if( ncc>0 )
14102  {
14103  applyrotationsfromtheleft(fwddir, 1+cstart-1, n+cstart-1, cstart, cend, &work0, &work1, c, &ctemp, _state);
14104  }
14105  }
14106 
14107  /*
14108  * Compute singular values to relative accuracy TOL
14109  * (By setting TOL to be negative, algorithm will compute
14110  * singular values to absolute accuracy ABS(TOL)*norm(input matrix))
14111  */
14112  tolmul = ae_maxreal(10, ae_minreal(100, ae_pow(eps, -0.125, _state), _state), _state);
14113  tol = tolmul*eps;
14114 
14115  /*
14116  * Compute approximate maximum, minimum singular values
14117  */
14118  smax = 0;
14119  for(i=1; i<=n; i++)
14120  {
14121  smax = ae_maxreal(smax, ae_fabs(d->ptr.p_double[i], _state), _state);
14122  }
14123  for(i=1; i<=n-1; i++)
14124  {
14125  smax = ae_maxreal(smax, ae_fabs(e->ptr.p_double[i], _state), _state);
14126  }
14127  sminl = 0;
14128  if( ae_fp_greater_eq(tol,0) )
14129  {
14130 
14131  /*
14132  * Relative accuracy desired
14133  */
14134  sminoa = ae_fabs(d->ptr.p_double[1], _state);
14135  if( ae_fp_neq(sminoa,0) )
14136  {
14137  mu = sminoa;
14138  for(i=2; i<=n; i++)
14139  {
14140  mu = ae_fabs(d->ptr.p_double[i], _state)*(mu/(mu+ae_fabs(e->ptr.p_double[i-1], _state)));
14141  sminoa = ae_minreal(sminoa, mu, _state);
14142  if( ae_fp_eq(sminoa,0) )
14143  {
14144  break;
14145  }
14146  }
14147  }
14148  sminoa = sminoa/ae_sqrt(n, _state);
14149  thresh = ae_maxreal(tol*sminoa, maxitr*n*n*unfl, _state);
14150  }
14151  else
14152  {
14153 
14154  /*
14155  * Absolute accuracy desired
14156  */
14157  thresh = ae_maxreal(ae_fabs(tol, _state)*smax, maxitr*n*n*unfl, _state);
14158  }
14159 
14160  /*
14161  * Prepare for main iteration loop for the singular values
14162  * (MAXIT is the maximum number of passes through the inner
14163  * loop permitted before nonconvergence signalled.)
14164  */
14165  maxit = maxitr*n*n;
14166  iter = 0;
14167  oldll = -1;
14168  oldm = -1;
14169 
14170  /*
14171  * M points to last element of unconverged part of matrix
14172  */
14173  m = n;
14174 
14175  /*
14176  * Begin main iteration loop
14177  */
14178  for(;;)
14179  {
14180 
14181  /*
14182  * Check for convergence or exceeding iteration count
14183  */
14184  if( m<=1 )
14185  {
14186  break;
14187  }
14188  if( iter>maxit )
14189  {
14190  result = ae_false;
14191  ae_frame_leave(_state);
14192  return result;
14193  }
14194 
14195  /*
14196  * Find diagonal block of matrix to work on
14197  */
14198  if( ae_fp_less(tol,0)&&ae_fp_less_eq(ae_fabs(d->ptr.p_double[m], _state),thresh) )
14199  {
14200  d->ptr.p_double[m] = 0;
14201  }
14202  smax = ae_fabs(d->ptr.p_double[m], _state);
14203  smin = smax;
14204  matrixsplitflag = ae_false;
14205  for(lll=1; lll<=m-1; lll++)
14206  {
14207  ll = m-lll;
14208  abss = ae_fabs(d->ptr.p_double[ll], _state);
14209  abse = ae_fabs(e->ptr.p_double[ll], _state);
14210  if( ae_fp_less(tol,0)&&ae_fp_less_eq(abss,thresh) )
14211  {
14212  d->ptr.p_double[ll] = 0;
14213  }
14214  if( ae_fp_less_eq(abse,thresh) )
14215  {
14216  matrixsplitflag = ae_true;
14217  break;
14218  }
14219  smin = ae_minreal(smin, abss, _state);
14220  smax = ae_maxreal(smax, ae_maxreal(abss, abse, _state), _state);
14221  }
14222  if( !matrixsplitflag )
14223  {
14224  ll = 0;
14225  }
14226  else
14227  {
14228 
14229  /*
14230  * Matrix splits since E(LL) = 0
14231  */
14232  e->ptr.p_double[ll] = 0;
14233  if( ll==m-1 )
14234  {
14235 
14236  /*
14237  * Convergence of bottom singular value, return to top of loop
14238  */
14239  m = m-1;
14240  continue;
14241  }
14242  }
14243  ll = ll+1;
14244 
14245  /*
14246  * E(LL) through E(M-1) are nonzero, E(LL-1) is zero
14247  */
14248  if( ll==m-1 )
14249  {
14250 
14251  /*
14252  * 2 by 2 block, handle separately
14253  */
14254  bdsvd_svdv2x2(d->ptr.p_double[m-1], e->ptr.p_double[m-1], d->ptr.p_double[m], &sigmn, &sigmx, &sinr, &cosr, &sinl, &cosl, _state);
14255  d->ptr.p_double[m-1] = sigmx;
14256  e->ptr.p_double[m-1] = 0;
14257  d->ptr.p_double[m] = sigmn;
14258 
14259  /*
14260  * Compute singular vectors, if desired
14261  */
14262  if( ncvt>0 )
14263  {
14264  mm0 = m+(vstart-1);
14265  mm1 = m-1+(vstart-1);
14266  ae_v_moved(&vttemp.ptr.p_double[vstart], 1, &vt->ptr.pp_double[mm1][vstart], 1, ae_v_len(vstart,vend), cosr);
14267  ae_v_addd(&vttemp.ptr.p_double[vstart], 1, &vt->ptr.pp_double[mm0][vstart], 1, ae_v_len(vstart,vend), sinr);
14268  ae_v_muld(&vt->ptr.pp_double[mm0][vstart], 1, ae_v_len(vstart,vend), cosr);
14269  ae_v_subd(&vt->ptr.pp_double[mm0][vstart], 1, &vt->ptr.pp_double[mm1][vstart], 1, ae_v_len(vstart,vend), sinr);
14270  ae_v_move(&vt->ptr.pp_double[mm1][vstart], 1, &vttemp.ptr.p_double[vstart], 1, ae_v_len(vstart,vend));
14271  }
14272  if( nru>0 )
14273  {
14274  mm0 = m+ustart-1;
14275  mm1 = m-1+ustart-1;
14276  ae_v_moved(&utemp.ptr.p_double[ustart], 1, &u->ptr.pp_double[ustart][mm1], u->stride, ae_v_len(ustart,uend), cosl);
14277  ae_v_addd(&utemp.ptr.p_double[ustart], 1, &u->ptr.pp_double[ustart][mm0], u->stride, ae_v_len(ustart,uend), sinl);
14278  ae_v_muld(&u->ptr.pp_double[ustart][mm0], u->stride, ae_v_len(ustart,uend), cosl);
14279  ae_v_subd(&u->ptr.pp_double[ustart][mm0], u->stride, &u->ptr.pp_double[ustart][mm1], u->stride, ae_v_len(ustart,uend), sinl);
14280  ae_v_move(&u->ptr.pp_double[ustart][mm1], u->stride, &utemp.ptr.p_double[ustart], 1, ae_v_len(ustart,uend));
14281  }
14282  if( ncc>0 )
14283  {
14284  mm0 = m+cstart-1;
14285  mm1 = m-1+cstart-1;
14286  ae_v_moved(&ctemp.ptr.p_double[cstart], 1, &c->ptr.pp_double[mm1][cstart], 1, ae_v_len(cstart,cend), cosl);
14287  ae_v_addd(&ctemp.ptr.p_double[cstart], 1, &c->ptr.pp_double[mm0][cstart], 1, ae_v_len(cstart,cend), sinl);
14288  ae_v_muld(&c->ptr.pp_double[mm0][cstart], 1, ae_v_len(cstart,cend), cosl);
14289  ae_v_subd(&c->ptr.pp_double[mm0][cstart], 1, &c->ptr.pp_double[mm1][cstart], 1, ae_v_len(cstart,cend), sinl);
14290  ae_v_move(&c->ptr.pp_double[mm1][cstart], 1, &ctemp.ptr.p_double[cstart], 1, ae_v_len(cstart,cend));
14291  }
14292  m = m-2;
14293  continue;
14294  }
14295 
14296  /*
14297  * If working on new submatrix, choose shift direction
14298  * (from larger end diagonal element towards smaller)
14299  *
14300  * Previously was
14301  * "if (LL>OLDM) or (M<OLDLL) then"
14302  * fixed thanks to Michael Rolle < m@rolle.name >
14303  * Very strange that LAPACK still contains it.
14304  */
14305  bchangedir = ae_false;
14306  if( idir==1&&ae_fp_less(ae_fabs(d->ptr.p_double[ll], _state),1.0E-3*ae_fabs(d->ptr.p_double[m], _state)) )
14307  {
14308  bchangedir = ae_true;
14309  }
14310  if( idir==2&&ae_fp_less(ae_fabs(d->ptr.p_double[m], _state),1.0E-3*ae_fabs(d->ptr.p_double[ll], _state)) )
14311  {
14312  bchangedir = ae_true;
14313  }
14314  if( (ll!=oldll||m!=oldm)||bchangedir )
14315  {
14316  if( ae_fp_greater_eq(ae_fabs(d->ptr.p_double[ll], _state),ae_fabs(d->ptr.p_double[m], _state)) )
14317  {
14318 
14319  /*
14320  * Chase bulge from top (big end) to bottom (small end)
14321  */
14322  idir = 1;
14323  }
14324  else
14325  {
14326 
14327  /*
14328  * Chase bulge from bottom (big end) to top (small end)
14329  */
14330  idir = 2;
14331  }
14332  }
14333 
14334  /*
14335  * Apply convergence tests
14336  */
14337  if( idir==1 )
14338  {
14339 
14340  /*
14341  * Run convergence test in forward direction
14342  * First apply standard test to bottom of matrix
14343  */
14344  if( ae_fp_less_eq(ae_fabs(e->ptr.p_double[m-1], _state),ae_fabs(tol, _state)*ae_fabs(d->ptr.p_double[m], _state))||(ae_fp_less(tol,0)&&ae_fp_less_eq(ae_fabs(e->ptr.p_double[m-1], _state),thresh)) )
14345  {
14346  e->ptr.p_double[m-1] = 0;
14347  continue;
14348  }
14349  if( ae_fp_greater_eq(tol,0) )
14350  {
14351 
14352  /*
14353  * If relative accuracy desired,
14354  * apply convergence criterion forward
14355  */
14356  mu = ae_fabs(d->ptr.p_double[ll], _state);
14357  sminl = mu;
14358  iterflag = ae_false;
14359  for(lll=ll; lll<=m-1; lll++)
14360  {
14361  if( ae_fp_less_eq(ae_fabs(e->ptr.p_double[lll], _state),tol*mu) )
14362  {
14363  e->ptr.p_double[lll] = 0;
14364  iterflag = ae_true;
14365  break;
14366  }
14367  mu = ae_fabs(d->ptr.p_double[lll+1], _state)*(mu/(mu+ae_fabs(e->ptr.p_double[lll], _state)));
14368  sminl = ae_minreal(sminl, mu, _state);
14369  }
14370  if( iterflag )
14371  {
14372  continue;
14373  }
14374  }
14375  }
14376  else
14377  {
14378 
14379  /*
14380  * Run convergence test in backward direction
14381  * First apply standard test to top of matrix
14382  */
14383  if( ae_fp_less_eq(ae_fabs(e->ptr.p_double[ll], _state),ae_fabs(tol, _state)*ae_fabs(d->ptr.p_double[ll], _state))||(ae_fp_less(tol,0)&&ae_fp_less_eq(ae_fabs(e->ptr.p_double[ll], _state),thresh)) )
14384  {
14385  e->ptr.p_double[ll] = 0;
14386  continue;
14387  }
14388  if( ae_fp_greater_eq(tol,0) )
14389  {
14390 
14391  /*
14392  * If relative accuracy desired,
14393  * apply convergence criterion backward
14394  */
14395  mu = ae_fabs(d->ptr.p_double[m], _state);
14396  sminl = mu;
14397  iterflag = ae_false;
14398  for(lll=m-1; lll>=ll; lll--)
14399  {
14400  if( ae_fp_less_eq(ae_fabs(e->ptr.p_double[lll], _state),tol*mu) )
14401  {
14402  e->ptr.p_double[lll] = 0;
14403  iterflag = ae_true;
14404  break;
14405  }
14406  mu = ae_fabs(d->ptr.p_double[lll], _state)*(mu/(mu+ae_fabs(e->ptr.p_double[lll], _state)));
14407  sminl = ae_minreal(sminl, mu, _state);
14408  }
14409  if( iterflag )
14410  {
14411  continue;
14412  }
14413  }
14414  }
14415  oldll = ll;
14416  oldm = m;
14417 
14418  /*
14419  * Compute shift. First, test if shifting would ruin relative
14420  * accuracy, and if so set the shift to zero.
14421  */
14422  if( ae_fp_greater_eq(tol,0)&&ae_fp_less_eq(n*tol*(sminl/smax),ae_maxreal(eps, 0.01*tol, _state)) )
14423  {
14424 
14425  /*
14426  * Use a zero shift to avoid loss of relative accuracy
14427  */
14428  shift = 0;
14429  }
14430  else
14431  {
14432 
14433  /*
14434  * Compute the shift from 2-by-2 block at end of matrix
14435  */
14436  if( idir==1 )
14437  {
14438  sll = ae_fabs(d->ptr.p_double[ll], _state);
14439  bdsvd_svd2x2(d->ptr.p_double[m-1], e->ptr.p_double[m-1], d->ptr.p_double[m], &shift, &r, _state);
14440  }
14441  else
14442  {
14443  sll = ae_fabs(d->ptr.p_double[m], _state);
14444  bdsvd_svd2x2(d->ptr.p_double[ll], e->ptr.p_double[ll], d->ptr.p_double[ll+1], &shift, &r, _state);
14445  }
14446 
14447  /*
14448  * Test if shift negligible, and if so set to zero
14449  */
14450  if( ae_fp_greater(sll,0) )
14451  {
14452  if( ae_fp_less(ae_sqr(shift/sll, _state),eps) )
14453  {
14454  shift = 0;
14455  }
14456  }
14457  }
14458 
14459  /*
14460  * Increment iteration count
14461  */
14462  iter = iter+m-ll;
14463 
14464  /*
14465  * If SHIFT = 0, do simplified QR iteration
14466  */
14467  if( ae_fp_eq(shift,0) )
14468  {
14469  if( idir==1 )
14470  {
14471 
14472  /*
14473  * Chase bulge from top to bottom
14474  * Save cosines and sines for later singular vector updates
14475  */
14476  cs = 1;
14477  oldcs = 1;
14478  for(i=ll; i<=m-1; i++)
14479  {
14480  generaterotation(d->ptr.p_double[i]*cs, e->ptr.p_double[i], &cs, &sn, &r, _state);
14481  if( i>ll )
14482  {
14483  e->ptr.p_double[i-1] = oldsn*r;
14484  }
14485  generaterotation(oldcs*r, d->ptr.p_double[i+1]*sn, &oldcs, &oldsn, &tmp, _state);
14486  d->ptr.p_double[i] = tmp;
14487  work0.ptr.p_double[i-ll+1] = cs;
14488  work1.ptr.p_double[i-ll+1] = sn;
14489  work2.ptr.p_double[i-ll+1] = oldcs;
14490  work3.ptr.p_double[i-ll+1] = oldsn;
14491  }
14492  h = d->ptr.p_double[m]*cs;
14493  d->ptr.p_double[m] = h*oldcs;
14494  e->ptr.p_double[m-1] = h*oldsn;
14495 
14496  /*
14497  * Update singular vectors
14498  */
14499  if( ncvt>0 )
14500  {
14501  applyrotationsfromtheleft(fwddir, ll+vstart-1, m+vstart-1, vstart, vend, &work0, &work1, vt, &vttemp, _state);
14502  }
14503  if( nru>0 )
14504  {
14505  applyrotationsfromtheright(fwddir, ustart, uend, ll+ustart-1, m+ustart-1, &work2, &work3, u, &utemp, _state);
14506  }
14507  if( ncc>0 )
14508  {
14509  applyrotationsfromtheleft(fwddir, ll+cstart-1, m+cstart-1, cstart, cend, &work2, &work3, c, &ctemp, _state);
14510  }
14511 
14512  /*
14513  * Test convergence
14514  */
14515  if( ae_fp_less_eq(ae_fabs(e->ptr.p_double[m-1], _state),thresh) )
14516  {
14517  e->ptr.p_double[m-1] = 0;
14518  }
14519  }
14520  else
14521  {
14522 
14523  /*
14524  * Chase bulge from bottom to top
14525  * Save cosines and sines for later singular vector updates
14526  */
14527  cs = 1;
14528  oldcs = 1;
14529  for(i=m; i>=ll+1; i--)
14530  {
14531  generaterotation(d->ptr.p_double[i]*cs, e->ptr.p_double[i-1], &cs, &sn, &r, _state);
14532  if( i<m )
14533  {
14534  e->ptr.p_double[i] = oldsn*r;
14535  }
14536  generaterotation(oldcs*r, d->ptr.p_double[i-1]*sn, &oldcs, &oldsn, &tmp, _state);
14537  d->ptr.p_double[i] = tmp;
14538  work0.ptr.p_double[i-ll] = cs;
14539  work1.ptr.p_double[i-ll] = -sn;
14540  work2.ptr.p_double[i-ll] = oldcs;
14541  work3.ptr.p_double[i-ll] = -oldsn;
14542  }
14543  h = d->ptr.p_double[ll]*cs;
14544  d->ptr.p_double[ll] = h*oldcs;
14545  e->ptr.p_double[ll] = h*oldsn;
14546 
14547  /*
14548  * Update singular vectors
14549  */
14550  if( ncvt>0 )
14551  {
14552  applyrotationsfromtheleft(!fwddir, ll+vstart-1, m+vstart-1, vstart, vend, &work2, &work3, vt, &vttemp, _state);
14553  }
14554  if( nru>0 )
14555  {
14556  applyrotationsfromtheright(!fwddir, ustart, uend, ll+ustart-1, m+ustart-1, &work0, &work1, u, &utemp, _state);
14557  }
14558  if( ncc>0 )
14559  {
14560  applyrotationsfromtheleft(!fwddir, ll+cstart-1, m+cstart-1, cstart, cend, &work0, &work1, c, &ctemp, _state);
14561  }
14562 
14563  /*
14564  * Test convergence
14565  */
14566  if( ae_fp_less_eq(ae_fabs(e->ptr.p_double[ll], _state),thresh) )
14567  {
14568  e->ptr.p_double[ll] = 0;
14569  }
14570  }
14571  }
14572  else
14573  {
14574 
14575  /*
14576  * Use nonzero shift
14577  */
14578  if( idir==1 )
14579  {
14580 
14581  /*
14582  * Chase bulge from top to bottom
14583  * Save cosines and sines for later singular vector updates
14584  */
14585  f = (ae_fabs(d->ptr.p_double[ll], _state)-shift)*(bdsvd_extsignbdsqr(1, d->ptr.p_double[ll], _state)+shift/d->ptr.p_double[ll]);
14586  g = e->ptr.p_double[ll];
14587  for(i=ll; i<=m-1; i++)
14588  {
14589  generaterotation(f, g, &cosr, &sinr, &r, _state);
14590  if( i>ll )
14591  {
14592  e->ptr.p_double[i-1] = r;
14593  }
14594  f = cosr*d->ptr.p_double[i]+sinr*e->ptr.p_double[i];
14595  e->ptr.p_double[i] = cosr*e->ptr.p_double[i]-sinr*d->ptr.p_double[i];
14596  g = sinr*d->ptr.p_double[i+1];
14597  d->ptr.p_double[i+1] = cosr*d->ptr.p_double[i+1];
14598  generaterotation(f, g, &cosl, &sinl, &r, _state);
14599  d->ptr.p_double[i] = r;
14600  f = cosl*e->ptr.p_double[i]+sinl*d->ptr.p_double[i+1];
14601  d->ptr.p_double[i+1] = cosl*d->ptr.p_double[i+1]-sinl*e->ptr.p_double[i];
14602  if( i<m-1 )
14603  {
14604  g = sinl*e->ptr.p_double[i+1];
14605  e->ptr.p_double[i+1] = cosl*e->ptr.p_double[i+1];
14606  }
14607  work0.ptr.p_double[i-ll+1] = cosr;
14608  work1.ptr.p_double[i-ll+1] = sinr;
14609  work2.ptr.p_double[i-ll+1] = cosl;
14610  work3.ptr.p_double[i-ll+1] = sinl;
14611  }
14612  e->ptr.p_double[m-1] = f;
14613 
14614  /*
14615  * Update singular vectors
14616  */
14617  if( ncvt>0 )
14618  {
14619  applyrotationsfromtheleft(fwddir, ll+vstart-1, m+vstart-1, vstart, vend, &work0, &work1, vt, &vttemp, _state);
14620  }
14621  if( nru>0 )
14622  {
14623  applyrotationsfromtheright(fwddir, ustart, uend, ll+ustart-1, m+ustart-1, &work2, &work3, u, &utemp, _state);
14624  }
14625  if( ncc>0 )
14626  {
14627  applyrotationsfromtheleft(fwddir, ll+cstart-1, m+cstart-1, cstart, cend, &work2, &work3, c, &ctemp, _state);
14628  }
14629 
14630  /*
14631  * Test convergence
14632  */
14633  if( ae_fp_less_eq(ae_fabs(e->ptr.p_double[m-1], _state),thresh) )
14634  {
14635  e->ptr.p_double[m-1] = 0;
14636  }
14637  }
14638  else
14639  {
14640 
14641  /*
14642  * Chase bulge from bottom to top
14643  * Save cosines and sines for later singular vector updates
14644  */
14645  f = (ae_fabs(d->ptr.p_double[m], _state)-shift)*(bdsvd_extsignbdsqr(1, d->ptr.p_double[m], _state)+shift/d->ptr.p_double[m]);
14646  g = e->ptr.p_double[m-1];
14647  for(i=m; i>=ll+1; i--)
14648  {
14649  generaterotation(f, g, &cosr, &sinr, &r, _state);
14650  if( i<m )
14651  {
14652  e->ptr.p_double[i] = r;
14653  }
14654  f = cosr*d->ptr.p_double[i]+sinr*e->ptr.p_double[i-1];
14655  e->ptr.p_double[i-1] = cosr*e->ptr.p_double[i-1]-sinr*d->ptr.p_double[i];
14656  g = sinr*d->ptr.p_double[i-1];
14657  d->ptr.p_double[i-1] = cosr*d->ptr.p_double[i-1];
14658  generaterotation(f, g, &cosl, &sinl, &r, _state);
14659  d->ptr.p_double[i] = r;
14660  f = cosl*e->ptr.p_double[i-1]+sinl*d->ptr.p_double[i-1];
14661  d->ptr.p_double[i-1] = cosl*d->ptr.p_double[i-1]-sinl*e->ptr.p_double[i-1];
14662  if( i>ll+1 )
14663  {
14664  g = sinl*e->ptr.p_double[i-2];
14665  e->ptr.p_double[i-2] = cosl*e->ptr.p_double[i-2];
14666  }
14667  work0.ptr.p_double[i-ll] = cosr;
14668  work1.ptr.p_double[i-ll] = -sinr;
14669  work2.ptr.p_double[i-ll] = cosl;
14670  work3.ptr.p_double[i-ll] = -sinl;
14671  }
14672  e->ptr.p_double[ll] = f;
14673 
14674  /*
14675  * Test convergence
14676  */
14677  if( ae_fp_less_eq(ae_fabs(e->ptr.p_double[ll], _state),thresh) )
14678  {
14679  e->ptr.p_double[ll] = 0;
14680  }
14681 
14682  /*
14683  * Update singular vectors if desired
14684  */
14685  if( ncvt>0 )
14686  {
14687  applyrotationsfromtheleft(!fwddir, ll+vstart-1, m+vstart-1, vstart, vend, &work2, &work3, vt, &vttemp, _state);
14688  }
14689  if( nru>0 )
14690  {
14691  applyrotationsfromtheright(!fwddir, ustart, uend, ll+ustart-1, m+ustart-1, &work0, &work1, u, &utemp, _state);
14692  }
14693  if( ncc>0 )
14694  {
14695  applyrotationsfromtheleft(!fwddir, ll+cstart-1, m+cstart-1, cstart, cend, &work0, &work1, c, &ctemp, _state);
14696  }
14697  }
14698  }
14699 
14700  /*
14701  * QR iteration finished, go back and check convergence
14702  */
14703  continue;
14704  }
14705 
14706  /*
14707  * All singular values converged, so make them positive
14708  */
14709  for(i=1; i<=n; i++)
14710  {
14711  if( ae_fp_less(d->ptr.p_double[i],0) )
14712  {
14713  d->ptr.p_double[i] = -d->ptr.p_double[i];
14714 
14715  /*
14716  * Change sign of singular vectors, if desired
14717  */
14718  if( ncvt>0 )
14719  {
14720  ae_v_muld(&vt->ptr.pp_double[i+vstart-1][vstart], 1, ae_v_len(vstart,vend), -1);
14721  }
14722  }
14723  }
14724 
14725  /*
14726  * Sort the singular values into decreasing order (insertion sort on
14727  * singular values, but only one transposition per singular vector)
14728  */
14729  for(i=1; i<=n-1; i++)
14730  {
14731 
14732  /*
14733  * Scan for smallest D(I)
14734  */
14735  isub = 1;
14736  smin = d->ptr.p_double[1];
14737  for(j=2; j<=n+1-i; j++)
14738  {
14739  if( ae_fp_less_eq(d->ptr.p_double[j],smin) )
14740  {
14741  isub = j;
14742  smin = d->ptr.p_double[j];
14743  }
14744  }
14745  if( isub!=n+1-i )
14746  {
14747 
14748  /*
14749  * Swap singular values and vectors
14750  */
14751  d->ptr.p_double[isub] = d->ptr.p_double[n+1-i];
14752  d->ptr.p_double[n+1-i] = smin;
14753  if( ncvt>0 )
14754  {
14755  j = n+1-i;
14756  ae_v_move(&vttemp.ptr.p_double[vstart], 1, &vt->ptr.pp_double[isub+vstart-1][vstart], 1, ae_v_len(vstart,vend));
14757  ae_v_move(&vt->ptr.pp_double[isub+vstart-1][vstart], 1, &vt->ptr.pp_double[j+vstart-1][vstart], 1, ae_v_len(vstart,vend));
14758  ae_v_move(&vt->ptr.pp_double[j+vstart-1][vstart], 1, &vttemp.ptr.p_double[vstart], 1, ae_v_len(vstart,vend));
14759  }
14760  if( nru>0 )
14761  {
14762  j = n+1-i;
14763  ae_v_move(&utemp.ptr.p_double[ustart], 1, &u->ptr.pp_double[ustart][isub+ustart-1], u->stride, ae_v_len(ustart,uend));
14764  ae_v_move(&u->ptr.pp_double[ustart][isub+ustart-1], u->stride, &u->ptr.pp_double[ustart][j+ustart-1], u->stride, ae_v_len(ustart,uend));
14765  ae_v_move(&u->ptr.pp_double[ustart][j+ustart-1], u->stride, &utemp.ptr.p_double[ustart], 1, ae_v_len(ustart,uend));
14766  }
14767  if( ncc>0 )
14768  {
14769  j = n+1-i;
14770  ae_v_move(&ctemp.ptr.p_double[cstart], 1, &c->ptr.pp_double[isub+cstart-1][cstart], 1, ae_v_len(cstart,cend));
14771  ae_v_move(&c->ptr.pp_double[isub+cstart-1][cstart], 1, &c->ptr.pp_double[j+cstart-1][cstart], 1, ae_v_len(cstart,cend));
14772  ae_v_move(&c->ptr.pp_double[j+cstart-1][cstart], 1, &ctemp.ptr.p_double[cstart], 1, ae_v_len(cstart,cend));
14773  }
14774  }
14775  }
14776  ae_frame_leave(_state);
14777  return result;
14778 }
14779 
14780 
14781 static double bdsvd_extsignbdsqr(double a, double b, ae_state *_state)
14782 {
14783  double result;
14784 
14785 
14786  if( ae_fp_greater_eq(b,0) )
14787  {
14788  result = ae_fabs(a, _state);
14789  }
14790  else
14791  {
14792  result = -ae_fabs(a, _state);
14793  }
14794  return result;
14795 }
14796 
14797 
14798 static void bdsvd_svd2x2(double f,
14799  double g,
14800  double h,
14801  double* ssmin,
14802  double* ssmax,
14803  ae_state *_state)
14804 {
14805  double aas;
14806  double at;
14807  double au;
14808  double c;
14809  double fa;
14810  double fhmn;
14811  double fhmx;
14812  double ga;
14813  double ha;
14814 
14815  *ssmin = 0;
14816  *ssmax = 0;
14817 
14818  fa = ae_fabs(f, _state);
14819  ga = ae_fabs(g, _state);
14820  ha = ae_fabs(h, _state);
14821  fhmn = ae_minreal(fa, ha, _state);
14822  fhmx = ae_maxreal(fa, ha, _state);
14823  if( ae_fp_eq(fhmn,0) )
14824  {
14825  *ssmin = 0;
14826  if( ae_fp_eq(fhmx,0) )
14827  {
14828  *ssmax = ga;
14829  }
14830  else
14831  {
14832  *ssmax = ae_maxreal(fhmx, ga, _state)*ae_sqrt(1+ae_sqr(ae_minreal(fhmx, ga, _state)/ae_maxreal(fhmx, ga, _state), _state), _state);
14833  }
14834  }
14835  else
14836  {
14837  if( ae_fp_less(ga,fhmx) )
14838  {
14839  aas = 1+fhmn/fhmx;
14840  at = (fhmx-fhmn)/fhmx;
14841  au = ae_sqr(ga/fhmx, _state);
14842  c = 2/(ae_sqrt(aas*aas+au, _state)+ae_sqrt(at*at+au, _state));
14843  *ssmin = fhmn*c;
14844  *ssmax = fhmx/c;
14845  }
14846  else
14847  {
14848  au = fhmx/ga;
14849  if( ae_fp_eq(au,0) )
14850  {
14851 
14852  /*
14853  * Avoid possible harmful underflow if exponent range
14854  * asymmetric (true SSMIN may not underflow even if
14855  * AU underflows)
14856  */
14857  *ssmin = fhmn*fhmx/ga;
14858  *ssmax = ga;
14859  }
14860  else
14861  {
14862  aas = 1+fhmn/fhmx;
14863  at = (fhmx-fhmn)/fhmx;
14864  c = 1/(ae_sqrt(1+ae_sqr(aas*au, _state), _state)+ae_sqrt(1+ae_sqr(at*au, _state), _state));
14865  *ssmin = fhmn*c*au;
14866  *ssmin = *ssmin+(*ssmin);
14867  *ssmax = ga/(c+c);
14868  }
14869  }
14870  }
14871 }
14872 
14873 
14874 static void bdsvd_svdv2x2(double f,
14875  double g,
14876  double h,
14877  double* ssmin,
14878  double* ssmax,
14879  double* snr,
14880  double* csr,
14881  double* snl,
14882  double* csl,
14883  ae_state *_state)
14884 {
14885  ae_bool gasmal;
14886  ae_bool swp;
14887  ae_int_t pmax;
14888  double a;
14889  double clt;
14890  double crt;
14891  double d;
14892  double fa;
14893  double ft;
14894  double ga;
14895  double gt;
14896  double ha;
14897  double ht;
14898  double l;
14899  double m;
14900  double mm;
14901  double r;
14902  double s;
14903  double slt;
14904  double srt;
14905  double t;
14906  double temp;
14907  double tsign;
14908  double tt;
14909  double v;
14910 
14911  *ssmin = 0;
14912  *ssmax = 0;
14913  *snr = 0;
14914  *csr = 0;
14915  *snl = 0;
14916  *csl = 0;
14917 
14918  ft = f;
14919  fa = ae_fabs(ft, _state);
14920  ht = h;
14921  ha = ae_fabs(h, _state);
14922 
14923  /*
14924  * these initializers are not really necessary,
14925  * but without them compiler complains about uninitialized locals
14926  */
14927  clt = 0;
14928  crt = 0;
14929  slt = 0;
14930  srt = 0;
14931  tsign = 0;
14932 
14933  /*
14934  * PMAX points to the maximum absolute element of matrix
14935  * PMAX = 1 if F largest in absolute values
14936  * PMAX = 2 if G largest in absolute values
14937  * PMAX = 3 if H largest in absolute values
14938  */
14939  pmax = 1;
14940  swp = ae_fp_greater(ha,fa);
14941  if( swp )
14942  {
14943 
14944  /*
14945  * Now FA .ge. HA
14946  */
14947  pmax = 3;
14948  temp = ft;
14949  ft = ht;
14950  ht = temp;
14951  temp = fa;
14952  fa = ha;
14953  ha = temp;
14954  }
14955  gt = g;
14956  ga = ae_fabs(gt, _state);
14957  if( ae_fp_eq(ga,0) )
14958  {
14959 
14960  /*
14961  * Diagonal matrix
14962  */
14963  *ssmin = ha;
14964  *ssmax = fa;
14965  clt = 1;
14966  crt = 1;
14967  slt = 0;
14968  srt = 0;
14969  }
14970  else
14971  {
14972  gasmal = ae_true;
14973  if( ae_fp_greater(ga,fa) )
14974  {
14975  pmax = 2;
14976  if( ae_fp_less(fa/ga,ae_machineepsilon) )
14977  {
14978 
14979  /*
14980  * Case of very large GA
14981  */
14982  gasmal = ae_false;
14983  *ssmax = ga;
14984  if( ae_fp_greater(ha,1) )
14985  {
14986  v = ga/ha;
14987  *ssmin = fa/v;
14988  }
14989  else
14990  {
14991  v = fa/ga;
14992  *ssmin = v*ha;
14993  }
14994  clt = 1;
14995  slt = ht/gt;
14996  srt = 1;
14997  crt = ft/gt;
14998  }
14999  }
15000  if( gasmal )
15001  {
15002 
15003  /*
15004  * Normal case
15005  */
15006  d = fa-ha;
15007  if( ae_fp_eq(d,fa) )
15008  {
15009  l = 1;
15010  }
15011  else
15012  {
15013  l = d/fa;
15014  }
15015  m = gt/ft;
15016  t = 2-l;
15017  mm = m*m;
15018  tt = t*t;
15019  s = ae_sqrt(tt+mm, _state);
15020  if( ae_fp_eq(l,0) )
15021  {
15022  r = ae_fabs(m, _state);
15023  }
15024  else
15025  {
15026  r = ae_sqrt(l*l+mm, _state);
15027  }
15028  a = 0.5*(s+r);
15029  *ssmin = ha/a;
15030  *ssmax = fa*a;
15031  if( ae_fp_eq(mm,0) )
15032  {
15033 
15034  /*
15035  * Note that M is very tiny
15036  */
15037  if( ae_fp_eq(l,0) )
15038  {
15039  t = bdsvd_extsignbdsqr(2, ft, _state)*bdsvd_extsignbdsqr(1, gt, _state);
15040  }
15041  else
15042  {
15043  t = gt/bdsvd_extsignbdsqr(d, ft, _state)+m/t;
15044  }
15045  }
15046  else
15047  {
15048  t = (m/(s+t)+m/(r+l))*(1+a);
15049  }
15050  l = ae_sqrt(t*t+4, _state);
15051  crt = 2/l;
15052  srt = t/l;
15053  clt = (crt+srt*m)/a;
15054  v = ht/ft;
15055  slt = v*srt/a;
15056  }
15057  }
15058  if( swp )
15059  {
15060  *csl = srt;
15061  *snl = crt;
15062  *csr = slt;
15063  *snr = clt;
15064  }
15065  else
15066  {
15067  *csl = clt;
15068  *snl = slt;
15069  *csr = crt;
15070  *snr = srt;
15071  }
15072 
15073  /*
15074  * Correct signs of SSMAX and SSMIN
15075  */
15076  if( pmax==1 )
15077  {
15078  tsign = bdsvd_extsignbdsqr(1, *csr, _state)*bdsvd_extsignbdsqr(1, *csl, _state)*bdsvd_extsignbdsqr(1, f, _state);
15079  }
15080  if( pmax==2 )
15081  {
15082  tsign = bdsvd_extsignbdsqr(1, *snr, _state)*bdsvd_extsignbdsqr(1, *csl, _state)*bdsvd_extsignbdsqr(1, g, _state);
15083  }
15084  if( pmax==3 )
15085  {
15086  tsign = bdsvd_extsignbdsqr(1, *snr, _state)*bdsvd_extsignbdsqr(1, *snl, _state)*bdsvd_extsignbdsqr(1, h, _state);
15087  }
15088  *ssmax = bdsvd_extsignbdsqr(*ssmax, tsign, _state);
15089  *ssmin = bdsvd_extsignbdsqr(*ssmin, tsign*bdsvd_extsignbdsqr(1, f, _state)*bdsvd_extsignbdsqr(1, h, _state), _state);
15090 }
15091 
15092 
15093 
15094 
15095 /*************************************************************************
15096 Singular value decomposition of a rectangular matrix.
15097 
15098 The algorithm calculates the singular value decomposition of a matrix of
15099 size MxN: A = U * S * V^T
15100 
15101 The algorithm finds the singular values and, optionally, matrices U and V^T.
15102 The algorithm can find both first min(M,N) columns of matrix U and rows of
15103 matrix V^T (singular vectors), and matrices U and V^T wholly (of sizes MxM
15104 and NxN respectively).
15105 
15106 Take into account that the subroutine does not return matrix V but V^T.
15107 
15108 Input parameters:
15109  A - matrix to be decomposed.
15110  Array whose indexes range within [0..M-1, 0..N-1].
15111  M - number of rows in matrix A.
15112  N - number of columns in matrix A.
15113  UNeeded - 0, 1 or 2. See the description of the parameter U.
15114  VTNeeded - 0, 1 or 2. See the description of the parameter VT.
15115  AdditionalMemory -
15116  If the parameter:
15117  * equals 0, the algorithm doesn’t use additional
15118  memory (lower requirements, lower performance).
15119  * equals 1, the algorithm uses additional
15120  memory of size min(M,N)*min(M,N) of real numbers.
15121  It often speeds up the algorithm.
15122  * equals 2, the algorithm uses additional
15123  memory of size M*min(M,N) of real numbers.
15124  It allows to get a maximum performance.
15125  The recommended value of the parameter is 2.
15126 
15127 Output parameters:
15128  W - contains singular values in descending order.
15129  U - if UNeeded=0, U isn't changed, the left singular vectors
15130  are not calculated.
15131  if Uneeded=1, U contains left singular vectors (first
15132  min(M,N) columns of matrix U). Array whose indexes range
15133  within [0..M-1, 0..Min(M,N)-1].
15134  if UNeeded=2, U contains matrix U wholly. Array whose
15135  indexes range within [0..M-1, 0..M-1].
15136  VT - if VTNeeded=0, VT isn’t changed, the right singular vectors
15137  are not calculated.
15138  if VTNeeded=1, VT contains right singular vectors (first
15139  min(M,N) rows of matrix V^T). Array whose indexes range
15140  within [0..min(M,N)-1, 0..N-1].
15141  if VTNeeded=2, VT contains matrix V^T wholly. Array whose
15142  indexes range within [0..N-1, 0..N-1].
15143 
15144  -- ALGLIB --
15145  Copyright 2005 by Bochkanov Sergey
15146 *************************************************************************/
15147 ae_bool rmatrixsvd(/* Real */ ae_matrix* a,
15148  ae_int_t m,
15149  ae_int_t n,
15150  ae_int_t uneeded,
15151  ae_int_t vtneeded,
15152  ae_int_t additionalmemory,
15153  /* Real */ ae_vector* w,
15154  /* Real */ ae_matrix* u,
15155  /* Real */ ae_matrix* vt,
15156  ae_state *_state)
15157 {
15158  ae_frame _frame_block;
15159  ae_matrix _a;
15160  ae_vector tauq;
15161  ae_vector taup;
15162  ae_vector tau;
15163  ae_vector e;
15164  ae_vector work;
15165  ae_matrix t2;
15166  ae_bool isupper;
15167  ae_int_t minmn;
15168  ae_int_t ncu;
15169  ae_int_t nrvt;
15170  ae_int_t nru;
15171  ae_int_t ncvt;
15172  ae_int_t i;
15173  ae_int_t j;
15174  ae_bool result;
15175 
15176  ae_frame_make(_state, &_frame_block);
15177  ae_matrix_init_copy(&_a, a, _state, ae_true);
15178  a = &_a;
15179  ae_vector_clear(w);
15180  ae_matrix_clear(u);
15181  ae_matrix_clear(vt);
15182  ae_vector_init(&tauq, 0, DT_REAL, _state, ae_true);
15183  ae_vector_init(&taup, 0, DT_REAL, _state, ae_true);
15184  ae_vector_init(&tau, 0, DT_REAL, _state, ae_true);
15185  ae_vector_init(&e, 0, DT_REAL, _state, ae_true);
15186  ae_vector_init(&work, 0, DT_REAL, _state, ae_true);
15187  ae_matrix_init(&t2, 0, 0, DT_REAL, _state, ae_true);
15188 
15189  result = ae_true;
15190  if( m==0||n==0 )
15191  {
15192  ae_frame_leave(_state);
15193  return result;
15194  }
15195  ae_assert(uneeded>=0&&uneeded<=2, "SVDDecomposition: wrong parameters!", _state);
15196  ae_assert(vtneeded>=0&&vtneeded<=2, "SVDDecomposition: wrong parameters!", _state);
15197  ae_assert(additionalmemory>=0&&additionalmemory<=2, "SVDDecomposition: wrong parameters!", _state);
15198 
15199  /*
15200  * initialize
15201  */
15202  minmn = ae_minint(m, n, _state);
15203  ae_vector_set_length(w, minmn+1, _state);
15204  ncu = 0;
15205  nru = 0;
15206  if( uneeded==1 )
15207  {
15208  nru = m;
15209  ncu = minmn;
15210  ae_matrix_set_length(u, nru-1+1, ncu-1+1, _state);
15211  }
15212  if( uneeded==2 )
15213  {
15214  nru = m;
15215  ncu = m;
15216  ae_matrix_set_length(u, nru-1+1, ncu-1+1, _state);
15217  }
15218  nrvt = 0;
15219  ncvt = 0;
15220  if( vtneeded==1 )
15221  {
15222  nrvt = minmn;
15223  ncvt = n;
15224  ae_matrix_set_length(vt, nrvt-1+1, ncvt-1+1, _state);
15225  }
15226  if( vtneeded==2 )
15227  {
15228  nrvt = n;
15229  ncvt = n;
15230  ae_matrix_set_length(vt, nrvt-1+1, ncvt-1+1, _state);
15231  }
15232 
15233  /*
15234  * M much larger than N
15235  * Use bidiagonal reduction with QR-decomposition
15236  */
15237  if( ae_fp_greater(m,1.6*n) )
15238  {
15239  if( uneeded==0 )
15240  {
15241 
15242  /*
15243  * No left singular vectors to be computed
15244  */
15245  rmatrixqr(a, m, n, &tau, _state);
15246  for(i=0; i<=n-1; i++)
15247  {
15248  for(j=0; j<=i-1; j++)
15249  {
15250  a->ptr.pp_double[i][j] = 0;
15251  }
15252  }
15253  rmatrixbd(a, n, n, &tauq, &taup, _state);
15254  rmatrixbdunpackpt(a, n, n, &taup, nrvt, vt, _state);
15255  rmatrixbdunpackdiagonals(a, n, n, &isupper, w, &e, _state);
15256  result = rmatrixbdsvd(w, &e, n, isupper, ae_false, u, 0, a, 0, vt, ncvt, _state);
15257  ae_frame_leave(_state);
15258  return result;
15259  }
15260  else
15261  {
15262 
15263  /*
15264  * Left singular vectors (may be full matrix U) to be computed
15265  */
15266  rmatrixqr(a, m, n, &tau, _state);
15267  rmatrixqrunpackq(a, m, n, &tau, ncu, u, _state);
15268  for(i=0; i<=n-1; i++)
15269  {
15270  for(j=0; j<=i-1; j++)
15271  {
15272  a->ptr.pp_double[i][j] = 0;
15273  }
15274  }
15275  rmatrixbd(a, n, n, &tauq, &taup, _state);
15276  rmatrixbdunpackpt(a, n, n, &taup, nrvt, vt, _state);
15277  rmatrixbdunpackdiagonals(a, n, n, &isupper, w, &e, _state);
15278  if( additionalmemory<1 )
15279  {
15280 
15281  /*
15282  * No additional memory can be used
15283  */
15284  rmatrixbdmultiplybyq(a, n, n, &tauq, u, m, n, ae_true, ae_false, _state);
15285  result = rmatrixbdsvd(w, &e, n, isupper, ae_false, u, m, a, 0, vt, ncvt, _state);
15286  }
15287  else
15288  {
15289 
15290  /*
15291  * Large U. Transforming intermediate matrix T2
15292  */
15293  ae_vector_set_length(&work, ae_maxint(m, n, _state)+1, _state);
15294  rmatrixbdunpackq(a, n, n, &tauq, n, &t2, _state);
15295  copymatrix(u, 0, m-1, 0, n-1, a, 0, m-1, 0, n-1, _state);
15296  inplacetranspose(&t2, 0, n-1, 0, n-1, &work, _state);
15297  result = rmatrixbdsvd(w, &e, n, isupper, ae_false, u, 0, &t2, n, vt, ncvt, _state);
15298  matrixmatrixmultiply(a, 0, m-1, 0, n-1, ae_false, &t2, 0, n-1, 0, n-1, ae_true, 1.0, u, 0, m-1, 0, n-1, 0.0, &work, _state);
15299  }
15300  ae_frame_leave(_state);
15301  return result;
15302  }
15303  }
15304 
15305  /*
15306  * N much larger than M
15307  * Use bidiagonal reduction with LQ-decomposition
15308  */
15309  if( ae_fp_greater(n,1.6*m) )
15310  {
15311  if( vtneeded==0 )
15312  {
15313 
15314  /*
15315  * No right singular vectors to be computed
15316  */
15317  rmatrixlq(a, m, n, &tau, _state);
15318  for(i=0; i<=m-1; i++)
15319  {
15320  for(j=i+1; j<=m-1; j++)
15321  {
15322  a->ptr.pp_double[i][j] = 0;
15323  }
15324  }
15325  rmatrixbd(a, m, m, &tauq, &taup, _state);
15326  rmatrixbdunpackq(a, m, m, &tauq, ncu, u, _state);
15327  rmatrixbdunpackdiagonals(a, m, m, &isupper, w, &e, _state);
15328  ae_vector_set_length(&work, m+1, _state);
15329  inplacetranspose(u, 0, nru-1, 0, ncu-1, &work, _state);
15330  result = rmatrixbdsvd(w, &e, m, isupper, ae_false, a, 0, u, nru, vt, 0, _state);
15331  inplacetranspose(u, 0, nru-1, 0, ncu-1, &work, _state);
15332  ae_frame_leave(_state);
15333  return result;
15334  }
15335  else
15336  {
15337 
15338  /*
15339  * Right singular vectors (may be full matrix VT) to be computed
15340  */
15341  rmatrixlq(a, m, n, &tau, _state);
15342  rmatrixlqunpackq(a, m, n, &tau, nrvt, vt, _state);
15343  for(i=0; i<=m-1; i++)
15344  {
15345  for(j=i+1; j<=m-1; j++)
15346  {
15347  a->ptr.pp_double[i][j] = 0;
15348  }
15349  }
15350  rmatrixbd(a, m, m, &tauq, &taup, _state);
15351  rmatrixbdunpackq(a, m, m, &tauq, ncu, u, _state);
15352  rmatrixbdunpackdiagonals(a, m, m, &isupper, w, &e, _state);
15353  ae_vector_set_length(&work, ae_maxint(m, n, _state)+1, _state);
15354  inplacetranspose(u, 0, nru-1, 0, ncu-1, &work, _state);
15355  if( additionalmemory<1 )
15356  {
15357 
15358  /*
15359  * No additional memory available
15360  */
15361  rmatrixbdmultiplybyp(a, m, m, &taup, vt, m, n, ae_false, ae_true, _state);
15362  result = rmatrixbdsvd(w, &e, m, isupper, ae_false, a, 0, u, nru, vt, n, _state);
15363  }
15364  else
15365  {
15366 
15367  /*
15368  * Large VT. Transforming intermediate matrix T2
15369  */
15370  rmatrixbdunpackpt(a, m, m, &taup, m, &t2, _state);
15371  result = rmatrixbdsvd(w, &e, m, isupper, ae_false, a, 0, u, nru, &t2, m, _state);
15372  copymatrix(vt, 0, m-1, 0, n-1, a, 0, m-1, 0, n-1, _state);
15373  matrixmatrixmultiply(&t2, 0, m-1, 0, m-1, ae_false, a, 0, m-1, 0, n-1, ae_false, 1.0, vt, 0, m-1, 0, n-1, 0.0, &work, _state);
15374  }
15375  inplacetranspose(u, 0, nru-1, 0, ncu-1, &work, _state);
15376  ae_frame_leave(_state);
15377  return result;
15378  }
15379  }
15380 
15381  /*
15382  * M<=N
15383  * We can use inplace transposition of U to get rid of columnwise operations
15384  */
15385  if( m<=n )
15386  {
15387  rmatrixbd(a, m, n, &tauq, &taup, _state);
15388  rmatrixbdunpackq(a, m, n, &tauq, ncu, u, _state);
15389  rmatrixbdunpackpt(a, m, n, &taup, nrvt, vt, _state);
15390  rmatrixbdunpackdiagonals(a, m, n, &isupper, w, &e, _state);
15391  ae_vector_set_length(&work, m+1, _state);
15392  inplacetranspose(u, 0, nru-1, 0, ncu-1, &work, _state);
15393  result = rmatrixbdsvd(w, &e, minmn, isupper, ae_false, a, 0, u, nru, vt, ncvt, _state);
15394  inplacetranspose(u, 0, nru-1, 0, ncu-1, &work, _state);
15395  ae_frame_leave(_state);
15396  return result;
15397  }
15398 
15399  /*
15400  * Simple bidiagonal reduction
15401  */
15402  rmatrixbd(a, m, n, &tauq, &taup, _state);
15403  rmatrixbdunpackq(a, m, n, &tauq, ncu, u, _state);
15404  rmatrixbdunpackpt(a, m, n, &taup, nrvt, vt, _state);
15405  rmatrixbdunpackdiagonals(a, m, n, &isupper, w, &e, _state);
15406  if( additionalmemory<2||uneeded==0 )
15407  {
15408 
15409  /*
15410  * We can't use additional memory or there is no need in such operations
15411  */
15412  result = rmatrixbdsvd(w, &e, minmn, isupper, ae_false, u, nru, a, 0, vt, ncvt, _state);
15413  }
15414  else
15415  {
15416 
15417  /*
15418  * We can use additional memory
15419  */
15420  ae_matrix_set_length(&t2, minmn-1+1, m-1+1, _state);
15421  copyandtranspose(u, 0, m-1, 0, minmn-1, &t2, 0, minmn-1, 0, m-1, _state);
15422  result = rmatrixbdsvd(w, &e, minmn, isupper, ae_false, u, 0, &t2, m, vt, ncvt, _state);
15423  copyandtranspose(&t2, 0, minmn-1, 0, m-1, u, 0, m-1, 0, minmn-1, _state);
15424  }
15425  ae_frame_leave(_state);
15426  return result;
15427 }
15428 
15429 
15430 
15431 
15432 /*************************************************************************
15433 Finding the eigenvalues and eigenvectors of a symmetric matrix
15434 
15435 The algorithm finds eigen pairs of a symmetric matrix by reducing it to
15436 tridiagonal form and using the QL/QR algorithm.
15437 
15438 Input parameters:
15439  A - symmetric matrix which is given by its upper or lower
15440  triangular part.
15441  Array whose indexes range within [0..N-1, 0..N-1].
15442  N - size of matrix A.
15443  ZNeeded - flag controlling whether the eigenvectors are needed or not.
15444  If ZNeeded is equal to:
15445  * 0, the eigenvectors are not returned;
15446  * 1, the eigenvectors are returned.
15447  IsUpper - storage format.
15448 
15449 Output parameters:
15450  D - eigenvalues in ascending order.
15451  Array whose index ranges within [0..N-1].
15452  Z - if ZNeeded is equal to:
15453  * 0, Z hasn’t changed;
15454  * 1, Z contains the eigenvectors.
15455  Array whose indexes range within [0..N-1, 0..N-1].
15456  The eigenvectors are stored in the matrix columns.
15457 
15458 Result:
15459  True, if the algorithm has converged.
15460  False, if the algorithm hasn't converged (rare case).
15461 
15462  -- ALGLIB --
15463  Copyright 2005-2008 by Bochkanov Sergey
15464 *************************************************************************/
15465 ae_bool smatrixevd(/* Real */ ae_matrix* a,
15466  ae_int_t n,
15467  ae_int_t zneeded,
15468  ae_bool isupper,
15469  /* Real */ ae_vector* d,
15470  /* Real */ ae_matrix* z,
15471  ae_state *_state)
15472 {
15473  ae_frame _frame_block;
15474  ae_matrix _a;
15475  ae_vector tau;
15476  ae_vector e;
15477  ae_bool result;
15478 
15479  ae_frame_make(_state, &_frame_block);
15480  ae_matrix_init_copy(&_a, a, _state, ae_true);
15481  a = &_a;
15482  ae_vector_clear(d);
15483  ae_matrix_clear(z);
15484  ae_vector_init(&tau, 0, DT_REAL, _state, ae_true);
15485  ae_vector_init(&e, 0, DT_REAL, _state, ae_true);
15486 
15487  ae_assert(zneeded==0||zneeded==1, "SMatrixEVD: incorrect ZNeeded", _state);
15488  smatrixtd(a, n, isupper, &tau, d, &e, _state);
15489  if( zneeded==1 )
15490  {
15491  smatrixtdunpackq(a, n, isupper, &tau, z, _state);
15492  }
15493  result = smatrixtdevd(d, &e, n, zneeded, z, _state);
15494  ae_frame_leave(_state);
15495  return result;
15496 }
15497 
15498 
15499 /*************************************************************************
15500 Subroutine for finding the eigenvalues (and eigenvectors) of a symmetric
15501 matrix in a given half open interval (A, B] by using a bisection and
15502 inverse iteration
15503 
15504 Input parameters:
15505  A - symmetric matrix which is given by its upper or lower
15506  triangular part. Array [0..N-1, 0..N-1].
15507  N - size of matrix A.
15508  ZNeeded - flag controlling whether the eigenvectors are needed or not.
15509  If ZNeeded is equal to:
15510  * 0, the eigenvectors are not returned;
15511  * 1, the eigenvectors are returned.
15512  IsUpperA - storage format of matrix A.
15513  B1, B2 - half open interval (B1, B2] to search eigenvalues in.
15514 
15515 Output parameters:
15516  M - number of eigenvalues found in a given half-interval (M>=0).
15517  W - array of the eigenvalues found.
15518  Array whose index ranges within [0..M-1].
15519  Z - if ZNeeded is equal to:
15520  * 0, Z hasn’t changed;
15521  * 1, Z contains eigenvectors.
15522  Array whose indexes range within [0..N-1, 0..M-1].
15523  The eigenvectors are stored in the matrix columns.
15524 
15525 Result:
15526  True, if successful. M contains the number of eigenvalues in the given
15527  half-interval (could be equal to 0), W contains the eigenvalues,
15528  Z contains the eigenvectors (if needed).
15529 
15530  False, if the bisection method subroutine wasn't able to find the
15531  eigenvalues in the given interval or if the inverse iteration subroutine
15532  wasn't able to find all the corresponding eigenvectors.
15533  In that case, the eigenvalues and eigenvectors are not returned,
15534  M is equal to 0.
15535 
15536  -- ALGLIB --
15537  Copyright 07.01.2006 by Bochkanov Sergey
15538 *************************************************************************/
15539 ae_bool smatrixevdr(/* Real */ ae_matrix* a,
15540  ae_int_t n,
15541  ae_int_t zneeded,
15542  ae_bool isupper,
15543  double b1,
15544  double b2,
15545  ae_int_t* m,
15546  /* Real */ ae_vector* w,
15547  /* Real */ ae_matrix* z,
15548  ae_state *_state)
15549 {
15550  ae_frame _frame_block;
15551  ae_matrix _a;
15552  ae_vector tau;
15553  ae_vector e;
15554  ae_bool result;
15555 
15556  ae_frame_make(_state, &_frame_block);
15557  ae_matrix_init_copy(&_a, a, _state, ae_true);
15558  a = &_a;
15559  *m = 0;
15560  ae_vector_clear(w);
15561  ae_matrix_clear(z);
15562  ae_vector_init(&tau, 0, DT_REAL, _state, ae_true);
15563  ae_vector_init(&e, 0, DT_REAL, _state, ae_true);
15564 
15565  ae_assert(zneeded==0||zneeded==1, "SMatrixTDEVDR: incorrect ZNeeded", _state);
15566  smatrixtd(a, n, isupper, &tau, w, &e, _state);
15567  if( zneeded==1 )
15568  {
15569  smatrixtdunpackq(a, n, isupper, &tau, z, _state);
15570  }
15571  result = smatrixtdevdr(w, &e, n, zneeded, b1, b2, m, z, _state);
15572  ae_frame_leave(_state);
15573  return result;
15574 }
15575 
15576 
15577 /*************************************************************************
15578 Subroutine for finding the eigenvalues and eigenvectors of a symmetric
15579 matrix with given indexes by using bisection and inverse iteration methods.
15580 
15581 Input parameters:
15582  A - symmetric matrix which is given by its upper or lower
15583  triangular part. Array whose indexes range within [0..N-1, 0..N-1].
15584  N - size of matrix A.
15585  ZNeeded - flag controlling whether the eigenvectors are needed or not.
15586  If ZNeeded is equal to:
15587  * 0, the eigenvectors are not returned;
15588  * 1, the eigenvectors are returned.
15589  IsUpperA - storage format of matrix A.
15590  I1, I2 - index interval for searching (from I1 to I2).
15591  0 <= I1 <= I2 <= N-1.
15592 
15593 Output parameters:
15594  W - array of the eigenvalues found.
15595  Array whose index ranges within [0..I2-I1].
15596  Z - if ZNeeded is equal to:
15597  * 0, Z hasn’t changed;
15598  * 1, Z contains eigenvectors.
15599  Array whose indexes range within [0..N-1, 0..I2-I1].
15600  In that case, the eigenvectors are stored in the matrix columns.
15601 
15602 Result:
15603  True, if successful. W contains the eigenvalues, Z contains the
15604  eigenvectors (if needed).
15605 
15606  False, if the bisection method subroutine wasn't able to find the
15607  eigenvalues in the given interval or if the inverse iteration subroutine
15608  wasn't able to find all the corresponding eigenvectors.
15609  In that case, the eigenvalues and eigenvectors are not returned.
15610 
15611  -- ALGLIB --
15612  Copyright 07.01.2006 by Bochkanov Sergey
15613 *************************************************************************/
15614 ae_bool smatrixevdi(/* Real */ ae_matrix* a,
15615  ae_int_t n,
15616  ae_int_t zneeded,
15617  ae_bool isupper,
15618  ae_int_t i1,
15619  ae_int_t i2,
15620  /* Real */ ae_vector* w,
15621  /* Real */ ae_matrix* z,
15622  ae_state *_state)
15623 {
15624  ae_frame _frame_block;
15625  ae_matrix _a;
15626  ae_vector tau;
15627  ae_vector e;
15628  ae_bool result;
15629 
15630  ae_frame_make(_state, &_frame_block);
15631  ae_matrix_init_copy(&_a, a, _state, ae_true);
15632  a = &_a;
15633  ae_vector_clear(w);
15634  ae_matrix_clear(z);
15635  ae_vector_init(&tau, 0, DT_REAL, _state, ae_true);
15636  ae_vector_init(&e, 0, DT_REAL, _state, ae_true);
15637 
15638  ae_assert(zneeded==0||zneeded==1, "SMatrixEVDI: incorrect ZNeeded", _state);
15639  smatrixtd(a, n, isupper, &tau, w, &e, _state);
15640  if( zneeded==1 )
15641  {
15642  smatrixtdunpackq(a, n, isupper, &tau, z, _state);
15643  }
15644  result = smatrixtdevdi(w, &e, n, zneeded, i1, i2, z, _state);
15645  ae_frame_leave(_state);
15646  return result;
15647 }
15648 
15649 
15650 /*************************************************************************
15651 Finding the eigenvalues and eigenvectors of a Hermitian matrix
15652 
15653 The algorithm finds eigen pairs of a Hermitian matrix by reducing it to
15654 real tridiagonal form and using the QL/QR algorithm.
15655 
15656 Input parameters:
15657  A - Hermitian matrix which is given by its upper or lower
15658  triangular part.
15659  Array whose indexes range within [0..N-1, 0..N-1].
15660  N - size of matrix A.
15661  IsUpper - storage format.
15662  ZNeeded - flag controlling whether the eigenvectors are needed or
15663  not. If ZNeeded is equal to:
15664  * 0, the eigenvectors are not returned;
15665  * 1, the eigenvectors are returned.
15666 
15667 Output parameters:
15668  D - eigenvalues in ascending order.
15669  Array whose index ranges within [0..N-1].
15670  Z - if ZNeeded is equal to:
15671  * 0, Z hasn’t changed;
15672  * 1, Z contains the eigenvectors.
15673  Array whose indexes range within [0..N-1, 0..N-1].
15674  The eigenvectors are stored in the matrix columns.
15675 
15676 Result:
15677  True, if the algorithm has converged.
15678  False, if the algorithm hasn't converged (rare case).
15679 
15680 Note:
15681  eigenvectors of Hermitian matrix are defined up to multiplication by
15682  a complex number L, such that |L|=1.
15683 
15684  -- ALGLIB --
15685  Copyright 2005, 23 March 2007 by Bochkanov Sergey
15686 *************************************************************************/
15687 ae_bool hmatrixevd(/* Complex */ ae_matrix* a,
15688  ae_int_t n,
15689  ae_int_t zneeded,
15690  ae_bool isupper,
15691  /* Real */ ae_vector* d,
15692  /* Complex */ ae_matrix* z,
15693  ae_state *_state)
15694 {
15695  ae_frame _frame_block;
15696  ae_matrix _a;
15697  ae_vector tau;
15698  ae_vector e;
15699  ae_vector work;
15700  ae_matrix t;
15701  ae_matrix q;
15702  ae_int_t i;
15703  ae_int_t k;
15704  double v;
15705  ae_bool result;
15706 
15707  ae_frame_make(_state, &_frame_block);
15708  ae_matrix_init_copy(&_a, a, _state, ae_true);
15709  a = &_a;
15710  ae_vector_clear(d);
15711  ae_matrix_clear(z);
15712  ae_vector_init(&tau, 0, DT_COMPLEX, _state, ae_true);
15713  ae_vector_init(&e, 0, DT_REAL, _state, ae_true);
15714  ae_vector_init(&work, 0, DT_REAL, _state, ae_true);
15715  ae_matrix_init(&t, 0, 0, DT_REAL, _state, ae_true);
15716  ae_matrix_init(&q, 0, 0, DT_COMPLEX, _state, ae_true);
15717 
15718  ae_assert(zneeded==0||zneeded==1, "HermitianEVD: incorrect ZNeeded", _state);
15719 
15720  /*
15721  * Reduce to tridiagonal form
15722  */
15723  hmatrixtd(a, n, isupper, &tau, d, &e, _state);
15724  if( zneeded==1 )
15725  {
15726  hmatrixtdunpackq(a, n, isupper, &tau, &q, _state);
15727  zneeded = 2;
15728  }
15729 
15730  /*
15731  * TDEVD
15732  */
15733  result = smatrixtdevd(d, &e, n, zneeded, &t, _state);
15734 
15735  /*
15736  * Eigenvectors are needed
15737  * Calculate Z = Q*T = Re(Q)*T + i*Im(Q)*T
15738  */
15739  if( result&&zneeded!=0 )
15740  {
15741  ae_vector_set_length(&work, n-1+1, _state);
15742  ae_matrix_set_length(z, n-1+1, n-1+1, _state);
15743  for(i=0; i<=n-1; i++)
15744  {
15745 
15746  /*
15747  * Calculate real part
15748  */
15749  for(k=0; k<=n-1; k++)
15750  {
15751  work.ptr.p_double[k] = 0;
15752  }
15753  for(k=0; k<=n-1; k++)
15754  {
15755  v = q.ptr.pp_complex[i][k].x;
15756  ae_v_addd(&work.ptr.p_double[0], 1, &t.ptr.pp_double[k][0], 1, ae_v_len(0,n-1), v);
15757  }
15758  for(k=0; k<=n-1; k++)
15759  {
15760  z->ptr.pp_complex[i][k].x = work.ptr.p_double[k];
15761  }
15762 
15763  /*
15764  * Calculate imaginary part
15765  */
15766  for(k=0; k<=n-1; k++)
15767  {
15768  work.ptr.p_double[k] = 0;
15769  }
15770  for(k=0; k<=n-1; k++)
15771  {
15772  v = q.ptr.pp_complex[i][k].y;
15773  ae_v_addd(&work.ptr.p_double[0], 1, &t.ptr.pp_double[k][0], 1, ae_v_len(0,n-1), v);
15774  }
15775  for(k=0; k<=n-1; k++)
15776  {
15777  z->ptr.pp_complex[i][k].y = work.ptr.p_double[k];
15778  }
15779  }
15780  }
15781  ae_frame_leave(_state);
15782  return result;
15783 }
15784 
15785 
15786 /*************************************************************************
15787 Subroutine for finding the eigenvalues (and eigenvectors) of a Hermitian
15788 matrix in a given half-interval (A, B] by using a bisection and inverse
15789 iteration
15790 
15791 Input parameters:
15792  A - Hermitian matrix which is given by its upper or lower
15793  triangular part. Array whose indexes range within
15794  [0..N-1, 0..N-1].
15795  N - size of matrix A.
15796  ZNeeded - flag controlling whether the eigenvectors are needed or
15797  not. If ZNeeded is equal to:
15798  * 0, the eigenvectors are not returned;
15799  * 1, the eigenvectors are returned.
15800  IsUpperA - storage format of matrix A.
15801  B1, B2 - half-interval (B1, B2] to search eigenvalues in.
15802 
15803 Output parameters:
15804  M - number of eigenvalues found in a given half-interval, M>=0
15805  W - array of the eigenvalues found.
15806  Array whose index ranges within [0..M-1].
15807  Z - if ZNeeded is equal to:
15808  * 0, Z hasn’t changed;
15809  * 1, Z contains eigenvectors.
15810  Array whose indexes range within [0..N-1, 0..M-1].
15811  The eigenvectors are stored in the matrix columns.
15812 
15813 Result:
15814  True, if successful. M contains the number of eigenvalues in the given
15815  half-interval (could be equal to 0), W contains the eigenvalues,
15816  Z contains the eigenvectors (if needed).
15817 
15818  False, if the bisection method subroutine wasn't able to find the
15819  eigenvalues in the given interval or if the inverse iteration
15820  subroutine wasn't able to find all the corresponding eigenvectors.
15821  In that case, the eigenvalues and eigenvectors are not returned, M is
15822  equal to 0.
15823 
15824 Note:
15825  eigen vectors of Hermitian matrix are defined up to multiplication by
15826  a complex number L, such as |L|=1.
15827 
15828  -- ALGLIB --
15829  Copyright 07.01.2006, 24.03.2007 by Bochkanov Sergey.
15830 *************************************************************************/
15831 ae_bool hmatrixevdr(/* Complex */ ae_matrix* a,
15832  ae_int_t n,
15833  ae_int_t zneeded,
15834  ae_bool isupper,
15835  double b1,
15836  double b2,
15837  ae_int_t* m,
15838  /* Real */ ae_vector* w,
15839  /* Complex */ ae_matrix* z,
15840  ae_state *_state)
15841 {
15842  ae_frame _frame_block;
15843  ae_matrix _a;
15844  ae_matrix q;
15845  ae_matrix t;
15846  ae_vector tau;
15847  ae_vector e;
15848  ae_vector work;
15849  ae_int_t i;
15850  ae_int_t k;
15851  double v;
15852  ae_bool result;
15853 
15854  ae_frame_make(_state, &_frame_block);
15855  ae_matrix_init_copy(&_a, a, _state, ae_true);
15856  a = &_a;
15857  *m = 0;
15858  ae_vector_clear(w);
15859  ae_matrix_clear(z);
15860  ae_matrix_init(&q, 0, 0, DT_COMPLEX, _state, ae_true);
15861  ae_matrix_init(&t, 0, 0, DT_REAL, _state, ae_true);
15862  ae_vector_init(&tau, 0, DT_COMPLEX, _state, ae_true);
15863  ae_vector_init(&e, 0, DT_REAL, _state, ae_true);
15864  ae_vector_init(&work, 0, DT_REAL, _state, ae_true);
15865 
15866  ae_assert(zneeded==0||zneeded==1, "HermitianEigenValuesAndVectorsInInterval: incorrect ZNeeded", _state);
15867 
15868  /*
15869  * Reduce to tridiagonal form
15870  */
15871  hmatrixtd(a, n, isupper, &tau, w, &e, _state);
15872  if( zneeded==1 )
15873  {
15874  hmatrixtdunpackq(a, n, isupper, &tau, &q, _state);
15875  zneeded = 2;
15876  }
15877 
15878  /*
15879  * Bisection and inverse iteration
15880  */
15881  result = smatrixtdevdr(w, &e, n, zneeded, b1, b2, m, &t, _state);
15882 
15883  /*
15884  * Eigenvectors are needed
15885  * Calculate Z = Q*T = Re(Q)*T + i*Im(Q)*T
15886  */
15887  if( (result&&zneeded!=0)&&*m!=0 )
15888  {
15889  ae_vector_set_length(&work, *m-1+1, _state);
15890  ae_matrix_set_length(z, n-1+1, *m-1+1, _state);
15891  for(i=0; i<=n-1; i++)
15892  {
15893 
15894  /*
15895  * Calculate real part
15896  */
15897  for(k=0; k<=*m-1; k++)
15898  {
15899  work.ptr.p_double[k] = 0;
15900  }
15901  for(k=0; k<=n-1; k++)
15902  {
15903  v = q.ptr.pp_complex[i][k].x;
15904  ae_v_addd(&work.ptr.p_double[0], 1, &t.ptr.pp_double[k][0], 1, ae_v_len(0,*m-1), v);
15905  }
15906  for(k=0; k<=*m-1; k++)
15907  {
15908  z->ptr.pp_complex[i][k].x = work.ptr.p_double[k];
15909  }
15910 
15911  /*
15912  * Calculate imaginary part
15913  */
15914  for(k=0; k<=*m-1; k++)
15915  {
15916  work.ptr.p_double[k] = 0;
15917  }
15918  for(k=0; k<=n-1; k++)
15919  {
15920  v = q.ptr.pp_complex[i][k].y;
15921  ae_v_addd(&work.ptr.p_double[0], 1, &t.ptr.pp_double[k][0], 1, ae_v_len(0,*m-1), v);
15922  }
15923  for(k=0; k<=*m-1; k++)
15924  {
15925  z->ptr.pp_complex[i][k].y = work.ptr.p_double[k];
15926  }
15927  }
15928  }
15929  ae_frame_leave(_state);
15930  return result;
15931 }
15932 
15933 
15934 /*************************************************************************
15935 Subroutine for finding the eigenvalues and eigenvectors of a Hermitian
15936 matrix with given indexes by using bisection and inverse iteration methods
15937 
15938 Input parameters:
15939  A - Hermitian matrix which is given by its upper or lower
15940  triangular part.
15941  Array whose indexes range within [0..N-1, 0..N-1].
15942  N - size of matrix A.
15943  ZNeeded - flag controlling whether the eigenvectors are needed or
15944  not. If ZNeeded is equal to:
15945  * 0, the eigenvectors are not returned;
15946  * 1, the eigenvectors are returned.
15947  IsUpperA - storage format of matrix A.
15948  I1, I2 - index interval for searching (from I1 to I2).
15949  0 <= I1 <= I2 <= N-1.
15950 
15951 Output parameters:
15952  W - array of the eigenvalues found.
15953  Array whose index ranges within [0..I2-I1].
15954  Z - if ZNeeded is equal to:
15955  * 0, Z hasn’t changed;
15956  * 1, Z contains eigenvectors.
15957  Array whose indexes range within [0..N-1, 0..I2-I1].
15958  In that case, the eigenvectors are stored in the matrix
15959  columns.
15960 
15961 Result:
15962  True, if successful. W contains the eigenvalues, Z contains the
15963  eigenvectors (if needed).
15964 
15965  False, if the bisection method subroutine wasn't able to find the
15966  eigenvalues in the given interval or if the inverse iteration
15967  subroutine wasn't able to find all the corresponding eigenvectors.
15968  In that case, the eigenvalues and eigenvectors are not returned.
15969 
15970 Note:
15971  eigen vectors of Hermitian matrix are defined up to multiplication by
15972  a complex number L, such as |L|=1.
15973 
15974  -- ALGLIB --
15975  Copyright 07.01.2006, 24.03.2007 by Bochkanov Sergey.
15976 *************************************************************************/
15977 ae_bool hmatrixevdi(/* Complex */ ae_matrix* a,
15978  ae_int_t n,
15979  ae_int_t zneeded,
15980  ae_bool isupper,
15981  ae_int_t i1,
15982  ae_int_t i2,
15983  /* Real */ ae_vector* w,
15984  /* Complex */ ae_matrix* z,
15985  ae_state *_state)
15986 {
15987  ae_frame _frame_block;
15988  ae_matrix _a;
15989  ae_matrix q;
15990  ae_matrix t;
15991  ae_vector tau;
15992  ae_vector e;
15993  ae_vector work;
15994  ae_int_t i;
15995  ae_int_t k;
15996  double v;
15997  ae_int_t m;
15998  ae_bool result;
15999 
16000  ae_frame_make(_state, &_frame_block);
16001  ae_matrix_init_copy(&_a, a, _state, ae_true);
16002  a = &_a;
16003  ae_vector_clear(w);
16004  ae_matrix_clear(z);
16005  ae_matrix_init(&q, 0, 0, DT_COMPLEX, _state, ae_true);
16006  ae_matrix_init(&t, 0, 0, DT_REAL, _state, ae_true);
16007  ae_vector_init(&tau, 0, DT_COMPLEX, _state, ae_true);
16008  ae_vector_init(&e, 0, DT_REAL, _state, ae_true);
16009  ae_vector_init(&work, 0, DT_REAL, _state, ae_true);
16010 
16011  ae_assert(zneeded==0||zneeded==1, "HermitianEigenValuesAndVectorsByIndexes: incorrect ZNeeded", _state);
16012 
16013  /*
16014  * Reduce to tridiagonal form
16015  */
16016  hmatrixtd(a, n, isupper, &tau, w, &e, _state);
16017  if( zneeded==1 )
16018  {
16019  hmatrixtdunpackq(a, n, isupper, &tau, &q, _state);
16020  zneeded = 2;
16021  }
16022 
16023  /*
16024  * Bisection and inverse iteration
16025  */
16026  result = smatrixtdevdi(w, &e, n, zneeded, i1, i2, &t, _state);
16027 
16028  /*
16029  * Eigenvectors are needed
16030  * Calculate Z = Q*T = Re(Q)*T + i*Im(Q)*T
16031  */
16032  m = i2-i1+1;
16033  if( result&&zneeded!=0 )
16034  {
16035  ae_vector_set_length(&work, m-1+1, _state);
16036  ae_matrix_set_length(z, n-1+1, m-1+1, _state);
16037  for(i=0; i<=n-1; i++)
16038  {
16039 
16040  /*
16041  * Calculate real part
16042  */
16043  for(k=0; k<=m-1; k++)
16044  {
16045  work.ptr.p_double[k] = 0;
16046  }
16047  for(k=0; k<=n-1; k++)
16048  {
16049  v = q.ptr.pp_complex[i][k].x;
16050  ae_v_addd(&work.ptr.p_double[0], 1, &t.ptr.pp_double[k][0], 1, ae_v_len(0,m-1), v);
16051  }
16052  for(k=0; k<=m-1; k++)
16053  {
16054  z->ptr.pp_complex[i][k].x = work.ptr.p_double[k];
16055  }
16056 
16057  /*
16058  * Calculate imaginary part
16059  */
16060  for(k=0; k<=m-1; k++)
16061  {
16062  work.ptr.p_double[k] = 0;
16063  }
16064  for(k=0; k<=n-1; k++)
16065  {
16066  v = q.ptr.pp_complex[i][k].y;
16067  ae_v_addd(&work.ptr.p_double[0], 1, &t.ptr.pp_double[k][0], 1, ae_v_len(0,m-1), v);
16068  }
16069  for(k=0; k<=m-1; k++)
16070  {
16071  z->ptr.pp_complex[i][k].y = work.ptr.p_double[k];
16072  }
16073  }
16074  }
16075  ae_frame_leave(_state);
16076  return result;
16077 }
16078 
16079 
16080 /*************************************************************************
16081 Finding the eigenvalues and eigenvectors of a tridiagonal symmetric matrix
16082 
16083 The algorithm finds the eigen pairs of a tridiagonal symmetric matrix by
16084 using an QL/QR algorithm with implicit shifts.
16085 
16086 Input parameters:
16087  D - the main diagonal of a tridiagonal matrix.
16088  Array whose index ranges within [0..N-1].
16089  E - the secondary diagonal of a tridiagonal matrix.
16090  Array whose index ranges within [0..N-2].
16091  N - size of matrix A.
16092  ZNeeded - flag controlling whether the eigenvectors are needed or not.
16093  If ZNeeded is equal to:
16094  * 0, the eigenvectors are not needed;
16095  * 1, the eigenvectors of a tridiagonal matrix
16096  are multiplied by the square matrix Z. It is used if the
16097  tridiagonal matrix is obtained by the similarity
16098  transformation of a symmetric matrix;
16099  * 2, the eigenvectors of a tridiagonal matrix replace the
16100  square matrix Z;
16101  * 3, matrix Z contains the first row of the eigenvectors
16102  matrix.
16103  Z - if ZNeeded=1, Z contains the square matrix by which the
16104  eigenvectors are multiplied.
16105  Array whose indexes range within [0..N-1, 0..N-1].
16106 
16107 Output parameters:
16108  D - eigenvalues in ascending order.
16109  Array whose index ranges within [0..N-1].
16110  Z - if ZNeeded is equal to:
16111  * 0, Z hasn’t changed;
16112  * 1, Z contains the product of a given matrix (from the left)
16113  and the eigenvectors matrix (from the right);
16114  * 2, Z contains the eigenvectors.
16115  * 3, Z contains the first row of the eigenvectors matrix.
16116  If ZNeeded<3, Z is the array whose indexes range within [0..N-1, 0..N-1].
16117  In that case, the eigenvectors are stored in the matrix columns.
16118  If ZNeeded=3, Z is the array whose indexes range within [0..0, 0..N-1].
16119 
16120 Result:
16121  True, if the algorithm has converged.
16122  False, if the algorithm hasn't converged.
16123 
16124  -- LAPACK routine (version 3.0) --
16125  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
16126  Courant Institute, Argonne National Lab, and Rice University
16127  September 30, 1994
16128 *************************************************************************/
16129 ae_bool smatrixtdevd(/* Real */ ae_vector* d,
16130  /* Real */ ae_vector* e,
16131  ae_int_t n,
16132  ae_int_t zneeded,
16133  /* Real */ ae_matrix* z,
16134  ae_state *_state)
16135 {
16136  ae_frame _frame_block;
16137  ae_vector _e;
16138  ae_vector d1;
16139  ae_vector e1;
16140  ae_matrix z1;
16141  ae_int_t i;
16142  ae_bool result;
16143 
16144  ae_frame_make(_state, &_frame_block);
16145  ae_vector_init_copy(&_e, e, _state, ae_true);
16146  e = &_e;
16147  ae_vector_init(&d1, 0, DT_REAL, _state, ae_true);
16148  ae_vector_init(&e1, 0, DT_REAL, _state, ae_true);
16149  ae_matrix_init(&z1, 0, 0, DT_REAL, _state, ae_true);
16150 
16151 
16152  /*
16153  * Prepare 1-based task
16154  */
16155  ae_vector_set_length(&d1, n+1, _state);
16156  ae_vector_set_length(&e1, n+1, _state);
16157  ae_v_move(&d1.ptr.p_double[1], 1, &d->ptr.p_double[0], 1, ae_v_len(1,n));
16158  if( n>1 )
16159  {
16160  ae_v_move(&e1.ptr.p_double[1], 1, &e->ptr.p_double[0], 1, ae_v_len(1,n-1));
16161  }
16162  if( zneeded==1 )
16163  {
16164  ae_matrix_set_length(&z1, n+1, n+1, _state);
16165  for(i=1; i<=n; i++)
16166  {
16167  ae_v_move(&z1.ptr.pp_double[i][1], 1, &z->ptr.pp_double[i-1][0], 1, ae_v_len(1,n));
16168  }
16169  }
16170 
16171  /*
16172  * Solve 1-based task
16173  */
16174  result = evd_tridiagonalevd(&d1, &e1, n, zneeded, &z1, _state);
16175  if( !result )
16176  {
16177  ae_frame_leave(_state);
16178  return result;
16179  }
16180 
16181  /*
16182  * Convert back to 0-based result
16183  */
16184  ae_v_move(&d->ptr.p_double[0], 1, &d1.ptr.p_double[1], 1, ae_v_len(0,n-1));
16185  if( zneeded!=0 )
16186  {
16187  if( zneeded==1 )
16188  {
16189  for(i=1; i<=n; i++)
16190  {
16191  ae_v_move(&z->ptr.pp_double[i-1][0], 1, &z1.ptr.pp_double[i][1], 1, ae_v_len(0,n-1));
16192  }
16193  ae_frame_leave(_state);
16194  return result;
16195  }
16196  if( zneeded==2 )
16197  {
16198  ae_matrix_set_length(z, n-1+1, n-1+1, _state);
16199  for(i=1; i<=n; i++)
16200  {
16201  ae_v_move(&z->ptr.pp_double[i-1][0], 1, &z1.ptr.pp_double[i][1], 1, ae_v_len(0,n-1));
16202  }
16203  ae_frame_leave(_state);
16204  return result;
16205  }
16206  if( zneeded==3 )
16207  {
16208  ae_matrix_set_length(z, 0+1, n-1+1, _state);
16209  ae_v_move(&z->ptr.pp_double[0][0], 1, &z1.ptr.pp_double[1][1], 1, ae_v_len(0,n-1));
16210  ae_frame_leave(_state);
16211  return result;
16212  }
16213  ae_assert(ae_false, "SMatrixTDEVD: Incorrect ZNeeded!", _state);
16214  }
16215  ae_frame_leave(_state);
16216  return result;
16217 }
16218 
16219 
16220 /*************************************************************************
16221 Subroutine for finding the tridiagonal matrix eigenvalues/vectors in a
16222 given half-interval (A, B] by using bisection and inverse iteration.
16223 
16224 Input parameters:
16225  D - the main diagonal of a tridiagonal matrix.
16226  Array whose index ranges within [0..N-1].
16227  E - the secondary diagonal of a tridiagonal matrix.
16228  Array whose index ranges within [0..N-2].
16229  N - size of matrix, N>=0.
16230  ZNeeded - flag controlling whether the eigenvectors are needed or not.
16231  If ZNeeded is equal to:
16232  * 0, the eigenvectors are not needed;
16233  * 1, the eigenvectors of a tridiagonal matrix are multiplied
16234  by the square matrix Z. It is used if the tridiagonal
16235  matrix is obtained by the similarity transformation
16236  of a symmetric matrix.
16237  * 2, the eigenvectors of a tridiagonal matrix replace matrix Z.
16238  A, B - half-interval (A, B] to search eigenvalues in.
16239  Z - if ZNeeded is equal to:
16240  * 0, Z isn't used and remains unchanged;
16241  * 1, Z contains the square matrix (array whose indexes range
16242  within [0..N-1, 0..N-1]) which reduces the given symmetric
16243  matrix to tridiagonal form;
16244  * 2, Z isn't used (but changed on the exit).
16245 
16246 Output parameters:
16247  D - array of the eigenvalues found.
16248  Array whose index ranges within [0..M-1].
16249  M - number of eigenvalues found in the given half-interval (M>=0).
16250  Z - if ZNeeded is equal to:
16251  * 0, doesn't contain any information;
16252  * 1, contains the product of a given NxN matrix Z (from the
16253  left) and NxM matrix of the eigenvectors found (from the
16254  right). Array whose indexes range within [0..N-1, 0..M-1].
16255  * 2, contains the matrix of the eigenvectors found.
16256  Array whose indexes range within [0..N-1, 0..M-1].
16257 
16258 Result:
16259 
16260  True, if successful. In that case, M contains the number of eigenvalues
16261  in the given half-interval (could be equal to 0), D contains the eigenvalues,
16262  Z contains the eigenvectors (if needed).
16263  It should be noted that the subroutine changes the size of arrays D and Z.
16264 
16265  False, if the bisection method subroutine wasn't able to find the
16266  eigenvalues in the given interval or if the inverse iteration subroutine
16267  wasn't able to find all the corresponding eigenvectors. In that case,
16268  the eigenvalues and eigenvectors are not returned, M is equal to 0.
16269 
16270  -- ALGLIB --
16271  Copyright 31.03.2008 by Bochkanov Sergey
16272 *************************************************************************/
16273 ae_bool smatrixtdevdr(/* Real */ ae_vector* d,
16274  /* Real */ ae_vector* e,
16275  ae_int_t n,
16276  ae_int_t zneeded,
16277  double a,
16278  double b,
16279  ae_int_t* m,
16280  /* Real */ ae_matrix* z,
16281  ae_state *_state)
16282 {
16283  ae_frame _frame_block;
16284  ae_int_t errorcode;
16285  ae_int_t nsplit;
16286  ae_int_t i;
16287  ae_int_t j;
16288  ae_int_t k;
16289  ae_int_t cr;
16290  ae_vector iblock;
16291  ae_vector isplit;
16292  ae_vector ifail;
16293  ae_vector d1;
16294  ae_vector e1;
16295  ae_vector w;
16296  ae_matrix z2;
16297  ae_matrix z3;
16298  double v;
16299  ae_bool result;
16300 
16301  ae_frame_make(_state, &_frame_block);
16302  *m = 0;
16303  ae_vector_init(&iblock, 0, DT_INT, _state, ae_true);
16304  ae_vector_init(&isplit, 0, DT_INT, _state, ae_true);
16305  ae_vector_init(&ifail, 0, DT_INT, _state, ae_true);
16306  ae_vector_init(&d1, 0, DT_REAL, _state, ae_true);
16307  ae_vector_init(&e1, 0, DT_REAL, _state, ae_true);
16308  ae_vector_init(&w, 0, DT_REAL, _state, ae_true);
16309  ae_matrix_init(&z2, 0, 0, DT_REAL, _state, ae_true);
16310  ae_matrix_init(&z3, 0, 0, DT_REAL, _state, ae_true);
16311 
16312  ae_assert(zneeded>=0&&zneeded<=2, "SMatrixTDEVDR: incorrect ZNeeded!", _state);
16313 
16314  /*
16315  * Special cases
16316  */
16317  if( ae_fp_less_eq(b,a) )
16318  {
16319  *m = 0;
16320  result = ae_true;
16321  ae_frame_leave(_state);
16322  return result;
16323  }
16324  if( n<=0 )
16325  {
16326  *m = 0;
16327  result = ae_true;
16328  ae_frame_leave(_state);
16329  return result;
16330  }
16331 
16332  /*
16333  * Copy D,E to D1, E1
16334  */
16335  ae_vector_set_length(&d1, n+1, _state);
16336  ae_v_move(&d1.ptr.p_double[1], 1, &d->ptr.p_double[0], 1, ae_v_len(1,n));
16337  if( n>1 )
16338  {
16339  ae_vector_set_length(&e1, n-1+1, _state);
16340  ae_v_move(&e1.ptr.p_double[1], 1, &e->ptr.p_double[0], 1, ae_v_len(1,n-1));
16341  }
16342 
16343  /*
16344  * No eigen vectors
16345  */
16346  if( zneeded==0 )
16347  {
16348  result = evd_internalbisectioneigenvalues(&d1, &e1, n, 2, 1, a, b, 0, 0, -1, &w, m, &nsplit, &iblock, &isplit, &errorcode, _state);
16349  if( !result||*m==0 )
16350  {
16351  *m = 0;
16352  ae_frame_leave(_state);
16353  return result;
16354  }
16355  ae_vector_set_length(d, *m-1+1, _state);
16356  ae_v_move(&d->ptr.p_double[0], 1, &w.ptr.p_double[1], 1, ae_v_len(0,*m-1));
16357  ae_frame_leave(_state);
16358  return result;
16359  }
16360 
16361  /*
16362  * Eigen vectors are multiplied by Z
16363  */
16364  if( zneeded==1 )
16365  {
16366 
16367  /*
16368  * Find eigen pairs
16369  */
16370  result = evd_internalbisectioneigenvalues(&d1, &e1, n, 2, 2, a, b, 0, 0, -1, &w, m, &nsplit, &iblock, &isplit, &errorcode, _state);
16371  if( !result||*m==0 )
16372  {
16373  *m = 0;
16374  ae_frame_leave(_state);
16375  return result;
16376  }
16377  evd_internaldstein(n, &d1, &e1, *m, &w, &iblock, &isplit, &z2, &ifail, &cr, _state);
16378  if( cr!=0 )
16379  {
16380  *m = 0;
16381  result = ae_false;
16382  ae_frame_leave(_state);
16383  return result;
16384  }
16385 
16386  /*
16387  * Sort eigen values and vectors
16388  */
16389  for(i=1; i<=*m; i++)
16390  {
16391  k = i;
16392  for(j=i; j<=*m; j++)
16393  {
16394  if( ae_fp_less(w.ptr.p_double[j],w.ptr.p_double[k]) )
16395  {
16396  k = j;
16397  }
16398  }
16399  v = w.ptr.p_double[i];
16400  w.ptr.p_double[i] = w.ptr.p_double[k];
16401  w.ptr.p_double[k] = v;
16402  for(j=1; j<=n; j++)
16403  {
16404  v = z2.ptr.pp_double[j][i];
16405  z2.ptr.pp_double[j][i] = z2.ptr.pp_double[j][k];
16406  z2.ptr.pp_double[j][k] = v;
16407  }
16408  }
16409 
16410  /*
16411  * Transform Z2 and overwrite Z
16412  */
16413  ae_matrix_set_length(&z3, *m+1, n+1, _state);
16414  for(i=1; i<=*m; i++)
16415  {
16416  ae_v_move(&z3.ptr.pp_double[i][1], 1, &z2.ptr.pp_double[1][i], z2.stride, ae_v_len(1,n));
16417  }
16418  for(i=1; i<=n; i++)
16419  {
16420  for(j=1; j<=*m; j++)
16421  {
16422  v = ae_v_dotproduct(&z->ptr.pp_double[i-1][0], 1, &z3.ptr.pp_double[j][1], 1, ae_v_len(0,n-1));
16423  z2.ptr.pp_double[i][j] = v;
16424  }
16425  }
16426  ae_matrix_set_length(z, n-1+1, *m-1+1, _state);
16427  for(i=1; i<=*m; i++)
16428  {
16429  ae_v_move(&z->ptr.pp_double[0][i-1], z->stride, &z2.ptr.pp_double[1][i], z2.stride, ae_v_len(0,n-1));
16430  }
16431 
16432  /*
16433  * Store W
16434  */
16435  ae_vector_set_length(d, *m-1+1, _state);
16436  for(i=1; i<=*m; i++)
16437  {
16438  d->ptr.p_double[i-1] = w.ptr.p_double[i];
16439  }
16440  ae_frame_leave(_state);
16441  return result;
16442  }
16443 
16444  /*
16445  * Eigen vectors are stored in Z
16446  */
16447  if( zneeded==2 )
16448  {
16449 
16450  /*
16451  * Find eigen pairs
16452  */
16453  result = evd_internalbisectioneigenvalues(&d1, &e1, n, 2, 2, a, b, 0, 0, -1, &w, m, &nsplit, &iblock, &isplit, &errorcode, _state);
16454  if( !result||*m==0 )
16455  {
16456  *m = 0;
16457  ae_frame_leave(_state);
16458  return result;
16459  }
16460  evd_internaldstein(n, &d1, &e1, *m, &w, &iblock, &isplit, &z2, &ifail, &cr, _state);
16461  if( cr!=0 )
16462  {
16463  *m = 0;
16464  result = ae_false;
16465  ae_frame_leave(_state);
16466  return result;
16467  }
16468 
16469  /*
16470  * Sort eigen values and vectors
16471  */
16472  for(i=1; i<=*m; i++)
16473  {
16474  k = i;
16475  for(j=i; j<=*m; j++)
16476  {
16477  if( ae_fp_less(w.ptr.p_double[j],w.ptr.p_double[k]) )
16478  {
16479  k = j;
16480  }
16481  }
16482  v = w.ptr.p_double[i];
16483  w.ptr.p_double[i] = w.ptr.p_double[k];
16484  w.ptr.p_double[k] = v;
16485  for(j=1; j<=n; j++)
16486  {
16487  v = z2.ptr.pp_double[j][i];
16488  z2.ptr.pp_double[j][i] = z2.ptr.pp_double[j][k];
16489  z2.ptr.pp_double[j][k] = v;
16490  }
16491  }
16492 
16493  /*
16494  * Store W
16495  */
16496  ae_vector_set_length(d, *m-1+1, _state);
16497  for(i=1; i<=*m; i++)
16498  {
16499  d->ptr.p_double[i-1] = w.ptr.p_double[i];
16500  }
16501  ae_matrix_set_length(z, n-1+1, *m-1+1, _state);
16502  for(i=1; i<=*m; i++)
16503  {
16504  ae_v_move(&z->ptr.pp_double[0][i-1], z->stride, &z2.ptr.pp_double[1][i], z2.stride, ae_v_len(0,n-1));
16505  }
16506  ae_frame_leave(_state);
16507  return result;
16508  }
16509  result = ae_false;
16510  ae_frame_leave(_state);
16511  return result;
16512 }
16513 
16514 
16515 /*************************************************************************
16516 Subroutine for finding tridiagonal matrix eigenvalues/vectors with given
16517 indexes (in ascending order) by using the bisection and inverse iteraion.
16518 
16519 Input parameters:
16520  D - the main diagonal of a tridiagonal matrix.
16521  Array whose index ranges within [0..N-1].
16522  E - the secondary diagonal of a tridiagonal matrix.
16523  Array whose index ranges within [0..N-2].
16524  N - size of matrix. N>=0.
16525  ZNeeded - flag controlling whether the eigenvectors are needed or not.
16526  If ZNeeded is equal to:
16527  * 0, the eigenvectors are not needed;
16528  * 1, the eigenvectors of a tridiagonal matrix are multiplied
16529  by the square matrix Z. It is used if the
16530  tridiagonal matrix is obtained by the similarity transformation
16531  of a symmetric matrix.
16532  * 2, the eigenvectors of a tridiagonal matrix replace
16533  matrix Z.
16534  I1, I2 - index interval for searching (from I1 to I2).
16535  0 <= I1 <= I2 <= N-1.
16536  Z - if ZNeeded is equal to:
16537  * 0, Z isn't used and remains unchanged;
16538  * 1, Z contains the square matrix (array whose indexes range within [0..N-1, 0..N-1])
16539  which reduces the given symmetric matrix to tridiagonal form;
16540  * 2, Z isn't used (but changed on the exit).
16541 
16542 Output parameters:
16543  D - array of the eigenvalues found.
16544  Array whose index ranges within [0..I2-I1].
16545  Z - if ZNeeded is equal to:
16546  * 0, doesn't contain any information;
16547  * 1, contains the product of a given NxN matrix Z (from the left) and
16548  Nx(I2-I1) matrix of the eigenvectors found (from the right).
16549  Array whose indexes range within [0..N-1, 0..I2-I1].
16550  * 2, contains the matrix of the eigenvalues found.
16551  Array whose indexes range within [0..N-1, 0..I2-I1].
16552 
16553 
16554 Result:
16555 
16556  True, if successful. In that case, D contains the eigenvalues,
16557  Z contains the eigenvectors (if needed).
16558  It should be noted that the subroutine changes the size of arrays D and Z.
16559 
16560  False, if the bisection method subroutine wasn't able to find the eigenvalues
16561  in the given interval or if the inverse iteration subroutine wasn't able
16562  to find all the corresponding eigenvectors. In that case, the eigenvalues
16563  and eigenvectors are not returned.
16564 
16565  -- ALGLIB --
16566  Copyright 25.12.2005 by Bochkanov Sergey
16567 *************************************************************************/
16568 ae_bool smatrixtdevdi(/* Real */ ae_vector* d,
16569  /* Real */ ae_vector* e,
16570  ae_int_t n,
16571  ae_int_t zneeded,
16572  ae_int_t i1,
16573  ae_int_t i2,
16574  /* Real */ ae_matrix* z,
16575  ae_state *_state)
16576 {
16577  ae_frame _frame_block;
16578  ae_int_t errorcode;
16579  ae_int_t nsplit;
16580  ae_int_t i;
16581  ae_int_t j;
16582  ae_int_t k;
16583  ae_int_t m;
16584  ae_int_t cr;
16585  ae_vector iblock;
16586  ae_vector isplit;
16587  ae_vector ifail;
16588  ae_vector w;
16589  ae_vector d1;
16590  ae_vector e1;
16591  ae_matrix z2;
16592  ae_matrix z3;
16593  double v;
16594  ae_bool result;
16595 
16596  ae_frame_make(_state, &_frame_block);
16597  ae_vector_init(&iblock, 0, DT_INT, _state, ae_true);
16598  ae_vector_init(&isplit, 0, DT_INT, _state, ae_true);
16599  ae_vector_init(&ifail, 0, DT_INT, _state, ae_true);
16600  ae_vector_init(&w, 0, DT_REAL, _state, ae_true);
16601  ae_vector_init(&d1, 0, DT_REAL, _state, ae_true);
16602  ae_vector_init(&e1, 0, DT_REAL, _state, ae_true);
16603  ae_matrix_init(&z2, 0, 0, DT_REAL, _state, ae_true);
16604  ae_matrix_init(&z3, 0, 0, DT_REAL, _state, ae_true);
16605 
16606  ae_assert((0<=i1&&i1<=i2)&&i2<n, "SMatrixTDEVDI: incorrect I1/I2!", _state);
16607 
16608  /*
16609  * Copy D,E to D1, E1
16610  */
16611  ae_vector_set_length(&d1, n+1, _state);
16612  ae_v_move(&d1.ptr.p_double[1], 1, &d->ptr.p_double[0], 1, ae_v_len(1,n));
16613  if( n>1 )
16614  {
16615  ae_vector_set_length(&e1, n-1+1, _state);
16616  ae_v_move(&e1.ptr.p_double[1], 1, &e->ptr.p_double[0], 1, ae_v_len(1,n-1));
16617  }
16618 
16619  /*
16620  * No eigen vectors
16621  */
16622  if( zneeded==0 )
16623  {
16624  result = evd_internalbisectioneigenvalues(&d1, &e1, n, 3, 1, 0, 0, i1+1, i2+1, -1, &w, &m, &nsplit, &iblock, &isplit, &errorcode, _state);
16625  if( !result )
16626  {
16627  ae_frame_leave(_state);
16628  return result;
16629  }
16630  if( m!=i2-i1+1 )
16631  {
16632  result = ae_false;
16633  ae_frame_leave(_state);
16634  return result;
16635  }
16636  ae_vector_set_length(d, m-1+1, _state);
16637  for(i=1; i<=m; i++)
16638  {
16639  d->ptr.p_double[i-1] = w.ptr.p_double[i];
16640  }
16641  ae_frame_leave(_state);
16642  return result;
16643  }
16644 
16645  /*
16646  * Eigen vectors are multiplied by Z
16647  */
16648  if( zneeded==1 )
16649  {
16650 
16651  /*
16652  * Find eigen pairs
16653  */
16654  result = evd_internalbisectioneigenvalues(&d1, &e1, n, 3, 2, 0, 0, i1+1, i2+1, -1, &w, &m, &nsplit, &iblock, &isplit, &errorcode, _state);
16655  if( !result )
16656  {
16657  ae_frame_leave(_state);
16658  return result;
16659  }
16660  if( m!=i2-i1+1 )
16661  {
16662  result = ae_false;
16663  ae_frame_leave(_state);
16664  return result;
16665  }
16666  evd_internaldstein(n, &d1, &e1, m, &w, &iblock, &isplit, &z2, &ifail, &cr, _state);
16667  if( cr!=0 )
16668  {
16669  result = ae_false;
16670  ae_frame_leave(_state);
16671  return result;
16672  }
16673 
16674  /*
16675  * Sort eigen values and vectors
16676  */
16677  for(i=1; i<=m; i++)
16678  {
16679  k = i;
16680  for(j=i; j<=m; j++)
16681  {
16682  if( ae_fp_less(w.ptr.p_double[j],w.ptr.p_double[k]) )
16683  {
16684  k = j;
16685  }
16686  }
16687  v = w.ptr.p_double[i];
16688  w.ptr.p_double[i] = w.ptr.p_double[k];
16689  w.ptr.p_double[k] = v;
16690  for(j=1; j<=n; j++)
16691  {
16692  v = z2.ptr.pp_double[j][i];
16693  z2.ptr.pp_double[j][i] = z2.ptr.pp_double[j][k];
16694  z2.ptr.pp_double[j][k] = v;
16695  }
16696  }
16697 
16698  /*
16699  * Transform Z2 and overwrite Z
16700  */
16701  ae_matrix_set_length(&z3, m+1, n+1, _state);
16702  for(i=1; i<=m; i++)
16703  {
16704  ae_v_move(&z3.ptr.pp_double[i][1], 1, &z2.ptr.pp_double[1][i], z2.stride, ae_v_len(1,n));
16705  }
16706  for(i=1; i<=n; i++)
16707  {
16708  for(j=1; j<=m; j++)
16709  {
16710  v = ae_v_dotproduct(&z->ptr.pp_double[i-1][0], 1, &z3.ptr.pp_double[j][1], 1, ae_v_len(0,n-1));
16711  z2.ptr.pp_double[i][j] = v;
16712  }
16713  }
16714  ae_matrix_set_length(z, n-1+1, m-1+1, _state);
16715  for(i=1; i<=m; i++)
16716  {
16717  ae_v_move(&z->ptr.pp_double[0][i-1], z->stride, &z2.ptr.pp_double[1][i], z2.stride, ae_v_len(0,n-1));
16718  }
16719 
16720  /*
16721  * Store W
16722  */
16723  ae_vector_set_length(d, m-1+1, _state);
16724  for(i=1; i<=m; i++)
16725  {
16726  d->ptr.p_double[i-1] = w.ptr.p_double[i];
16727  }
16728  ae_frame_leave(_state);
16729  return result;
16730  }
16731 
16732  /*
16733  * Eigen vectors are stored in Z
16734  */
16735  if( zneeded==2 )
16736  {
16737 
16738  /*
16739  * Find eigen pairs
16740  */
16741  result = evd_internalbisectioneigenvalues(&d1, &e1, n, 3, 2, 0, 0, i1+1, i2+1, -1, &w, &m, &nsplit, &iblock, &isplit, &errorcode, _state);
16742  if( !result )
16743  {
16744  ae_frame_leave(_state);
16745  return result;
16746  }
16747  if( m!=i2-i1+1 )
16748  {
16749  result = ae_false;
16750  ae_frame_leave(_state);
16751  return result;
16752  }
16753  evd_internaldstein(n, &d1, &e1, m, &w, &iblock, &isplit, &z2, &ifail, &cr, _state);
16754  if( cr!=0 )
16755  {
16756  result = ae_false;
16757  ae_frame_leave(_state);
16758  return result;
16759  }
16760 
16761  /*
16762  * Sort eigen values and vectors
16763  */
16764  for(i=1; i<=m; i++)
16765  {
16766  k = i;
16767  for(j=i; j<=m; j++)
16768  {
16769  if( ae_fp_less(w.ptr.p_double[j],w.ptr.p_double[k]) )
16770  {
16771  k = j;
16772  }
16773  }
16774  v = w.ptr.p_double[i];
16775  w.ptr.p_double[i] = w.ptr.p_double[k];
16776  w.ptr.p_double[k] = v;
16777  for(j=1; j<=n; j++)
16778  {
16779  v = z2.ptr.pp_double[j][i];
16780  z2.ptr.pp_double[j][i] = z2.ptr.pp_double[j][k];
16781  z2.ptr.pp_double[j][k] = v;
16782  }
16783  }
16784 
16785  /*
16786  * Store Z
16787  */
16788  ae_matrix_set_length(z, n-1+1, m-1+1, _state);
16789  for(i=1; i<=m; i++)
16790  {
16791  ae_v_move(&z->ptr.pp_double[0][i-1], z->stride, &z2.ptr.pp_double[1][i], z2.stride, ae_v_len(0,n-1));
16792  }
16793 
16794  /*
16795  * Store W
16796  */
16797  ae_vector_set_length(d, m-1+1, _state);
16798  for(i=1; i<=m; i++)
16799  {
16800  d->ptr.p_double[i-1] = w.ptr.p_double[i];
16801  }
16802  ae_frame_leave(_state);
16803  return result;
16804  }
16805  result = ae_false;
16806  ae_frame_leave(_state);
16807  return result;
16808 }
16809 
16810 
16811 /*************************************************************************
16812 Finding eigenvalues and eigenvectors of a general matrix
16813 
16814 The algorithm finds eigenvalues and eigenvectors of a general matrix by
16815 using the QR algorithm with multiple shifts. The algorithm can find
16816 eigenvalues and both left and right eigenvectors.
16817 
16818 The right eigenvector is a vector x such that A*x = w*x, and the left
16819 eigenvector is a vector y such that y'*A = w*y' (here y' implies a complex
16820 conjugate transposition of vector y).
16821 
16822 Input parameters:
16823  A - matrix. Array whose indexes range within [0..N-1, 0..N-1].
16824  N - size of matrix A.
16825  VNeeded - flag controlling whether eigenvectors are needed or not.
16826  If VNeeded is equal to:
16827  * 0, eigenvectors are not returned;
16828  * 1, right eigenvectors are returned;
16829  * 2, left eigenvectors are returned;
16830  * 3, both left and right eigenvectors are returned.
16831 
16832 Output parameters:
16833  WR - real parts of eigenvalues.
16834  Array whose index ranges within [0..N-1].
16835  WR - imaginary parts of eigenvalues.
16836  Array whose index ranges within [0..N-1].
16837  VL, VR - arrays of left and right eigenvectors (if they are needed).
16838  If WI[i]=0, the respective eigenvalue is a real number,
16839  and it corresponds to the column number I of matrices VL/VR.
16840  If WI[i]>0, we have a pair of complex conjugate numbers with
16841  positive and negative imaginary parts:
16842  the first eigenvalue WR[i] + sqrt(-1)*WI[i];
16843  the second eigenvalue WR[i+1] + sqrt(-1)*WI[i+1];
16844  WI[i]>0
16845  WI[i+1] = -WI[i] < 0
16846  In that case, the eigenvector corresponding to the first
16847  eigenvalue is located in i and i+1 columns of matrices
16848  VL/VR (the column number i contains the real part, and the
16849  column number i+1 contains the imaginary part), and the vector
16850  corresponding to the second eigenvalue is a complex conjugate to
16851  the first vector.
16852  Arrays whose indexes range within [0..N-1, 0..N-1].
16853 
16854 Result:
16855  True, if the algorithm has converged.
16856  False, if the algorithm has not converged.
16857 
16858 Note 1:
16859  Some users may ask the following question: what if WI[N-1]>0?
16860  WI[N] must contain an eigenvalue which is complex conjugate to the
16861  N-th eigenvalue, but the array has only size N?
16862  The answer is as follows: such a situation cannot occur because the
16863  algorithm finds a pairs of eigenvalues, therefore, if WI[i]>0, I is
16864  strictly less than N-1.
16865 
16866 Note 2:
16867  The algorithm performance depends on the value of the internal parameter
16868  NS of the InternalSchurDecomposition subroutine which defines the number
16869  of shifts in the QR algorithm (similarly to the block width in block-matrix
16870  algorithms of linear algebra). If you require maximum performance
16871  on your machine, it is recommended to adjust this parameter manually.
16872 
16873 
16874 See also the InternalTREVC subroutine.
16875 
16876 The algorithm is based on the LAPACK 3.0 library.
16877 *************************************************************************/
16878 ae_bool rmatrixevd(/* Real */ ae_matrix* a,
16879  ae_int_t n,
16880  ae_int_t vneeded,
16881  /* Real */ ae_vector* wr,
16882  /* Real */ ae_vector* wi,
16883  /* Real */ ae_matrix* vl,
16884  /* Real */ ae_matrix* vr,
16885  ae_state *_state)
16886 {
16887  ae_frame _frame_block;
16888  ae_matrix _a;
16889  ae_matrix a1;
16890  ae_matrix vl1;
16891  ae_matrix vr1;
16892  ae_vector wr1;
16893  ae_vector wi1;
16894  ae_int_t i;
16895  ae_bool result;
16896 
16897  ae_frame_make(_state, &_frame_block);
16898  ae_matrix_init_copy(&_a, a, _state, ae_true);
16899  a = &_a;
16900  ae_vector_clear(wr);
16901  ae_vector_clear(wi);
16902  ae_matrix_clear(vl);
16903  ae_matrix_clear(vr);
16904  ae_matrix_init(&a1, 0, 0, DT_REAL, _state, ae_true);
16905  ae_matrix_init(&vl1, 0, 0, DT_REAL, _state, ae_true);
16906  ae_matrix_init(&vr1, 0, 0, DT_REAL, _state, ae_true);
16907  ae_vector_init(&wr1, 0, DT_REAL, _state, ae_true);
16908  ae_vector_init(&wi1, 0, DT_REAL, _state, ae_true);
16909 
16910  ae_assert(vneeded>=0&&vneeded<=3, "RMatrixEVD: incorrect VNeeded!", _state);
16911  ae_matrix_set_length(&a1, n+1, n+1, _state);
16912  for(i=1; i<=n; i++)
16913  {
16914  ae_v_move(&a1.ptr.pp_double[i][1], 1, &a->ptr.pp_double[i-1][0], 1, ae_v_len(1,n));
16915  }
16916  result = evd_nonsymmetricevd(&a1, n, vneeded, &wr1, &wi1, &vl1, &vr1, _state);
16917  if( result )
16918  {
16919  ae_vector_set_length(wr, n-1+1, _state);
16920  ae_vector_set_length(wi, n-1+1, _state);
16921  ae_v_move(&wr->ptr.p_double[0], 1, &wr1.ptr.p_double[1], 1, ae_v_len(0,n-1));
16922  ae_v_move(&wi->ptr.p_double[0], 1, &wi1.ptr.p_double[1], 1, ae_v_len(0,n-1));
16923  if( vneeded==2||vneeded==3 )
16924  {
16925  ae_matrix_set_length(vl, n-1+1, n-1+1, _state);
16926  for(i=0; i<=n-1; i++)
16927  {
16928  ae_v_move(&vl->ptr.pp_double[i][0], 1, &vl1.ptr.pp_double[i+1][1], 1, ae_v_len(0,n-1));
16929  }
16930  }
16931  if( vneeded==1||vneeded==3 )
16932  {
16933  ae_matrix_set_length(vr, n-1+1, n-1+1, _state);
16934  for(i=0; i<=n-1; i++)
16935  {
16936  ae_v_move(&vr->ptr.pp_double[i][0], 1, &vr1.ptr.pp_double[i+1][1], 1, ae_v_len(0,n-1));
16937  }
16938  }
16939  }
16940  ae_frame_leave(_state);
16941  return result;
16942 }
16943 
16944 
16945 static ae_bool evd_tridiagonalevd(/* Real */ ae_vector* d,
16946  /* Real */ ae_vector* e,
16947  ae_int_t n,
16948  ae_int_t zneeded,
16949  /* Real */ ae_matrix* z,
16950  ae_state *_state)
16951 {
16952  ae_frame _frame_block;
16953  ae_vector _e;
16954  ae_int_t maxit;
16955  ae_int_t i;
16956  ae_int_t ii;
16957  ae_int_t iscale;
16958  ae_int_t j;
16959  ae_int_t jtot;
16960  ae_int_t k;
16961  ae_int_t t;
16962  ae_int_t l;
16963  ae_int_t l1;
16964  ae_int_t lend;
16965  ae_int_t lendm1;
16966  ae_int_t lendp1;
16967  ae_int_t lendsv;
16968  ae_int_t lm1;
16969  ae_int_t lsv;
16970  ae_int_t m;
16971  ae_int_t mm1;
16972  ae_int_t nm1;
16973  ae_int_t nmaxit;
16974  ae_int_t tmpint;
16975  double anorm;
16976  double b;
16977  double c;
16978  double eps;
16979  double eps2;
16980  double f;
16981  double g;
16982  double p;
16983  double r;
16984  double rt1;
16985  double rt2;
16986  double s;
16987  double safmax;
16988  double safmin;
16989  double ssfmax;
16990  double ssfmin;
16991  double tst;
16992  double tmp;
16993  ae_vector work1;
16994  ae_vector work2;
16995  ae_vector workc;
16996  ae_vector works;
16997  ae_vector wtemp;
16998  ae_bool gotoflag;
16999  ae_int_t zrows;
17000  ae_bool wastranspose;
17001  ae_bool result;
17002 
17003  ae_frame_make(_state, &_frame_block);
17004  ae_vector_init_copy(&_e, e, _state, ae_true);
17005  e = &_e;
17006  ae_vector_init(&work1, 0, DT_REAL, _state, ae_true);
17007  ae_vector_init(&work2, 0, DT_REAL, _state, ae_true);
17008  ae_vector_init(&workc, 0, DT_REAL, _state, ae_true);
17009  ae_vector_init(&works, 0, DT_REAL, _state, ae_true);
17010  ae_vector_init(&wtemp, 0, DT_REAL, _state, ae_true);
17011 
17012  ae_assert(zneeded>=0&&zneeded<=3, "TridiagonalEVD: Incorrent ZNeeded", _state);
17013 
17014  /*
17015  * Quick return if possible
17016  */
17017  if( zneeded<0||zneeded>3 )
17018  {
17019  result = ae_false;
17020  ae_frame_leave(_state);
17021  return result;
17022  }
17023  result = ae_true;
17024  if( n==0 )
17025  {
17026  ae_frame_leave(_state);
17027  return result;
17028  }
17029  if( n==1 )
17030  {
17031  if( zneeded==2||zneeded==3 )
17032  {
17033  ae_matrix_set_length(z, 1+1, 1+1, _state);
17034  z->ptr.pp_double[1][1] = 1;
17035  }
17036  ae_frame_leave(_state);
17037  return result;
17038  }
17039  maxit = 30;
17040 
17041  /*
17042  * Initialize arrays
17043  */
17044  ae_vector_set_length(&wtemp, n+1, _state);
17045  ae_vector_set_length(&work1, n-1+1, _state);
17046  ae_vector_set_length(&work2, n-1+1, _state);
17047  ae_vector_set_length(&workc, n+1, _state);
17048  ae_vector_set_length(&works, n+1, _state);
17049 
17050  /*
17051  * Determine the unit roundoff and over/underflow thresholds.
17052  */
17053  eps = ae_machineepsilon;
17054  eps2 = ae_sqr(eps, _state);
17055  safmin = ae_minrealnumber;
17056  safmax = ae_maxrealnumber;
17057  ssfmax = ae_sqrt(safmax, _state)/3;
17058  ssfmin = ae_sqrt(safmin, _state)/eps2;
17059 
17060  /*
17061  * Prepare Z
17062  *
17063  * Here we are using transposition to get rid of column operations
17064  *
17065  */
17066  wastranspose = ae_false;
17067  zrows = 0;
17068  if( zneeded==1 )
17069  {
17070  zrows = n;
17071  }
17072  if( zneeded==2 )
17073  {
17074  zrows = n;
17075  }
17076  if( zneeded==3 )
17077  {
17078  zrows = 1;
17079  }
17080  if( zneeded==1 )
17081  {
17082  wastranspose = ae_true;
17083  inplacetranspose(z, 1, n, 1, n, &wtemp, _state);
17084  }
17085  if( zneeded==2 )
17086  {
17087  wastranspose = ae_true;
17088  ae_matrix_set_length(z, n+1, n+1, _state);
17089  for(i=1; i<=n; i++)
17090  {
17091  for(j=1; j<=n; j++)
17092  {
17093  if( i==j )
17094  {
17095  z->ptr.pp_double[i][j] = 1;
17096  }
17097  else
17098  {
17099  z->ptr.pp_double[i][j] = 0;
17100  }
17101  }
17102  }
17103  }
17104  if( zneeded==3 )
17105  {
17106  wastranspose = ae_false;
17107  ae_matrix_set_length(z, 1+1, n+1, _state);
17108  for(j=1; j<=n; j++)
17109  {
17110  if( j==1 )
17111  {
17112  z->ptr.pp_double[1][j] = 1;
17113  }
17114  else
17115  {
17116  z->ptr.pp_double[1][j] = 0;
17117  }
17118  }
17119  }
17120  nmaxit = n*maxit;
17121  jtot = 0;
17122 
17123  /*
17124  * Determine where the matrix splits and choose QL or QR iteration
17125  * for each block, according to whether top or bottom diagonal
17126  * element is smaller.
17127  */
17128  l1 = 1;
17129  nm1 = n-1;
17130  for(;;)
17131  {
17132  if( l1>n )
17133  {
17134  break;
17135  }
17136  if( l1>1 )
17137  {
17138  e->ptr.p_double[l1-1] = 0;
17139  }
17140  gotoflag = ae_false;
17141  m = l1;
17142  if( l1<=nm1 )
17143  {
17144  for(m=l1; m<=nm1; m++)
17145  {
17146  tst = ae_fabs(e->ptr.p_double[m], _state);
17147  if( ae_fp_eq(tst,0) )
17148  {
17149  gotoflag = ae_true;
17150  break;
17151  }
17152  if( ae_fp_less_eq(tst,ae_sqrt(ae_fabs(d->ptr.p_double[m], _state), _state)*ae_sqrt(ae_fabs(d->ptr.p_double[m+1], _state), _state)*eps) )
17153  {
17154  e->ptr.p_double[m] = 0;
17155  gotoflag = ae_true;
17156  break;
17157  }
17158  }
17159  }
17160  if( !gotoflag )
17161  {
17162  m = n;
17163  }
17164 
17165  /*
17166  * label 30:
17167  */
17168  l = l1;
17169  lsv = l;
17170  lend = m;
17171  lendsv = lend;
17172  l1 = m+1;
17173  if( lend==l )
17174  {
17175  continue;
17176  }
17177 
17178  /*
17179  * Scale submatrix in rows and columns L to LEND
17180  */
17181  if( l==lend )
17182  {
17183  anorm = ae_fabs(d->ptr.p_double[l], _state);
17184  }
17185  else
17186  {
17187  anorm = ae_maxreal(ae_fabs(d->ptr.p_double[l], _state)+ae_fabs(e->ptr.p_double[l], _state), ae_fabs(e->ptr.p_double[lend-1], _state)+ae_fabs(d->ptr.p_double[lend], _state), _state);
17188  for(i=l+1; i<=lend-1; i++)
17189  {
17190  anorm = ae_maxreal(anorm, ae_fabs(d->ptr.p_double[i], _state)+ae_fabs(e->ptr.p_double[i], _state)+ae_fabs(e->ptr.p_double[i-1], _state), _state);
17191  }
17192  }
17193  iscale = 0;
17194  if( ae_fp_eq(anorm,0) )
17195  {
17196  continue;
17197  }
17198  if( ae_fp_greater(anorm,ssfmax) )
17199  {
17200  iscale = 1;
17201  tmp = ssfmax/anorm;
17202  tmpint = lend-1;
17203  ae_v_muld(&d->ptr.p_double[l], 1, ae_v_len(l,lend), tmp);
17204  ae_v_muld(&e->ptr.p_double[l], 1, ae_v_len(l,tmpint), tmp);
17205  }
17206  if( ae_fp_less(anorm,ssfmin) )
17207  {
17208  iscale = 2;
17209  tmp = ssfmin/anorm;
17210  tmpint = lend-1;
17211  ae_v_muld(&d->ptr.p_double[l], 1, ae_v_len(l,lend), tmp);
17212  ae_v_muld(&e->ptr.p_double[l], 1, ae_v_len(l,tmpint), tmp);
17213  }
17214 
17215  /*
17216  * Choose between QL and QR iteration
17217  */
17218  if( ae_fp_less(ae_fabs(d->ptr.p_double[lend], _state),ae_fabs(d->ptr.p_double[l], _state)) )
17219  {
17220  lend = lsv;
17221  l = lendsv;
17222  }
17223  if( lend>l )
17224  {
17225 
17226  /*
17227  * QL Iteration
17228  *
17229  * Look for small subdiagonal element.
17230  */
17231  for(;;)
17232  {
17233  gotoflag = ae_false;
17234  if( l!=lend )
17235  {
17236  lendm1 = lend-1;
17237  for(m=l; m<=lendm1; m++)
17238  {
17239  tst = ae_sqr(ae_fabs(e->ptr.p_double[m], _state), _state);
17240  if( ae_fp_less_eq(tst,eps2*ae_fabs(d->ptr.p_double[m], _state)*ae_fabs(d->ptr.p_double[m+1], _state)+safmin) )
17241  {
17242  gotoflag = ae_true;
17243  break;
17244  }
17245  }
17246  }
17247  if( !gotoflag )
17248  {
17249  m = lend;
17250  }
17251  if( m<lend )
17252  {
17253  e->ptr.p_double[m] = 0;
17254  }
17255  p = d->ptr.p_double[l];
17256  if( m!=l )
17257  {
17258 
17259  /*
17260  * If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
17261  * to compute its eigensystem.
17262  */
17263  if( m==l+1 )
17264  {
17265  if( zneeded>0 )
17266  {
17267  evd_tdevdev2(d->ptr.p_double[l], e->ptr.p_double[l], d->ptr.p_double[l+1], &rt1, &rt2, &c, &s, _state);
17268  work1.ptr.p_double[l] = c;
17269  work2.ptr.p_double[l] = s;
17270  workc.ptr.p_double[1] = work1.ptr.p_double[l];
17271  works.ptr.p_double[1] = work2.ptr.p_double[l];
17272  if( !wastranspose )
17273  {
17274  applyrotationsfromtheright(ae_false, 1, zrows, l, l+1, &workc, &works, z, &wtemp, _state);
17275  }
17276  else
17277  {
17278  applyrotationsfromtheleft(ae_false, l, l+1, 1, zrows, &workc, &works, z, &wtemp, _state);
17279  }
17280  }
17281  else
17282  {
17283  evd_tdevde2(d->ptr.p_double[l], e->ptr.p_double[l], d->ptr.p_double[l+1], &rt1, &rt2, _state);
17284  }
17285  d->ptr.p_double[l] = rt1;
17286  d->ptr.p_double[l+1] = rt2;
17287  e->ptr.p_double[l] = 0;
17288  l = l+2;
17289  if( l<=lend )
17290  {
17291  continue;
17292  }
17293 
17294  /*
17295  * GOTO 140
17296  */
17297  break;
17298  }
17299  if( jtot==nmaxit )
17300  {
17301 
17302  /*
17303  * GOTO 140
17304  */
17305  break;
17306  }
17307  jtot = jtot+1;
17308 
17309  /*
17310  * Form shift.
17311  */
17312  g = (d->ptr.p_double[l+1]-p)/(2*e->ptr.p_double[l]);
17313  r = evd_tdevdpythag(g, 1, _state);
17314  g = d->ptr.p_double[m]-p+e->ptr.p_double[l]/(g+evd_tdevdextsign(r, g, _state));
17315  s = 1;
17316  c = 1;
17317  p = 0;
17318 
17319  /*
17320  * Inner loop
17321  */
17322  mm1 = m-1;
17323  for(i=mm1; i>=l; i--)
17324  {
17325  f = s*e->ptr.p_double[i];
17326  b = c*e->ptr.p_double[i];
17327  generaterotation(g, f, &c, &s, &r, _state);
17328  if( i!=m-1 )
17329  {
17330  e->ptr.p_double[i+1] = r;
17331  }
17332  g = d->ptr.p_double[i+1]-p;
17333  r = (d->ptr.p_double[i]-g)*s+2*c*b;
17334  p = s*r;
17335  d->ptr.p_double[i+1] = g+p;
17336  g = c*r-b;
17337 
17338  /*
17339  * If eigenvectors are desired, then save rotations.
17340  */
17341  if( zneeded>0 )
17342  {
17343  work1.ptr.p_double[i] = c;
17344  work2.ptr.p_double[i] = -s;
17345  }
17346  }
17347 
17348  /*
17349  * If eigenvectors are desired, then apply saved rotations.
17350  */
17351  if( zneeded>0 )
17352  {
17353  for(i=l; i<=m-1; i++)
17354  {
17355  workc.ptr.p_double[i-l+1] = work1.ptr.p_double[i];
17356  works.ptr.p_double[i-l+1] = work2.ptr.p_double[i];
17357  }
17358  if( !wastranspose )
17359  {
17360  applyrotationsfromtheright(ae_false, 1, zrows, l, m, &workc, &works, z, &wtemp, _state);
17361  }
17362  else
17363  {
17364  applyrotationsfromtheleft(ae_false, l, m, 1, zrows, &workc, &works, z, &wtemp, _state);
17365  }
17366  }
17367  d->ptr.p_double[l] = d->ptr.p_double[l]-p;
17368  e->ptr.p_double[l] = g;
17369  continue;
17370  }
17371 
17372  /*
17373  * Eigenvalue found.
17374  */
17375  d->ptr.p_double[l] = p;
17376  l = l+1;
17377  if( l<=lend )
17378  {
17379  continue;
17380  }
17381  break;
17382  }
17383  }
17384  else
17385  {
17386 
17387  /*
17388  * QR Iteration
17389  *
17390  * Look for small superdiagonal element.
17391  */
17392  for(;;)
17393  {
17394  gotoflag = ae_false;
17395  if( l!=lend )
17396  {
17397  lendp1 = lend+1;
17398  for(m=l; m>=lendp1; m--)
17399  {
17400  tst = ae_sqr(ae_fabs(e->ptr.p_double[m-1], _state), _state);
17401  if( ae_fp_less_eq(tst,eps2*ae_fabs(d->ptr.p_double[m], _state)*ae_fabs(d->ptr.p_double[m-1], _state)+safmin) )
17402  {
17403  gotoflag = ae_true;
17404  break;
17405  }
17406  }
17407  }
17408  if( !gotoflag )
17409  {
17410  m = lend;
17411  }
17412  if( m>lend )
17413  {
17414  e->ptr.p_double[m-1] = 0;
17415  }
17416  p = d->ptr.p_double[l];
17417  if( m!=l )
17418  {
17419 
17420  /*
17421  * If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
17422  * to compute its eigensystem.
17423  */
17424  if( m==l-1 )
17425  {
17426  if( zneeded>0 )
17427  {
17428  evd_tdevdev2(d->ptr.p_double[l-1], e->ptr.p_double[l-1], d->ptr.p_double[l], &rt1, &rt2, &c, &s, _state);
17429  work1.ptr.p_double[m] = c;
17430  work2.ptr.p_double[m] = s;
17431  workc.ptr.p_double[1] = c;
17432  works.ptr.p_double[1] = s;
17433  if( !wastranspose )
17434  {
17435  applyrotationsfromtheright(ae_true, 1, zrows, l-1, l, &workc, &works, z, &wtemp, _state);
17436  }
17437  else
17438  {
17439  applyrotationsfromtheleft(ae_true, l-1, l, 1, zrows, &workc, &works, z, &wtemp, _state);
17440  }
17441  }
17442  else
17443  {
17444  evd_tdevde2(d->ptr.p_double[l-1], e->ptr.p_double[l-1], d->ptr.p_double[l], &rt1, &rt2, _state);
17445  }
17446  d->ptr.p_double[l-1] = rt1;
17447  d->ptr.p_double[l] = rt2;
17448  e->ptr.p_double[l-1] = 0;
17449  l = l-2;
17450  if( l>=lend )
17451  {
17452  continue;
17453  }
17454  break;
17455  }
17456  if( jtot==nmaxit )
17457  {
17458  break;
17459  }
17460  jtot = jtot+1;
17461 
17462  /*
17463  * Form shift.
17464  */
17465  g = (d->ptr.p_double[l-1]-p)/(2*e->ptr.p_double[l-1]);
17466  r = evd_tdevdpythag(g, 1, _state);
17467  g = d->ptr.p_double[m]-p+e->ptr.p_double[l-1]/(g+evd_tdevdextsign(r, g, _state));
17468  s = 1;
17469  c = 1;
17470  p = 0;
17471 
17472  /*
17473  * Inner loop
17474  */
17475  lm1 = l-1;
17476  for(i=m; i<=lm1; i++)
17477  {
17478  f = s*e->ptr.p_double[i];
17479  b = c*e->ptr.p_double[i];
17480  generaterotation(g, f, &c, &s, &r, _state);
17481  if( i!=m )
17482  {
17483  e->ptr.p_double[i-1] = r;
17484  }
17485  g = d->ptr.p_double[i]-p;
17486  r = (d->ptr.p_double[i+1]-g)*s+2*c*b;
17487  p = s*r;
17488  d->ptr.p_double[i] = g+p;
17489  g = c*r-b;
17490 
17491  /*
17492  * If eigenvectors are desired, then save rotations.
17493  */
17494  if( zneeded>0 )
17495  {
17496  work1.ptr.p_double[i] = c;
17497  work2.ptr.p_double[i] = s;
17498  }
17499  }
17500 
17501  /*
17502  * If eigenvectors are desired, then apply saved rotations.
17503  */
17504  if( zneeded>0 )
17505  {
17506  for(i=m; i<=l-1; i++)
17507  {
17508  workc.ptr.p_double[i-m+1] = work1.ptr.p_double[i];
17509  works.ptr.p_double[i-m+1] = work2.ptr.p_double[i];
17510  }
17511  if( !wastranspose )
17512  {
17513  applyrotationsfromtheright(ae_true, 1, zrows, m, l, &workc, &works, z, &wtemp, _state);
17514  }
17515  else
17516  {
17517  applyrotationsfromtheleft(ae_true, m, l, 1, zrows, &workc, &works, z, &wtemp, _state);
17518  }
17519  }
17520  d->ptr.p_double[l] = d->ptr.p_double[l]-p;
17521  e->ptr.p_double[lm1] = g;
17522  continue;
17523  }
17524 
17525  /*
17526  * Eigenvalue found.
17527  */
17528  d->ptr.p_double[l] = p;
17529  l = l-1;
17530  if( l>=lend )
17531  {
17532  continue;
17533  }
17534  break;
17535  }
17536  }
17537 
17538  /*
17539  * Undo scaling if necessary
17540  */
17541  if( iscale==1 )
17542  {
17543  tmp = anorm/ssfmax;
17544  tmpint = lendsv-1;
17545  ae_v_muld(&d->ptr.p_double[lsv], 1, ae_v_len(lsv,lendsv), tmp);
17546  ae_v_muld(&e->ptr.p_double[lsv], 1, ae_v_len(lsv,tmpint), tmp);
17547  }
17548  if( iscale==2 )
17549  {
17550  tmp = anorm/ssfmin;
17551  tmpint = lendsv-1;
17552  ae_v_muld(&d->ptr.p_double[lsv], 1, ae_v_len(lsv,lendsv), tmp);
17553  ae_v_muld(&e->ptr.p_double[lsv], 1, ae_v_len(lsv,tmpint), tmp);
17554  }
17555 
17556  /*
17557  * Check for no convergence to an eigenvalue after a total
17558  * of N*MAXIT iterations.
17559  */
17560  if( jtot>=nmaxit )
17561  {
17562  result = ae_false;
17563  if( wastranspose )
17564  {
17565  inplacetranspose(z, 1, n, 1, n, &wtemp, _state);
17566  }
17567  ae_frame_leave(_state);
17568  return result;
17569  }
17570  }
17571 
17572  /*
17573  * Order eigenvalues and eigenvectors.
17574  */
17575  if( zneeded==0 )
17576  {
17577 
17578  /*
17579  * Sort
17580  */
17581  if( n==1 )
17582  {
17583  ae_frame_leave(_state);
17584  return result;
17585  }
17586  if( n==2 )
17587  {
17588  if( ae_fp_greater(d->ptr.p_double[1],d->ptr.p_double[2]) )
17589  {
17590  tmp = d->ptr.p_double[1];
17591  d->ptr.p_double[1] = d->ptr.p_double[2];
17592  d->ptr.p_double[2] = tmp;
17593  }
17594  ae_frame_leave(_state);
17595  return result;
17596  }
17597  i = 2;
17598  do
17599  {
17600  t = i;
17601  while(t!=1)
17602  {
17603  k = t/2;
17604  if( ae_fp_greater_eq(d->ptr.p_double[k],d->ptr.p_double[t]) )
17605  {
17606  t = 1;
17607  }
17608  else
17609  {
17610  tmp = d->ptr.p_double[k];
17611  d->ptr.p_double[k] = d->ptr.p_double[t];
17612  d->ptr.p_double[t] = tmp;
17613  t = k;
17614  }
17615  }
17616  i = i+1;
17617  }
17618  while(i<=n);
17619  i = n-1;
17620  do
17621  {
17622  tmp = d->ptr.p_double[i+1];
17623  d->ptr.p_double[i+1] = d->ptr.p_double[1];
17624  d->ptr.p_double[1] = tmp;
17625  t = 1;
17626  while(t!=0)
17627  {
17628  k = 2*t;
17629  if( k>i )
17630  {
17631  t = 0;
17632  }
17633  else
17634  {
17635  if( k<i )
17636  {
17637  if( ae_fp_greater(d->ptr.p_double[k+1],d->ptr.p_double[k]) )
17638  {
17639  k = k+1;
17640  }
17641  }
17642  if( ae_fp_greater_eq(d->ptr.p_double[t],d->ptr.p_double[k]) )
17643  {
17644  t = 0;
17645  }
17646  else
17647  {
17648  tmp = d->ptr.p_double[k];
17649  d->ptr.p_double[k] = d->ptr.p_double[t];
17650  d->ptr.p_double[t] = tmp;
17651  t = k;
17652  }
17653  }
17654  }
17655  i = i-1;
17656  }
17657  while(i>=1);
17658  }
17659  else
17660  {
17661 
17662  /*
17663  * Use Selection Sort to minimize swaps of eigenvectors
17664  */
17665  for(ii=2; ii<=n; ii++)
17666  {
17667  i = ii-1;
17668  k = i;
17669  p = d->ptr.p_double[i];
17670  for(j=ii; j<=n; j++)
17671  {
17672  if( ae_fp_less(d->ptr.p_double[j],p) )
17673  {
17674  k = j;
17675  p = d->ptr.p_double[j];
17676  }
17677  }
17678  if( k!=i )
17679  {
17680  d->ptr.p_double[k] = d->ptr.p_double[i];
17681  d->ptr.p_double[i] = p;
17682  if( wastranspose )
17683  {
17684  ae_v_move(&wtemp.ptr.p_double[1], 1, &z->ptr.pp_double[i][1], 1, ae_v_len(1,n));
17685  ae_v_move(&z->ptr.pp_double[i][1], 1, &z->ptr.pp_double[k][1], 1, ae_v_len(1,n));
17686  ae_v_move(&z->ptr.pp_double[k][1], 1, &wtemp.ptr.p_double[1], 1, ae_v_len(1,n));
17687  }
17688  else
17689  {
17690  ae_v_move(&wtemp.ptr.p_double[1], 1, &z->ptr.pp_double[1][i], z->stride, ae_v_len(1,zrows));
17691  ae_v_move(&z->ptr.pp_double[1][i], z->stride, &z->ptr.pp_double[1][k], z->stride, ae_v_len(1,zrows));
17692  ae_v_move(&z->ptr.pp_double[1][k], z->stride, &wtemp.ptr.p_double[1], 1, ae_v_len(1,zrows));
17693  }
17694  }
17695  }
17696  if( wastranspose )
17697  {
17698  inplacetranspose(z, 1, n, 1, n, &wtemp, _state);
17699  }
17700  }
17701  ae_frame_leave(_state);
17702  return result;
17703 }
17704 
17705 
17706 /*************************************************************************
17707 DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix
17708  [ A B ]
17709  [ B C ].
17710 On return, RT1 is the eigenvalue of larger absolute value, and RT2
17711 is the eigenvalue of smaller absolute value.
17712 
17713  -- LAPACK auxiliary routine (version 3.0) --
17714  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
17715  Courant Institute, Argonne National Lab, and Rice University
17716  October 31, 1992
17717 *************************************************************************/
17718 static void evd_tdevde2(double a,
17719  double b,
17720  double c,
17721  double* rt1,
17722  double* rt2,
17723  ae_state *_state)
17724 {
17725  double ab;
17726  double acmn;
17727  double acmx;
17728  double adf;
17729  double df;
17730  double rt;
17731  double sm;
17732  double tb;
17733 
17734  *rt1 = 0;
17735  *rt2 = 0;
17736 
17737  sm = a+c;
17738  df = a-c;
17739  adf = ae_fabs(df, _state);
17740  tb = b+b;
17741  ab = ae_fabs(tb, _state);
17742  if( ae_fp_greater(ae_fabs(a, _state),ae_fabs(c, _state)) )
17743  {
17744  acmx = a;
17745  acmn = c;
17746  }
17747  else
17748  {
17749  acmx = c;
17750  acmn = a;
17751  }
17752  if( ae_fp_greater(adf,ab) )
17753  {
17754  rt = adf*ae_sqrt(1+ae_sqr(ab/adf, _state), _state);
17755  }
17756  else
17757  {
17758  if( ae_fp_less(adf,ab) )
17759  {
17760  rt = ab*ae_sqrt(1+ae_sqr(adf/ab, _state), _state);
17761  }
17762  else
17763  {
17764 
17765  /*
17766  * Includes case AB=ADF=0
17767  */
17768  rt = ab*ae_sqrt(2, _state);
17769  }
17770  }
17771  if( ae_fp_less(sm,0) )
17772  {
17773  *rt1 = 0.5*(sm-rt);
17774 
17775  /*
17776  * Order of execution important.
17777  * To get fully accurate smaller eigenvalue,
17778  * next line needs to be executed in higher precision.
17779  */
17780  *rt2 = acmx/(*rt1)*acmn-b/(*rt1)*b;
17781  }
17782  else
17783  {
17784  if( ae_fp_greater(sm,0) )
17785  {
17786  *rt1 = 0.5*(sm+rt);
17787 
17788  /*
17789  * Order of execution important.
17790  * To get fully accurate smaller eigenvalue,
17791  * next line needs to be executed in higher precision.
17792  */
17793  *rt2 = acmx/(*rt1)*acmn-b/(*rt1)*b;
17794  }
17795  else
17796  {
17797 
17798  /*
17799  * Includes case RT1 = RT2 = 0
17800  */
17801  *rt1 = 0.5*rt;
17802  *rt2 = -0.5*rt;
17803  }
17804  }
17805 }
17806 
17807 
17808 /*************************************************************************
17809 DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix
17810 
17811  [ A B ]
17812  [ B C ].
17813 
17814 On return, RT1 is the eigenvalue of larger absolute value, RT2 is the
17815 eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right
17816 eigenvector for RT1, giving the decomposition
17817 
17818  [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ]
17819  [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ].
17820 
17821 
17822  -- LAPACK auxiliary routine (version 3.0) --
17823  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
17824  Courant Institute, Argonne National Lab, and Rice University
17825  October 31, 1992
17826 *************************************************************************/
17827 static void evd_tdevdev2(double a,
17828  double b,
17829  double c,
17830  double* rt1,
17831  double* rt2,
17832  double* cs1,
17833  double* sn1,
17834  ae_state *_state)
17835 {
17836  ae_int_t sgn1;
17837  ae_int_t sgn2;
17838  double ab;
17839  double acmn;
17840  double acmx;
17841  double acs;
17842  double adf;
17843  double cs;
17844  double ct;
17845  double df;
17846  double rt;
17847  double sm;
17848  double tb;
17849  double tn;
17850 
17851  *rt1 = 0;
17852  *rt2 = 0;
17853  *cs1 = 0;
17854  *sn1 = 0;
17855 
17856 
17857  /*
17858  * Compute the eigenvalues
17859  */
17860  sm = a+c;
17861  df = a-c;
17862  adf = ae_fabs(df, _state);
17863  tb = b+b;
17864  ab = ae_fabs(tb, _state);
17865  if( ae_fp_greater(ae_fabs(a, _state),ae_fabs(c, _state)) )
17866  {
17867  acmx = a;
17868  acmn = c;
17869  }
17870  else
17871  {
17872  acmx = c;
17873  acmn = a;
17874  }
17875  if( ae_fp_greater(adf,ab) )
17876  {
17877  rt = adf*ae_sqrt(1+ae_sqr(ab/adf, _state), _state);
17878  }
17879  else
17880  {
17881  if( ae_fp_less(adf,ab) )
17882  {
17883  rt = ab*ae_sqrt(1+ae_sqr(adf/ab, _state), _state);
17884  }
17885  else
17886  {
17887 
17888  /*
17889  * Includes case AB=ADF=0
17890  */
17891  rt = ab*ae_sqrt(2, _state);
17892  }
17893  }
17894  if( ae_fp_less(sm,0) )
17895  {
17896  *rt1 = 0.5*(sm-rt);
17897  sgn1 = -1;
17898 
17899  /*
17900  * Order of execution important.
17901  * To get fully accurate smaller eigenvalue,
17902  * next line needs to be executed in higher precision.
17903  */
17904  *rt2 = acmx/(*rt1)*acmn-b/(*rt1)*b;
17905  }
17906  else
17907  {
17908  if( ae_fp_greater(sm,0) )
17909  {
17910  *rt1 = 0.5*(sm+rt);
17911  sgn1 = 1;
17912 
17913  /*
17914  * Order of execution important.
17915  * To get fully accurate smaller eigenvalue,
17916  * next line needs to be executed in higher precision.
17917  */
17918  *rt2 = acmx/(*rt1)*acmn-b/(*rt1)*b;
17919  }
17920  else
17921  {
17922 
17923  /*
17924  * Includes case RT1 = RT2 = 0
17925  */
17926  *rt1 = 0.5*rt;
17927  *rt2 = -0.5*rt;
17928  sgn1 = 1;
17929  }
17930  }
17931 
17932  /*
17933  * Compute the eigenvector
17934  */
17935  if( ae_fp_greater_eq(df,0) )
17936  {
17937  cs = df+rt;
17938  sgn2 = 1;
17939  }
17940  else
17941  {
17942  cs = df-rt;
17943  sgn2 = -1;
17944  }
17945  acs = ae_fabs(cs, _state);
17946  if( ae_fp_greater(acs,ab) )
17947  {
17948  ct = -tb/cs;
17949  *sn1 = 1/ae_sqrt(1+ct*ct, _state);
17950  *cs1 = ct*(*sn1);
17951  }
17952  else
17953  {
17954  if( ae_fp_eq(ab,0) )
17955  {
17956  *cs1 = 1;
17957  *sn1 = 0;
17958  }
17959  else
17960  {
17961  tn = -cs/tb;
17962  *cs1 = 1/ae_sqrt(1+tn*tn, _state);
17963  *sn1 = tn*(*cs1);
17964  }
17965  }
17966  if( sgn1==sgn2 )
17967  {
17968  tn = *cs1;
17969  *cs1 = -*sn1;
17970  *sn1 = tn;
17971  }
17972 }
17973 
17974 
17975 /*************************************************************************
17976 Internal routine
17977 *************************************************************************/
17978 static double evd_tdevdpythag(double a, double b, ae_state *_state)
17979 {
17980  double result;
17981 
17982 
17983  if( ae_fp_less(ae_fabs(a, _state),ae_fabs(b, _state)) )
17984  {
17985  result = ae_fabs(b, _state)*ae_sqrt(1+ae_sqr(a/b, _state), _state);
17986  }
17987  else
17988  {
17989  result = ae_fabs(a, _state)*ae_sqrt(1+ae_sqr(b/a, _state), _state);
17990  }
17991  return result;
17992 }
17993 
17994 
17995 /*************************************************************************
17996 Internal routine
17997 *************************************************************************/
17998 static double evd_tdevdextsign(double a, double b, ae_state *_state)
17999 {
18000  double result;
18001 
18002 
18003  if( ae_fp_greater_eq(b,0) )
18004  {
18005  result = ae_fabs(a, _state);
18006  }
18007  else
18008  {
18009  result = -ae_fabs(a, _state);
18010  }
18011  return result;
18012 }
18013 
18014 
18015 static ae_bool evd_internalbisectioneigenvalues(/* Real */ ae_vector* d,
18016  /* Real */ ae_vector* e,
18017  ae_int_t n,
18018  ae_int_t irange,
18019  ae_int_t iorder,
18020  double vl,
18021  double vu,
18022  ae_int_t il,
18023  ae_int_t iu,
18024  double abstol,
18025  /* Real */ ae_vector* w,
18026  ae_int_t* m,
18027  ae_int_t* nsplit,
18028  /* Integer */ ae_vector* iblock,
18029  /* Integer */ ae_vector* isplit,
18030  ae_int_t* errorcode,
18031  ae_state *_state)
18032 {
18033  ae_frame _frame_block;
18034  ae_vector _d;
18035  ae_vector _e;
18036  double fudge;
18037  double relfac;
18038  ae_bool ncnvrg;
18039  ae_bool toofew;
18040  ae_int_t ib;
18041  ae_int_t ibegin;
18042  ae_int_t idiscl;
18043  ae_int_t idiscu;
18044  ae_int_t ie;
18045  ae_int_t iend;
18046  ae_int_t iinfo;
18047  ae_int_t im;
18048  ae_int_t iin;
18049  ae_int_t ioff;
18050  ae_int_t iout;
18051  ae_int_t itmax;
18052  ae_int_t iw;
18053  ae_int_t iwoff;
18054  ae_int_t j;
18055  ae_int_t itmp1;
18056  ae_int_t jb;
18057  ae_int_t jdisc;
18058  ae_int_t je;
18059  ae_int_t nwl;
18060  ae_int_t nwu;
18061  double atoli;
18062  double bnorm;
18063  double gl;
18064  double gu;
18065  double pivmin;
18066  double rtoli;
18067  double safemn;
18068  double tmp1;
18069  double tmp2;
18070  double tnorm;
18071  double ulp;
18072  double wkill;
18073  double wl;
18074  double wlu;
18075  double wu;
18076  double wul;
18077  double scalefactor;
18078  double t;
18079  ae_vector idumma;
18080  ae_vector work;
18081  ae_vector iwork;
18082  ae_vector ia1s2;
18083  ae_vector ra1s2;
18084  ae_matrix ra1s2x2;
18085  ae_matrix ia1s2x2;
18086  ae_vector ra1siin;
18087  ae_vector ra2siin;
18088  ae_vector ra3siin;
18089  ae_vector ra4siin;
18090  ae_matrix ra1siinx2;
18091  ae_matrix ia1siinx2;
18092  ae_vector iworkspace;
18093  ae_vector rworkspace;
18094  ae_int_t tmpi;
18095  ae_bool result;
18096 
18097  ae_frame_make(_state, &_frame_block);
18098  ae_vector_init_copy(&_d, d, _state, ae_true);
18099  d = &_d;
18100  ae_vector_init_copy(&_e, e, _state, ae_true);
18101  e = &_e;
18102  ae_vector_clear(w);
18103  *m = 0;
18104  *nsplit = 0;
18105  ae_vector_clear(iblock);
18106  ae_vector_clear(isplit);
18107  *errorcode = 0;
18108  ae_vector_init(&idumma, 0, DT_INT, _state, ae_true);
18109  ae_vector_init(&work, 0, DT_REAL, _state, ae_true);
18110  ae_vector_init(&iwork, 0, DT_INT, _state, ae_true);
18111  ae_vector_init(&ia1s2, 0, DT_INT, _state, ae_true);
18112  ae_vector_init(&ra1s2, 0, DT_REAL, _state, ae_true);
18113  ae_matrix_init(&ra1s2x2, 0, 0, DT_REAL, _state, ae_true);
18114  ae_matrix_init(&ia1s2x2, 0, 0, DT_INT, _state, ae_true);
18115  ae_vector_init(&ra1siin, 0, DT_REAL, _state, ae_true);
18116  ae_vector_init(&ra2siin, 0, DT_REAL, _state, ae_true);
18117  ae_vector_init(&ra3siin, 0, DT_REAL, _state, ae_true);
18118  ae_vector_init(&ra4siin, 0, DT_REAL, _state, ae_true);
18119  ae_matrix_init(&ra1siinx2, 0, 0, DT_REAL, _state, ae_true);
18120  ae_matrix_init(&ia1siinx2, 0, 0, DT_INT, _state, ae_true);
18121  ae_vector_init(&iworkspace, 0, DT_INT, _state, ae_true);
18122  ae_vector_init(&rworkspace, 0, DT_REAL, _state, ae_true);
18123 
18124 
18125  /*
18126  * Quick return if possible
18127  */
18128  *m = 0;
18129  if( n==0 )
18130  {
18131  result = ae_true;
18132  ae_frame_leave(_state);
18133  return result;
18134  }
18135 
18136  /*
18137  * Get machine constants
18138  * NB is the minimum vector length for vector bisection, or 0
18139  * if only scalar is to be done.
18140  */
18141  fudge = 2;
18142  relfac = 2;
18143  safemn = ae_minrealnumber;
18144  ulp = 2*ae_machineepsilon;
18145  rtoli = ulp*relfac;
18146  ae_vector_set_length(&idumma, 1+1, _state);
18147  ae_vector_set_length(&work, 4*n+1, _state);
18148  ae_vector_set_length(&iwork, 3*n+1, _state);
18149  ae_vector_set_length(w, n+1, _state);
18150  ae_vector_set_length(iblock, n+1, _state);
18151  ae_vector_set_length(isplit, n+1, _state);
18152  ae_vector_set_length(&ia1s2, 2+1, _state);
18153  ae_vector_set_length(&ra1s2, 2+1, _state);
18154  ae_matrix_set_length(&ra1s2x2, 2+1, 2+1, _state);
18155  ae_matrix_set_length(&ia1s2x2, 2+1, 2+1, _state);
18156  ae_vector_set_length(&ra1siin, n+1, _state);
18157  ae_vector_set_length(&ra2siin, n+1, _state);
18158  ae_vector_set_length(&ra3siin, n+1, _state);
18159  ae_vector_set_length(&ra4siin, n+1, _state);
18160  ae_matrix_set_length(&ra1siinx2, n+1, 2+1, _state);
18161  ae_matrix_set_length(&ia1siinx2, n+1, 2+1, _state);
18162  ae_vector_set_length(&iworkspace, n+1, _state);
18163  ae_vector_set_length(&rworkspace, n+1, _state);
18164 
18165  /*
18166  * these initializers are not really necessary,
18167  * but without them compiler complains about uninitialized locals
18168  */
18169  wlu = 0;
18170  wul = 0;
18171 
18172  /*
18173  * Check for Errors
18174  */
18175  result = ae_false;
18176  *errorcode = 0;
18177  if( irange<=0||irange>=4 )
18178  {
18179  *errorcode = -4;
18180  }
18181  if( iorder<=0||iorder>=3 )
18182  {
18183  *errorcode = -5;
18184  }
18185  if( n<0 )
18186  {
18187  *errorcode = -3;
18188  }
18189  if( irange==2&&ae_fp_greater_eq(vl,vu) )
18190  {
18191  *errorcode = -6;
18192  }
18193  if( irange==3&&(il<1||il>ae_maxint(1, n, _state)) )
18194  {
18195  *errorcode = -8;
18196  }
18197  if( irange==3&&(iu<ae_minint(n, il, _state)||iu>n) )
18198  {
18199  *errorcode = -9;
18200  }
18201  if( *errorcode!=0 )
18202  {
18203  ae_frame_leave(_state);
18204  return result;
18205  }
18206 
18207  /*
18208  * Initialize error flags
18209  */
18210  ncnvrg = ae_false;
18211  toofew = ae_false;
18212 
18213  /*
18214  * Simplifications:
18215  */
18216  if( (irange==3&&il==1)&&iu==n )
18217  {
18218  irange = 1;
18219  }
18220 
18221  /*
18222  * Special Case when N=1
18223  */
18224  if( n==1 )
18225  {
18226  *nsplit = 1;
18227  isplit->ptr.p_int[1] = 1;
18228  if( irange==2&&(ae_fp_greater_eq(vl,d->ptr.p_double[1])||ae_fp_less(vu,d->ptr.p_double[1])) )
18229  {
18230  *m = 0;
18231  }
18232  else
18233  {
18234  w->ptr.p_double[1] = d->ptr.p_double[1];
18235  iblock->ptr.p_int[1] = 1;
18236  *m = 1;
18237  }
18238  result = ae_true;
18239  ae_frame_leave(_state);
18240  return result;
18241  }
18242 
18243  /*
18244  * Scaling
18245  */
18246  t = ae_fabs(d->ptr.p_double[n], _state);
18247  for(j=1; j<=n-1; j++)
18248  {
18249  t = ae_maxreal(t, ae_fabs(d->ptr.p_double[j], _state), _state);
18250  t = ae_maxreal(t, ae_fabs(e->ptr.p_double[j], _state), _state);
18251  }
18252  scalefactor = 1;
18253  if( ae_fp_neq(t,0) )
18254  {
18255  if( ae_fp_greater(t,ae_sqrt(ae_sqrt(ae_minrealnumber, _state), _state)*ae_sqrt(ae_maxrealnumber, _state)) )
18256  {
18257  scalefactor = t;
18258  }
18259  if( ae_fp_less(t,ae_sqrt(ae_sqrt(ae_maxrealnumber, _state), _state)*ae_sqrt(ae_minrealnumber, _state)) )
18260  {
18261  scalefactor = t;
18262  }
18263  for(j=1; j<=n-1; j++)
18264  {
18265  d->ptr.p_double[j] = d->ptr.p_double[j]/scalefactor;
18266  e->ptr.p_double[j] = e->ptr.p_double[j]/scalefactor;
18267  }
18268  d->ptr.p_double[n] = d->ptr.p_double[n]/scalefactor;
18269  }
18270 
18271  /*
18272  * Compute Splitting Points
18273  */
18274  *nsplit = 1;
18275  work.ptr.p_double[n] = 0;
18276  pivmin = 1;
18277  for(j=2; j<=n; j++)
18278  {
18279  tmp1 = ae_sqr(e->ptr.p_double[j-1], _state);
18280  if( ae_fp_greater(ae_fabs(d->ptr.p_double[j]*d->ptr.p_double[j-1], _state)*ae_sqr(ulp, _state)+safemn,tmp1) )
18281  {
18282  isplit->ptr.p_int[*nsplit] = j-1;
18283  *nsplit = *nsplit+1;
18284  work.ptr.p_double[j-1] = 0;
18285  }
18286  else
18287  {
18288  work.ptr.p_double[j-1] = tmp1;
18289  pivmin = ae_maxreal(pivmin, tmp1, _state);
18290  }
18291  }
18292  isplit->ptr.p_int[*nsplit] = n;
18293  pivmin = pivmin*safemn;
18294 
18295  /*
18296  * Compute Interval and ATOLI
18297  */
18298  if( irange==3 )
18299  {
18300 
18301  /*
18302  * RANGE='I': Compute the interval containing eigenvalues
18303  * IL through IU.
18304  *
18305  * Compute Gershgorin interval for entire (split) matrix
18306  * and use it as the initial interval
18307  */
18308  gu = d->ptr.p_double[1];
18309  gl = d->ptr.p_double[1];
18310  tmp1 = 0;
18311  for(j=1; j<=n-1; j++)
18312  {
18313  tmp2 = ae_sqrt(work.ptr.p_double[j], _state);
18314  gu = ae_maxreal(gu, d->ptr.p_double[j]+tmp1+tmp2, _state);
18315  gl = ae_minreal(gl, d->ptr.p_double[j]-tmp1-tmp2, _state);
18316  tmp1 = tmp2;
18317  }
18318  gu = ae_maxreal(gu, d->ptr.p_double[n]+tmp1, _state);
18319  gl = ae_minreal(gl, d->ptr.p_double[n]-tmp1, _state);
18320  tnorm = ae_maxreal(ae_fabs(gl, _state), ae_fabs(gu, _state), _state);
18321  gl = gl-fudge*tnorm*ulp*n-fudge*2*pivmin;
18322  gu = gu+fudge*tnorm*ulp*n+fudge*pivmin;
18323 
18324  /*
18325  * Compute Iteration parameters
18326  */
18327  itmax = ae_iceil((ae_log(tnorm+pivmin, _state)-ae_log(pivmin, _state))/ae_log(2, _state), _state)+2;
18328  if( ae_fp_less_eq(abstol,0) )
18329  {
18330  atoli = ulp*tnorm;
18331  }
18332  else
18333  {
18334  atoli = abstol;
18335  }
18336  work.ptr.p_double[n+1] = gl;
18337  work.ptr.p_double[n+2] = gl;
18338  work.ptr.p_double[n+3] = gu;
18339  work.ptr.p_double[n+4] = gu;
18340  work.ptr.p_double[n+5] = gl;
18341  work.ptr.p_double[n+6] = gu;
18342  iwork.ptr.p_int[1] = -1;
18343  iwork.ptr.p_int[2] = -1;
18344  iwork.ptr.p_int[3] = n+1;
18345  iwork.ptr.p_int[4] = n+1;
18346  iwork.ptr.p_int[5] = il-1;
18347  iwork.ptr.p_int[6] = iu;
18348 
18349  /*
18350  * Calling DLAEBZ
18351  *
18352  * DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E,
18353  * WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT,
18354  * IWORK, W, IBLOCK, IINFO )
18355  */
18356  ia1s2.ptr.p_int[1] = iwork.ptr.p_int[5];
18357  ia1s2.ptr.p_int[2] = iwork.ptr.p_int[6];
18358  ra1s2.ptr.p_double[1] = work.ptr.p_double[n+5];
18359  ra1s2.ptr.p_double[2] = work.ptr.p_double[n+6];
18360  ra1s2x2.ptr.pp_double[1][1] = work.ptr.p_double[n+1];
18361  ra1s2x2.ptr.pp_double[2][1] = work.ptr.p_double[n+2];
18362  ra1s2x2.ptr.pp_double[1][2] = work.ptr.p_double[n+3];
18363  ra1s2x2.ptr.pp_double[2][2] = work.ptr.p_double[n+4];
18364  ia1s2x2.ptr.pp_int[1][1] = iwork.ptr.p_int[1];
18365  ia1s2x2.ptr.pp_int[2][1] = iwork.ptr.p_int[2];
18366  ia1s2x2.ptr.pp_int[1][2] = iwork.ptr.p_int[3];
18367  ia1s2x2.ptr.pp_int[2][2] = iwork.ptr.p_int[4];
18368  evd_internaldlaebz(3, itmax, n, 2, 2, atoli, rtoli, pivmin, d, e, &work, &ia1s2, &ra1s2x2, &ra1s2, &iout, &ia1s2x2, w, iblock, &iinfo, _state);
18369  iwork.ptr.p_int[5] = ia1s2.ptr.p_int[1];
18370  iwork.ptr.p_int[6] = ia1s2.ptr.p_int[2];
18371  work.ptr.p_double[n+5] = ra1s2.ptr.p_double[1];
18372  work.ptr.p_double[n+6] = ra1s2.ptr.p_double[2];
18373  work.ptr.p_double[n+1] = ra1s2x2.ptr.pp_double[1][1];
18374  work.ptr.p_double[n+2] = ra1s2x2.ptr.pp_double[2][1];
18375  work.ptr.p_double[n+3] = ra1s2x2.ptr.pp_double[1][2];
18376  work.ptr.p_double[n+4] = ra1s2x2.ptr.pp_double[2][2];
18377  iwork.ptr.p_int[1] = ia1s2x2.ptr.pp_int[1][1];
18378  iwork.ptr.p_int[2] = ia1s2x2.ptr.pp_int[2][1];
18379  iwork.ptr.p_int[3] = ia1s2x2.ptr.pp_int[1][2];
18380  iwork.ptr.p_int[4] = ia1s2x2.ptr.pp_int[2][2];
18381  if( iwork.ptr.p_int[6]==iu )
18382  {
18383  wl = work.ptr.p_double[n+1];
18384  wlu = work.ptr.p_double[n+3];
18385  nwl = iwork.ptr.p_int[1];
18386  wu = work.ptr.p_double[n+4];
18387  wul = work.ptr.p_double[n+2];
18388  nwu = iwork.ptr.p_int[4];
18389  }
18390  else
18391  {
18392  wl = work.ptr.p_double[n+2];
18393  wlu = work.ptr.p_double[n+4];
18394  nwl = iwork.ptr.p_int[2];
18395  wu = work.ptr.p_double[n+3];
18396  wul = work.ptr.p_double[n+1];
18397  nwu = iwork.ptr.p_int[3];
18398  }
18399  if( ((nwl<0||nwl>=n)||nwu<1)||nwu>n )
18400  {
18401  *errorcode = 4;
18402  result = ae_false;
18403  ae_frame_leave(_state);
18404  return result;
18405  }
18406  }
18407  else
18408  {
18409 
18410  /*
18411  * RANGE='A' or 'V' -- Set ATOLI
18412  */
18413  tnorm = ae_maxreal(ae_fabs(d->ptr.p_double[1], _state)+ae_fabs(e->ptr.p_double[1], _state), ae_fabs(d->ptr.p_double[n], _state)+ae_fabs(e->ptr.p_double[n-1], _state), _state);
18414  for(j=2; j<=n-1; j++)
18415  {
18416  tnorm = ae_maxreal(tnorm, ae_fabs(d->ptr.p_double[j], _state)+ae_fabs(e->ptr.p_double[j-1], _state)+ae_fabs(e->ptr.p_double[j], _state), _state);
18417  }
18418  if( ae_fp_less_eq(abstol,0) )
18419  {
18420  atoli = ulp*tnorm;
18421  }
18422  else
18423  {
18424  atoli = abstol;
18425  }
18426  if( irange==2 )
18427  {
18428  wl = vl;
18429  wu = vu;
18430  }
18431  else
18432  {
18433  wl = 0;
18434  wu = 0;
18435  }
18436  }
18437 
18438  /*
18439  * Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.
18440  * NWL accumulates the number of eigenvalues .le. WL,
18441  * NWU accumulates the number of eigenvalues .le. WU
18442  */
18443  *m = 0;
18444  iend = 0;
18445  *errorcode = 0;
18446  nwl = 0;
18447  nwu = 0;
18448  for(jb=1; jb<=*nsplit; jb++)
18449  {
18450  ioff = iend;
18451  ibegin = ioff+1;
18452  iend = isplit->ptr.p_int[jb];
18453  iin = iend-ioff;
18454  if( iin==1 )
18455  {
18456 
18457  /*
18458  * Special Case -- IIN=1
18459  */
18460  if( irange==1||ae_fp_greater_eq(wl,d->ptr.p_double[ibegin]-pivmin) )
18461  {
18462  nwl = nwl+1;
18463  }
18464  if( irange==1||ae_fp_greater_eq(wu,d->ptr.p_double[ibegin]-pivmin) )
18465  {
18466  nwu = nwu+1;
18467  }
18468  if( irange==1||(ae_fp_less(wl,d->ptr.p_double[ibegin]-pivmin)&&ae_fp_greater_eq(wu,d->ptr.p_double[ibegin]-pivmin)) )
18469  {
18470  *m = *m+1;
18471  w->ptr.p_double[*m] = d->ptr.p_double[ibegin];
18472  iblock->ptr.p_int[*m] = jb;
18473  }
18474  }
18475  else
18476  {
18477 
18478  /*
18479  * General Case -- IIN > 1
18480  *
18481  * Compute Gershgorin Interval
18482  * and use it as the initial interval
18483  */
18484  gu = d->ptr.p_double[ibegin];
18485  gl = d->ptr.p_double[ibegin];
18486  tmp1 = 0;
18487  for(j=ibegin; j<=iend-1; j++)
18488  {
18489  tmp2 = ae_fabs(e->ptr.p_double[j], _state);
18490  gu = ae_maxreal(gu, d->ptr.p_double[j]+tmp1+tmp2, _state);
18491  gl = ae_minreal(gl, d->ptr.p_double[j]-tmp1-tmp2, _state);
18492  tmp1 = tmp2;
18493  }
18494  gu = ae_maxreal(gu, d->ptr.p_double[iend]+tmp1, _state);
18495  gl = ae_minreal(gl, d->ptr.p_double[iend]-tmp1, _state);
18496  bnorm = ae_maxreal(ae_fabs(gl, _state), ae_fabs(gu, _state), _state);
18497  gl = gl-fudge*bnorm*ulp*iin-fudge*pivmin;
18498  gu = gu+fudge*bnorm*ulp*iin+fudge*pivmin;
18499 
18500  /*
18501  * Compute ATOLI for the current submatrix
18502  */
18503  if( ae_fp_less_eq(abstol,0) )
18504  {
18505  atoli = ulp*ae_maxreal(ae_fabs(gl, _state), ae_fabs(gu, _state), _state);
18506  }
18507  else
18508  {
18509  atoli = abstol;
18510  }
18511  if( irange>1 )
18512  {
18513  if( ae_fp_less(gu,wl) )
18514  {
18515  nwl = nwl+iin;
18516  nwu = nwu+iin;
18517  continue;
18518  }
18519  gl = ae_maxreal(gl, wl, _state);
18520  gu = ae_minreal(gu, wu, _state);
18521  if( ae_fp_greater_eq(gl,gu) )
18522  {
18523  continue;
18524  }
18525  }
18526 
18527  /*
18528  * Set Up Initial Interval
18529  */
18530  work.ptr.p_double[n+1] = gl;
18531  work.ptr.p_double[n+iin+1] = gu;
18532 
18533  /*
18534  * Calling DLAEBZ
18535  *
18536  * CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
18537  * D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
18538  * IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM,
18539  * IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
18540  */
18541  for(tmpi=1; tmpi<=iin; tmpi++)
18542  {
18543  ra1siin.ptr.p_double[tmpi] = d->ptr.p_double[ibegin-1+tmpi];
18544  if( ibegin-1+tmpi<n )
18545  {
18546  ra2siin.ptr.p_double[tmpi] = e->ptr.p_double[ibegin-1+tmpi];
18547  }
18548  ra3siin.ptr.p_double[tmpi] = work.ptr.p_double[ibegin-1+tmpi];
18549  ra1siinx2.ptr.pp_double[tmpi][1] = work.ptr.p_double[n+tmpi];
18550  ra1siinx2.ptr.pp_double[tmpi][2] = work.ptr.p_double[n+tmpi+iin];
18551  ra4siin.ptr.p_double[tmpi] = work.ptr.p_double[n+2*iin+tmpi];
18552  rworkspace.ptr.p_double[tmpi] = w->ptr.p_double[*m+tmpi];
18553  iworkspace.ptr.p_int[tmpi] = iblock->ptr.p_int[*m+tmpi];
18554  ia1siinx2.ptr.pp_int[tmpi][1] = iwork.ptr.p_int[tmpi];
18555  ia1siinx2.ptr.pp_int[tmpi][2] = iwork.ptr.p_int[tmpi+iin];
18556  }
18557  evd_internaldlaebz(1, 0, iin, iin, 1, atoli, rtoli, pivmin, &ra1siin, &ra2siin, &ra3siin, &idumma, &ra1siinx2, &ra4siin, &im, &ia1siinx2, &rworkspace, &iworkspace, &iinfo, _state);
18558  for(tmpi=1; tmpi<=iin; tmpi++)
18559  {
18560  work.ptr.p_double[n+tmpi] = ra1siinx2.ptr.pp_double[tmpi][1];
18561  work.ptr.p_double[n+tmpi+iin] = ra1siinx2.ptr.pp_double[tmpi][2];
18562  work.ptr.p_double[n+2*iin+tmpi] = ra4siin.ptr.p_double[tmpi];
18563  w->ptr.p_double[*m+tmpi] = rworkspace.ptr.p_double[tmpi];
18564  iblock->ptr.p_int[*m+tmpi] = iworkspace.ptr.p_int[tmpi];
18565  iwork.ptr.p_int[tmpi] = ia1siinx2.ptr.pp_int[tmpi][1];
18566  iwork.ptr.p_int[tmpi+iin] = ia1siinx2.ptr.pp_int[tmpi][2];
18567  }
18568  nwl = nwl+iwork.ptr.p_int[1];
18569  nwu = nwu+iwork.ptr.p_int[iin+1];
18570  iwoff = *m-iwork.ptr.p_int[1];
18571 
18572  /*
18573  * Compute Eigenvalues
18574  */
18575  itmax = ae_iceil((ae_log(gu-gl+pivmin, _state)-ae_log(pivmin, _state))/ae_log(2, _state), _state)+2;
18576 
18577  /*
18578  * Calling DLAEBZ
18579  *
18580  *CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
18581  * D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
18582  * IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT,
18583  * IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
18584  */
18585  for(tmpi=1; tmpi<=iin; tmpi++)
18586  {
18587  ra1siin.ptr.p_double[tmpi] = d->ptr.p_double[ibegin-1+tmpi];
18588  if( ibegin-1+tmpi<n )
18589  {
18590  ra2siin.ptr.p_double[tmpi] = e->ptr.p_double[ibegin-1+tmpi];
18591  }
18592  ra3siin.ptr.p_double[tmpi] = work.ptr.p_double[ibegin-1+tmpi];
18593  ra1siinx2.ptr.pp_double[tmpi][1] = work.ptr.p_double[n+tmpi];
18594  ra1siinx2.ptr.pp_double[tmpi][2] = work.ptr.p_double[n+tmpi+iin];
18595  ra4siin.ptr.p_double[tmpi] = work.ptr.p_double[n+2*iin+tmpi];
18596  rworkspace.ptr.p_double[tmpi] = w->ptr.p_double[*m+tmpi];
18597  iworkspace.ptr.p_int[tmpi] = iblock->ptr.p_int[*m+tmpi];
18598  ia1siinx2.ptr.pp_int[tmpi][1] = iwork.ptr.p_int[tmpi];
18599  ia1siinx2.ptr.pp_int[tmpi][2] = iwork.ptr.p_int[tmpi+iin];
18600  }
18601  evd_internaldlaebz(2, itmax, iin, iin, 1, atoli, rtoli, pivmin, &ra1siin, &ra2siin, &ra3siin, &idumma, &ra1siinx2, &ra4siin, &iout, &ia1siinx2, &rworkspace, &iworkspace, &iinfo, _state);
18602  for(tmpi=1; tmpi<=iin; tmpi++)
18603  {
18604  work.ptr.p_double[n+tmpi] = ra1siinx2.ptr.pp_double[tmpi][1];
18605  work.ptr.p_double[n+tmpi+iin] = ra1siinx2.ptr.pp_double[tmpi][2];
18606  work.ptr.p_double[n+2*iin+tmpi] = ra4siin.ptr.p_double[tmpi];
18607  w->ptr.p_double[*m+tmpi] = rworkspace.ptr.p_double[tmpi];
18608  iblock->ptr.p_int[*m+tmpi] = iworkspace.ptr.p_int[tmpi];
18609  iwork.ptr.p_int[tmpi] = ia1siinx2.ptr.pp_int[tmpi][1];
18610  iwork.ptr.p_int[tmpi+iin] = ia1siinx2.ptr.pp_int[tmpi][2];
18611  }
18612 
18613  /*
18614  * Copy Eigenvalues Into W and IBLOCK
18615  * Use -JB for block number for unconverged eigenvalues.
18616  */
18617  for(j=1; j<=iout; j++)
18618  {
18619  tmp1 = 0.5*(work.ptr.p_double[j+n]+work.ptr.p_double[j+iin+n]);
18620 
18621  /*
18622  * Flag non-convergence.
18623  */
18624  if( j>iout-iinfo )
18625  {
18626  ncnvrg = ae_true;
18627  ib = -jb;
18628  }
18629  else
18630  {
18631  ib = jb;
18632  }
18633  for(je=iwork.ptr.p_int[j]+1+iwoff; je<=iwork.ptr.p_int[j+iin]+iwoff; je++)
18634  {
18635  w->ptr.p_double[je] = tmp1;
18636  iblock->ptr.p_int[je] = ib;
18637  }
18638  }
18639  *m = *m+im;
18640  }
18641  }
18642 
18643  /*
18644  * If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
18645  * If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
18646  */
18647  if( irange==3 )
18648  {
18649  im = 0;
18650  idiscl = il-1-nwl;
18651  idiscu = nwu-iu;
18652  if( idiscl>0||idiscu>0 )
18653  {
18654  for(je=1; je<=*m; je++)
18655  {
18656  if( ae_fp_less_eq(w->ptr.p_double[je],wlu)&&idiscl>0 )
18657  {
18658  idiscl = idiscl-1;
18659  }
18660  else
18661  {
18662  if( ae_fp_greater_eq(w->ptr.p_double[je],wul)&&idiscu>0 )
18663  {
18664  idiscu = idiscu-1;
18665  }
18666  else
18667  {
18668  im = im+1;
18669  w->ptr.p_double[im] = w->ptr.p_double[je];
18670  iblock->ptr.p_int[im] = iblock->ptr.p_int[je];
18671  }
18672  }
18673  }
18674  *m = im;
18675  }
18676  if( idiscl>0||idiscu>0 )
18677  {
18678 
18679  /*
18680  * Code to deal with effects of bad arithmetic:
18681  * Some low eigenvalues to be discarded are not in (WL,WLU],
18682  * or high eigenvalues to be discarded are not in (WUL,WU]
18683  * so just kill off the smallest IDISCL/largest IDISCU
18684  * eigenvalues, by simply finding the smallest/largest
18685  * eigenvalue(s).
18686  *
18687  * (If N(w) is monotone non-decreasing, this should never
18688  * happen.)
18689  */
18690  if( idiscl>0 )
18691  {
18692  wkill = wu;
18693  for(jdisc=1; jdisc<=idiscl; jdisc++)
18694  {
18695  iw = 0;
18696  for(je=1; je<=*m; je++)
18697  {
18698  if( iblock->ptr.p_int[je]!=0&&(ae_fp_less(w->ptr.p_double[je],wkill)||iw==0) )
18699  {
18700  iw = je;
18701  wkill = w->ptr.p_double[je];
18702  }
18703  }
18704  iblock->ptr.p_int[iw] = 0;
18705  }
18706  }
18707  if( idiscu>0 )
18708  {
18709  wkill = wl;
18710  for(jdisc=1; jdisc<=idiscu; jdisc++)
18711  {
18712  iw = 0;
18713  for(je=1; je<=*m; je++)
18714  {
18715  if( iblock->ptr.p_int[je]!=0&&(ae_fp_greater(w->ptr.p_double[je],wkill)||iw==0) )
18716  {
18717  iw = je;
18718  wkill = w->ptr.p_double[je];
18719  }
18720  }
18721  iblock->ptr.p_int[iw] = 0;
18722  }
18723  }
18724  im = 0;
18725  for(je=1; je<=*m; je++)
18726  {
18727  if( iblock->ptr.p_int[je]!=0 )
18728  {
18729  im = im+1;
18730  w->ptr.p_double[im] = w->ptr.p_double[je];
18731  iblock->ptr.p_int[im] = iblock->ptr.p_int[je];
18732  }
18733  }
18734  *m = im;
18735  }
18736  if( idiscl<0||idiscu<0 )
18737  {
18738  toofew = ae_true;
18739  }
18740  }
18741 
18742  /*
18743  * If ORDER='B', do nothing -- the eigenvalues are already sorted
18744  * by block.
18745  * If ORDER='E', sort the eigenvalues from smallest to largest
18746  */
18747  if( iorder==1&&*nsplit>1 )
18748  {
18749  for(je=1; je<=*m-1; je++)
18750  {
18751  ie = 0;
18752  tmp1 = w->ptr.p_double[je];
18753  for(j=je+1; j<=*m; j++)
18754  {
18755  if( ae_fp_less(w->ptr.p_double[j],tmp1) )
18756  {
18757  ie = j;
18758  tmp1 = w->ptr.p_double[j];
18759  }
18760  }
18761  if( ie!=0 )
18762  {
18763  itmp1 = iblock->ptr.p_int[ie];
18764  w->ptr.p_double[ie] = w->ptr.p_double[je];
18765  iblock->ptr.p_int[ie] = iblock->ptr.p_int[je];
18766  w->ptr.p_double[je] = tmp1;
18767  iblock->ptr.p_int[je] = itmp1;
18768  }
18769  }
18770  }
18771  for(j=1; j<=*m; j++)
18772  {
18773  w->ptr.p_double[j] = w->ptr.p_double[j]*scalefactor;
18774  }
18775  *errorcode = 0;
18776  if( ncnvrg )
18777  {
18778  *errorcode = *errorcode+1;
18779  }
18780  if( toofew )
18781  {
18782  *errorcode = *errorcode+2;
18783  }
18784  result = *errorcode==0;
18785  ae_frame_leave(_state);
18786  return result;
18787 }
18788 
18789 
18790 static void evd_internaldstein(ae_int_t n,
18791  /* Real */ ae_vector* d,
18792  /* Real */ ae_vector* e,
18793  ae_int_t m,
18794  /* Real */ ae_vector* w,
18795  /* Integer */ ae_vector* iblock,
18796  /* Integer */ ae_vector* isplit,
18797  /* Real */ ae_matrix* z,
18798  /* Integer */ ae_vector* ifail,
18799  ae_int_t* info,
18800  ae_state *_state)
18801 {
18802  ae_frame _frame_block;
18803  ae_vector _e;
18804  ae_vector _w;
18805  ae_int_t maxits;
18806  ae_int_t extra;
18807  ae_int_t b1;
18808  ae_int_t blksiz;
18809  ae_int_t bn;
18810  ae_int_t gpind;
18811  ae_int_t i;
18812  ae_int_t iinfo;
18813  ae_int_t its;
18814  ae_int_t j;
18815  ae_int_t j1;
18816  ae_int_t jblk;
18817  ae_int_t jmax;
18818  ae_int_t nblk;
18819  ae_int_t nrmchk;
18820  double dtpcrt;
18821  double eps;
18822  double eps1;
18823  double nrm;
18824  double onenrm;
18825  double ortol;
18826  double pertol;
18827  double scl;
18828  double sep;
18829  double tol;
18830  double xj;
18831  double xjm;
18832  double ztr;
18833  ae_vector work1;
18834  ae_vector work2;
18835  ae_vector work3;
18836  ae_vector work4;
18837  ae_vector work5;
18838  ae_vector iwork;
18839  ae_bool tmpcriterion;
18840  ae_int_t ti;
18841  ae_int_t i1;
18842  ae_int_t i2;
18843  double v;
18844 
18845  ae_frame_make(_state, &_frame_block);
18846  ae_vector_init_copy(&_e, e, _state, ae_true);
18847  e = &_e;
18848  ae_vector_init_copy(&_w, w, _state, ae_true);
18849  w = &_w;
18850  ae_matrix_clear(z);
18851  ae_vector_clear(ifail);
18852  *info = 0;
18853  ae_vector_init(&work1, 0, DT_REAL, _state, ae_true);
18854  ae_vector_init(&work2, 0, DT_REAL, _state, ae_true);
18855  ae_vector_init(&work3, 0, DT_REAL, _state, ae_true);
18856  ae_vector_init(&work4, 0, DT_REAL, _state, ae_true);
18857  ae_vector_init(&work5, 0, DT_REAL, _state, ae_true);
18858  ae_vector_init(&iwork, 0, DT_INT, _state, ae_true);
18859 
18860  maxits = 5;
18861  extra = 2;
18862  ae_vector_set_length(&work1, ae_maxint(n, 1, _state)+1, _state);
18863  ae_vector_set_length(&work2, ae_maxint(n-1, 1, _state)+1, _state);
18864  ae_vector_set_length(&work3, ae_maxint(n, 1, _state)+1, _state);
18865  ae_vector_set_length(&work4, ae_maxint(n, 1, _state)+1, _state);
18866  ae_vector_set_length(&work5, ae_maxint(n, 1, _state)+1, _state);
18867  ae_vector_set_length(&iwork, ae_maxint(n, 1, _state)+1, _state);
18868  ae_vector_set_length(ifail, ae_maxint(m, 1, _state)+1, _state);
18869  ae_matrix_set_length(z, ae_maxint(n, 1, _state)+1, ae_maxint(m, 1, _state)+1, _state);
18870 
18871  /*
18872  * these initializers are not really necessary,
18873  * but without them compiler complains about uninitialized locals
18874  */
18875  gpind = 0;
18876  onenrm = 0;
18877  ortol = 0;
18878  dtpcrt = 0;
18879  xjm = 0;
18880 
18881  /*
18882  * Test the input parameters.
18883  */
18884  *info = 0;
18885  for(i=1; i<=m; i++)
18886  {
18887  ifail->ptr.p_int[i] = 0;
18888  }
18889  if( n<0 )
18890  {
18891  *info = -1;
18892  ae_frame_leave(_state);
18893  return;
18894  }
18895  if( m<0||m>n )
18896  {
18897  *info = -4;
18898  ae_frame_leave(_state);
18899  return;
18900  }
18901  for(j=2; j<=m; j++)
18902  {
18903  if( iblock->ptr.p_int[j]<iblock->ptr.p_int[j-1] )
18904  {
18905  *info = -6;
18906  break;
18907  }
18908  if( iblock->ptr.p_int[j]==iblock->ptr.p_int[j-1]&&ae_fp_less(w->ptr.p_double[j],w->ptr.p_double[j-1]) )
18909  {
18910  *info = -5;
18911  break;
18912  }
18913  }
18914  if( *info!=0 )
18915  {
18916  ae_frame_leave(_state);
18917  return;
18918  }
18919 
18920  /*
18921  * Quick return if possible
18922  */
18923  if( n==0||m==0 )
18924  {
18925  ae_frame_leave(_state);
18926  return;
18927  }
18928  if( n==1 )
18929  {
18930  z->ptr.pp_double[1][1] = 1;
18931  ae_frame_leave(_state);
18932  return;
18933  }
18934 
18935  /*
18936  * Some preparations
18937  */
18938  ti = n-1;
18939  ae_v_move(&work1.ptr.p_double[1], 1, &e->ptr.p_double[1], 1, ae_v_len(1,ti));
18940  ae_vector_set_length(e, n+1, _state);
18941  ae_v_move(&e->ptr.p_double[1], 1, &work1.ptr.p_double[1], 1, ae_v_len(1,ti));
18942  ae_v_move(&work1.ptr.p_double[1], 1, &w->ptr.p_double[1], 1, ae_v_len(1,m));
18943  ae_vector_set_length(w, n+1, _state);
18944  ae_v_move(&w->ptr.p_double[1], 1, &work1.ptr.p_double[1], 1, ae_v_len(1,m));
18945 
18946  /*
18947  * Get machine constants.
18948  */
18949  eps = ae_machineepsilon;
18950 
18951  /*
18952  * Compute eigenvectors of matrix blocks.
18953  */
18954  j1 = 1;
18955  for(nblk=1; nblk<=iblock->ptr.p_int[m]; nblk++)
18956  {
18957 
18958  /*
18959  * Find starting and ending indices of block nblk.
18960  */
18961  if( nblk==1 )
18962  {
18963  b1 = 1;
18964  }
18965  else
18966  {
18967  b1 = isplit->ptr.p_int[nblk-1]+1;
18968  }
18969  bn = isplit->ptr.p_int[nblk];
18970  blksiz = bn-b1+1;
18971  if( blksiz!=1 )
18972  {
18973 
18974  /*
18975  * Compute reorthogonalization criterion and stopping criterion.
18976  */
18977  gpind = b1;
18978  onenrm = ae_fabs(d->ptr.p_double[b1], _state)+ae_fabs(e->ptr.p_double[b1], _state);
18979  onenrm = ae_maxreal(onenrm, ae_fabs(d->ptr.p_double[bn], _state)+ae_fabs(e->ptr.p_double[bn-1], _state), _state);
18980  for(i=b1+1; i<=bn-1; i++)
18981  {
18982  onenrm = ae_maxreal(onenrm, ae_fabs(d->ptr.p_double[i], _state)+ae_fabs(e->ptr.p_double[i-1], _state)+ae_fabs(e->ptr.p_double[i], _state), _state);
18983  }
18984  ortol = 0.001*onenrm;
18985  dtpcrt = ae_sqrt(0.1/blksiz, _state);
18986  }
18987 
18988  /*
18989  * Loop through eigenvalues of block nblk.
18990  */
18991  jblk = 0;
18992  for(j=j1; j<=m; j++)
18993  {
18994  if( iblock->ptr.p_int[j]!=nblk )
18995  {
18996  j1 = j;
18997  break;
18998  }
18999  jblk = jblk+1;
19000  xj = w->ptr.p_double[j];
19001  if( blksiz==1 )
19002  {
19003 
19004  /*
19005  * Skip all the work if the block size is one.
19006  */
19007  work1.ptr.p_double[1] = 1;
19008  }
19009  else
19010  {
19011 
19012  /*
19013  * If eigenvalues j and j-1 are too close, add a relatively
19014  * small perturbation.
19015  */
19016  if( jblk>1 )
19017  {
19018  eps1 = ae_fabs(eps*xj, _state);
19019  pertol = 10*eps1;
19020  sep = xj-xjm;
19021  if( ae_fp_less(sep,pertol) )
19022  {
19023  xj = xjm+pertol;
19024  }
19025  }
19026  its = 0;
19027  nrmchk = 0;
19028 
19029  /*
19030  * Get random starting vector.
19031  */
19032  for(ti=1; ti<=blksiz; ti++)
19033  {
19034  work1.ptr.p_double[ti] = 2*ae_randomreal(_state)-1;
19035  }
19036 
19037  /*
19038  * Copy the matrix T so it won't be destroyed in factorization.
19039  */
19040  for(ti=1; ti<=blksiz-1; ti++)
19041  {
19042  work2.ptr.p_double[ti] = e->ptr.p_double[b1+ti-1];
19043  work3.ptr.p_double[ti] = e->ptr.p_double[b1+ti-1];
19044  work4.ptr.p_double[ti] = d->ptr.p_double[b1+ti-1];
19045  }
19046  work4.ptr.p_double[blksiz] = d->ptr.p_double[b1+blksiz-1];
19047 
19048  /*
19049  * Compute LU factors with partial pivoting ( PT = LU )
19050  */
19051  tol = 0;
19052  evd_tdininternaldlagtf(blksiz, &work4, xj, &work2, &work3, tol, &work5, &iwork, &iinfo, _state);
19053 
19054  /*
19055  * Update iteration count.
19056  */
19057  do
19058  {
19059  its = its+1;
19060  if( its>maxits )
19061  {
19062 
19063  /*
19064  * If stopping criterion was not satisfied, update info and
19065  * store eigenvector number in array ifail.
19066  */
19067  *info = *info+1;
19068  ifail->ptr.p_int[*info] = j;
19069  break;
19070  }
19071 
19072  /*
19073  * Normalize and scale the righthand side vector Pb.
19074  */
19075  v = 0;
19076  for(ti=1; ti<=blksiz; ti++)
19077  {
19078  v = v+ae_fabs(work1.ptr.p_double[ti], _state);
19079  }
19080  scl = blksiz*onenrm*ae_maxreal(eps, ae_fabs(work4.ptr.p_double[blksiz], _state), _state)/v;
19081  ae_v_muld(&work1.ptr.p_double[1], 1, ae_v_len(1,blksiz), scl);
19082 
19083  /*
19084  * Solve the system LU = Pb.
19085  */
19086  evd_tdininternaldlagts(blksiz, &work4, &work2, &work3, &work5, &iwork, &work1, &tol, &iinfo, _state);
19087 
19088  /*
19089  * Reorthogonalize by modified Gram-Schmidt if eigenvalues are
19090  * close enough.
19091  */
19092  if( jblk!=1 )
19093  {
19094  if( ae_fp_greater(ae_fabs(xj-xjm, _state),ortol) )
19095  {
19096  gpind = j;
19097  }
19098  if( gpind!=j )
19099  {
19100  for(i=gpind; i<=j-1; i++)
19101  {
19102  i1 = b1;
19103  i2 = b1+blksiz-1;
19104  ztr = ae_v_dotproduct(&work1.ptr.p_double[1], 1, &z->ptr.pp_double[i1][i], z->stride, ae_v_len(1,blksiz));
19105  ae_v_subd(&work1.ptr.p_double[1], 1, &z->ptr.pp_double[i1][i], z->stride, ae_v_len(1,blksiz), ztr);
19106  touchint(&i2, _state);
19107  }
19108  }
19109  }
19110 
19111  /*
19112  * Check the infinity norm of the iterate.
19113  */
19114  jmax = vectoridxabsmax(&work1, 1, blksiz, _state);
19115  nrm = ae_fabs(work1.ptr.p_double[jmax], _state);
19116 
19117  /*
19118  * Continue for additional iterations after norm reaches
19119  * stopping criterion.
19120  */
19121  tmpcriterion = ae_false;
19122  if( ae_fp_less(nrm,dtpcrt) )
19123  {
19124  tmpcriterion = ae_true;
19125  }
19126  else
19127  {
19128  nrmchk = nrmchk+1;
19129  if( nrmchk<extra+1 )
19130  {
19131  tmpcriterion = ae_true;
19132  }
19133  }
19134  }
19135  while(tmpcriterion);
19136 
19137  /*
19138  * Accept iterate as jth eigenvector.
19139  */
19140  scl = 1/vectornorm2(&work1, 1, blksiz, _state);
19141  jmax = vectoridxabsmax(&work1, 1, blksiz, _state);
19142  if( ae_fp_less(work1.ptr.p_double[jmax],0) )
19143  {
19144  scl = -scl;
19145  }
19146  ae_v_muld(&work1.ptr.p_double[1], 1, ae_v_len(1,blksiz), scl);
19147  }
19148  for(i=1; i<=n; i++)
19149  {
19150  z->ptr.pp_double[i][j] = 0;
19151  }
19152  for(i=1; i<=blksiz; i++)
19153  {
19154  z->ptr.pp_double[b1+i-1][j] = work1.ptr.p_double[i];
19155  }
19156 
19157  /*
19158  * Save the shift to check eigenvalue spacing at next
19159  * iteration.
19160  */
19161  xjm = xj;
19162  }
19163  }
19164  ae_frame_leave(_state);
19165 }
19166 
19167 
19168 static void evd_tdininternaldlagtf(ae_int_t n,
19169  /* Real */ ae_vector* a,
19170  double lambdav,
19171  /* Real */ ae_vector* b,
19172  /* Real */ ae_vector* c,
19173  double tol,
19174  /* Real */ ae_vector* d,
19175  /* Integer */ ae_vector* iin,
19176  ae_int_t* info,
19177  ae_state *_state)
19178 {
19179  ae_int_t k;
19180  double eps;
19181  double mult;
19182  double piv1;
19183  double piv2;
19184  double scale1;
19185  double scale2;
19186  double temp;
19187  double tl;
19188 
19189  *info = 0;
19190 
19191  *info = 0;
19192  if( n<0 )
19193  {
19194  *info = -1;
19195  return;
19196  }
19197  if( n==0 )
19198  {
19199  return;
19200  }
19201  a->ptr.p_double[1] = a->ptr.p_double[1]-lambdav;
19202  iin->ptr.p_int[n] = 0;
19203  if( n==1 )
19204  {
19205  if( ae_fp_eq(a->ptr.p_double[1],0) )
19206  {
19207  iin->ptr.p_int[1] = 1;
19208  }
19209  return;
19210  }
19211  eps = ae_machineepsilon;
19212  tl = ae_maxreal(tol, eps, _state);
19213  scale1 = ae_fabs(a->ptr.p_double[1], _state)+ae_fabs(b->ptr.p_double[1], _state);
19214  for(k=1; k<=n-1; k++)
19215  {
19216  a->ptr.p_double[k+1] = a->ptr.p_double[k+1]-lambdav;
19217  scale2 = ae_fabs(c->ptr.p_double[k], _state)+ae_fabs(a->ptr.p_double[k+1], _state);
19218  if( k<n-1 )
19219  {
19220  scale2 = scale2+ae_fabs(b->ptr.p_double[k+1], _state);
19221  }
19222  if( ae_fp_eq(a->ptr.p_double[k],0) )
19223  {
19224  piv1 = 0;
19225  }
19226  else
19227  {
19228  piv1 = ae_fabs(a->ptr.p_double[k], _state)/scale1;
19229  }
19230  if( ae_fp_eq(c->ptr.p_double[k],0) )
19231  {
19232  iin->ptr.p_int[k] = 0;
19233  piv2 = 0;
19234  scale1 = scale2;
19235  if( k<n-1 )
19236  {
19237  d->ptr.p_double[k] = 0;
19238  }
19239  }
19240  else
19241  {
19242  piv2 = ae_fabs(c->ptr.p_double[k], _state)/scale2;
19243  if( ae_fp_less_eq(piv2,piv1) )
19244  {
19245  iin->ptr.p_int[k] = 0;
19246  scale1 = scale2;
19247  c->ptr.p_double[k] = c->ptr.p_double[k]/a->ptr.p_double[k];
19248  a->ptr.p_double[k+1] = a->ptr.p_double[k+1]-c->ptr.p_double[k]*b->ptr.p_double[k];
19249  if( k<n-1 )
19250  {
19251  d->ptr.p_double[k] = 0;
19252  }
19253  }
19254  else
19255  {
19256  iin->ptr.p_int[k] = 1;
19257  mult = a->ptr.p_double[k]/c->ptr.p_double[k];
19258  a->ptr.p_double[k] = c->ptr.p_double[k];
19259  temp = a->ptr.p_double[k+1];
19260  a->ptr.p_double[k+1] = b->ptr.p_double[k]-mult*temp;
19261  if( k<n-1 )
19262  {
19263  d->ptr.p_double[k] = b->ptr.p_double[k+1];
19264  b->ptr.p_double[k+1] = -mult*d->ptr.p_double[k];
19265  }
19266  b->ptr.p_double[k] = temp;
19267  c->ptr.p_double[k] = mult;
19268  }
19269  }
19270  if( ae_fp_less_eq(ae_maxreal(piv1, piv2, _state),tl)&&iin->ptr.p_int[n]==0 )
19271  {
19272  iin->ptr.p_int[n] = k;
19273  }
19274  }
19275  if( ae_fp_less_eq(ae_fabs(a->ptr.p_double[n], _state),scale1*tl)&&iin->ptr.p_int[n]==0 )
19276  {
19277  iin->ptr.p_int[n] = n;
19278  }
19279 }
19280 
19281 
19282 static void evd_tdininternaldlagts(ae_int_t n,
19283  /* Real */ ae_vector* a,
19284  /* Real */ ae_vector* b,
19285  /* Real */ ae_vector* c,
19286  /* Real */ ae_vector* d,
19287  /* Integer */ ae_vector* iin,
19288  /* Real */ ae_vector* y,
19289  double* tol,
19290  ae_int_t* info,
19291  ae_state *_state)
19292 {
19293  ae_int_t k;
19294  double absak;
19295  double ak;
19296  double bignum;
19297  double eps;
19298  double pert;
19299  double sfmin;
19300  double temp;
19301 
19302  *info = 0;
19303 
19304  *info = 0;
19305  if( n<0 )
19306  {
19307  *info = -1;
19308  return;
19309  }
19310  if( n==0 )
19311  {
19312  return;
19313  }
19314  eps = ae_machineepsilon;
19315  sfmin = ae_minrealnumber;
19316  bignum = 1/sfmin;
19317  if( ae_fp_less_eq(*tol,0) )
19318  {
19319  *tol = ae_fabs(a->ptr.p_double[1], _state);
19320  if( n>1 )
19321  {
19322  *tol = ae_maxreal(*tol, ae_maxreal(ae_fabs(a->ptr.p_double[2], _state), ae_fabs(b->ptr.p_double[1], _state), _state), _state);
19323  }
19324  for(k=3; k<=n; k++)
19325  {
19326  *tol = ae_maxreal(*tol, ae_maxreal(ae_fabs(a->ptr.p_double[k], _state), ae_maxreal(ae_fabs(b->ptr.p_double[k-1], _state), ae_fabs(d->ptr.p_double[k-2], _state), _state), _state), _state);
19327  }
19328  *tol = *tol*eps;
19329  if( ae_fp_eq(*tol,0) )
19330  {
19331  *tol = eps;
19332  }
19333  }
19334  for(k=2; k<=n; k++)
19335  {
19336  if( iin->ptr.p_int[k-1]==0 )
19337  {
19338  y->ptr.p_double[k] = y->ptr.p_double[k]-c->ptr.p_double[k-1]*y->ptr.p_double[k-1];
19339  }
19340  else
19341  {
19342  temp = y->ptr.p_double[k-1];
19343  y->ptr.p_double[k-1] = y->ptr.p_double[k];
19344  y->ptr.p_double[k] = temp-c->ptr.p_double[k-1]*y->ptr.p_double[k];
19345  }
19346  }
19347  for(k=n; k>=1; k--)
19348  {
19349  if( k<=n-2 )
19350  {
19351  temp = y->ptr.p_double[k]-b->ptr.p_double[k]*y->ptr.p_double[k+1]-d->ptr.p_double[k]*y->ptr.p_double[k+2];
19352  }
19353  else
19354  {
19355  if( k==n-1 )
19356  {
19357  temp = y->ptr.p_double[k]-b->ptr.p_double[k]*y->ptr.p_double[k+1];
19358  }
19359  else
19360  {
19361  temp = y->ptr.p_double[k];
19362  }
19363  }
19364  ak = a->ptr.p_double[k];
19365  pert = ae_fabs(*tol, _state);
19366  if( ae_fp_less(ak,0) )
19367  {
19368  pert = -pert;
19369  }
19370  for(;;)
19371  {
19372  absak = ae_fabs(ak, _state);
19373  if( ae_fp_less(absak,1) )
19374  {
19375  if( ae_fp_less(absak,sfmin) )
19376  {
19377  if( ae_fp_eq(absak,0)||ae_fp_greater(ae_fabs(temp, _state)*sfmin,absak) )
19378  {
19379  ak = ak+pert;
19380  pert = 2*pert;
19381  continue;
19382  }
19383  else
19384  {
19385  temp = temp*bignum;
19386  ak = ak*bignum;
19387  }
19388  }
19389  else
19390  {
19391  if( ae_fp_greater(ae_fabs(temp, _state),absak*bignum) )
19392  {
19393  ak = ak+pert;
19394  pert = 2*pert;
19395  continue;
19396  }
19397  }
19398  }
19399  break;
19400  }
19401  y->ptr.p_double[k] = temp/ak;
19402  }
19403 }
19404 
19405 
19406 static void evd_internaldlaebz(ae_int_t ijob,
19407  ae_int_t nitmax,
19408  ae_int_t n,
19409  ae_int_t mmax,
19410  ae_int_t minp,
19411  double abstol,
19412  double reltol,
19413  double pivmin,
19414  /* Real */ ae_vector* d,
19415  /* Real */ ae_vector* e,
19416  /* Real */ ae_vector* e2,
19417  /* Integer */ ae_vector* nval,
19418  /* Real */ ae_matrix* ab,
19419  /* Real */ ae_vector* c,
19420  ae_int_t* mout,
19421  /* Integer */ ae_matrix* nab,
19422  /* Real */ ae_vector* work,
19423  /* Integer */ ae_vector* iwork,
19424  ae_int_t* info,
19425  ae_state *_state)
19426 {
19427  ae_int_t itmp1;
19428  ae_int_t itmp2;
19429  ae_int_t j;
19430  ae_int_t ji;
19431  ae_int_t jit;
19432  ae_int_t jp;
19433  ae_int_t kf;
19434  ae_int_t kfnew;
19435  ae_int_t kl;
19436  ae_int_t klnew;
19437  double tmp1;
19438  double tmp2;
19439 
19440  *mout = 0;
19441  *info = 0;
19442 
19443  *info = 0;
19444  if( ijob<1||ijob>3 )
19445  {
19446  *info = -1;
19447  return;
19448  }
19449 
19450  /*
19451  * Initialize NAB
19452  */
19453  if( ijob==1 )
19454  {
19455 
19456  /*
19457  * Compute the number of eigenvalues in the initial intervals.
19458  */
19459  *mout = 0;
19460 
19461  /*
19462  *DIR$ NOVECTOR
19463  */
19464  for(ji=1; ji<=minp; ji++)
19465  {
19466  for(jp=1; jp<=2; jp++)
19467  {
19468  tmp1 = d->ptr.p_double[1]-ab->ptr.pp_double[ji][jp];
19469  if( ae_fp_less(ae_fabs(tmp1, _state),pivmin) )
19470  {
19471  tmp1 = -pivmin;
19472  }
19473  nab->ptr.pp_int[ji][jp] = 0;
19474  if( ae_fp_less_eq(tmp1,0) )
19475  {
19476  nab->ptr.pp_int[ji][jp] = 1;
19477  }
19478  for(j=2; j<=n; j++)
19479  {
19480  tmp1 = d->ptr.p_double[j]-e2->ptr.p_double[j-1]/tmp1-ab->ptr.pp_double[ji][jp];
19481  if( ae_fp_less(ae_fabs(tmp1, _state),pivmin) )
19482  {
19483  tmp1 = -pivmin;
19484  }
19485  if( ae_fp_less_eq(tmp1,0) )
19486  {
19487  nab->ptr.pp_int[ji][jp] = nab->ptr.pp_int[ji][jp]+1;
19488  }
19489  }
19490  }
19491  *mout = *mout+nab->ptr.pp_int[ji][2]-nab->ptr.pp_int[ji][1];
19492  }
19493  return;
19494  }
19495 
19496  /*
19497  * Initialize for loop
19498  *
19499  * KF and KL have the following meaning:
19500  * Intervals 1,...,KF-1 have converged.
19501  * Intervals KF,...,KL still need to be refined.
19502  */
19503  kf = 1;
19504  kl = minp;
19505 
19506  /*
19507  * If IJOB=2, initialize C.
19508  * If IJOB=3, use the user-supplied starting point.
19509  */
19510  if( ijob==2 )
19511  {
19512  for(ji=1; ji<=minp; ji++)
19513  {
19514  c->ptr.p_double[ji] = 0.5*(ab->ptr.pp_double[ji][1]+ab->ptr.pp_double[ji][2]);
19515  }
19516  }
19517 
19518  /*
19519  * Iteration loop
19520  */
19521  for(jit=1; jit<=nitmax; jit++)
19522  {
19523 
19524  /*
19525  * Loop over intervals
19526  *
19527  *
19528  * Serial Version of the loop
19529  */
19530  klnew = kl;
19531  for(ji=kf; ji<=kl; ji++)
19532  {
19533 
19534  /*
19535  * Compute N(w), the number of eigenvalues less than w
19536  */
19537  tmp1 = c->ptr.p_double[ji];
19538  tmp2 = d->ptr.p_double[1]-tmp1;
19539  itmp1 = 0;
19540  if( ae_fp_less_eq(tmp2,pivmin) )
19541  {
19542  itmp1 = 1;
19543  tmp2 = ae_minreal(tmp2, -pivmin, _state);
19544  }
19545 
19546  /*
19547  * A series of compiler directives to defeat vectorization
19548  * for the next loop
19549  *
19550  **$PL$ CMCHAR=' '
19551  *CDIR$ NEXTSCALAR
19552  *C$DIR SCALAR
19553  *CDIR$ NEXT SCALAR
19554  *CVD$L NOVECTOR
19555  *CDEC$ NOVECTOR
19556  *CVD$ NOVECTOR
19557  **VDIR NOVECTOR
19558  **VOCL LOOP,SCALAR
19559  *CIBM PREFER SCALAR
19560  **$PL$ CMCHAR='*'
19561  */
19562  for(j=2; j<=n; j++)
19563  {
19564  tmp2 = d->ptr.p_double[j]-e2->ptr.p_double[j-1]/tmp2-tmp1;
19565  if( ae_fp_less_eq(tmp2,pivmin) )
19566  {
19567  itmp1 = itmp1+1;
19568  tmp2 = ae_minreal(tmp2, -pivmin, _state);
19569  }
19570  }
19571  if( ijob<=2 )
19572  {
19573 
19574  /*
19575  * IJOB=2: Choose all intervals containing eigenvalues.
19576  *
19577  * Insure that N(w) is monotone
19578  */
19579  itmp1 = ae_minint(nab->ptr.pp_int[ji][2], ae_maxint(nab->ptr.pp_int[ji][1], itmp1, _state), _state);
19580 
19581  /*
19582  * Update the Queue -- add intervals if both halves
19583  * contain eigenvalues.
19584  */
19585  if( itmp1==nab->ptr.pp_int[ji][2] )
19586  {
19587 
19588  /*
19589  * No eigenvalue in the upper interval:
19590  * just use the lower interval.
19591  */
19592  ab->ptr.pp_double[ji][2] = tmp1;
19593  }
19594  else
19595  {
19596  if( itmp1==nab->ptr.pp_int[ji][1] )
19597  {
19598 
19599  /*
19600  * No eigenvalue in the lower interval:
19601  * just use the upper interval.
19602  */
19603  ab->ptr.pp_double[ji][1] = tmp1;
19604  }
19605  else
19606  {
19607  if( klnew<mmax )
19608  {
19609 
19610  /*
19611  * Eigenvalue in both intervals -- add upper to queue.
19612  */
19613  klnew = klnew+1;
19614  ab->ptr.pp_double[klnew][2] = ab->ptr.pp_double[ji][2];
19615  nab->ptr.pp_int[klnew][2] = nab->ptr.pp_int[ji][2];
19616  ab->ptr.pp_double[klnew][1] = tmp1;
19617  nab->ptr.pp_int[klnew][1] = itmp1;
19618  ab->ptr.pp_double[ji][2] = tmp1;
19619  nab->ptr.pp_int[ji][2] = itmp1;
19620  }
19621  else
19622  {
19623  *info = mmax+1;
19624  return;
19625  }
19626  }
19627  }
19628  }
19629  else
19630  {
19631 
19632  /*
19633  * IJOB=3: Binary search. Keep only the interval
19634  * containing w s.t. N(w) = NVAL
19635  */
19636  if( itmp1<=nval->ptr.p_int[ji] )
19637  {
19638  ab->ptr.pp_double[ji][1] = tmp1;
19639  nab->ptr.pp_int[ji][1] = itmp1;
19640  }
19641  if( itmp1>=nval->ptr.p_int[ji] )
19642  {
19643  ab->ptr.pp_double[ji][2] = tmp1;
19644  nab->ptr.pp_int[ji][2] = itmp1;
19645  }
19646  }
19647  }
19648  kl = klnew;
19649 
19650  /*
19651  * Check for convergence
19652  */
19653  kfnew = kf;
19654  for(ji=kf; ji<=kl; ji++)
19655  {
19656  tmp1 = ae_fabs(ab->ptr.pp_double[ji][2]-ab->ptr.pp_double[ji][1], _state);
19657  tmp2 = ae_maxreal(ae_fabs(ab->ptr.pp_double[ji][2], _state), ae_fabs(ab->ptr.pp_double[ji][1], _state), _state);
19658  if( ae_fp_less(tmp1,ae_maxreal(abstol, ae_maxreal(pivmin, reltol*tmp2, _state), _state))||nab->ptr.pp_int[ji][1]>=nab->ptr.pp_int[ji][2] )
19659  {
19660 
19661  /*
19662  * Converged -- Swap with position KFNEW,
19663  * then increment KFNEW
19664  */
19665  if( ji>kfnew )
19666  {
19667  tmp1 = ab->ptr.pp_double[ji][1];
19668  tmp2 = ab->ptr.pp_double[ji][2];
19669  itmp1 = nab->ptr.pp_int[ji][1];
19670  itmp2 = nab->ptr.pp_int[ji][2];
19671  ab->ptr.pp_double[ji][1] = ab->ptr.pp_double[kfnew][1];
19672  ab->ptr.pp_double[ji][2] = ab->ptr.pp_double[kfnew][2];
19673  nab->ptr.pp_int[ji][1] = nab->ptr.pp_int[kfnew][1];
19674  nab->ptr.pp_int[ji][2] = nab->ptr.pp_int[kfnew][2];
19675  ab->ptr.pp_double[kfnew][1] = tmp1;
19676  ab->ptr.pp_double[kfnew][2] = tmp2;
19677  nab->ptr.pp_int[kfnew][1] = itmp1;
19678  nab->ptr.pp_int[kfnew][2] = itmp2;
19679  if( ijob==3 )
19680  {
19681  itmp1 = nval->ptr.p_int[ji];
19682  nval->ptr.p_int[ji] = nval->ptr.p_int[kfnew];
19683  nval->ptr.p_int[kfnew] = itmp1;
19684  }
19685  }
19686  kfnew = kfnew+1;
19687  }
19688  }
19689  kf = kfnew;
19690 
19691  /*
19692  * Choose Midpoints
19693  */
19694  for(ji=kf; ji<=kl; ji++)
19695  {
19696  c->ptr.p_double[ji] = 0.5*(ab->ptr.pp_double[ji][1]+ab->ptr.pp_double[ji][2]);
19697  }
19698 
19699  /*
19700  * If no more intervals to refine, quit.
19701  */
19702  if( kf>kl )
19703  {
19704  break;
19705  }
19706  }
19707 
19708  /*
19709  * Converged
19710  */
19711  *info = ae_maxint(kl+1-kf, 0, _state);
19712  *mout = kl;
19713 }
19714 
19715 
19716 /*************************************************************************
19717 Internal subroutine
19718 
19719  -- LAPACK routine (version 3.0) --
19720  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
19721  Courant Institute, Argonne National Lab, and Rice University
19722  June 30, 1999
19723 *************************************************************************/
19724 static void evd_internaltrevc(/* Real */ ae_matrix* t,
19725  ae_int_t n,
19726  ae_int_t side,
19727  ae_int_t howmny,
19728  /* Boolean */ ae_vector* vselect,
19729  /* Real */ ae_matrix* vl,
19730  /* Real */ ae_matrix* vr,
19731  ae_int_t* m,
19732  ae_int_t* info,
19733  ae_state *_state)
19734 {
19735  ae_frame _frame_block;
19736  ae_vector _vselect;
19737  ae_bool allv;
19738  ae_bool bothv;
19739  ae_bool leftv;
19740  ae_bool over;
19741  ae_bool pair;
19742  ae_bool rightv;
19743  ae_bool somev;
19744  ae_int_t i;
19745  ae_int_t ierr;
19746  ae_int_t ii;
19747  ae_int_t ip;
19748  ae_int_t iis;
19749  ae_int_t j;
19750  ae_int_t j1;
19751  ae_int_t j2;
19752  ae_int_t jnxt;
19753  ae_int_t k;
19754  ae_int_t ki;
19755  ae_int_t n2;
19756  double beta;
19757  double bignum;
19758  double emax;
19759  double rec;
19760  double remax;
19761  double scl;
19762  double smin;
19763  double smlnum;
19764  double ulp;
19765  double unfl;
19766  double vcrit;
19767  double vmax;
19768  double wi;
19769  double wr;
19770  double xnorm;
19771  ae_matrix x;
19772  ae_vector work;
19773  ae_vector temp;
19774  ae_matrix temp11;
19775  ae_matrix temp22;
19776  ae_matrix temp11b;
19777  ae_matrix temp21b;
19778  ae_matrix temp12b;
19779  ae_matrix temp22b;
19780  ae_bool skipflag;
19781  ae_int_t k1;
19782  ae_int_t k2;
19783  ae_int_t k3;
19784  ae_int_t k4;
19785  double vt;
19786  ae_vector rswap4;
19787  ae_vector zswap4;
19788  ae_matrix ipivot44;
19789  ae_vector civ4;
19790  ae_vector crv4;
19791 
19792  ae_frame_make(_state, &_frame_block);
19793  ae_vector_init_copy(&_vselect, vselect, _state, ae_true);
19794  vselect = &_vselect;
19795  *m = 0;
19796  *info = 0;
19797  ae_matrix_init(&x, 0, 0, DT_REAL, _state, ae_true);
19798  ae_vector_init(&work, 0, DT_REAL, _state, ae_true);
19799  ae_vector_init(&temp, 0, DT_REAL, _state, ae_true);
19800  ae_matrix_init(&temp11, 0, 0, DT_REAL, _state, ae_true);
19801  ae_matrix_init(&temp22, 0, 0, DT_REAL, _state, ae_true);
19802  ae_matrix_init(&temp11b, 0, 0, DT_REAL, _state, ae_true);
19803  ae_matrix_init(&temp21b, 0, 0, DT_REAL, _state, ae_true);
19804  ae_matrix_init(&temp12b, 0, 0, DT_REAL, _state, ae_true);
19805  ae_matrix_init(&temp22b, 0, 0, DT_REAL, _state, ae_true);
19806  ae_vector_init(&rswap4, 0, DT_BOOL, _state, ae_true);
19807  ae_vector_init(&zswap4, 0, DT_BOOL, _state, ae_true);
19808  ae_matrix_init(&ipivot44, 0, 0, DT_INT, _state, ae_true);
19809  ae_vector_init(&civ4, 0, DT_REAL, _state, ae_true);
19810  ae_vector_init(&crv4, 0, DT_REAL, _state, ae_true);
19811 
19812  ae_matrix_set_length(&x, 2+1, 2+1, _state);
19813  ae_matrix_set_length(&temp11, 1+1, 1+1, _state);
19814  ae_matrix_set_length(&temp11b, 1+1, 1+1, _state);
19815  ae_matrix_set_length(&temp21b, 2+1, 1+1, _state);
19816  ae_matrix_set_length(&temp12b, 1+1, 2+1, _state);
19817  ae_matrix_set_length(&temp22b, 2+1, 2+1, _state);
19818  ae_matrix_set_length(&temp22, 2+1, 2+1, _state);
19819  ae_vector_set_length(&work, 3*n+1, _state);
19820  ae_vector_set_length(&temp, n+1, _state);
19821  ae_vector_set_length(&rswap4, 4+1, _state);
19822  ae_vector_set_length(&zswap4, 4+1, _state);
19823  ae_matrix_set_length(&ipivot44, 4+1, 4+1, _state);
19824  ae_vector_set_length(&civ4, 4+1, _state);
19825  ae_vector_set_length(&crv4, 4+1, _state);
19826  if( howmny!=1 )
19827  {
19828  if( side==1||side==3 )
19829  {
19830  ae_matrix_set_length(vr, n+1, n+1, _state);
19831  }
19832  if( side==2||side==3 )
19833  {
19834  ae_matrix_set_length(vl, n+1, n+1, _state);
19835  }
19836  }
19837 
19838  /*
19839  * Decode and test the input parameters
19840  */
19841  bothv = side==3;
19842  rightv = side==1||bothv;
19843  leftv = side==2||bothv;
19844  allv = howmny==2;
19845  over = howmny==1;
19846  somev = howmny==3;
19847  *info = 0;
19848  if( n<0 )
19849  {
19850  *info = -2;
19851  ae_frame_leave(_state);
19852  return;
19853  }
19854  if( !rightv&&!leftv )
19855  {
19856  *info = -3;
19857  ae_frame_leave(_state);
19858  return;
19859  }
19860  if( (!allv&&!over)&&!somev )
19861  {
19862  *info = -4;
19863  ae_frame_leave(_state);
19864  return;
19865  }
19866 
19867  /*
19868  * Set M to the number of columns required to store the selected
19869  * eigenvectors, standardize the array SELECT if necessary, and
19870  * test MM.
19871  */
19872  if( somev )
19873  {
19874  *m = 0;
19875  pair = ae_false;
19876  for(j=1; j<=n; j++)
19877  {
19878  if( pair )
19879  {
19880  pair = ae_false;
19881  vselect->ptr.p_bool[j] = ae_false;
19882  }
19883  else
19884  {
19885  if( j<n )
19886  {
19887  if( ae_fp_eq(t->ptr.pp_double[j+1][j],0) )
19888  {
19889  if( vselect->ptr.p_bool[j] )
19890  {
19891  *m = *m+1;
19892  }
19893  }
19894  else
19895  {
19896  pair = ae_true;
19897  if( vselect->ptr.p_bool[j]||vselect->ptr.p_bool[j+1] )
19898  {
19899  vselect->ptr.p_bool[j] = ae_true;
19900  *m = *m+2;
19901  }
19902  }
19903  }
19904  else
19905  {
19906  if( vselect->ptr.p_bool[n] )
19907  {
19908  *m = *m+1;
19909  }
19910  }
19911  }
19912  }
19913  }
19914  else
19915  {
19916  *m = n;
19917  }
19918 
19919  /*
19920  * Quick return if possible.
19921  */
19922  if( n==0 )
19923  {
19924  ae_frame_leave(_state);
19925  return;
19926  }
19927 
19928  /*
19929  * Set the constants to control overflow.
19930  */
19931  unfl = ae_minrealnumber;
19932  ulp = ae_machineepsilon;
19933  smlnum = unfl*(n/ulp);
19934  bignum = (1-ulp)/smlnum;
19935 
19936  /*
19937  * Compute 1-norm of each column of strictly upper triangular
19938  * part of T to control overflow in triangular solver.
19939  */
19940  work.ptr.p_double[1] = 0;
19941  for(j=2; j<=n; j++)
19942  {
19943  work.ptr.p_double[j] = 0;
19944  for(i=1; i<=j-1; i++)
19945  {
19946  work.ptr.p_double[j] = work.ptr.p_double[j]+ae_fabs(t->ptr.pp_double[i][j], _state);
19947  }
19948  }
19949 
19950  /*
19951  * Index IP is used to specify the real or complex eigenvalue:
19952  * IP = 0, real eigenvalue,
19953  * 1, first of conjugate complex pair: (wr,wi)
19954  * -1, second of conjugate complex pair: (wr,wi)
19955  */
19956  n2 = 2*n;
19957  if( rightv )
19958  {
19959 
19960  /*
19961  * Compute right eigenvectors.
19962  */
19963  ip = 0;
19964  iis = *m;
19965  for(ki=n; ki>=1; ki--)
19966  {
19967  skipflag = ae_false;
19968  if( ip==1 )
19969  {
19970  skipflag = ae_true;
19971  }
19972  else
19973  {
19974  if( ki!=1 )
19975  {
19976  if( ae_fp_neq(t->ptr.pp_double[ki][ki-1],0) )
19977  {
19978  ip = -1;
19979  }
19980  }
19981  if( somev )
19982  {
19983  if( ip==0 )
19984  {
19985  if( !vselect->ptr.p_bool[ki] )
19986  {
19987  skipflag = ae_true;
19988  }
19989  }
19990  else
19991  {
19992  if( !vselect->ptr.p_bool[ki-1] )
19993  {
19994  skipflag = ae_true;
19995  }
19996  }
19997  }
19998  }
19999  if( !skipflag )
20000  {
20001 
20002  /*
20003  * Compute the KI-th eigenvalue (WR,WI).
20004  */
20005  wr = t->ptr.pp_double[ki][ki];
20006  wi = 0;
20007  if( ip!=0 )
20008  {
20009  wi = ae_sqrt(ae_fabs(t->ptr.pp_double[ki][ki-1], _state), _state)*ae_sqrt(ae_fabs(t->ptr.pp_double[ki-1][ki], _state), _state);
20010  }
20011  smin = ae_maxreal(ulp*(ae_fabs(wr, _state)+ae_fabs(wi, _state)), smlnum, _state);
20012  if( ip==0 )
20013  {
20014 
20015  /*
20016  * Real right eigenvector
20017  */
20018  work.ptr.p_double[ki+n] = 1;
20019 
20020  /*
20021  * Form right-hand side
20022  */
20023  for(k=1; k<=ki-1; k++)
20024  {
20025  work.ptr.p_double[k+n] = -t->ptr.pp_double[k][ki];
20026  }
20027 
20028  /*
20029  * Solve the upper quasi-triangular system:
20030  * (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK.
20031  */
20032  jnxt = ki-1;
20033  for(j=ki-1; j>=1; j--)
20034  {
20035  if( j>jnxt )
20036  {
20037  continue;
20038  }
20039  j1 = j;
20040  j2 = j;
20041  jnxt = j-1;
20042  if( j>1 )
20043  {
20044  if( ae_fp_neq(t->ptr.pp_double[j][j-1],0) )
20045  {
20046  j1 = j-1;
20047  jnxt = j-2;
20048  }
20049  }
20050  if( j1==j2 )
20051  {
20052 
20053  /*
20054  * 1-by-1 diagonal block
20055  */
20056  temp11.ptr.pp_double[1][1] = t->ptr.pp_double[j][j];
20057  temp11b.ptr.pp_double[1][1] = work.ptr.p_double[j+n];
20058  evd_internalhsevdlaln2(ae_false, 1, 1, smin, 1, &temp11, 1.0, 1.0, &temp11b, wr, 0.0, &rswap4, &zswap4, &ipivot44, &civ4, &crv4, &x, &scl, &xnorm, &ierr, _state);
20059 
20060  /*
20061  * Scale X(1,1) to avoid overflow when updating
20062  * the right-hand side.
20063  */
20064  if( ae_fp_greater(xnorm,1) )
20065  {
20066  if( ae_fp_greater(work.ptr.p_double[j],bignum/xnorm) )
20067  {
20068  x.ptr.pp_double[1][1] = x.ptr.pp_double[1][1]/xnorm;
20069  scl = scl/xnorm;
20070  }
20071  }
20072 
20073  /*
20074  * Scale if necessary
20075  */
20076  if( ae_fp_neq(scl,1) )
20077  {
20078  k1 = n+1;
20079  k2 = n+ki;
20080  ae_v_muld(&work.ptr.p_double[k1], 1, ae_v_len(k1,k2), scl);
20081  }
20082  work.ptr.p_double[j+n] = x.ptr.pp_double[1][1];
20083 
20084  /*
20085  * Update right-hand side
20086  */
20087  k1 = 1+n;
20088  k2 = j-1+n;
20089  k3 = j-1;
20090  vt = -x.ptr.pp_double[1][1];
20091  ae_v_addd(&work.ptr.p_double[k1], 1, &t->ptr.pp_double[1][j], t->stride, ae_v_len(k1,k2), vt);
20092  }
20093  else
20094  {
20095 
20096  /*
20097  * 2-by-2 diagonal block
20098  */
20099  temp22.ptr.pp_double[1][1] = t->ptr.pp_double[j-1][j-1];
20100  temp22.ptr.pp_double[1][2] = t->ptr.pp_double[j-1][j];
20101  temp22.ptr.pp_double[2][1] = t->ptr.pp_double[j][j-1];
20102  temp22.ptr.pp_double[2][2] = t->ptr.pp_double[j][j];
20103  temp21b.ptr.pp_double[1][1] = work.ptr.p_double[j-1+n];
20104  temp21b.ptr.pp_double[2][1] = work.ptr.p_double[j+n];
20105  evd_internalhsevdlaln2(ae_false, 2, 1, smin, 1.0, &temp22, 1.0, 1.0, &temp21b, wr, 0, &rswap4, &zswap4, &ipivot44, &civ4, &crv4, &x, &scl, &xnorm, &ierr, _state);
20106 
20107  /*
20108  * Scale X(1,1) and X(2,1) to avoid overflow when
20109  * updating the right-hand side.
20110  */
20111  if( ae_fp_greater(xnorm,1) )
20112  {
20113  beta = ae_maxreal(work.ptr.p_double[j-1], work.ptr.p_double[j], _state);
20114  if( ae_fp_greater(beta,bignum/xnorm) )
20115  {
20116  x.ptr.pp_double[1][1] = x.ptr.pp_double[1][1]/xnorm;
20117  x.ptr.pp_double[2][1] = x.ptr.pp_double[2][1]/xnorm;
20118  scl = scl/xnorm;
20119  }
20120  }
20121 
20122  /*
20123  * Scale if necessary
20124  */
20125  if( ae_fp_neq(scl,1) )
20126  {
20127  k1 = 1+n;
20128  k2 = ki+n;
20129  ae_v_muld(&work.ptr.p_double[k1], 1, ae_v_len(k1,k2), scl);
20130  }
20131  work.ptr.p_double[j-1+n] = x.ptr.pp_double[1][1];
20132  work.ptr.p_double[j+n] = x.ptr.pp_double[2][1];
20133 
20134  /*
20135  * Update right-hand side
20136  */
20137  k1 = 1+n;
20138  k2 = j-2+n;
20139  k3 = j-2;
20140  k4 = j-1;
20141  vt = -x.ptr.pp_double[1][1];
20142  ae_v_addd(&work.ptr.p_double[k1], 1, &t->ptr.pp_double[1][k4], t->stride, ae_v_len(k1,k2), vt);
20143  vt = -x.ptr.pp_double[2][1];
20144  ae_v_addd(&work.ptr.p_double[k1], 1, &t->ptr.pp_double[1][j], t->stride, ae_v_len(k1,k2), vt);
20145  }
20146  }
20147 
20148  /*
20149  * Copy the vector x or Q*x to VR and normalize.
20150  */
20151  if( !over )
20152  {
20153  k1 = 1+n;
20154  k2 = ki+n;
20155  ae_v_move(&vr->ptr.pp_double[1][iis], vr->stride, &work.ptr.p_double[k1], 1, ae_v_len(1,ki));
20156  ii = columnidxabsmax(vr, 1, ki, iis, _state);
20157  remax = 1/ae_fabs(vr->ptr.pp_double[ii][iis], _state);
20158  ae_v_muld(&vr->ptr.pp_double[1][iis], vr->stride, ae_v_len(1,ki), remax);
20159  for(k=ki+1; k<=n; k++)
20160  {
20161  vr->ptr.pp_double[k][iis] = 0;
20162  }
20163  }
20164  else
20165  {
20166  if( ki>1 )
20167  {
20168  ae_v_move(&temp.ptr.p_double[1], 1, &vr->ptr.pp_double[1][ki], vr->stride, ae_v_len(1,n));
20169  matrixvectormultiply(vr, 1, n, 1, ki-1, ae_false, &work, 1+n, ki-1+n, 1.0, &temp, 1, n, work.ptr.p_double[ki+n], _state);
20170  ae_v_move(&vr->ptr.pp_double[1][ki], vr->stride, &temp.ptr.p_double[1], 1, ae_v_len(1,n));
20171  }
20172  ii = columnidxabsmax(vr, 1, n, ki, _state);
20173  remax = 1/ae_fabs(vr->ptr.pp_double[ii][ki], _state);
20174  ae_v_muld(&vr->ptr.pp_double[1][ki], vr->stride, ae_v_len(1,n), remax);
20175  }
20176  }
20177  else
20178  {
20179 
20180  /*
20181  * Complex right eigenvector.
20182  *
20183  * Initial solve
20184  * [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0.
20185  * [ (T(KI,KI-1) T(KI,KI) ) ]
20186  */
20187  if( ae_fp_greater_eq(ae_fabs(t->ptr.pp_double[ki-1][ki], _state),ae_fabs(t->ptr.pp_double[ki][ki-1], _state)) )
20188  {
20189  work.ptr.p_double[ki-1+n] = 1;
20190  work.ptr.p_double[ki+n2] = wi/t->ptr.pp_double[ki-1][ki];
20191  }
20192  else
20193  {
20194  work.ptr.p_double[ki-1+n] = -wi/t->ptr.pp_double[ki][ki-1];
20195  work.ptr.p_double[ki+n2] = 1;
20196  }
20197  work.ptr.p_double[ki+n] = 0;
20198  work.ptr.p_double[ki-1+n2] = 0;
20199 
20200  /*
20201  * Form right-hand side
20202  */
20203  for(k=1; k<=ki-2; k++)
20204  {
20205  work.ptr.p_double[k+n] = -work.ptr.p_double[ki-1+n]*t->ptr.pp_double[k][ki-1];
20206  work.ptr.p_double[k+n2] = -work.ptr.p_double[ki+n2]*t->ptr.pp_double[k][ki];
20207  }
20208 
20209  /*
20210  * Solve upper quasi-triangular system:
20211  * (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2)
20212  */
20213  jnxt = ki-2;
20214  for(j=ki-2; j>=1; j--)
20215  {
20216  if( j>jnxt )
20217  {
20218  continue;
20219  }
20220  j1 = j;
20221  j2 = j;
20222  jnxt = j-1;
20223  if( j>1 )
20224  {
20225  if( ae_fp_neq(t->ptr.pp_double[j][j-1],0) )
20226  {
20227  j1 = j-1;
20228  jnxt = j-2;
20229  }
20230  }
20231  if( j1==j2 )
20232  {
20233 
20234  /*
20235  * 1-by-1 diagonal block
20236  */
20237  temp11.ptr.pp_double[1][1] = t->ptr.pp_double[j][j];
20238  temp12b.ptr.pp_double[1][1] = work.ptr.p_double[j+n];
20239  temp12b.ptr.pp_double[1][2] = work.ptr.p_double[j+n+n];
20240  evd_internalhsevdlaln2(ae_false, 1, 2, smin, 1.0, &temp11, 1.0, 1.0, &temp12b, wr, wi, &rswap4, &zswap4, &ipivot44, &civ4, &crv4, &x, &scl, &xnorm, &ierr, _state);
20241 
20242  /*
20243  * Scale X(1,1) and X(1,2) to avoid overflow when
20244  * updating the right-hand side.
20245  */
20246  if( ae_fp_greater(xnorm,1) )
20247  {
20248  if( ae_fp_greater(work.ptr.p_double[j],bignum/xnorm) )
20249  {
20250  x.ptr.pp_double[1][1] = x.ptr.pp_double[1][1]/xnorm;
20251  x.ptr.pp_double[1][2] = x.ptr.pp_double[1][2]/xnorm;
20252  scl = scl/xnorm;
20253  }
20254  }
20255 
20256  /*
20257  * Scale if necessary
20258  */
20259  if( ae_fp_neq(scl,1) )
20260  {
20261  k1 = 1+n;
20262  k2 = ki+n;
20263  ae_v_muld(&work.ptr.p_double[k1], 1, ae_v_len(k1,k2), scl);
20264  k1 = 1+n2;
20265  k2 = ki+n2;
20266  ae_v_muld(&work.ptr.p_double[k1], 1, ae_v_len(k1,k2), scl);
20267  }
20268  work.ptr.p_double[j+n] = x.ptr.pp_double[1][1];
20269  work.ptr.p_double[j+n2] = x.ptr.pp_double[1][2];
20270 
20271  /*
20272  * Update the right-hand side
20273  */
20274  k1 = 1+n;
20275  k2 = j-1+n;
20276  k3 = 1;
20277  k4 = j-1;
20278  vt = -x.ptr.pp_double[1][1];
20279  ae_v_addd(&work.ptr.p_double[k1], 1, &t->ptr.pp_double[k3][j], t->stride, ae_v_len(k1,k2), vt);
20280  k1 = 1+n2;
20281  k2 = j-1+n2;
20282  k3 = 1;
20283  k4 = j-1;
20284  vt = -x.ptr.pp_double[1][2];
20285  ae_v_addd(&work.ptr.p_double[k1], 1, &t->ptr.pp_double[k3][j], t->stride, ae_v_len(k1,k2), vt);
20286  }
20287  else
20288  {
20289 
20290  /*
20291  * 2-by-2 diagonal block
20292  */
20293  temp22.ptr.pp_double[1][1] = t->ptr.pp_double[j-1][j-1];
20294  temp22.ptr.pp_double[1][2] = t->ptr.pp_double[j-1][j];
20295  temp22.ptr.pp_double[2][1] = t->ptr.pp_double[j][j-1];
20296  temp22.ptr.pp_double[2][2] = t->ptr.pp_double[j][j];
20297  temp22b.ptr.pp_double[1][1] = work.ptr.p_double[j-1+n];
20298  temp22b.ptr.pp_double[1][2] = work.ptr.p_double[j-1+n+n];
20299  temp22b.ptr.pp_double[2][1] = work.ptr.p_double[j+n];
20300  temp22b.ptr.pp_double[2][2] = work.ptr.p_double[j+n+n];
20301  evd_internalhsevdlaln2(ae_false, 2, 2, smin, 1.0, &temp22, 1.0, 1.0, &temp22b, wr, wi, &rswap4, &zswap4, &ipivot44, &civ4, &crv4, &x, &scl, &xnorm, &ierr, _state);
20302 
20303  /*
20304  * Scale X to avoid overflow when updating
20305  * the right-hand side.
20306  */
20307  if( ae_fp_greater(xnorm,1) )
20308  {
20309  beta = ae_maxreal(work.ptr.p_double[j-1], work.ptr.p_double[j], _state);
20310  if( ae_fp_greater(beta,bignum/xnorm) )
20311  {
20312  rec = 1/xnorm;
20313  x.ptr.pp_double[1][1] = x.ptr.pp_double[1][1]*rec;
20314  x.ptr.pp_double[1][2] = x.ptr.pp_double[1][2]*rec;
20315  x.ptr.pp_double[2][1] = x.ptr.pp_double[2][1]*rec;
20316  x.ptr.pp_double[2][2] = x.ptr.pp_double[2][2]*rec;
20317  scl = scl*rec;
20318  }
20319  }
20320 
20321  /*
20322  * Scale if necessary
20323  */
20324  if( ae_fp_neq(scl,1) )
20325  {
20326  ae_v_muld(&work.ptr.p_double[1+n], 1, ae_v_len(1+n,ki+n), scl);
20327  ae_v_muld(&work.ptr.p_double[1+n2], 1, ae_v_len(1+n2,ki+n2), scl);
20328  }
20329  work.ptr.p_double[j-1+n] = x.ptr.pp_double[1][1];
20330  work.ptr.p_double[j+n] = x.ptr.pp_double[2][1];
20331  work.ptr.p_double[j-1+n2] = x.ptr.pp_double[1][2];
20332  work.ptr.p_double[j+n2] = x.ptr.pp_double[2][2];
20333 
20334  /*
20335  * Update the right-hand side
20336  */
20337  vt = -x.ptr.pp_double[1][1];
20338  ae_v_addd(&work.ptr.p_double[n+1], 1, &t->ptr.pp_double[1][j-1], t->stride, ae_v_len(n+1,n+j-2), vt);
20339  vt = -x.ptr.pp_double[2][1];
20340  ae_v_addd(&work.ptr.p_double[n+1], 1, &t->ptr.pp_double[1][j], t->stride, ae_v_len(n+1,n+j-2), vt);
20341  vt = -x.ptr.pp_double[1][2];
20342  ae_v_addd(&work.ptr.p_double[n2+1], 1, &t->ptr.pp_double[1][j-1], t->stride, ae_v_len(n2+1,n2+j-2), vt);
20343  vt = -x.ptr.pp_double[2][2];
20344  ae_v_addd(&work.ptr.p_double[n2+1], 1, &t->ptr.pp_double[1][j], t->stride, ae_v_len(n2+1,n2+j-2), vt);
20345  }
20346  }
20347 
20348  /*
20349  * Copy the vector x or Q*x to VR and normalize.
20350  */
20351  if( !over )
20352  {
20353  ae_v_move(&vr->ptr.pp_double[1][iis-1], vr->stride, &work.ptr.p_double[n+1], 1, ae_v_len(1,ki));
20354  ae_v_move(&vr->ptr.pp_double[1][iis], vr->stride, &work.ptr.p_double[n2+1], 1, ae_v_len(1,ki));
20355  emax = 0;
20356  for(k=1; k<=ki; k++)
20357  {
20358  emax = ae_maxreal(emax, ae_fabs(vr->ptr.pp_double[k][iis-1], _state)+ae_fabs(vr->ptr.pp_double[k][iis], _state), _state);
20359  }
20360  remax = 1/emax;
20361  ae_v_muld(&vr->ptr.pp_double[1][iis-1], vr->stride, ae_v_len(1,ki), remax);
20362  ae_v_muld(&vr->ptr.pp_double[1][iis], vr->stride, ae_v_len(1,ki), remax);
20363  for(k=ki+1; k<=n; k++)
20364  {
20365  vr->ptr.pp_double[k][iis-1] = 0;
20366  vr->ptr.pp_double[k][iis] = 0;
20367  }
20368  }
20369  else
20370  {
20371  if( ki>2 )
20372  {
20373  ae_v_move(&temp.ptr.p_double[1], 1, &vr->ptr.pp_double[1][ki-1], vr->stride, ae_v_len(1,n));
20374  matrixvectormultiply(vr, 1, n, 1, ki-2, ae_false, &work, 1+n, ki-2+n, 1.0, &temp, 1, n, work.ptr.p_double[ki-1+n], _state);
20375  ae_v_move(&vr->ptr.pp_double[1][ki-1], vr->stride, &temp.ptr.p_double[1], 1, ae_v_len(1,n));
20376  ae_v_move(&temp.ptr.p_double[1], 1, &vr->ptr.pp_double[1][ki], vr->stride, ae_v_len(1,n));
20377  matrixvectormultiply(vr, 1, n, 1, ki-2, ae_false, &work, 1+n2, ki-2+n2, 1.0, &temp, 1, n, work.ptr.p_double[ki+n2], _state);
20378  ae_v_move(&vr->ptr.pp_double[1][ki], vr->stride, &temp.ptr.p_double[1], 1, ae_v_len(1,n));
20379  }
20380  else
20381  {
20382  vt = work.ptr.p_double[ki-1+n];
20383  ae_v_muld(&vr->ptr.pp_double[1][ki-1], vr->stride, ae_v_len(1,n), vt);
20384  vt = work.ptr.p_double[ki+n2];
20385  ae_v_muld(&vr->ptr.pp_double[1][ki], vr->stride, ae_v_len(1,n), vt);
20386  }
20387  emax = 0;
20388  for(k=1; k<=n; k++)
20389  {
20390  emax = ae_maxreal(emax, ae_fabs(vr->ptr.pp_double[k][ki-1], _state)+ae_fabs(vr->ptr.pp_double[k][ki], _state), _state);
20391  }
20392  remax = 1/emax;
20393  ae_v_muld(&vr->ptr.pp_double[1][ki-1], vr->stride, ae_v_len(1,n), remax);
20394  ae_v_muld(&vr->ptr.pp_double[1][ki], vr->stride, ae_v_len(1,n), remax);
20395  }
20396  }
20397  iis = iis-1;
20398  if( ip!=0 )
20399  {
20400  iis = iis-1;
20401  }
20402  }
20403  if( ip==1 )
20404  {
20405  ip = 0;
20406  }
20407  if( ip==-1 )
20408  {
20409  ip = 1;
20410  }
20411  }
20412  }
20413  if( leftv )
20414  {
20415 
20416  /*
20417  * Compute left eigenvectors.
20418  */
20419  ip = 0;
20420  iis = 1;
20421  for(ki=1; ki<=n; ki++)
20422  {
20423  skipflag = ae_false;
20424  if( ip==-1 )
20425  {
20426  skipflag = ae_true;
20427  }
20428  else
20429  {
20430  if( ki!=n )
20431  {
20432  if( ae_fp_neq(t->ptr.pp_double[ki+1][ki],0) )
20433  {
20434  ip = 1;
20435  }
20436  }
20437  if( somev )
20438  {
20439  if( !vselect->ptr.p_bool[ki] )
20440  {
20441  skipflag = ae_true;
20442  }
20443  }
20444  }
20445  if( !skipflag )
20446  {
20447 
20448  /*
20449  * Compute the KI-th eigenvalue (WR,WI).
20450  */
20451  wr = t->ptr.pp_double[ki][ki];
20452  wi = 0;
20453  if( ip!=0 )
20454  {
20455  wi = ae_sqrt(ae_fabs(t->ptr.pp_double[ki][ki+1], _state), _state)*ae_sqrt(ae_fabs(t->ptr.pp_double[ki+1][ki], _state), _state);
20456  }
20457  smin = ae_maxreal(ulp*(ae_fabs(wr, _state)+ae_fabs(wi, _state)), smlnum, _state);
20458  if( ip==0 )
20459  {
20460 
20461  /*
20462  * Real left eigenvector.
20463  */
20464  work.ptr.p_double[ki+n] = 1;
20465 
20466  /*
20467  * Form right-hand side
20468  */
20469  for(k=ki+1; k<=n; k++)
20470  {
20471  work.ptr.p_double[k+n] = -t->ptr.pp_double[ki][k];
20472  }
20473 
20474  /*
20475  * Solve the quasi-triangular system:
20476  * (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK
20477  */
20478  vmax = 1;
20479  vcrit = bignum;
20480  jnxt = ki+1;
20481  for(j=ki+1; j<=n; j++)
20482  {
20483  if( j<jnxt )
20484  {
20485  continue;
20486  }
20487  j1 = j;
20488  j2 = j;
20489  jnxt = j+1;
20490  if( j<n )
20491  {
20492  if( ae_fp_neq(t->ptr.pp_double[j+1][j],0) )
20493  {
20494  j2 = j+1;
20495  jnxt = j+2;
20496  }
20497  }
20498  if( j1==j2 )
20499  {
20500 
20501  /*
20502  * 1-by-1 diagonal block
20503  *
20504  * Scale if necessary to avoid overflow when forming
20505  * the right-hand side.
20506  */
20507  if( ae_fp_greater(work.ptr.p_double[j],vcrit) )
20508  {
20509  rec = 1/vmax;
20510  ae_v_muld(&work.ptr.p_double[ki+n], 1, ae_v_len(ki+n,n+n), rec);
20511  vmax = 1;
20512  vcrit = bignum;
20513  }
20514  vt = ae_v_dotproduct(&t->ptr.pp_double[ki+1][j], t->stride, &work.ptr.p_double[ki+1+n], 1, ae_v_len(ki+1,j-1));
20515  work.ptr.p_double[j+n] = work.ptr.p_double[j+n]-vt;
20516 
20517  /*
20518  * Solve (T(J,J)-WR)'*X = WORK
20519  */
20520  temp11.ptr.pp_double[1][1] = t->ptr.pp_double[j][j];
20521  temp11b.ptr.pp_double[1][1] = work.ptr.p_double[j+n];
20522  evd_internalhsevdlaln2(ae_false, 1, 1, smin, 1.0, &temp11, 1.0, 1.0, &temp11b, wr, 0, &rswap4, &zswap4, &ipivot44, &civ4, &crv4, &x, &scl, &xnorm, &ierr, _state);
20523 
20524  /*
20525  * Scale if necessary
20526  */
20527  if( ae_fp_neq(scl,1) )
20528  {
20529  ae_v_muld(&work.ptr.p_double[ki+n], 1, ae_v_len(ki+n,n+n), scl);
20530  }
20531  work.ptr.p_double[j+n] = x.ptr.pp_double[1][1];
20532  vmax = ae_maxreal(ae_fabs(work.ptr.p_double[j+n], _state), vmax, _state);
20533  vcrit = bignum/vmax;
20534  }
20535  else
20536  {
20537 
20538  /*
20539  * 2-by-2 diagonal block
20540  *
20541  * Scale if necessary to avoid overflow when forming
20542  * the right-hand side.
20543  */
20544  beta = ae_maxreal(work.ptr.p_double[j], work.ptr.p_double[j+1], _state);
20545  if( ae_fp_greater(beta,vcrit) )
20546  {
20547  rec = 1/vmax;
20548  ae_v_muld(&work.ptr.p_double[ki+n], 1, ae_v_len(ki+n,n+n), rec);
20549  vmax = 1;
20550  vcrit = bignum;
20551  }
20552  vt = ae_v_dotproduct(&t->ptr.pp_double[ki+1][j], t->stride, &work.ptr.p_double[ki+1+n], 1, ae_v_len(ki+1,j-1));
20553  work.ptr.p_double[j+n] = work.ptr.p_double[j+n]-vt;
20554  vt = ae_v_dotproduct(&t->ptr.pp_double[ki+1][j+1], t->stride, &work.ptr.p_double[ki+1+n], 1, ae_v_len(ki+1,j-1));
20555  work.ptr.p_double[j+1+n] = work.ptr.p_double[j+1+n]-vt;
20556 
20557  /*
20558  * Solve
20559  * [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 )
20560  * [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 )
20561  */
20562  temp22.ptr.pp_double[1][1] = t->ptr.pp_double[j][j];
20563  temp22.ptr.pp_double[1][2] = t->ptr.pp_double[j][j+1];
20564  temp22.ptr.pp_double[2][1] = t->ptr.pp_double[j+1][j];
20565  temp22.ptr.pp_double[2][2] = t->ptr.pp_double[j+1][j+1];
20566  temp21b.ptr.pp_double[1][1] = work.ptr.p_double[j+n];
20567  temp21b.ptr.pp_double[2][1] = work.ptr.p_double[j+1+n];
20568  evd_internalhsevdlaln2(ae_true, 2, 1, smin, 1.0, &temp22, 1.0, 1.0, &temp21b, wr, 0, &rswap4, &zswap4, &ipivot44, &civ4, &crv4, &x, &scl, &xnorm, &ierr, _state);
20569 
20570  /*
20571  * Scale if necessary
20572  */
20573  if( ae_fp_neq(scl,1) )
20574  {
20575  ae_v_muld(&work.ptr.p_double[ki+n], 1, ae_v_len(ki+n,n+n), scl);
20576  }
20577  work.ptr.p_double[j+n] = x.ptr.pp_double[1][1];
20578  work.ptr.p_double[j+1+n] = x.ptr.pp_double[2][1];
20579  vmax = ae_maxreal(ae_fabs(work.ptr.p_double[j+n], _state), ae_maxreal(ae_fabs(work.ptr.p_double[j+1+n], _state), vmax, _state), _state);
20580  vcrit = bignum/vmax;
20581  }
20582  }
20583 
20584  /*
20585  * Copy the vector x or Q*x to VL and normalize.
20586  */
20587  if( !over )
20588  {
20589  ae_v_move(&vl->ptr.pp_double[ki][iis], vl->stride, &work.ptr.p_double[ki+n], 1, ae_v_len(ki,n));
20590  ii = columnidxabsmax(vl, ki, n, iis, _state);
20591  remax = 1/ae_fabs(vl->ptr.pp_double[ii][iis], _state);
20592  ae_v_muld(&vl->ptr.pp_double[ki][iis], vl->stride, ae_v_len(ki,n), remax);
20593  for(k=1; k<=ki-1; k++)
20594  {
20595  vl->ptr.pp_double[k][iis] = 0;
20596  }
20597  }
20598  else
20599  {
20600  if( ki<n )
20601  {
20602  ae_v_move(&temp.ptr.p_double[1], 1, &vl->ptr.pp_double[1][ki], vl->stride, ae_v_len(1,n));
20603  matrixvectormultiply(vl, 1, n, ki+1, n, ae_false, &work, ki+1+n, n+n, 1.0, &temp, 1, n, work.ptr.p_double[ki+n], _state);
20604  ae_v_move(&vl->ptr.pp_double[1][ki], vl->stride, &temp.ptr.p_double[1], 1, ae_v_len(1,n));
20605  }
20606  ii = columnidxabsmax(vl, 1, n, ki, _state);
20607  remax = 1/ae_fabs(vl->ptr.pp_double[ii][ki], _state);
20608  ae_v_muld(&vl->ptr.pp_double[1][ki], vl->stride, ae_v_len(1,n), remax);
20609  }
20610  }
20611  else
20612  {
20613 
20614  /*
20615  * Complex left eigenvector.
20616  *
20617  * Initial solve:
20618  * ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))*X = 0.
20619  * ((T(KI+1,KI) T(KI+1,KI+1)) )
20620  */
20621  if( ae_fp_greater_eq(ae_fabs(t->ptr.pp_double[ki][ki+1], _state),ae_fabs(t->ptr.pp_double[ki+1][ki], _state)) )
20622  {
20623  work.ptr.p_double[ki+n] = wi/t->ptr.pp_double[ki][ki+1];
20624  work.ptr.p_double[ki+1+n2] = 1;
20625  }
20626  else
20627  {
20628  work.ptr.p_double[ki+n] = 1;
20629  work.ptr.p_double[ki+1+n2] = -wi/t->ptr.pp_double[ki+1][ki];
20630  }
20631  work.ptr.p_double[ki+1+n] = 0;
20632  work.ptr.p_double[ki+n2] = 0;
20633 
20634  /*
20635  * Form right-hand side
20636  */
20637  for(k=ki+2; k<=n; k++)
20638  {
20639  work.ptr.p_double[k+n] = -work.ptr.p_double[ki+n]*t->ptr.pp_double[ki][k];
20640  work.ptr.p_double[k+n2] = -work.ptr.p_double[ki+1+n2]*t->ptr.pp_double[ki+1][k];
20641  }
20642 
20643  /*
20644  * Solve complex quasi-triangular system:
20645  * ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2
20646  */
20647  vmax = 1;
20648  vcrit = bignum;
20649  jnxt = ki+2;
20650  for(j=ki+2; j<=n; j++)
20651  {
20652  if( j<jnxt )
20653  {
20654  continue;
20655  }
20656  j1 = j;
20657  j2 = j;
20658  jnxt = j+1;
20659  if( j<n )
20660  {
20661  if( ae_fp_neq(t->ptr.pp_double[j+1][j],0) )
20662  {
20663  j2 = j+1;
20664  jnxt = j+2;
20665  }
20666  }
20667  if( j1==j2 )
20668  {
20669 
20670  /*
20671  * 1-by-1 diagonal block
20672  *
20673  * Scale if necessary to avoid overflow when
20674  * forming the right-hand side elements.
20675  */
20676  if( ae_fp_greater(work.ptr.p_double[j],vcrit) )
20677  {
20678  rec = 1/vmax;
20679  ae_v_muld(&work.ptr.p_double[ki+n], 1, ae_v_len(ki+n,n+n), rec);
20680  ae_v_muld(&work.ptr.p_double[ki+n2], 1, ae_v_len(ki+n2,n+n2), rec);
20681  vmax = 1;
20682  vcrit = bignum;
20683  }
20684  vt = ae_v_dotproduct(&t->ptr.pp_double[ki+2][j], t->stride, &work.ptr.p_double[ki+2+n], 1, ae_v_len(ki+2,j-1));
20685  work.ptr.p_double[j+n] = work.ptr.p_double[j+n]-vt;
20686  vt = ae_v_dotproduct(&t->ptr.pp_double[ki+2][j], t->stride, &work.ptr.p_double[ki+2+n2], 1, ae_v_len(ki+2,j-1));
20687  work.ptr.p_double[j+n2] = work.ptr.p_double[j+n2]-vt;
20688 
20689  /*
20690  * Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2
20691  */
20692  temp11.ptr.pp_double[1][1] = t->ptr.pp_double[j][j];
20693  temp12b.ptr.pp_double[1][1] = work.ptr.p_double[j+n];
20694  temp12b.ptr.pp_double[1][2] = work.ptr.p_double[j+n+n];
20695  evd_internalhsevdlaln2(ae_false, 1, 2, smin, 1.0, &temp11, 1.0, 1.0, &temp12b, wr, -wi, &rswap4, &zswap4, &ipivot44, &civ4, &crv4, &x, &scl, &xnorm, &ierr, _state);
20696 
20697  /*
20698  * Scale if necessary
20699  */
20700  if( ae_fp_neq(scl,1) )
20701  {
20702  ae_v_muld(&work.ptr.p_double[ki+n], 1, ae_v_len(ki+n,n+n), scl);
20703  ae_v_muld(&work.ptr.p_double[ki+n2], 1, ae_v_len(ki+n2,n+n2), scl);
20704  }
20705  work.ptr.p_double[j+n] = x.ptr.pp_double[1][1];
20706  work.ptr.p_double[j+n2] = x.ptr.pp_double[1][2];
20707  vmax = ae_maxreal(ae_fabs(work.ptr.p_double[j+n], _state), ae_maxreal(ae_fabs(work.ptr.p_double[j+n2], _state), vmax, _state), _state);
20708  vcrit = bignum/vmax;
20709  }
20710  else
20711  {
20712 
20713  /*
20714  * 2-by-2 diagonal block
20715  *
20716  * Scale if necessary to avoid overflow when forming
20717  * the right-hand side elements.
20718  */
20719  beta = ae_maxreal(work.ptr.p_double[j], work.ptr.p_double[j+1], _state);
20720  if( ae_fp_greater(beta,vcrit) )
20721  {
20722  rec = 1/vmax;
20723  ae_v_muld(&work.ptr.p_double[ki+n], 1, ae_v_len(ki+n,n+n), rec);
20724  ae_v_muld(&work.ptr.p_double[ki+n2], 1, ae_v_len(ki+n2,n+n2), rec);
20725  vmax = 1;
20726  vcrit = bignum;
20727  }
20728  vt = ae_v_dotproduct(&t->ptr.pp_double[ki+2][j], t->stride, &work.ptr.p_double[ki+2+n], 1, ae_v_len(ki+2,j-1));
20729  work.ptr.p_double[j+n] = work.ptr.p_double[j+n]-vt;
20730  vt = ae_v_dotproduct(&t->ptr.pp_double[ki+2][j], t->stride, &work.ptr.p_double[ki+2+n2], 1, ae_v_len(ki+2,j-1));
20731  work.ptr.p_double[j+n2] = work.ptr.p_double[j+n2]-vt;
20732  vt = ae_v_dotproduct(&t->ptr.pp_double[ki+2][j+1], t->stride, &work.ptr.p_double[ki+2+n], 1, ae_v_len(ki+2,j-1));
20733  work.ptr.p_double[j+1+n] = work.ptr.p_double[j+1+n]-vt;
20734  vt = ae_v_dotproduct(&t->ptr.pp_double[ki+2][j+1], t->stride, &work.ptr.p_double[ki+2+n2], 1, ae_v_len(ki+2,j-1));
20735  work.ptr.p_double[j+1+n2] = work.ptr.p_double[j+1+n2]-vt;
20736 
20737  /*
20738  * Solve 2-by-2 complex linear equation
20739  * ([T(j,j) T(j,j+1) ]'-(wr-i*wi)*I)*X = SCALE*B
20740  * ([T(j+1,j) T(j+1,j+1)] )
20741  */
20742  temp22.ptr.pp_double[1][1] = t->ptr.pp_double[j][j];
20743  temp22.ptr.pp_double[1][2] = t->ptr.pp_double[j][j+1];
20744  temp22.ptr.pp_double[2][1] = t->ptr.pp_double[j+1][j];
20745  temp22.ptr.pp_double[2][2] = t->ptr.pp_double[j+1][j+1];
20746  temp22b.ptr.pp_double[1][1] = work.ptr.p_double[j+n];
20747  temp22b.ptr.pp_double[1][2] = work.ptr.p_double[j+n+n];
20748  temp22b.ptr.pp_double[2][1] = work.ptr.p_double[j+1+n];
20749  temp22b.ptr.pp_double[2][2] = work.ptr.p_double[j+1+n+n];
20750  evd_internalhsevdlaln2(ae_true, 2, 2, smin, 1.0, &temp22, 1.0, 1.0, &temp22b, wr, -wi, &rswap4, &zswap4, &ipivot44, &civ4, &crv4, &x, &scl, &xnorm, &ierr, _state);
20751 
20752  /*
20753  * Scale if necessary
20754  */
20755  if( ae_fp_neq(scl,1) )
20756  {
20757  ae_v_muld(&work.ptr.p_double[ki+n], 1, ae_v_len(ki+n,n+n), scl);
20758  ae_v_muld(&work.ptr.p_double[ki+n2], 1, ae_v_len(ki+n2,n+n2), scl);
20759  }
20760  work.ptr.p_double[j+n] = x.ptr.pp_double[1][1];
20761  work.ptr.p_double[j+n2] = x.ptr.pp_double[1][2];
20762  work.ptr.p_double[j+1+n] = x.ptr.pp_double[2][1];
20763  work.ptr.p_double[j+1+n2] = x.ptr.pp_double[2][2];
20764  vmax = ae_maxreal(ae_fabs(x.ptr.pp_double[1][1], _state), vmax, _state);
20765  vmax = ae_maxreal(ae_fabs(x.ptr.pp_double[1][2], _state), vmax, _state);
20766  vmax = ae_maxreal(ae_fabs(x.ptr.pp_double[2][1], _state), vmax, _state);
20767  vmax = ae_maxreal(ae_fabs(x.ptr.pp_double[2][2], _state), vmax, _state);
20768  vcrit = bignum/vmax;
20769  }
20770  }
20771 
20772  /*
20773  * Copy the vector x or Q*x to VL and normalize.
20774  */
20775  if( !over )
20776  {
20777  ae_v_move(&vl->ptr.pp_double[ki][iis], vl->stride, &work.ptr.p_double[ki+n], 1, ae_v_len(ki,n));
20778  ae_v_move(&vl->ptr.pp_double[ki][iis+1], vl->stride, &work.ptr.p_double[ki+n2], 1, ae_v_len(ki,n));
20779  emax = 0;
20780  for(k=ki; k<=n; k++)
20781  {
20782  emax = ae_maxreal(emax, ae_fabs(vl->ptr.pp_double[k][iis], _state)+ae_fabs(vl->ptr.pp_double[k][iis+1], _state), _state);
20783  }
20784  remax = 1/emax;
20785  ae_v_muld(&vl->ptr.pp_double[ki][iis], vl->stride, ae_v_len(ki,n), remax);
20786  ae_v_muld(&vl->ptr.pp_double[ki][iis+1], vl->stride, ae_v_len(ki,n), remax);
20787  for(k=1; k<=ki-1; k++)
20788  {
20789  vl->ptr.pp_double[k][iis] = 0;
20790  vl->ptr.pp_double[k][iis+1] = 0;
20791  }
20792  }
20793  else
20794  {
20795  if( ki<n-1 )
20796  {
20797  ae_v_move(&temp.ptr.p_double[1], 1, &vl->ptr.pp_double[1][ki], vl->stride, ae_v_len(1,n));
20798  matrixvectormultiply(vl, 1, n, ki+2, n, ae_false, &work, ki+2+n, n+n, 1.0, &temp, 1, n, work.ptr.p_double[ki+n], _state);
20799  ae_v_move(&vl->ptr.pp_double[1][ki], vl->stride, &temp.ptr.p_double[1], 1, ae_v_len(1,n));
20800  ae_v_move(&temp.ptr.p_double[1], 1, &vl->ptr.pp_double[1][ki+1], vl->stride, ae_v_len(1,n));
20801  matrixvectormultiply(vl, 1, n, ki+2, n, ae_false, &work, ki+2+n2, n+n2, 1.0, &temp, 1, n, work.ptr.p_double[ki+1+n2], _state);
20802  ae_v_move(&vl->ptr.pp_double[1][ki+1], vl->stride, &temp.ptr.p_double[1], 1, ae_v_len(1,n));
20803  }
20804  else
20805  {
20806  vt = work.ptr.p_double[ki+n];
20807  ae_v_muld(&vl->ptr.pp_double[1][ki], vl->stride, ae_v_len(1,n), vt);
20808  vt = work.ptr.p_double[ki+1+n2];
20809  ae_v_muld(&vl->ptr.pp_double[1][ki+1], vl->stride, ae_v_len(1,n), vt);
20810  }
20811  emax = 0;
20812  for(k=1; k<=n; k++)
20813  {
20814  emax = ae_maxreal(emax, ae_fabs(vl->ptr.pp_double[k][ki], _state)+ae_fabs(vl->ptr.pp_double[k][ki+1], _state), _state);
20815  }
20816  remax = 1/emax;
20817  ae_v_muld(&vl->ptr.pp_double[1][ki], vl->stride, ae_v_len(1,n), remax);
20818  ae_v_muld(&vl->ptr.pp_double[1][ki+1], vl->stride, ae_v_len(1,n), remax);
20819  }
20820  }
20821  iis = iis+1;
20822  if( ip!=0 )
20823  {
20824  iis = iis+1;
20825  }
20826  }
20827  if( ip==-1 )
20828  {
20829  ip = 0;
20830  }
20831  if( ip==1 )
20832  {
20833  ip = -1;
20834  }
20835  }
20836  }
20837  ae_frame_leave(_state);
20838 }
20839 
20840 
20841 /*************************************************************************
20842 DLALN2 solves a system of the form (ca A - w D ) X = s B
20843 or (ca A' - w D) X = s B with possible scaling ("s") and
20844 perturbation of A. (A' means A-transpose.)
20845 
20846 A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA
20847 real diagonal matrix, w is a real or complex value, and X and B are
20848 NA x 1 matrices -- real if w is real, complex if w is complex. NA
20849 may be 1 or 2.
20850 
20851 If w is complex, X and B are represented as NA x 2 matrices,
20852 the first column of each being the real part and the second
20853 being the imaginary part.
20854 
20855 "s" is a scaling factor (.LE. 1), computed by DLALN2, which is
20856 so chosen that X can be computed without overflow. X is further
20857 scaled if necessary to assure that norm(ca A - w D)*norm(X) is less
20858 than overflow.
20859 
20860 If both singular values of (ca A - w D) are less than SMIN,
20861 SMIN*identity will be used instead of (ca A - w D). If only one
20862 singular value is less than SMIN, one element of (ca A - w D) will be
20863 perturbed enough to make the smallest singular value roughly SMIN.
20864 If both singular values are at least SMIN, (ca A - w D) will not be
20865 perturbed. In any case, the perturbation will be at most some small
20866 multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values
20867 are computed by infinity-norm approximations, and thus will only be
20868 correct to a factor of 2 or so.
20869 
20870 Note: all input quantities are assumed to be smaller than overflow
20871 by a reasonable factor. (See BIGNUM.)
20872 
20873  -- LAPACK auxiliary routine (version 3.0) --
20874  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
20875  Courant Institute, Argonne National Lab, and Rice University
20876  October 31, 1992
20877 *************************************************************************/
20878 static void evd_internalhsevdlaln2(ae_bool ltrans,
20879  ae_int_t na,
20880  ae_int_t nw,
20881  double smin,
20882  double ca,
20883  /* Real */ ae_matrix* a,
20884  double d1,
20885  double d2,
20886  /* Real */ ae_matrix* b,
20887  double wr,
20888  double wi,
20889  /* Boolean */ ae_vector* rswap4,
20890  /* Boolean */ ae_vector* zswap4,
20891  /* Integer */ ae_matrix* ipivot44,
20892  /* Real */ ae_vector* civ4,
20893  /* Real */ ae_vector* crv4,
20894  /* Real */ ae_matrix* x,
20895  double* scl,
20896  double* xnorm,
20897  ae_int_t* info,
20898  ae_state *_state)
20899 {
20900  ae_int_t icmax;
20901  ae_int_t j;
20902  double bbnd;
20903  double bi1;
20904  double bi2;
20905  double bignum;
20906  double bnorm;
20907  double br1;
20908  double br2;
20909  double ci21;
20910  double ci22;
20911  double cmax;
20912  double cnorm;
20913  double cr21;
20914  double cr22;
20915  double csi;
20916  double csr;
20917  double li21;
20918  double lr21;
20919  double smini;
20920  double smlnum;
20921  double temp;
20922  double u22abs;
20923  double ui11;
20924  double ui11r;
20925  double ui12;
20926  double ui12s;
20927  double ui22;
20928  double ur11;
20929  double ur11r;
20930  double ur12;
20931  double ur12s;
20932  double ur22;
20933  double xi1;
20934  double xi2;
20935  double xr1;
20936  double xr2;
20937  double tmp1;
20938  double tmp2;
20939 
20940  *scl = 0;
20941  *xnorm = 0;
20942  *info = 0;
20943 
20944  zswap4->ptr.p_bool[1] = ae_false;
20945  zswap4->ptr.p_bool[2] = ae_false;
20946  zswap4->ptr.p_bool[3] = ae_true;
20947  zswap4->ptr.p_bool[4] = ae_true;
20948  rswap4->ptr.p_bool[1] = ae_false;
20949  rswap4->ptr.p_bool[2] = ae_true;
20950  rswap4->ptr.p_bool[3] = ae_false;
20951  rswap4->ptr.p_bool[4] = ae_true;
20952  ipivot44->ptr.pp_int[1][1] = 1;
20953  ipivot44->ptr.pp_int[2][1] = 2;
20954  ipivot44->ptr.pp_int[3][1] = 3;
20955  ipivot44->ptr.pp_int[4][1] = 4;
20956  ipivot44->ptr.pp_int[1][2] = 2;
20957  ipivot44->ptr.pp_int[2][2] = 1;
20958  ipivot44->ptr.pp_int[3][2] = 4;
20959  ipivot44->ptr.pp_int[4][2] = 3;
20960  ipivot44->ptr.pp_int[1][3] = 3;
20961  ipivot44->ptr.pp_int[2][3] = 4;
20962  ipivot44->ptr.pp_int[3][3] = 1;
20963  ipivot44->ptr.pp_int[4][3] = 2;
20964  ipivot44->ptr.pp_int[1][4] = 4;
20965  ipivot44->ptr.pp_int[2][4] = 3;
20966  ipivot44->ptr.pp_int[3][4] = 2;
20967  ipivot44->ptr.pp_int[4][4] = 1;
20968  smlnum = 2*ae_minrealnumber;
20969  bignum = 1/smlnum;
20970  smini = ae_maxreal(smin, smlnum, _state);
20971 
20972  /*
20973  * Don't check for input errors
20974  */
20975  *info = 0;
20976 
20977  /*
20978  * Standard Initializations
20979  */
20980  *scl = 1;
20981  if( na==1 )
20982  {
20983 
20984  /*
20985  * 1 x 1 (i.e., scalar) system C X = B
20986  */
20987  if( nw==1 )
20988  {
20989 
20990  /*
20991  * Real 1x1 system.
20992  *
20993  * C = ca A - w D
20994  */
20995  csr = ca*a->ptr.pp_double[1][1]-wr*d1;
20996  cnorm = ae_fabs(csr, _state);
20997 
20998  /*
20999  * If | C | < SMINI, use C = SMINI
21000  */
21001  if( ae_fp_less(cnorm,smini) )
21002  {
21003  csr = smini;
21004  cnorm = smini;
21005  *info = 1;
21006  }
21007 
21008  /*
21009  * Check scaling for X = B / C
21010  */
21011  bnorm = ae_fabs(b->ptr.pp_double[1][1], _state);
21012  if( ae_fp_less(cnorm,1)&&ae_fp_greater(bnorm,1) )
21013  {
21014  if( ae_fp_greater(bnorm,bignum*cnorm) )
21015  {
21016  *scl = 1/bnorm;
21017  }
21018  }
21019 
21020  /*
21021  * Compute X
21022  */
21023  x->ptr.pp_double[1][1] = b->ptr.pp_double[1][1]*(*scl)/csr;
21024  *xnorm = ae_fabs(x->ptr.pp_double[1][1], _state);
21025  }
21026  else
21027  {
21028 
21029  /*
21030  * Complex 1x1 system (w is complex)
21031  *
21032  * C = ca A - w D
21033  */
21034  csr = ca*a->ptr.pp_double[1][1]-wr*d1;
21035  csi = -wi*d1;
21036  cnorm = ae_fabs(csr, _state)+ae_fabs(csi, _state);
21037 
21038  /*
21039  * If | C | < SMINI, use C = SMINI
21040  */
21041  if( ae_fp_less(cnorm,smini) )
21042  {
21043  csr = smini;
21044  csi = 0;
21045  cnorm = smini;
21046  *info = 1;
21047  }
21048 
21049  /*
21050  * Check scaling for X = B / C
21051  */
21052  bnorm = ae_fabs(b->ptr.pp_double[1][1], _state)+ae_fabs(b->ptr.pp_double[1][2], _state);
21053  if( ae_fp_less(cnorm,1)&&ae_fp_greater(bnorm,1) )
21054  {
21055  if( ae_fp_greater(bnorm,bignum*cnorm) )
21056  {
21057  *scl = 1/bnorm;
21058  }
21059  }
21060 
21061  /*
21062  * Compute X
21063  */
21064  evd_internalhsevdladiv(*scl*b->ptr.pp_double[1][1], *scl*b->ptr.pp_double[1][2], csr, csi, &tmp1, &tmp2, _state);
21065  x->ptr.pp_double[1][1] = tmp1;
21066  x->ptr.pp_double[1][2] = tmp2;
21067  *xnorm = ae_fabs(x->ptr.pp_double[1][1], _state)+ae_fabs(x->ptr.pp_double[1][2], _state);
21068  }
21069  }
21070  else
21071  {
21072 
21073  /*
21074  * 2x2 System
21075  *
21076  * Compute the real part of C = ca A - w D (or ca A' - w D )
21077  */
21078  crv4->ptr.p_double[1+0] = ca*a->ptr.pp_double[1][1]-wr*d1;
21079  crv4->ptr.p_double[2+2] = ca*a->ptr.pp_double[2][2]-wr*d2;
21080  if( ltrans )
21081  {
21082  crv4->ptr.p_double[1+2] = ca*a->ptr.pp_double[2][1];
21083  crv4->ptr.p_double[2+0] = ca*a->ptr.pp_double[1][2];
21084  }
21085  else
21086  {
21087  crv4->ptr.p_double[2+0] = ca*a->ptr.pp_double[2][1];
21088  crv4->ptr.p_double[1+2] = ca*a->ptr.pp_double[1][2];
21089  }
21090  if( nw==1 )
21091  {
21092 
21093  /*
21094  * Real 2x2 system (w is real)
21095  *
21096  * Find the largest element in C
21097  */
21098  cmax = 0;
21099  icmax = 0;
21100  for(j=1; j<=4; j++)
21101  {
21102  if( ae_fp_greater(ae_fabs(crv4->ptr.p_double[j], _state),cmax) )
21103  {
21104  cmax = ae_fabs(crv4->ptr.p_double[j], _state);
21105  icmax = j;
21106  }
21107  }
21108 
21109  /*
21110  * If norm(C) < SMINI, use SMINI*identity.
21111  */
21112  if( ae_fp_less(cmax,smini) )
21113  {
21114  bnorm = ae_maxreal(ae_fabs(b->ptr.pp_double[1][1], _state), ae_fabs(b->ptr.pp_double[2][1], _state), _state);
21115  if( ae_fp_less(smini,1)&&ae_fp_greater(bnorm,1) )
21116  {
21117  if( ae_fp_greater(bnorm,bignum*smini) )
21118  {
21119  *scl = 1/bnorm;
21120  }
21121  }
21122  temp = *scl/smini;
21123  x->ptr.pp_double[1][1] = temp*b->ptr.pp_double[1][1];
21124  x->ptr.pp_double[2][1] = temp*b->ptr.pp_double[2][1];
21125  *xnorm = temp*bnorm;
21126  *info = 1;
21127  return;
21128  }
21129 
21130  /*
21131  * Gaussian elimination with complete pivoting.
21132  */
21133  ur11 = crv4->ptr.p_double[icmax];
21134  cr21 = crv4->ptr.p_double[ipivot44->ptr.pp_int[2][icmax]];
21135  ur12 = crv4->ptr.p_double[ipivot44->ptr.pp_int[3][icmax]];
21136  cr22 = crv4->ptr.p_double[ipivot44->ptr.pp_int[4][icmax]];
21137  ur11r = 1/ur11;
21138  lr21 = ur11r*cr21;
21139  ur22 = cr22-ur12*lr21;
21140 
21141  /*
21142  * If smaller pivot < SMINI, use SMINI
21143  */
21144  if( ae_fp_less(ae_fabs(ur22, _state),smini) )
21145  {
21146  ur22 = smini;
21147  *info = 1;
21148  }
21149  if( rswap4->ptr.p_bool[icmax] )
21150  {
21151  br1 = b->ptr.pp_double[2][1];
21152  br2 = b->ptr.pp_double[1][1];
21153  }
21154  else
21155  {
21156  br1 = b->ptr.pp_double[1][1];
21157  br2 = b->ptr.pp_double[2][1];
21158  }
21159  br2 = br2-lr21*br1;
21160  bbnd = ae_maxreal(ae_fabs(br1*(ur22*ur11r), _state), ae_fabs(br2, _state), _state);
21161  if( ae_fp_greater(bbnd,1)&&ae_fp_less(ae_fabs(ur22, _state),1) )
21162  {
21163  if( ae_fp_greater_eq(bbnd,bignum*ae_fabs(ur22, _state)) )
21164  {
21165  *scl = 1/bbnd;
21166  }
21167  }
21168  xr2 = br2*(*scl)/ur22;
21169  xr1 = *scl*br1*ur11r-xr2*(ur11r*ur12);
21170  if( zswap4->ptr.p_bool[icmax] )
21171  {
21172  x->ptr.pp_double[1][1] = xr2;
21173  x->ptr.pp_double[2][1] = xr1;
21174  }
21175  else
21176  {
21177  x->ptr.pp_double[1][1] = xr1;
21178  x->ptr.pp_double[2][1] = xr2;
21179  }
21180  *xnorm = ae_maxreal(ae_fabs(xr1, _state), ae_fabs(xr2, _state), _state);
21181 
21182  /*
21183  * Further scaling if norm(A) norm(X) > overflow
21184  */
21185  if( ae_fp_greater(*xnorm,1)&&ae_fp_greater(cmax,1) )
21186  {
21187  if( ae_fp_greater(*xnorm,bignum/cmax) )
21188  {
21189  temp = cmax/bignum;
21190  x->ptr.pp_double[1][1] = temp*x->ptr.pp_double[1][1];
21191  x->ptr.pp_double[2][1] = temp*x->ptr.pp_double[2][1];
21192  *xnorm = temp*(*xnorm);
21193  *scl = temp*(*scl);
21194  }
21195  }
21196  }
21197  else
21198  {
21199 
21200  /*
21201  * Complex 2x2 system (w is complex)
21202  *
21203  * Find the largest element in C
21204  */
21205  civ4->ptr.p_double[1+0] = -wi*d1;
21206  civ4->ptr.p_double[2+0] = 0;
21207  civ4->ptr.p_double[1+2] = 0;
21208  civ4->ptr.p_double[2+2] = -wi*d2;
21209  cmax = 0;
21210  icmax = 0;
21211  for(j=1; j<=4; j++)
21212  {
21213  if( ae_fp_greater(ae_fabs(crv4->ptr.p_double[j], _state)+ae_fabs(civ4->ptr.p_double[j], _state),cmax) )
21214  {
21215  cmax = ae_fabs(crv4->ptr.p_double[j], _state)+ae_fabs(civ4->ptr.p_double[j], _state);
21216  icmax = j;
21217  }
21218  }
21219 
21220  /*
21221  * If norm(C) < SMINI, use SMINI*identity.
21222  */
21223  if( ae_fp_less(cmax,smini) )
21224  {
21225  bnorm = ae_maxreal(ae_fabs(b->ptr.pp_double[1][1], _state)+ae_fabs(b->ptr.pp_double[1][2], _state), ae_fabs(b->ptr.pp_double[2][1], _state)+ae_fabs(b->ptr.pp_double[2][2], _state), _state);
21226  if( ae_fp_less(smini,1)&&ae_fp_greater(bnorm,1) )
21227  {
21228  if( ae_fp_greater(bnorm,bignum*smini) )
21229  {
21230  *scl = 1/bnorm;
21231  }
21232  }
21233  temp = *scl/smini;
21234  x->ptr.pp_double[1][1] = temp*b->ptr.pp_double[1][1];
21235  x->ptr.pp_double[2][1] = temp*b->ptr.pp_double[2][1];
21236  x->ptr.pp_double[1][2] = temp*b->ptr.pp_double[1][2];
21237  x->ptr.pp_double[2][2] = temp*b->ptr.pp_double[2][2];
21238  *xnorm = temp*bnorm;
21239  *info = 1;
21240  return;
21241  }
21242 
21243  /*
21244  * Gaussian elimination with complete pivoting.
21245  */
21246  ur11 = crv4->ptr.p_double[icmax];
21247  ui11 = civ4->ptr.p_double[icmax];
21248  cr21 = crv4->ptr.p_double[ipivot44->ptr.pp_int[2][icmax]];
21249  ci21 = civ4->ptr.p_double[ipivot44->ptr.pp_int[2][icmax]];
21250  ur12 = crv4->ptr.p_double[ipivot44->ptr.pp_int[3][icmax]];
21251  ui12 = civ4->ptr.p_double[ipivot44->ptr.pp_int[3][icmax]];
21252  cr22 = crv4->ptr.p_double[ipivot44->ptr.pp_int[4][icmax]];
21253  ci22 = civ4->ptr.p_double[ipivot44->ptr.pp_int[4][icmax]];
21254  if( icmax==1||icmax==4 )
21255  {
21256 
21257  /*
21258  * Code when off-diagonals of pivoted C are real
21259  */
21260  if( ae_fp_greater(ae_fabs(ur11, _state),ae_fabs(ui11, _state)) )
21261  {
21262  temp = ui11/ur11;
21263  ur11r = 1/(ur11*(1+ae_sqr(temp, _state)));
21264  ui11r = -temp*ur11r;
21265  }
21266  else
21267  {
21268  temp = ur11/ui11;
21269  ui11r = -1/(ui11*(1+ae_sqr(temp, _state)));
21270  ur11r = -temp*ui11r;
21271  }
21272  lr21 = cr21*ur11r;
21273  li21 = cr21*ui11r;
21274  ur12s = ur12*ur11r;
21275  ui12s = ur12*ui11r;
21276  ur22 = cr22-ur12*lr21;
21277  ui22 = ci22-ur12*li21;
21278  }
21279  else
21280  {
21281 
21282  /*
21283  * Code when diagonals of pivoted C are real
21284  */
21285  ur11r = 1/ur11;
21286  ui11r = 0;
21287  lr21 = cr21*ur11r;
21288  li21 = ci21*ur11r;
21289  ur12s = ur12*ur11r;
21290  ui12s = ui12*ur11r;
21291  ur22 = cr22-ur12*lr21+ui12*li21;
21292  ui22 = -ur12*li21-ui12*lr21;
21293  }
21294  u22abs = ae_fabs(ur22, _state)+ae_fabs(ui22, _state);
21295 
21296  /*
21297  * If smaller pivot < SMINI, use SMINI
21298  */
21299  if( ae_fp_less(u22abs,smini) )
21300  {
21301  ur22 = smini;
21302  ui22 = 0;
21303  *info = 1;
21304  }
21305  if( rswap4->ptr.p_bool[icmax] )
21306  {
21307  br2 = b->ptr.pp_double[1][1];
21308  br1 = b->ptr.pp_double[2][1];
21309  bi2 = b->ptr.pp_double[1][2];
21310  bi1 = b->ptr.pp_double[2][2];
21311  }
21312  else
21313  {
21314  br1 = b->ptr.pp_double[1][1];
21315  br2 = b->ptr.pp_double[2][1];
21316  bi1 = b->ptr.pp_double[1][2];
21317  bi2 = b->ptr.pp_double[2][2];
21318  }
21319  br2 = br2-lr21*br1+li21*bi1;
21320  bi2 = bi2-li21*br1-lr21*bi1;
21321  bbnd = ae_maxreal((ae_fabs(br1, _state)+ae_fabs(bi1, _state))*(u22abs*(ae_fabs(ur11r, _state)+ae_fabs(ui11r, _state))), ae_fabs(br2, _state)+ae_fabs(bi2, _state), _state);
21322  if( ae_fp_greater(bbnd,1)&&ae_fp_less(u22abs,1) )
21323  {
21324  if( ae_fp_greater_eq(bbnd,bignum*u22abs) )
21325  {
21326  *scl = 1/bbnd;
21327  br1 = *scl*br1;
21328  bi1 = *scl*bi1;
21329  br2 = *scl*br2;
21330  bi2 = *scl*bi2;
21331  }
21332  }
21333  evd_internalhsevdladiv(br2, bi2, ur22, ui22, &xr2, &xi2, _state);
21334  xr1 = ur11r*br1-ui11r*bi1-ur12s*xr2+ui12s*xi2;
21335  xi1 = ui11r*br1+ur11r*bi1-ui12s*xr2-ur12s*xi2;
21336  if( zswap4->ptr.p_bool[icmax] )
21337  {
21338  x->ptr.pp_double[1][1] = xr2;
21339  x->ptr.pp_double[2][1] = xr1;
21340  x->ptr.pp_double[1][2] = xi2;
21341  x->ptr.pp_double[2][2] = xi1;
21342  }
21343  else
21344  {
21345  x->ptr.pp_double[1][1] = xr1;
21346  x->ptr.pp_double[2][1] = xr2;
21347  x->ptr.pp_double[1][2] = xi1;
21348  x->ptr.pp_double[2][2] = xi2;
21349  }
21350  *xnorm = ae_maxreal(ae_fabs(xr1, _state)+ae_fabs(xi1, _state), ae_fabs(xr2, _state)+ae_fabs(xi2, _state), _state);
21351 
21352  /*
21353  * Further scaling if norm(A) norm(X) > overflow
21354  */
21355  if( ae_fp_greater(*xnorm,1)&&ae_fp_greater(cmax,1) )
21356  {
21357  if( ae_fp_greater(*xnorm,bignum/cmax) )
21358  {
21359  temp = cmax/bignum;
21360  x->ptr.pp_double[1][1] = temp*x->ptr.pp_double[1][1];
21361  x->ptr.pp_double[2][1] = temp*x->ptr.pp_double[2][1];
21362  x->ptr.pp_double[1][2] = temp*x->ptr.pp_double[1][2];
21363  x->ptr.pp_double[2][2] = temp*x->ptr.pp_double[2][2];
21364  *xnorm = temp*(*xnorm);
21365  *scl = temp*(*scl);
21366  }
21367  }
21368  }
21369  }
21370 }
21371 
21372 
21373 /*************************************************************************
21374 performs complex division in real arithmetic
21375 
21376  a + i*b
21377  p + i*q = ---------
21378  c + i*d
21379 
21380 The algorithm is due to Robert L. Smith and can be found
21381 in D. Knuth, The art of Computer Programming, Vol.2, p.195
21382 
21383  -- LAPACK auxiliary routine (version 3.0) --
21384  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
21385  Courant Institute, Argonne National Lab, and Rice University
21386  October 31, 1992
21387 *************************************************************************/
21388 static void evd_internalhsevdladiv(double a,
21389  double b,
21390  double c,
21391  double d,
21392  double* p,
21393  double* q,
21394  ae_state *_state)
21395 {
21396  double e;
21397  double f;
21398 
21399  *p = 0;
21400  *q = 0;
21401 
21402  if( ae_fp_less(ae_fabs(d, _state),ae_fabs(c, _state)) )
21403  {
21404  e = d/c;
21405  f = c+d*e;
21406  *p = (a+b*e)/f;
21407  *q = (b-a*e)/f;
21408  }
21409  else
21410  {
21411  e = c/d;
21412  f = d+c*e;
21413  *p = (b+a*e)/f;
21414  *q = (-a+b*e)/f;
21415  }
21416 }
21417 
21418 
21419 static ae_bool evd_nonsymmetricevd(/* Real */ ae_matrix* a,
21420  ae_int_t n,
21421  ae_int_t vneeded,
21422  /* Real */ ae_vector* wr,
21423  /* Real */ ae_vector* wi,
21424  /* Real */ ae_matrix* vl,
21425  /* Real */ ae_matrix* vr,
21426  ae_state *_state)
21427 {
21428  ae_frame _frame_block;
21429  ae_matrix _a;
21430  ae_matrix s;
21431  ae_vector tau;
21432  ae_vector sel;
21433  ae_int_t i;
21434  ae_int_t info;
21435  ae_int_t m;
21436  ae_bool result;
21437 
21438  ae_frame_make(_state, &_frame_block);
21439  ae_matrix_init_copy(&_a, a, _state, ae_true);
21440  a = &_a;
21441  ae_vector_clear(wr);
21442  ae_vector_clear(wi);
21443  ae_matrix_clear(vl);
21444  ae_matrix_clear(vr);
21445  ae_matrix_init(&s, 0, 0, DT_REAL, _state, ae_true);
21446  ae_vector_init(&tau, 0, DT_REAL, _state, ae_true);
21447  ae_vector_init(&sel, 0, DT_BOOL, _state, ae_true);
21448 
21449  ae_assert(vneeded>=0&&vneeded<=3, "NonSymmetricEVD: incorrect VNeeded!", _state);
21450  if( vneeded==0 )
21451  {
21452 
21453  /*
21454  * Eigen values only
21455  */
21456  evd_toupperhessenberg(a, n, &tau, _state);
21457  internalschurdecomposition(a, n, 0, 0, wr, wi, &s, &info, _state);
21458  result = info==0;
21459  ae_frame_leave(_state);
21460  return result;
21461  }
21462 
21463  /*
21464  * Eigen values and vectors
21465  */
21466  evd_toupperhessenberg(a, n, &tau, _state);
21467  evd_unpackqfromupperhessenberg(a, n, &tau, &s, _state);
21468  internalschurdecomposition(a, n, 1, 1, wr, wi, &s, &info, _state);
21469  result = info==0;
21470  if( !result )
21471  {
21472  ae_frame_leave(_state);
21473  return result;
21474  }
21475  if( vneeded==1||vneeded==3 )
21476  {
21477  ae_matrix_set_length(vr, n+1, n+1, _state);
21478  for(i=1; i<=n; i++)
21479  {
21480  ae_v_move(&vr->ptr.pp_double[i][1], 1, &s.ptr.pp_double[i][1], 1, ae_v_len(1,n));
21481  }
21482  }
21483  if( vneeded==2||vneeded==3 )
21484  {
21485  ae_matrix_set_length(vl, n+1, n+1, _state);
21486  for(i=1; i<=n; i++)
21487  {
21488  ae_v_move(&vl->ptr.pp_double[i][1], 1, &s.ptr.pp_double[i][1], 1, ae_v_len(1,n));
21489  }
21490  }
21491  evd_internaltrevc(a, n, vneeded, 1, &sel, vl, vr, &m, &info, _state);
21492  result = info==0;
21493  ae_frame_leave(_state);
21494  return result;
21495 }
21496 
21497 
21498 static void evd_toupperhessenberg(/* Real */ ae_matrix* a,
21499  ae_int_t n,
21500  /* Real */ ae_vector* tau,
21501  ae_state *_state)
21502 {
21503  ae_frame _frame_block;
21504  ae_int_t i;
21505  ae_int_t ip1;
21506  ae_int_t nmi;
21507  double v;
21508  ae_vector t;
21509  ae_vector work;
21510 
21511  ae_frame_make(_state, &_frame_block);
21512  ae_vector_clear(tau);
21513  ae_vector_init(&t, 0, DT_REAL, _state, ae_true);
21514  ae_vector_init(&work, 0, DT_REAL, _state, ae_true);
21515 
21516  ae_assert(n>=0, "ToUpperHessenberg: incorrect N!", _state);
21517 
21518  /*
21519  * Quick return if possible
21520  */
21521  if( n<=1 )
21522  {
21523  ae_frame_leave(_state);
21524  return;
21525  }
21526  ae_vector_set_length(tau, n-1+1, _state);
21527  ae_vector_set_length(&t, n+1, _state);
21528  ae_vector_set_length(&work, n+1, _state);
21529  for(i=1; i<=n-1; i++)
21530  {
21531 
21532  /*
21533  * Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
21534  */
21535  ip1 = i+1;
21536  nmi = n-i;
21537  ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[ip1][i], a->stride, ae_v_len(1,nmi));
21538  generatereflection(&t, nmi, &v, _state);
21539  ae_v_move(&a->ptr.pp_double[ip1][i], a->stride, &t.ptr.p_double[1], 1, ae_v_len(ip1,n));
21540  tau->ptr.p_double[i] = v;
21541  t.ptr.p_double[1] = 1;
21542 
21543  /*
21544  * Apply H(i) to A(1:ihi,i+1:ihi) from the right
21545  */
21546  applyreflectionfromtheright(a, v, &t, 1, n, i+1, n, &work, _state);
21547 
21548  /*
21549  * Apply H(i) to A(i+1:ihi,i+1:n) from the left
21550  */
21551  applyreflectionfromtheleft(a, v, &t, i+1, n, i+1, n, &work, _state);
21552  }
21553  ae_frame_leave(_state);
21554 }
21555 
21556 
21557 static void evd_unpackqfromupperhessenberg(/* Real */ ae_matrix* a,
21558  ae_int_t n,
21559  /* Real */ ae_vector* tau,
21560  /* Real */ ae_matrix* q,
21561  ae_state *_state)
21562 {
21563  ae_frame _frame_block;
21564  ae_int_t i;
21565  ae_int_t j;
21566  ae_vector v;
21567  ae_vector work;
21568  ae_int_t ip1;
21569  ae_int_t nmi;
21570 
21571  ae_frame_make(_state, &_frame_block);
21572  ae_matrix_clear(q);
21573  ae_vector_init(&v, 0, DT_REAL, _state, ae_true);
21574  ae_vector_init(&work, 0, DT_REAL, _state, ae_true);
21575 
21576  if( n==0 )
21577  {
21578  ae_frame_leave(_state);
21579  return;
21580  }
21581 
21582  /*
21583  * init
21584  */
21585  ae_matrix_set_length(q, n+1, n+1, _state);
21586  ae_vector_set_length(&v, n+1, _state);
21587  ae_vector_set_length(&work, n+1, _state);
21588  for(i=1; i<=n; i++)
21589  {
21590  for(j=1; j<=n; j++)
21591  {
21592  if( i==j )
21593  {
21594  q->ptr.pp_double[i][j] = 1;
21595  }
21596  else
21597  {
21598  q->ptr.pp_double[i][j] = 0;
21599  }
21600  }
21601  }
21602 
21603  /*
21604  * unpack Q
21605  */
21606  for(i=1; i<=n-1; i++)
21607  {
21608 
21609  /*
21610  * Apply H(i)
21611  */
21612  ip1 = i+1;
21613  nmi = n-i;
21614  ae_v_move(&v.ptr.p_double[1], 1, &a->ptr.pp_double[ip1][i], a->stride, ae_v_len(1,nmi));
21615  v.ptr.p_double[1] = 1;
21616  applyreflectionfromtheright(q, tau->ptr.p_double[i], &v, 1, n, i+1, n, &work, _state);
21617  }
21618  ae_frame_leave(_state);
21619 }
21620 
21621 
21622 
21623 
21624 /*************************************************************************
21625 Generation of a random uniformly distributed (Haar) orthogonal matrix
21626 
21627 INPUT PARAMETERS:
21628  N - matrix size, N>=1
21629 
21630 OUTPUT PARAMETERS:
21631  A - orthogonal NxN matrix, array[0..N-1,0..N-1]
21632 
21633  -- ALGLIB routine --
21634  04.12.2009
21635  Bochkanov Sergey
21636 *************************************************************************/
21637 void rmatrixrndorthogonal(ae_int_t n,
21638  /* Real */ ae_matrix* a,
21639  ae_state *_state)
21640 {
21641  ae_int_t i;
21642  ae_int_t j;
21643 
21644  ae_matrix_clear(a);
21645 
21646  ae_assert(n>=1, "RMatrixRndOrthogonal: N<1!", _state);
21647  ae_matrix_set_length(a, n, n, _state);
21648  for(i=0; i<=n-1; i++)
21649  {
21650  for(j=0; j<=n-1; j++)
21651  {
21652  if( i==j )
21653  {
21654  a->ptr.pp_double[i][j] = 1;
21655  }
21656  else
21657  {
21658  a->ptr.pp_double[i][j] = 0;
21659  }
21660  }
21661  }
21662  rmatrixrndorthogonalfromtheright(a, n, n, _state);
21663 }
21664 
21665 
21666 /*************************************************************************
21667 Generation of random NxN matrix with given condition number and norm2(A)=1
21668 
21669 INPUT PARAMETERS:
21670  N - matrix size
21671  C - condition number (in 2-norm)
21672 
21673 OUTPUT PARAMETERS:
21674  A - random matrix with norm2(A)=1 and cond(A)=C
21675 
21676  -- ALGLIB routine --
21677  04.12.2009
21678  Bochkanov Sergey
21679 *************************************************************************/
21680 void rmatrixrndcond(ae_int_t n,
21681  double c,
21682  /* Real */ ae_matrix* a,
21683  ae_state *_state)
21684 {
21685  ae_frame _frame_block;
21686  ae_int_t i;
21687  ae_int_t j;
21688  double l1;
21689  double l2;
21690  hqrndstate rs;
21691 
21692  ae_frame_make(_state, &_frame_block);
21693  ae_matrix_clear(a);
21694  _hqrndstate_init(&rs, _state, ae_true);
21695 
21696  ae_assert(n>=1&&ae_fp_greater_eq(c,1), "RMatrixRndCond: N<1 or C<1!", _state);
21697  ae_matrix_set_length(a, n, n, _state);
21698  if( n==1 )
21699  {
21700 
21701  /*
21702  * special case
21703  */
21704  a->ptr.pp_double[0][0] = 2*ae_randominteger(2, _state)-1;
21705  ae_frame_leave(_state);
21706  return;
21707  }
21708  hqrndrandomize(&rs, _state);
21709  l1 = 0;
21710  l2 = ae_log(1/c, _state);
21711  for(i=0; i<=n-1; i++)
21712  {
21713  for(j=0; j<=n-1; j++)
21714  {
21715  a->ptr.pp_double[i][j] = 0;
21716  }
21717  }
21718  a->ptr.pp_double[0][0] = ae_exp(l1, _state);
21719  for(i=1; i<=n-2; i++)
21720  {
21721  a->ptr.pp_double[i][i] = ae_exp(hqrnduniformr(&rs, _state)*(l2-l1)+l1, _state);
21722  }
21723  a->ptr.pp_double[n-1][n-1] = ae_exp(l2, _state);
21724  rmatrixrndorthogonalfromtheleft(a, n, n, _state);
21725  rmatrixrndorthogonalfromtheright(a, n, n, _state);
21726  ae_frame_leave(_state);
21727 }
21728 
21729 
21730 /*************************************************************************
21731 Generation of a random Haar distributed orthogonal complex matrix
21732 
21733 INPUT PARAMETERS:
21734  N - matrix size, N>=1
21735 
21736 OUTPUT PARAMETERS:
21737  A - orthogonal NxN matrix, array[0..N-1,0..N-1]
21738 
21739  -- ALGLIB routine --
21740  04.12.2009
21741  Bochkanov Sergey
21742 *************************************************************************/
21743 void cmatrixrndorthogonal(ae_int_t n,
21744  /* Complex */ ae_matrix* a,
21745  ae_state *_state)
21746 {
21747  ae_int_t i;
21748  ae_int_t j;
21749 
21750  ae_matrix_clear(a);
21751 
21752  ae_assert(n>=1, "CMatrixRndOrthogonal: N<1!", _state);
21753  ae_matrix_set_length(a, n, n, _state);
21754  for(i=0; i<=n-1; i++)
21755  {
21756  for(j=0; j<=n-1; j++)
21757  {
21758  if( i==j )
21759  {
21760  a->ptr.pp_complex[i][j] = ae_complex_from_d(1);
21761  }
21762  else
21763  {
21764  a->ptr.pp_complex[i][j] = ae_complex_from_d(0);
21765  }
21766  }
21767  }
21768  cmatrixrndorthogonalfromtheright(a, n, n, _state);
21769 }
21770 
21771 
21772 /*************************************************************************
21773 Generation of random NxN complex matrix with given condition number C and
21774 norm2(A)=1
21775 
21776 INPUT PARAMETERS:
21777  N - matrix size
21778  C - condition number (in 2-norm)
21779 
21780 OUTPUT PARAMETERS:
21781  A - random matrix with norm2(A)=1 and cond(A)=C
21782 
21783  -- ALGLIB routine --
21784  04.12.2009
21785  Bochkanov Sergey
21786 *************************************************************************/
21787 void cmatrixrndcond(ae_int_t n,
21788  double c,
21789  /* Complex */ ae_matrix* a,
21790  ae_state *_state)
21791 {
21792  ae_frame _frame_block;
21793  ae_int_t i;
21794  ae_int_t j;
21795  double l1;
21796  double l2;
21797  hqrndstate state;
21798  ae_complex v;
21799 
21800  ae_frame_make(_state, &_frame_block);
21801  ae_matrix_clear(a);
21802  _hqrndstate_init(&state, _state, ae_true);
21803 
21804  ae_assert(n>=1&&ae_fp_greater_eq(c,1), "CMatrixRndCond: N<1 or C<1!", _state);
21805  ae_matrix_set_length(a, n, n, _state);
21806  if( n==1 )
21807  {
21808 
21809  /*
21810  * special case
21811  */
21812  hqrndrandomize(&state, _state);
21813  hqrndunit2(&state, &v.x, &v.y, _state);
21814  a->ptr.pp_complex[0][0] = v;
21815  ae_frame_leave(_state);
21816  return;
21817  }
21818  hqrndrandomize(&state, _state);
21819  l1 = 0;
21820  l2 = ae_log(1/c, _state);
21821  for(i=0; i<=n-1; i++)
21822  {
21823  for(j=0; j<=n-1; j++)
21824  {
21825  a->ptr.pp_complex[i][j] = ae_complex_from_d(0);
21826  }
21827  }
21828  a->ptr.pp_complex[0][0] = ae_complex_from_d(ae_exp(l1, _state));
21829  for(i=1; i<=n-2; i++)
21830  {
21831  a->ptr.pp_complex[i][i] = ae_complex_from_d(ae_exp(hqrnduniformr(&state, _state)*(l2-l1)+l1, _state));
21832  }
21833  a->ptr.pp_complex[n-1][n-1] = ae_complex_from_d(ae_exp(l2, _state));
21834  cmatrixrndorthogonalfromtheleft(a, n, n, _state);
21835  cmatrixrndorthogonalfromtheright(a, n, n, _state);
21836  ae_frame_leave(_state);
21837 }
21838 
21839 
21840 /*************************************************************************
21841 Generation of random NxN symmetric matrix with given condition number and
21842 norm2(A)=1
21843 
21844 INPUT PARAMETERS:
21845  N - matrix size
21846  C - condition number (in 2-norm)
21847 
21848 OUTPUT PARAMETERS:
21849  A - random matrix with norm2(A)=1 and cond(A)=C
21850 
21851  -- ALGLIB routine --
21852  04.12.2009
21853  Bochkanov Sergey
21854 *************************************************************************/
21855 void smatrixrndcond(ae_int_t n,
21856  double c,
21857  /* Real */ ae_matrix* a,
21858  ae_state *_state)
21859 {
21860  ae_frame _frame_block;
21861  ae_int_t i;
21862  ae_int_t j;
21863  double l1;
21864  double l2;
21865  hqrndstate rs;
21866 
21867  ae_frame_make(_state, &_frame_block);
21868  ae_matrix_clear(a);
21869  _hqrndstate_init(&rs, _state, ae_true);
21870 
21871  ae_assert(n>=1&&ae_fp_greater_eq(c,1), "SMatrixRndCond: N<1 or C<1!", _state);
21872  ae_matrix_set_length(a, n, n, _state);
21873  if( n==1 )
21874  {
21875 
21876  /*
21877  * special case
21878  */
21879  a->ptr.pp_double[0][0] = 2*ae_randominteger(2, _state)-1;
21880  ae_frame_leave(_state);
21881  return;
21882  }
21883 
21884  /*
21885  * Prepare matrix
21886  */
21887  hqrndrandomize(&rs, _state);
21888  l1 = 0;
21889  l2 = ae_log(1/c, _state);
21890  for(i=0; i<=n-1; i++)
21891  {
21892  for(j=0; j<=n-1; j++)
21893  {
21894  a->ptr.pp_double[i][j] = 0;
21895  }
21896  }
21897  a->ptr.pp_double[0][0] = ae_exp(l1, _state);
21898  for(i=1; i<=n-2; i++)
21899  {
21900  a->ptr.pp_double[i][i] = (2*hqrnduniformi(&rs, 2, _state)-1)*ae_exp(hqrnduniformr(&rs, _state)*(l2-l1)+l1, _state);
21901  }
21902  a->ptr.pp_double[n-1][n-1] = ae_exp(l2, _state);
21903 
21904  /*
21905  * Multiply
21906  */
21907  smatrixrndmultiply(a, n, _state);
21908  ae_frame_leave(_state);
21909 }
21910 
21911 
21912 /*************************************************************************
21913 Generation of random NxN symmetric positive definite matrix with given
21914 condition number and norm2(A)=1
21915 
21916 INPUT PARAMETERS:
21917  N - matrix size
21918  C - condition number (in 2-norm)
21919 
21920 OUTPUT PARAMETERS:
21921  A - random SPD matrix with norm2(A)=1 and cond(A)=C
21922 
21923  -- ALGLIB routine --
21924  04.12.2009
21925  Bochkanov Sergey
21926 *************************************************************************/
21927 void spdmatrixrndcond(ae_int_t n,
21928  double c,
21929  /* Real */ ae_matrix* a,
21930  ae_state *_state)
21931 {
21932  ae_frame _frame_block;
21933  ae_int_t i;
21934  ae_int_t j;
21935  double l1;
21936  double l2;
21937  hqrndstate rs;
21938 
21939  ae_frame_make(_state, &_frame_block);
21940  ae_matrix_clear(a);
21941  _hqrndstate_init(&rs, _state, ae_true);
21942 
21943 
21944  /*
21945  * Special cases
21946  */
21947  if( n<=0||ae_fp_less(c,1) )
21948  {
21949  ae_frame_leave(_state);
21950  return;
21951  }
21952  ae_matrix_set_length(a, n, n, _state);
21953  if( n==1 )
21954  {
21955  a->ptr.pp_double[0][0] = 1;
21956  ae_frame_leave(_state);
21957  return;
21958  }
21959 
21960  /*
21961  * Prepare matrix
21962  */
21963  hqrndrandomize(&rs, _state);
21964  l1 = 0;
21965  l2 = ae_log(1/c, _state);
21966  for(i=0; i<=n-1; i++)
21967  {
21968  for(j=0; j<=n-1; j++)
21969  {
21970  a->ptr.pp_double[i][j] = 0;
21971  }
21972  }
21973  a->ptr.pp_double[0][0] = ae_exp(l1, _state);
21974  for(i=1; i<=n-2; i++)
21975  {
21976  a->ptr.pp_double[i][i] = ae_exp(hqrnduniformr(&rs, _state)*(l2-l1)+l1, _state);
21977  }
21978  a->ptr.pp_double[n-1][n-1] = ae_exp(l2, _state);
21979 
21980  /*
21981  * Multiply
21982  */
21983  smatrixrndmultiply(a, n, _state);
21984  ae_frame_leave(_state);
21985 }
21986 
21987 
21988 /*************************************************************************
21989 Generation of random NxN Hermitian matrix with given condition number and
21990 norm2(A)=1
21991 
21992 INPUT PARAMETERS:
21993  N - matrix size
21994  C - condition number (in 2-norm)
21995 
21996 OUTPUT PARAMETERS:
21997  A - random matrix with norm2(A)=1 and cond(A)=C
21998 
21999  -- ALGLIB routine --
22000  04.12.2009
22001  Bochkanov Sergey
22002 *************************************************************************/
22003 void hmatrixrndcond(ae_int_t n,
22004  double c,
22005  /* Complex */ ae_matrix* a,
22006  ae_state *_state)
22007 {
22008  ae_frame _frame_block;
22009  ae_int_t i;
22010  ae_int_t j;
22011  double l1;
22012  double l2;
22013  hqrndstate rs;
22014 
22015  ae_frame_make(_state, &_frame_block);
22016  ae_matrix_clear(a);
22017  _hqrndstate_init(&rs, _state, ae_true);
22018 
22019  ae_assert(n>=1&&ae_fp_greater_eq(c,1), "HMatrixRndCond: N<1 or C<1!", _state);
22020  ae_matrix_set_length(a, n, n, _state);
22021  if( n==1 )
22022  {
22023 
22024  /*
22025  * special case
22026  */
22027  a->ptr.pp_complex[0][0] = ae_complex_from_d(2*ae_randominteger(2, _state)-1);
22028  ae_frame_leave(_state);
22029  return;
22030  }
22031 
22032  /*
22033  * Prepare matrix
22034  */
22035  hqrndrandomize(&rs, _state);
22036  l1 = 0;
22037  l2 = ae_log(1/c, _state);
22038  for(i=0; i<=n-1; i++)
22039  {
22040  for(j=0; j<=n-1; j++)
22041  {
22042  a->ptr.pp_complex[i][j] = ae_complex_from_d(0);
22043  }
22044  }
22045  a->ptr.pp_complex[0][0] = ae_complex_from_d(ae_exp(l1, _state));
22046  for(i=1; i<=n-2; i++)
22047  {
22048  a->ptr.pp_complex[i][i] = ae_complex_from_d((2*hqrnduniformi(&rs, 2, _state)-1)*ae_exp(hqrnduniformr(&rs, _state)*(l2-l1)+l1, _state));
22049  }
22050  a->ptr.pp_complex[n-1][n-1] = ae_complex_from_d(ae_exp(l2, _state));
22051 
22052  /*
22053  * Multiply
22054  */
22055  hmatrixrndmultiply(a, n, _state);
22056 
22057  /*
22058  * post-process to ensure that matrix diagonal is real
22059  */
22060  for(i=0; i<=n-1; i++)
22061  {
22062  a->ptr.pp_complex[i][i].y = 0;
22063  }
22064  ae_frame_leave(_state);
22065 }
22066 
22067 
22068 /*************************************************************************
22069 Generation of random NxN Hermitian positive definite matrix with given
22070 condition number and norm2(A)=1
22071 
22072 INPUT PARAMETERS:
22073  N - matrix size
22074  C - condition number (in 2-norm)
22075 
22076 OUTPUT PARAMETERS:
22077  A - random HPD matrix with norm2(A)=1 and cond(A)=C
22078 
22079  -- ALGLIB routine --
22080  04.12.2009
22081  Bochkanov Sergey
22082 *************************************************************************/
22083 void hpdmatrixrndcond(ae_int_t n,
22084  double c,
22085  /* Complex */ ae_matrix* a,
22086  ae_state *_state)
22087 {
22088  ae_frame _frame_block;
22089  ae_int_t i;
22090  ae_int_t j;
22091  double l1;
22092  double l2;
22093  hqrndstate rs;
22094 
22095  ae_frame_make(_state, &_frame_block);
22096  ae_matrix_clear(a);
22097  _hqrndstate_init(&rs, _state, ae_true);
22098 
22099 
22100  /*
22101  * Special cases
22102  */
22103  if( n<=0||ae_fp_less(c,1) )
22104  {
22105  ae_frame_leave(_state);
22106  return;
22107  }
22108  ae_matrix_set_length(a, n, n, _state);
22109  if( n==1 )
22110  {
22111  a->ptr.pp_complex[0][0] = ae_complex_from_d(1);
22112  ae_frame_leave(_state);
22113  return;
22114  }
22115 
22116  /*
22117  * Prepare matrix
22118  */
22119  hqrndrandomize(&rs, _state);
22120  l1 = 0;
22121  l2 = ae_log(1/c, _state);
22122  for(i=0; i<=n-1; i++)
22123  {
22124  for(j=0; j<=n-1; j++)
22125  {
22126  a->ptr.pp_complex[i][j] = ae_complex_from_d(0);
22127  }
22128  }
22129  a->ptr.pp_complex[0][0] = ae_complex_from_d(ae_exp(l1, _state));
22130  for(i=1; i<=n-2; i++)
22131  {
22132  a->ptr.pp_complex[i][i] = ae_complex_from_d(ae_exp(hqrnduniformr(&rs, _state)*(l2-l1)+l1, _state));
22133  }
22134  a->ptr.pp_complex[n-1][n-1] = ae_complex_from_d(ae_exp(l2, _state));
22135 
22136  /*
22137  * Multiply
22138  */
22139  hmatrixrndmultiply(a, n, _state);
22140 
22141  /*
22142  * post-process to ensure that matrix diagonal is real
22143  */
22144  for(i=0; i<=n-1; i++)
22145  {
22146  a->ptr.pp_complex[i][i].y = 0;
22147  }
22148  ae_frame_leave(_state);
22149 }
22150 
22151 
22152 /*************************************************************************
22153 Multiplication of MxN matrix by NxN random Haar distributed orthogonal matrix
22154 
22155 INPUT PARAMETERS:
22156  A - matrix, array[0..M-1, 0..N-1]
22157  M, N- matrix size
22158 
22159 OUTPUT PARAMETERS:
22160  A - A*Q, where Q is random NxN orthogonal matrix
22161 
22162  -- ALGLIB routine --
22163  04.12.2009
22164  Bochkanov Sergey
22165 *************************************************************************/
22166 void rmatrixrndorthogonalfromtheright(/* Real */ ae_matrix* a,
22167  ae_int_t m,
22168  ae_int_t n,
22169  ae_state *_state)
22170 {
22171  ae_frame _frame_block;
22172  double tau;
22173  double lambdav;
22174  ae_int_t s;
22175  ae_int_t i;
22176  double u1;
22177  double u2;
22178  ae_vector w;
22179  ae_vector v;
22180  hqrndstate state;
22181 
22182  ae_frame_make(_state, &_frame_block);
22183  ae_vector_init(&w, 0, DT_REAL, _state, ae_true);
22184  ae_vector_init(&v, 0, DT_REAL, _state, ae_true);
22185  _hqrndstate_init(&state, _state, ae_true);
22186 
22187  ae_assert(n>=1&&m>=1, "RMatrixRndOrthogonalFromTheRight: N<1 or M<1!", _state);
22188  if( n==1 )
22189  {
22190 
22191  /*
22192  * Special case
22193  */
22194  tau = 2*ae_randominteger(2, _state)-1;
22195  for(i=0; i<=m-1; i++)
22196  {
22197  a->ptr.pp_double[i][0] = a->ptr.pp_double[i][0]*tau;
22198  }
22199  ae_frame_leave(_state);
22200  return;
22201  }
22202 
22203  /*
22204  * General case.
22205  * First pass.
22206  */
22207  ae_vector_set_length(&w, m, _state);
22208  ae_vector_set_length(&v, n+1, _state);
22209  hqrndrandomize(&state, _state);
22210  for(s=2; s<=n; s++)
22211  {
22212 
22213  /*
22214  * Prepare random normal v
22215  */
22216  do
22217  {
22218  i = 1;
22219  while(i<=s)
22220  {
22221  hqrndnormal2(&state, &u1, &u2, _state);
22222  v.ptr.p_double[i] = u1;
22223  if( i+1<=s )
22224  {
22225  v.ptr.p_double[i+1] = u2;
22226  }
22227  i = i+2;
22228  }
22229  lambdav = ae_v_dotproduct(&v.ptr.p_double[1], 1, &v.ptr.p_double[1], 1, ae_v_len(1,s));
22230  }
22231  while(ae_fp_eq(lambdav,0));
22232 
22233  /*
22234  * Prepare and apply reflection
22235  */
22236  generatereflection(&v, s, &tau, _state);
22237  v.ptr.p_double[1] = 1;
22238  applyreflectionfromtheright(a, tau, &v, 0, m-1, n-s, n-1, &w, _state);
22239  }
22240 
22241  /*
22242  * Second pass.
22243  */
22244  for(i=0; i<=n-1; i++)
22245  {
22246  tau = 2*hqrnduniformi(&state, 2, _state)-1;
22247  ae_v_muld(&a->ptr.pp_double[0][i], a->stride, ae_v_len(0,m-1), tau);
22248  }
22249  ae_frame_leave(_state);
22250 }
22251 
22252 
22253 /*************************************************************************
22254 Multiplication of MxN matrix by MxM random Haar distributed orthogonal matrix
22255 
22256 INPUT PARAMETERS:
22257  A - matrix, array[0..M-1, 0..N-1]
22258  M, N- matrix size
22259 
22260 OUTPUT PARAMETERS:
22261  A - Q*A, where Q is random MxM orthogonal matrix
22262 
22263  -- ALGLIB routine --
22264  04.12.2009
22265  Bochkanov Sergey
22266 *************************************************************************/
22267 void rmatrixrndorthogonalfromtheleft(/* Real */ ae_matrix* a,
22268  ae_int_t m,
22269  ae_int_t n,
22270  ae_state *_state)
22271 {
22272  ae_frame _frame_block;
22273  double tau;
22274  double lambdav;
22275  ae_int_t s;
22276  ae_int_t i;
22277  ae_int_t j;
22278  double u1;
22279  double u2;
22280  ae_vector w;
22281  ae_vector v;
22282  hqrndstate state;
22283 
22284  ae_frame_make(_state, &_frame_block);
22285  ae_vector_init(&w, 0, DT_REAL, _state, ae_true);
22286  ae_vector_init(&v, 0, DT_REAL, _state, ae_true);
22287  _hqrndstate_init(&state, _state, ae_true);
22288 
22289  ae_assert(n>=1&&m>=1, "RMatrixRndOrthogonalFromTheRight: N<1 or M<1!", _state);
22290  if( m==1 )
22291  {
22292 
22293  /*
22294  * special case
22295  */
22296  tau = 2*ae_randominteger(2, _state)-1;
22297  for(j=0; j<=n-1; j++)
22298  {
22299  a->ptr.pp_double[0][j] = a->ptr.pp_double[0][j]*tau;
22300  }
22301  ae_frame_leave(_state);
22302  return;
22303  }
22304 
22305  /*
22306  * General case.
22307  * First pass.
22308  */
22309  ae_vector_set_length(&w, n, _state);
22310  ae_vector_set_length(&v, m+1, _state);
22311  hqrndrandomize(&state, _state);
22312  for(s=2; s<=m; s++)
22313  {
22314 
22315  /*
22316  * Prepare random normal v
22317  */
22318  do
22319  {
22320  i = 1;
22321  while(i<=s)
22322  {
22323  hqrndnormal2(&state, &u1, &u2, _state);
22324  v.ptr.p_double[i] = u1;
22325  if( i+1<=s )
22326  {
22327  v.ptr.p_double[i+1] = u2;
22328  }
22329  i = i+2;
22330  }
22331  lambdav = ae_v_dotproduct(&v.ptr.p_double[1], 1, &v.ptr.p_double[1], 1, ae_v_len(1,s));
22332  }
22333  while(ae_fp_eq(lambdav,0));
22334 
22335  /*
22336  * Prepare and apply reflection
22337  */
22338  generatereflection(&v, s, &tau, _state);
22339  v.ptr.p_double[1] = 1;
22340  applyreflectionfromtheleft(a, tau, &v, m-s, m-1, 0, n-1, &w, _state);
22341  }
22342 
22343  /*
22344  * Second pass.
22345  */
22346  for(i=0; i<=m-1; i++)
22347  {
22348  tau = 2*hqrnduniformi(&state, 2, _state)-1;
22349  ae_v_muld(&a->ptr.pp_double[i][0], 1, ae_v_len(0,n-1), tau);
22350  }
22351  ae_frame_leave(_state);
22352 }
22353 
22354 
22355 /*************************************************************************
22356 Multiplication of MxN complex matrix by NxN random Haar distributed
22357 complex orthogonal matrix
22358 
22359 INPUT PARAMETERS:
22360  A - matrix, array[0..M-1, 0..N-1]
22361  M, N- matrix size
22362 
22363 OUTPUT PARAMETERS:
22364  A - A*Q, where Q is random NxN orthogonal matrix
22365 
22366  -- ALGLIB routine --
22367  04.12.2009
22368  Bochkanov Sergey
22369 *************************************************************************/
22370 void cmatrixrndorthogonalfromtheright(/* Complex */ ae_matrix* a,
22371  ae_int_t m,
22372  ae_int_t n,
22373  ae_state *_state)
22374 {
22375  ae_frame _frame_block;
22376  ae_complex lambdav;
22377  ae_complex tau;
22378  ae_int_t s;
22379  ae_int_t i;
22380  ae_vector w;
22381  ae_vector v;
22382  hqrndstate state;
22383 
22384  ae_frame_make(_state, &_frame_block);
22385  ae_vector_init(&w, 0, DT_COMPLEX, _state, ae_true);
22386  ae_vector_init(&v, 0, DT_COMPLEX, _state, ae_true);
22387  _hqrndstate_init(&state, _state, ae_true);
22388 
22389  ae_assert(n>=1&&m>=1, "CMatrixRndOrthogonalFromTheRight: N<1 or M<1!", _state);
22390  if( n==1 )
22391  {
22392 
22393  /*
22394  * Special case
22395  */
22396  hqrndrandomize(&state, _state);
22397  hqrndunit2(&state, &tau.x, &tau.y, _state);
22398  for(i=0; i<=m-1; i++)
22399  {
22400  a->ptr.pp_complex[i][0] = ae_c_mul(a->ptr.pp_complex[i][0],tau);
22401  }
22402  ae_frame_leave(_state);
22403  return;
22404  }
22405 
22406  /*
22407  * General case.
22408  * First pass.
22409  */
22410  ae_vector_set_length(&w, m, _state);
22411  ae_vector_set_length(&v, n+1, _state);
22412  hqrndrandomize(&state, _state);
22413  for(s=2; s<=n; s++)
22414  {
22415 
22416  /*
22417  * Prepare random normal v
22418  */
22419  do
22420  {
22421  for(i=1; i<=s; i++)
22422  {
22423  hqrndnormal2(&state, &tau.x, &tau.y, _state);
22424  v.ptr.p_complex[i] = tau;
22425  }
22426  lambdav = ae_v_cdotproduct(&v.ptr.p_complex[1], 1, "N", &v.ptr.p_complex[1], 1, "Conj", ae_v_len(1,s));
22427  }
22428  while(ae_c_eq_d(lambdav,0));
22429 
22430  /*
22431  * Prepare and apply reflection
22432  */
22433  complexgeneratereflection(&v, s, &tau, _state);
22434  v.ptr.p_complex[1] = ae_complex_from_d(1);
22435  complexapplyreflectionfromtheright(a, tau, &v, 0, m-1, n-s, n-1, &w, _state);
22436  }
22437 
22438  /*
22439  * Second pass.
22440  */
22441  for(i=0; i<=n-1; i++)
22442  {
22443  hqrndunit2(&state, &tau.x, &tau.y, _state);
22444  ae_v_cmulc(&a->ptr.pp_complex[0][i], a->stride, ae_v_len(0,m-1), tau);
22445  }
22446  ae_frame_leave(_state);
22447 }
22448 
22449 
22450 /*************************************************************************
22451 Multiplication of MxN complex matrix by MxM random Haar distributed
22452 complex orthogonal matrix
22453 
22454 INPUT PARAMETERS:
22455  A - matrix, array[0..M-1, 0..N-1]
22456  M, N- matrix size
22457 
22458 OUTPUT PARAMETERS:
22459  A - Q*A, where Q is random MxM orthogonal matrix
22460 
22461  -- ALGLIB routine --
22462  04.12.2009
22463  Bochkanov Sergey
22464 *************************************************************************/
22465 void cmatrixrndorthogonalfromtheleft(/* Complex */ ae_matrix* a,
22466  ae_int_t m,
22467  ae_int_t n,
22468  ae_state *_state)
22469 {
22470  ae_frame _frame_block;
22471  ae_complex tau;
22472  ae_complex lambdav;
22473  ae_int_t s;
22474  ae_int_t i;
22475  ae_int_t j;
22476  ae_vector w;
22477  ae_vector v;
22478  hqrndstate state;
22479 
22480  ae_frame_make(_state, &_frame_block);
22481  ae_vector_init(&w, 0, DT_COMPLEX, _state, ae_true);
22482  ae_vector_init(&v, 0, DT_COMPLEX, _state, ae_true);
22483  _hqrndstate_init(&state, _state, ae_true);
22484 
22485  ae_assert(n>=1&&m>=1, "CMatrixRndOrthogonalFromTheRight: N<1 or M<1!", _state);
22486  if( m==1 )
22487  {
22488 
22489  /*
22490  * special case
22491  */
22492  hqrndrandomize(&state, _state);
22493  hqrndunit2(&state, &tau.x, &tau.y, _state);
22494  for(j=0; j<=n-1; j++)
22495  {
22496  a->ptr.pp_complex[0][j] = ae_c_mul(a->ptr.pp_complex[0][j],tau);
22497  }
22498  ae_frame_leave(_state);
22499  return;
22500  }
22501 
22502  /*
22503  * General case.
22504  * First pass.
22505  */
22506  ae_vector_set_length(&w, n, _state);
22507  ae_vector_set_length(&v, m+1, _state);
22508  hqrndrandomize(&state, _state);
22509  for(s=2; s<=m; s++)
22510  {
22511 
22512  /*
22513  * Prepare random normal v
22514  */
22515  do
22516  {
22517  for(i=1; i<=s; i++)
22518  {
22519  hqrndnormal2(&state, &tau.x, &tau.y, _state);
22520  v.ptr.p_complex[i] = tau;
22521  }
22522  lambdav = ae_v_cdotproduct(&v.ptr.p_complex[1], 1, "N", &v.ptr.p_complex[1], 1, "Conj", ae_v_len(1,s));
22523  }
22524  while(ae_c_eq_d(lambdav,0));
22525 
22526  /*
22527  * Prepare and apply reflection
22528  */
22529  complexgeneratereflection(&v, s, &tau, _state);
22530  v.ptr.p_complex[1] = ae_complex_from_d(1);
22531  complexapplyreflectionfromtheleft(a, tau, &v, m-s, m-1, 0, n-1, &w, _state);
22532  }
22533 
22534  /*
22535  * Second pass.
22536  */
22537  for(i=0; i<=m-1; i++)
22538  {
22539  hqrndunit2(&state, &tau.x, &tau.y, _state);
22540  ae_v_cmulc(&a->ptr.pp_complex[i][0], 1, ae_v_len(0,n-1), tau);
22541  }
22542  ae_frame_leave(_state);
22543 }
22544 
22545 
22546 /*************************************************************************
22547 Symmetric multiplication of NxN matrix by random Haar distributed
22548 orthogonal matrix
22549 
22550 INPUT PARAMETERS:
22551  A - matrix, array[0..N-1, 0..N-1]
22552  N - matrix size
22553 
22554 OUTPUT PARAMETERS:
22555  A - Q'*A*Q, where Q is random NxN orthogonal matrix
22556 
22557  -- ALGLIB routine --
22558  04.12.2009
22559  Bochkanov Sergey
22560 *************************************************************************/
22561 void smatrixrndmultiply(/* Real */ ae_matrix* a,
22562  ae_int_t n,
22563  ae_state *_state)
22564 {
22565  ae_frame _frame_block;
22566  double tau;
22567  double lambdav;
22568  ae_int_t s;
22569  ae_int_t i;
22570  double u1;
22571  double u2;
22572  ae_vector w;
22573  ae_vector v;
22574  hqrndstate state;
22575 
22576  ae_frame_make(_state, &_frame_block);
22577  ae_vector_init(&w, 0, DT_REAL, _state, ae_true);
22578  ae_vector_init(&v, 0, DT_REAL, _state, ae_true);
22579  _hqrndstate_init(&state, _state, ae_true);
22580 
22581 
22582  /*
22583  * General case.
22584  */
22585  ae_vector_set_length(&w, n, _state);
22586  ae_vector_set_length(&v, n+1, _state);
22587  hqrndrandomize(&state, _state);
22588  for(s=2; s<=n; s++)
22589  {
22590 
22591  /*
22592  * Prepare random normal v
22593  */
22594  do
22595  {
22596  i = 1;
22597  while(i<=s)
22598  {
22599  hqrndnormal2(&state, &u1, &u2, _state);
22600  v.ptr.p_double[i] = u1;
22601  if( i+1<=s )
22602  {
22603  v.ptr.p_double[i+1] = u2;
22604  }
22605  i = i+2;
22606  }
22607  lambdav = ae_v_dotproduct(&v.ptr.p_double[1], 1, &v.ptr.p_double[1], 1, ae_v_len(1,s));
22608  }
22609  while(ae_fp_eq(lambdav,0));
22610 
22611  /*
22612  * Prepare and apply reflection
22613  */
22614  generatereflection(&v, s, &tau, _state);
22615  v.ptr.p_double[1] = 1;
22616  applyreflectionfromtheright(a, tau, &v, 0, n-1, n-s, n-1, &w, _state);
22617  applyreflectionfromtheleft(a, tau, &v, n-s, n-1, 0, n-1, &w, _state);
22618  }
22619 
22620  /*
22621  * Second pass.
22622  */
22623  for(i=0; i<=n-1; i++)
22624  {
22625  tau = 2*hqrnduniformi(&state, 2, _state)-1;
22626  ae_v_muld(&a->ptr.pp_double[0][i], a->stride, ae_v_len(0,n-1), tau);
22627  ae_v_muld(&a->ptr.pp_double[i][0], 1, ae_v_len(0,n-1), tau);
22628  }
22629 
22630  /*
22631  * Copy upper triangle to lower
22632  */
22633  for(i=0; i<=n-2; i++)
22634  {
22635  ae_v_move(&a->ptr.pp_double[i+1][i], a->stride, &a->ptr.pp_double[i][i+1], 1, ae_v_len(i+1,n-1));
22636  }
22637  ae_frame_leave(_state);
22638 }
22639 
22640 
22641 /*************************************************************************
22642 Hermitian multiplication of NxN matrix by random Haar distributed
22643 complex orthogonal matrix
22644 
22645 INPUT PARAMETERS:
22646  A - matrix, array[0..N-1, 0..N-1]
22647  N - matrix size
22648 
22649 OUTPUT PARAMETERS:
22650  A - Q^H*A*Q, where Q is random NxN orthogonal matrix
22651 
22652  -- ALGLIB routine --
22653  04.12.2009
22654  Bochkanov Sergey
22655 *************************************************************************/
22656 void hmatrixrndmultiply(/* Complex */ ae_matrix* a,
22657  ae_int_t n,
22658  ae_state *_state)
22659 {
22660  ae_frame _frame_block;
22661  ae_complex tau;
22662  ae_complex lambdav;
22663  ae_int_t s;
22664  ae_int_t i;
22665  ae_vector w;
22666  ae_vector v;
22667  hqrndstate state;
22668 
22669  ae_frame_make(_state, &_frame_block);
22670  ae_vector_init(&w, 0, DT_COMPLEX, _state, ae_true);
22671  ae_vector_init(&v, 0, DT_COMPLEX, _state, ae_true);
22672  _hqrndstate_init(&state, _state, ae_true);
22673 
22674 
22675  /*
22676  * General case.
22677  */
22678  ae_vector_set_length(&w, n, _state);
22679  ae_vector_set_length(&v, n+1, _state);
22680  hqrndrandomize(&state, _state);
22681  for(s=2; s<=n; s++)
22682  {
22683 
22684  /*
22685  * Prepare random normal v
22686  */
22687  do
22688  {
22689  for(i=1; i<=s; i++)
22690  {
22691  hqrndnormal2(&state, &tau.x, &tau.y, _state);
22692  v.ptr.p_complex[i] = tau;
22693  }
22694  lambdav = ae_v_cdotproduct(&v.ptr.p_complex[1], 1, "N", &v.ptr.p_complex[1], 1, "Conj", ae_v_len(1,s));
22695  }
22696  while(ae_c_eq_d(lambdav,0));
22697 
22698  /*
22699  * Prepare and apply reflection
22700  */
22701  complexgeneratereflection(&v, s, &tau, _state);
22702  v.ptr.p_complex[1] = ae_complex_from_d(1);
22703  complexapplyreflectionfromtheright(a, tau, &v, 0, n-1, n-s, n-1, &w, _state);
22704  complexapplyreflectionfromtheleft(a, ae_c_conj(tau, _state), &v, n-s, n-1, 0, n-1, &w, _state);
22705  }
22706 
22707  /*
22708  * Second pass.
22709  */
22710  for(i=0; i<=n-1; i++)
22711  {
22712  hqrndunit2(&state, &tau.x, &tau.y, _state);
22713  ae_v_cmulc(&a->ptr.pp_complex[0][i], a->stride, ae_v_len(0,n-1), tau);
22714  tau = ae_c_conj(tau, _state);
22715  ae_v_cmulc(&a->ptr.pp_complex[i][0], 1, ae_v_len(0,n-1), tau);
22716  }
22717 
22718  /*
22719  * Change all values from lower triangle by complex-conjugate values
22720  * from upper one
22721  */
22722  for(i=0; i<=n-2; i++)
22723  {
22724  ae_v_cmove(&a->ptr.pp_complex[i+1][i], a->stride, &a->ptr.pp_complex[i][i+1], 1, "N", ae_v_len(i+1,n-1));
22725  }
22726  for(s=0; s<=n-2; s++)
22727  {
22728  for(i=s+1; i<=n-1; i++)
22729  {
22730  a->ptr.pp_complex[i][s].y = -a->ptr.pp_complex[i][s].y;
22731  }
22732  }
22733  ae_frame_leave(_state);
22734 }
22735 
22736 
22737 
22738 
22739 /*************************************************************************
22740 LU decomposition of a general real matrix with row pivoting
22741 
22742 A is represented as A = P*L*U, where:
22743 * L is lower unitriangular matrix
22744 * U is upper triangular matrix
22745 * P = P0*P1*...*PK, K=min(M,N)-1,
22746  Pi - permutation matrix for I and Pivots[I]
22747 
22748 This is cache-oblivous implementation of LU decomposition.
22749 It is optimized for square matrices. As for rectangular matrices:
22750 * best case - M>>N
22751 * worst case - N>>M, small M, large N, matrix does not fit in CPU cache
22752 
22753 INPUT PARAMETERS:
22754  A - array[0..M-1, 0..N-1].
22755  M - number of rows in matrix A.
22756  N - number of columns in matrix A.
22757 
22758 
22759 OUTPUT PARAMETERS:
22760  A - matrices L and U in compact form:
22761  * L is stored under main diagonal
22762  * U is stored on and above main diagonal
22763  Pivots - permutation matrix in compact form.
22764  array[0..Min(M-1,N-1)].
22765 
22766  -- ALGLIB routine --
22767  10.01.2010
22768  Bochkanov Sergey
22769 *************************************************************************/
22770 void rmatrixlu(/* Real */ ae_matrix* a,
22771  ae_int_t m,
22772  ae_int_t n,
22773  /* Integer */ ae_vector* pivots,
22774  ae_state *_state)
22775 {
22776 
22777  ae_vector_clear(pivots);
22778 
22779  ae_assert(m>0, "RMatrixLU: incorrect M!", _state);
22780  ae_assert(n>0, "RMatrixLU: incorrect N!", _state);
22781  rmatrixplu(a, m, n, pivots, _state);
22782 }
22783 
22784 
22785 /*************************************************************************
22786 LU decomposition of a general complex matrix with row pivoting
22787 
22788 A is represented as A = P*L*U, where:
22789 * L is lower unitriangular matrix
22790 * U is upper triangular matrix
22791 * P = P0*P1*...*PK, K=min(M,N)-1,
22792  Pi - permutation matrix for I and Pivots[I]
22793 
22794 This is cache-oblivous implementation of LU decomposition. It is optimized
22795 for square matrices. As for rectangular matrices:
22796 * best case - M>>N
22797 * worst case - N>>M, small M, large N, matrix does not fit in CPU cache
22798 
22799 INPUT PARAMETERS:
22800  A - array[0..M-1, 0..N-1].
22801  M - number of rows in matrix A.
22802  N - number of columns in matrix A.
22803 
22804 
22805 OUTPUT PARAMETERS:
22806  A - matrices L and U in compact form:
22807  * L is stored under main diagonal
22808  * U is stored on and above main diagonal
22809  Pivots - permutation matrix in compact form.
22810  array[0..Min(M-1,N-1)].
22811 
22812  -- ALGLIB routine --
22813  10.01.2010
22814  Bochkanov Sergey
22815 *************************************************************************/
22816 void cmatrixlu(/* Complex */ ae_matrix* a,
22817  ae_int_t m,
22818  ae_int_t n,
22819  /* Integer */ ae_vector* pivots,
22820  ae_state *_state)
22821 {
22822 
22823  ae_vector_clear(pivots);
22824 
22825  ae_assert(m>0, "CMatrixLU: incorrect M!", _state);
22826  ae_assert(n>0, "CMatrixLU: incorrect N!", _state);
22827  cmatrixplu(a, m, n, pivots, _state);
22828 }
22829 
22830 
22831 /*************************************************************************
22832 Cache-oblivious Cholesky decomposition
22833 
22834 The algorithm computes Cholesky decomposition of a Hermitian positive-
22835 definite matrix. The result of an algorithm is a representation of A as
22836 A=U'*U or A=L*L' (here X' detones conj(X^T)).
22837 
22838 INPUT PARAMETERS:
22839  A - upper or lower triangle of a factorized matrix.
22840  array with elements [0..N-1, 0..N-1].
22841  N - size of matrix A.
22842  IsUpper - if IsUpper=True, then A contains an upper triangle of
22843  a symmetric matrix, otherwise A contains a lower one.
22844 
22845 OUTPUT PARAMETERS:
22846  A - the result of factorization. If IsUpper=True, then
22847  the upper triangle contains matrix U, so that A = U'*U,
22848  and the elements below the main diagonal are not modified.
22849  Similarly, if IsUpper = False.
22850 
22851 RESULT:
22852  If the matrix is positive-definite, the function returns True.
22853  Otherwise, the function returns False. Contents of A is not determined
22854  in such case.
22855 
22856  -- ALGLIB routine --
22857  15.12.2009
22858  Bochkanov Sergey
22859 *************************************************************************/
22860 ae_bool hpdmatrixcholesky(/* Complex */ ae_matrix* a,
22861  ae_int_t n,
22862  ae_bool isupper,
22863  ae_state *_state)
22864 {
22865  ae_frame _frame_block;
22866  ae_vector tmp;
22867  ae_bool result;
22868 
22869  ae_frame_make(_state, &_frame_block);
22870  ae_vector_init(&tmp, 0, DT_COMPLEX, _state, ae_true);
22871 
22872  if( n<1 )
22873  {
22874  result = ae_false;
22875  ae_frame_leave(_state);
22876  return result;
22877  }
22878  result = trfac_hpdmatrixcholeskyrec(a, 0, n, isupper, &tmp, _state);
22879  ae_frame_leave(_state);
22880  return result;
22881 }
22882 
22883 
22884 /*************************************************************************
22885 Cache-oblivious Cholesky decomposition
22886 
22887 The algorithm computes Cholesky decomposition of a symmetric positive-
22888 definite matrix. The result of an algorithm is a representation of A as
22889 A=U^T*U or A=L*L^T
22890 
22891 INPUT PARAMETERS:
22892  A - upper or lower triangle of a factorized matrix.
22893  array with elements [0..N-1, 0..N-1].
22894  N - size of matrix A.
22895  IsUpper - if IsUpper=True, then A contains an upper triangle of
22896  a symmetric matrix, otherwise A contains a lower one.
22897 
22898 OUTPUT PARAMETERS:
22899  A - the result of factorization. If IsUpper=True, then
22900  the upper triangle contains matrix U, so that A = U^T*U,
22901  and the elements below the main diagonal are not modified.
22902  Similarly, if IsUpper = False.
22903 
22904 RESULT:
22905  If the matrix is positive-definite, the function returns True.
22906  Otherwise, the function returns False. Contents of A is not determined
22907  in such case.
22908 
22909  -- ALGLIB routine --
22910  15.12.2009
22911  Bochkanov Sergey
22912 *************************************************************************/
22913 ae_bool spdmatrixcholesky(/* Real */ ae_matrix* a,
22914  ae_int_t n,
22915  ae_bool isupper,
22916  ae_state *_state)
22917 {
22918  ae_frame _frame_block;
22919  ae_vector tmp;
22920  ae_bool result;
22921 
22922  ae_frame_make(_state, &_frame_block);
22923  ae_vector_init(&tmp, 0, DT_REAL, _state, ae_true);
22924 
22925  if( n<1 )
22926  {
22927  result = ae_false;
22928  ae_frame_leave(_state);
22929  return result;
22930  }
22931  result = spdmatrixcholeskyrec(a, 0, n, isupper, &tmp, _state);
22932  ae_frame_leave(_state);
22933  return result;
22934 }
22935 
22936 
22937 void rmatrixlup(/* Real */ ae_matrix* a,
22938  ae_int_t m,
22939  ae_int_t n,
22940  /* Integer */ ae_vector* pivots,
22941  ae_state *_state)
22942 {
22943  ae_frame _frame_block;
22944  ae_vector tmp;
22945  ae_int_t i;
22946  ae_int_t j;
22947  double mx;
22948  double v;
22949 
22950  ae_frame_make(_state, &_frame_block);
22951  ae_vector_clear(pivots);
22952  ae_vector_init(&tmp, 0, DT_REAL, _state, ae_true);
22953 
22954 
22955  /*
22956  * Internal LU decomposition subroutine.
22957  * Never call it directly.
22958  */
22959  ae_assert(m>0, "RMatrixLUP: incorrect M!", _state);
22960  ae_assert(n>0, "RMatrixLUP: incorrect N!", _state);
22961 
22962  /*
22963  * Scale matrix to avoid overflows,
22964  * decompose it, then scale back.
22965  */
22966  mx = 0;
22967  for(i=0; i<=m-1; i++)
22968  {
22969  for(j=0; j<=n-1; j++)
22970  {
22971  mx = ae_maxreal(mx, ae_fabs(a->ptr.pp_double[i][j], _state), _state);
22972  }
22973  }
22974  if( ae_fp_neq(mx,0) )
22975  {
22976  v = 1/mx;
22977  for(i=0; i<=m-1; i++)
22978  {
22979  ae_v_muld(&a->ptr.pp_double[i][0], 1, ae_v_len(0,n-1), v);
22980  }
22981  }
22982  ae_vector_set_length(pivots, ae_minint(m, n, _state), _state);
22983  ae_vector_set_length(&tmp, 2*ae_maxint(m, n, _state), _state);
22984  trfac_rmatrixluprec(a, 0, m, n, pivots, &tmp, _state);
22985  if( ae_fp_neq(mx,0) )
22986  {
22987  v = mx;
22988  for(i=0; i<=m-1; i++)
22989  {
22990  ae_v_muld(&a->ptr.pp_double[i][0], 1, ae_v_len(0,ae_minint(i, n-1, _state)), v);
22991  }
22992  }
22993  ae_frame_leave(_state);
22994 }
22995 
22996 
22997 void cmatrixlup(/* Complex */ ae_matrix* a,
22998  ae_int_t m,
22999  ae_int_t n,
23000  /* Integer */ ae_vector* pivots,
23001  ae_state *_state)
23002 {
23003  ae_frame _frame_block;
23004  ae_vector tmp;
23005  ae_int_t i;
23006  ae_int_t j;
23007  double mx;
23008  double v;
23009 
23010  ae_frame_make(_state, &_frame_block);
23011  ae_vector_clear(pivots);
23012  ae_vector_init(&tmp, 0, DT_COMPLEX, _state, ae_true);
23013 
23014 
23015  /*
23016  * Internal LU decomposition subroutine.
23017  * Never call it directly.
23018  */
23019  ae_assert(m>0, "CMatrixLUP: incorrect M!", _state);
23020  ae_assert(n>0, "CMatrixLUP: incorrect N!", _state);
23021 
23022  /*
23023  * Scale matrix to avoid overflows,
23024  * decompose it, then scale back.
23025  */
23026  mx = 0;
23027  for(i=0; i<=m-1; i++)
23028  {
23029  for(j=0; j<=n-1; j++)
23030  {
23031  mx = ae_maxreal(mx, ae_c_abs(a->ptr.pp_complex[i][j], _state), _state);
23032  }
23033  }
23034  if( ae_fp_neq(mx,0) )
23035  {
23036  v = 1/mx;
23037  for(i=0; i<=m-1; i++)
23038  {
23039  ae_v_cmuld(&a->ptr.pp_complex[i][0], 1, ae_v_len(0,n-1), v);
23040  }
23041  }
23042  ae_vector_set_length(pivots, ae_minint(m, n, _state), _state);
23043  ae_vector_set_length(&tmp, 2*ae_maxint(m, n, _state), _state);
23044  trfac_cmatrixluprec(a, 0, m, n, pivots, &tmp, _state);
23045  if( ae_fp_neq(mx,0) )
23046  {
23047  v = mx;
23048  for(i=0; i<=m-1; i++)
23049  {
23050  ae_v_cmuld(&a->ptr.pp_complex[i][0], 1, ae_v_len(0,ae_minint(i, n-1, _state)), v);
23051  }
23052  }
23053  ae_frame_leave(_state);
23054 }
23055 
23056 
23057 void rmatrixplu(/* Real */ ae_matrix* a,
23058  ae_int_t m,
23059  ae_int_t n,
23060  /* Integer */ ae_vector* pivots,
23061  ae_state *_state)
23062 {
23063  ae_frame _frame_block;
23064  ae_vector tmp;
23065  ae_int_t i;
23066  ae_int_t j;
23067  double mx;
23068  double v;
23069 
23070  ae_frame_make(_state, &_frame_block);
23071  ae_vector_clear(pivots);
23072  ae_vector_init(&tmp, 0, DT_REAL, _state, ae_true);
23073 
23074 
23075  /*
23076  * Internal LU decomposition subroutine.
23077  * Never call it directly.
23078  */
23079  ae_assert(m>0, "RMatrixPLU: incorrect M!", _state);
23080  ae_assert(n>0, "RMatrixPLU: incorrect N!", _state);
23081  ae_vector_set_length(&tmp, 2*ae_maxint(m, n, _state), _state);
23082  ae_vector_set_length(pivots, ae_minint(m, n, _state), _state);
23083 
23084  /*
23085  * Scale matrix to avoid overflows,
23086  * decompose it, then scale back.
23087  */
23088  mx = 0;
23089  for(i=0; i<=m-1; i++)
23090  {
23091  for(j=0; j<=n-1; j++)
23092  {
23093  mx = ae_maxreal(mx, ae_fabs(a->ptr.pp_double[i][j], _state), _state);
23094  }
23095  }
23096  if( ae_fp_neq(mx,0) )
23097  {
23098  v = 1/mx;
23099  for(i=0; i<=m-1; i++)
23100  {
23101  ae_v_muld(&a->ptr.pp_double[i][0], 1, ae_v_len(0,n-1), v);
23102  }
23103  }
23104  trfac_rmatrixplurec(a, 0, m, n, pivots, &tmp, _state);
23105  if( ae_fp_neq(mx,0) )
23106  {
23107  v = mx;
23108  for(i=0; i<=ae_minint(m, n, _state)-1; i++)
23109  {
23110  ae_v_muld(&a->ptr.pp_double[i][i], 1, ae_v_len(i,n-1), v);
23111  }
23112  }
23113  ae_frame_leave(_state);
23114 }
23115 
23116 
23117 void cmatrixplu(/* Complex */ ae_matrix* a,
23118  ae_int_t m,
23119  ae_int_t n,
23120  /* Integer */ ae_vector* pivots,
23121  ae_state *_state)
23122 {
23123  ae_frame _frame_block;
23124  ae_vector tmp;
23125  ae_int_t i;
23126  ae_int_t j;
23127  double mx;
23128  ae_complex v;
23129 
23130  ae_frame_make(_state, &_frame_block);
23131  ae_vector_clear(pivots);
23132  ae_vector_init(&tmp, 0, DT_COMPLEX, _state, ae_true);
23133 
23134 
23135  /*
23136  * Internal LU decomposition subroutine.
23137  * Never call it directly.
23138  */
23139  ae_assert(m>0, "CMatrixPLU: incorrect M!", _state);
23140  ae_assert(n>0, "CMatrixPLU: incorrect N!", _state);
23141  ae_vector_set_length(&tmp, 2*ae_maxint(m, n, _state), _state);
23142  ae_vector_set_length(pivots, ae_minint(m, n, _state), _state);
23143 
23144  /*
23145  * Scale matrix to avoid overflows,
23146  * decompose it, then scale back.
23147  */
23148  mx = 0;
23149  for(i=0; i<=m-1; i++)
23150  {
23151  for(j=0; j<=n-1; j++)
23152  {
23153  mx = ae_maxreal(mx, ae_c_abs(a->ptr.pp_complex[i][j], _state), _state);
23154  }
23155  }
23156  if( ae_fp_neq(mx,0) )
23157  {
23158  v = ae_complex_from_d(1/mx);
23159  for(i=0; i<=m-1; i++)
23160  {
23161  ae_v_cmulc(&a->ptr.pp_complex[i][0], 1, ae_v_len(0,n-1), v);
23162  }
23163  }
23164  trfac_cmatrixplurec(a, 0, m, n, pivots, &tmp, _state);
23165  if( ae_fp_neq(mx,0) )
23166  {
23167  v = ae_complex_from_d(mx);
23168  for(i=0; i<=ae_minint(m, n, _state)-1; i++)
23169  {
23170  ae_v_cmulc(&a->ptr.pp_complex[i][i], 1, ae_v_len(i,n-1), v);
23171  }
23172  }
23173  ae_frame_leave(_state);
23174 }
23175 
23176 
23177 /*************************************************************************
23178 Recursive computational subroutine for SPDMatrixCholesky.
23179 
23180 INPUT PARAMETERS:
23181  A - matrix given by upper or lower triangle
23182  Offs - offset of diagonal block to decompose
23183  N - diagonal block size
23184  IsUpper - what half is given
23185  Tmp - temporary array; allocated by function, if its size is too
23186  small; can be reused on subsequent calls.
23187 
23188 OUTPUT PARAMETERS:
23189  A - upper (or lower) triangle contains Cholesky decomposition
23190 
23191 RESULT:
23192  True, on success
23193  False, on failure
23194 
23195  -- ALGLIB routine --
23196  15.12.2009
23197  Bochkanov Sergey
23198 *************************************************************************/
23199 ae_bool spdmatrixcholeskyrec(/* Real */ ae_matrix* a,
23200  ae_int_t offs,
23201  ae_int_t n,
23202  ae_bool isupper,
23203  /* Real */ ae_vector* tmp,
23204  ae_state *_state)
23205 {
23206  ae_int_t n1;
23207  ae_int_t n2;
23208  ae_bool result;
23209 
23210 
23211 
23212  /*
23213  * check N
23214  */
23215  if( n<1 )
23216  {
23217  result = ae_false;
23218  return result;
23219  }
23220 
23221  /*
23222  * Prepare buffer
23223  */
23224  if( tmp->cnt<2*n )
23225  {
23226  ae_vector_set_length(tmp, 2*n, _state);
23227  }
23228 
23229  /*
23230  * special cases
23231  */
23232  if( n==1 )
23233  {
23234  if( ae_fp_greater(a->ptr.pp_double[offs][offs],0) )
23235  {
23236  a->ptr.pp_double[offs][offs] = ae_sqrt(a->ptr.pp_double[offs][offs], _state);
23237  result = ae_true;
23238  }
23239  else
23240  {
23241  result = ae_false;
23242  }
23243  return result;
23244  }
23245  if( n<=ablasblocksize(a, _state) )
23246  {
23247  result = trfac_spdmatrixcholesky2(a, offs, n, isupper, tmp, _state);
23248  return result;
23249  }
23250 
23251  /*
23252  * general case: split task in cache-oblivious manner
23253  */
23254  result = ae_true;
23255  ablassplitlength(a, n, &n1, &n2, _state);
23256  result = spdmatrixcholeskyrec(a, offs, n1, isupper, tmp, _state);
23257  if( !result )
23258  {
23259  return result;
23260  }
23261  if( n2>0 )
23262  {
23263  if( isupper )
23264  {
23265  rmatrixlefttrsm(n1, n2, a, offs, offs, isupper, ae_false, 1, a, offs, offs+n1, _state);
23266  rmatrixsyrk(n2, n1, -1.0, a, offs, offs+n1, 1, 1.0, a, offs+n1, offs+n1, isupper, _state);
23267  }
23268  else
23269  {
23270  rmatrixrighttrsm(n2, n1, a, offs, offs, isupper, ae_false, 1, a, offs+n1, offs, _state);
23271  rmatrixsyrk(n2, n1, -1.0, a, offs+n1, offs, 0, 1.0, a, offs+n1, offs+n1, isupper, _state);
23272  }
23273  result = spdmatrixcholeskyrec(a, offs+n1, n2, isupper, tmp, _state);
23274  if( !result )
23275  {
23276  return result;
23277  }
23278  }
23279  return result;
23280 }
23281 
23282 
23283 /*************************************************************************
23284 Recurrent complex LU subroutine.
23285 Never call it directly.
23286 
23287  -- ALGLIB routine --
23288  04.01.2010
23289  Bochkanov Sergey
23290 *************************************************************************/
23291 static void trfac_cmatrixluprec(/* Complex */ ae_matrix* a,
23292  ae_int_t offs,
23293  ae_int_t m,
23294  ae_int_t n,
23295  /* Integer */ ae_vector* pivots,
23296  /* Complex */ ae_vector* tmp,
23297  ae_state *_state)
23298 {
23299  ae_int_t i;
23300  ae_int_t m1;
23301  ae_int_t m2;
23302 
23303 
23304 
23305  /*
23306  * Kernel case
23307  */
23308  if( ae_minint(m, n, _state)<=ablascomplexblocksize(a, _state) )
23309  {
23310  trfac_cmatrixlup2(a, offs, m, n, pivots, tmp, _state);
23311  return;
23312  }
23313 
23314  /*
23315  * Preliminary step, make N>=M
23316  *
23317  * ( A1 )
23318  * A = ( ), where A1 is square
23319  * ( A2 )
23320  *
23321  * Factorize A1, update A2
23322  */
23323  if( m>n )
23324  {
23325  trfac_cmatrixluprec(a, offs, n, n, pivots, tmp, _state);
23326  for(i=0; i<=n-1; i++)
23327  {
23328  ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs+n][offs+i], a->stride, "N", ae_v_len(0,m-n-1));
23329  ae_v_cmove(&a->ptr.pp_complex[offs+n][offs+i], a->stride, &a->ptr.pp_complex[offs+n][pivots->ptr.p_int[offs+i]], a->stride, "N", ae_v_len(offs+n,offs+m-1));
23330  ae_v_cmove(&a->ptr.pp_complex[offs+n][pivots->ptr.p_int[offs+i]], a->stride, &tmp->ptr.p_complex[0], 1, "N", ae_v_len(offs+n,offs+m-1));
23331  }
23332  cmatrixrighttrsm(m-n, n, a, offs, offs, ae_true, ae_true, 0, a, offs+n, offs, _state);
23333  return;
23334  }
23335 
23336  /*
23337  * Non-kernel case
23338  */
23339  ablascomplexsplitlength(a, m, &m1, &m2, _state);
23340  trfac_cmatrixluprec(a, offs, m1, n, pivots, tmp, _state);
23341  if( m2>0 )
23342  {
23343  for(i=0; i<=m1-1; i++)
23344  {
23345  if( offs+i!=pivots->ptr.p_int[offs+i] )
23346  {
23347  ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs+m1][offs+i], a->stride, "N", ae_v_len(0,m2-1));
23348  ae_v_cmove(&a->ptr.pp_complex[offs+m1][offs+i], a->stride, &a->ptr.pp_complex[offs+m1][pivots->ptr.p_int[offs+i]], a->stride, "N", ae_v_len(offs+m1,offs+m-1));
23349  ae_v_cmove(&a->ptr.pp_complex[offs+m1][pivots->ptr.p_int[offs+i]], a->stride, &tmp->ptr.p_complex[0], 1, "N", ae_v_len(offs+m1,offs+m-1));
23350  }
23351  }
23352  cmatrixrighttrsm(m2, m1, a, offs, offs, ae_true, ae_true, 0, a, offs+m1, offs, _state);
23353  cmatrixgemm(m-m1, n-m1, m1, ae_complex_from_d(-1.0), a, offs+m1, offs, 0, a, offs, offs+m1, 0, ae_complex_from_d(1.0), a, offs+m1, offs+m1, _state);
23354  trfac_cmatrixluprec(a, offs+m1, m-m1, n-m1, pivots, tmp, _state);
23355  for(i=0; i<=m2-1; i++)
23356  {
23357  if( offs+m1+i!=pivots->ptr.p_int[offs+m1+i] )
23358  {
23359  ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs][offs+m1+i], a->stride, "N", ae_v_len(0,m1-1));
23360  ae_v_cmove(&a->ptr.pp_complex[offs][offs+m1+i], a->stride, &a->ptr.pp_complex[offs][pivots->ptr.p_int[offs+m1+i]], a->stride, "N", ae_v_len(offs,offs+m1-1));
23361  ae_v_cmove(&a->ptr.pp_complex[offs][pivots->ptr.p_int[offs+m1+i]], a->stride, &tmp->ptr.p_complex[0], 1, "N", ae_v_len(offs,offs+m1-1));
23362  }
23363  }
23364  }
23365 }
23366 
23367 
23368 /*************************************************************************
23369 Recurrent real LU subroutine.
23370 Never call it directly.
23371 
23372  -- ALGLIB routine --
23373  04.01.2010
23374  Bochkanov Sergey
23375 *************************************************************************/
23376 static void trfac_rmatrixluprec(/* Real */ ae_matrix* a,
23377  ae_int_t offs,
23378  ae_int_t m,
23379  ae_int_t n,
23380  /* Integer */ ae_vector* pivots,
23381  /* Real */ ae_vector* tmp,
23382  ae_state *_state)
23383 {
23384  ae_int_t i;
23385  ae_int_t m1;
23386  ae_int_t m2;
23387 
23388 
23389 
23390  /*
23391  * Kernel case
23392  */
23393  if( ae_minint(m, n, _state)<=ablasblocksize(a, _state) )
23394  {
23395  trfac_rmatrixlup2(a, offs, m, n, pivots, tmp, _state);
23396  return;
23397  }
23398 
23399  /*
23400  * Preliminary step, make N>=M
23401  *
23402  * ( A1 )
23403  * A = ( ), where A1 is square
23404  * ( A2 )
23405  *
23406  * Factorize A1, update A2
23407  */
23408  if( m>n )
23409  {
23410  trfac_rmatrixluprec(a, offs, n, n, pivots, tmp, _state);
23411  for(i=0; i<=n-1; i++)
23412  {
23413  if( offs+i!=pivots->ptr.p_int[offs+i] )
23414  {
23415  ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs+n][offs+i], a->stride, ae_v_len(0,m-n-1));
23416  ae_v_move(&a->ptr.pp_double[offs+n][offs+i], a->stride, &a->ptr.pp_double[offs+n][pivots->ptr.p_int[offs+i]], a->stride, ae_v_len(offs+n,offs+m-1));
23417  ae_v_move(&a->ptr.pp_double[offs+n][pivots->ptr.p_int[offs+i]], a->stride, &tmp->ptr.p_double[0], 1, ae_v_len(offs+n,offs+m-1));
23418  }
23419  }
23420  rmatrixrighttrsm(m-n, n, a, offs, offs, ae_true, ae_true, 0, a, offs+n, offs, _state);
23421  return;
23422  }
23423 
23424  /*
23425  * Non-kernel case
23426  */
23427  ablassplitlength(a, m, &m1, &m2, _state);
23428  trfac_rmatrixluprec(a, offs, m1, n, pivots, tmp, _state);
23429  if( m2>0 )
23430  {
23431  for(i=0; i<=m1-1; i++)
23432  {
23433  if( offs+i!=pivots->ptr.p_int[offs+i] )
23434  {
23435  ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs+m1][offs+i], a->stride, ae_v_len(0,m2-1));
23436  ae_v_move(&a->ptr.pp_double[offs+m1][offs+i], a->stride, &a->ptr.pp_double[offs+m1][pivots->ptr.p_int[offs+i]], a->stride, ae_v_len(offs+m1,offs+m-1));
23437  ae_v_move(&a->ptr.pp_double[offs+m1][pivots->ptr.p_int[offs+i]], a->stride, &tmp->ptr.p_double[0], 1, ae_v_len(offs+m1,offs+m-1));
23438  }
23439  }
23440  rmatrixrighttrsm(m2, m1, a, offs, offs, ae_true, ae_true, 0, a, offs+m1, offs, _state);
23441  rmatrixgemm(m-m1, n-m1, m1, -1.0, a, offs+m1, offs, 0, a, offs, offs+m1, 0, 1.0, a, offs+m1, offs+m1, _state);
23442  trfac_rmatrixluprec(a, offs+m1, m-m1, n-m1, pivots, tmp, _state);
23443  for(i=0; i<=m2-1; i++)
23444  {
23445  if( offs+m1+i!=pivots->ptr.p_int[offs+m1+i] )
23446  {
23447  ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs][offs+m1+i], a->stride, ae_v_len(0,m1-1));
23448  ae_v_move(&a->ptr.pp_double[offs][offs+m1+i], a->stride, &a->ptr.pp_double[offs][pivots->ptr.p_int[offs+m1+i]], a->stride, ae_v_len(offs,offs+m1-1));
23449  ae_v_move(&a->ptr.pp_double[offs][pivots->ptr.p_int[offs+m1+i]], a->stride, &tmp->ptr.p_double[0], 1, ae_v_len(offs,offs+m1-1));
23450  }
23451  }
23452  }
23453 }
23454 
23455 
23456 /*************************************************************************
23457 Recurrent complex LU subroutine.
23458 Never call it directly.
23459 
23460  -- ALGLIB routine --
23461  04.01.2010
23462  Bochkanov Sergey
23463 *************************************************************************/
23464 static void trfac_cmatrixplurec(/* Complex */ ae_matrix* a,
23465  ae_int_t offs,
23466  ae_int_t m,
23467  ae_int_t n,
23468  /* Integer */ ae_vector* pivots,
23469  /* Complex */ ae_vector* tmp,
23470  ae_state *_state)
23471 {
23472  ae_int_t i;
23473  ae_int_t n1;
23474  ae_int_t n2;
23475 
23476 
23477 
23478  /*
23479  * Kernel case
23480  */
23481  if( ae_minint(m, n, _state)<=ablascomplexblocksize(a, _state) )
23482  {
23483  trfac_cmatrixplu2(a, offs, m, n, pivots, tmp, _state);
23484  return;
23485  }
23486 
23487  /*
23488  * Preliminary step, make M>=N.
23489  *
23490  * A = (A1 A2), where A1 is square
23491  * Factorize A1, update A2
23492  */
23493  if( n>m )
23494  {
23495  trfac_cmatrixplurec(a, offs, m, m, pivots, tmp, _state);
23496  for(i=0; i<=m-1; i++)
23497  {
23498  ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs+i][offs+m], 1, "N", ae_v_len(0,n-m-1));
23499  ae_v_cmove(&a->ptr.pp_complex[offs+i][offs+m], 1, &a->ptr.pp_complex[pivots->ptr.p_int[offs+i]][offs+m], 1, "N", ae_v_len(offs+m,offs+n-1));
23500  ae_v_cmove(&a->ptr.pp_complex[pivots->ptr.p_int[offs+i]][offs+m], 1, &tmp->ptr.p_complex[0], 1, "N", ae_v_len(offs+m,offs+n-1));
23501  }
23502  cmatrixlefttrsm(m, n-m, a, offs, offs, ae_false, ae_true, 0, a, offs, offs+m, _state);
23503  return;
23504  }
23505 
23506  /*
23507  * Non-kernel case
23508  */
23509  ablascomplexsplitlength(a, n, &n1, &n2, _state);
23510  trfac_cmatrixplurec(a, offs, m, n1, pivots, tmp, _state);
23511  if( n2>0 )
23512  {
23513  for(i=0; i<=n1-1; i++)
23514  {
23515  if( offs+i!=pivots->ptr.p_int[offs+i] )
23516  {
23517  ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs+i][offs+n1], 1, "N", ae_v_len(0,n2-1));
23518  ae_v_cmove(&a->ptr.pp_complex[offs+i][offs+n1], 1, &a->ptr.pp_complex[pivots->ptr.p_int[offs+i]][offs+n1], 1, "N", ae_v_len(offs+n1,offs+n-1));
23519  ae_v_cmove(&a->ptr.pp_complex[pivots->ptr.p_int[offs+i]][offs+n1], 1, &tmp->ptr.p_complex[0], 1, "N", ae_v_len(offs+n1,offs+n-1));
23520  }
23521  }
23522  cmatrixlefttrsm(n1, n2, a, offs, offs, ae_false, ae_true, 0, a, offs, offs+n1, _state);
23523  cmatrixgemm(m-n1, n-n1, n1, ae_complex_from_d(-1.0), a, offs+n1, offs, 0, a, offs, offs+n1, 0, ae_complex_from_d(1.0), a, offs+n1, offs+n1, _state);
23524  trfac_cmatrixplurec(a, offs+n1, m-n1, n-n1, pivots, tmp, _state);
23525  for(i=0; i<=n2-1; i++)
23526  {
23527  if( offs+n1+i!=pivots->ptr.p_int[offs+n1+i] )
23528  {
23529  ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs+n1+i][offs], 1, "N", ae_v_len(0,n1-1));
23530  ae_v_cmove(&a->ptr.pp_complex[offs+n1+i][offs], 1, &a->ptr.pp_complex[pivots->ptr.p_int[offs+n1+i]][offs], 1, "N", ae_v_len(offs,offs+n1-1));
23531  ae_v_cmove(&a->ptr.pp_complex[pivots->ptr.p_int[offs+n1+i]][offs], 1, &tmp->ptr.p_complex[0], 1, "N", ae_v_len(offs,offs+n1-1));
23532  }
23533  }
23534  }
23535 }
23536 
23537 
23538 /*************************************************************************
23539 Recurrent real LU subroutine.
23540 Never call it directly.
23541 
23542  -- ALGLIB routine --
23543  04.01.2010
23544  Bochkanov Sergey
23545 *************************************************************************/
23546 static void trfac_rmatrixplurec(/* Real */ ae_matrix* a,
23547  ae_int_t offs,
23548  ae_int_t m,
23549  ae_int_t n,
23550  /* Integer */ ae_vector* pivots,
23551  /* Real */ ae_vector* tmp,
23552  ae_state *_state)
23553 {
23554  ae_int_t i;
23555  ae_int_t n1;
23556  ae_int_t n2;
23557 
23558 
23559 
23560  /*
23561  * Kernel case
23562  */
23563  if( ae_minint(m, n, _state)<=ablasblocksize(a, _state) )
23564  {
23565  trfac_rmatrixplu2(a, offs, m, n, pivots, tmp, _state);
23566  return;
23567  }
23568 
23569  /*
23570  * Preliminary step, make M>=N.
23571  *
23572  * A = (A1 A2), where A1 is square
23573  * Factorize A1, update A2
23574  */
23575  if( n>m )
23576  {
23577  trfac_rmatrixplurec(a, offs, m, m, pivots, tmp, _state);
23578  for(i=0; i<=m-1; i++)
23579  {
23580  ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs+i][offs+m], 1, ae_v_len(0,n-m-1));
23581  ae_v_move(&a->ptr.pp_double[offs+i][offs+m], 1, &a->ptr.pp_double[pivots->ptr.p_int[offs+i]][offs+m], 1, ae_v_len(offs+m,offs+n-1));
23582  ae_v_move(&a->ptr.pp_double[pivots->ptr.p_int[offs+i]][offs+m], 1, &tmp->ptr.p_double[0], 1, ae_v_len(offs+m,offs+n-1));
23583  }
23584  rmatrixlefttrsm(m, n-m, a, offs, offs, ae_false, ae_true, 0, a, offs, offs+m, _state);
23585  return;
23586  }
23587 
23588  /*
23589  * Non-kernel case
23590  */
23591  ablassplitlength(a, n, &n1, &n2, _state);
23592  trfac_rmatrixplurec(a, offs, m, n1, pivots, tmp, _state);
23593  if( n2>0 )
23594  {
23595  for(i=0; i<=n1-1; i++)
23596  {
23597  if( offs+i!=pivots->ptr.p_int[offs+i] )
23598  {
23599  ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs+i][offs+n1], 1, ae_v_len(0,n2-1));
23600  ae_v_move(&a->ptr.pp_double[offs+i][offs+n1], 1, &a->ptr.pp_double[pivots->ptr.p_int[offs+i]][offs+n1], 1, ae_v_len(offs+n1,offs+n-1));
23601  ae_v_move(&a->ptr.pp_double[pivots->ptr.p_int[offs+i]][offs+n1], 1, &tmp->ptr.p_double[0], 1, ae_v_len(offs+n1,offs+n-1));
23602  }
23603  }
23604  rmatrixlefttrsm(n1, n2, a, offs, offs, ae_false, ae_true, 0, a, offs, offs+n1, _state);
23605  rmatrixgemm(m-n1, n-n1, n1, -1.0, a, offs+n1, offs, 0, a, offs, offs+n1, 0, 1.0, a, offs+n1, offs+n1, _state);
23606  trfac_rmatrixplurec(a, offs+n1, m-n1, n-n1, pivots, tmp, _state);
23607  for(i=0; i<=n2-1; i++)
23608  {
23609  if( offs+n1+i!=pivots->ptr.p_int[offs+n1+i] )
23610  {
23611  ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs+n1+i][offs], 1, ae_v_len(0,n1-1));
23612  ae_v_move(&a->ptr.pp_double[offs+n1+i][offs], 1, &a->ptr.pp_double[pivots->ptr.p_int[offs+n1+i]][offs], 1, ae_v_len(offs,offs+n1-1));
23613  ae_v_move(&a->ptr.pp_double[pivots->ptr.p_int[offs+n1+i]][offs], 1, &tmp->ptr.p_double[0], 1, ae_v_len(offs,offs+n1-1));
23614  }
23615  }
23616  }
23617 }
23618 
23619 
23620 /*************************************************************************
23621 Complex LUP kernel
23622 
23623  -- ALGLIB routine --
23624  10.01.2010
23625  Bochkanov Sergey
23626 *************************************************************************/
23627 static void trfac_cmatrixlup2(/* Complex */ ae_matrix* a,
23628  ae_int_t offs,
23629  ae_int_t m,
23630  ae_int_t n,
23631  /* Integer */ ae_vector* pivots,
23632  /* Complex */ ae_vector* tmp,
23633  ae_state *_state)
23634 {
23635  ae_int_t i;
23636  ae_int_t j;
23637  ae_int_t jp;
23638  ae_complex s;
23639 
23640 
23641 
23642  /*
23643  * Quick return if possible
23644  */
23645  if( m==0||n==0 )
23646  {
23647  return;
23648  }
23649 
23650  /*
23651  * main cycle
23652  */
23653  for(j=0; j<=ae_minint(m-1, n-1, _state); j++)
23654  {
23655 
23656  /*
23657  * Find pivot, swap columns
23658  */
23659  jp = j;
23660  for(i=j+1; i<=n-1; i++)
23661  {
23662  if( ae_fp_greater(ae_c_abs(a->ptr.pp_complex[offs+j][offs+i], _state),ae_c_abs(a->ptr.pp_complex[offs+j][offs+jp], _state)) )
23663  {
23664  jp = i;
23665  }
23666  }
23667  pivots->ptr.p_int[offs+j] = offs+jp;
23668  if( jp!=j )
23669  {
23670  ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs][offs+j], a->stride, "N", ae_v_len(0,m-1));
23671  ae_v_cmove(&a->ptr.pp_complex[offs][offs+j], a->stride, &a->ptr.pp_complex[offs][offs+jp], a->stride, "N", ae_v_len(offs,offs+m-1));
23672  ae_v_cmove(&a->ptr.pp_complex[offs][offs+jp], a->stride, &tmp->ptr.p_complex[0], 1, "N", ae_v_len(offs,offs+m-1));
23673  }
23674 
23675  /*
23676  * LU decomposition of 1x(N-J) matrix
23677  */
23678  if( ae_c_neq_d(a->ptr.pp_complex[offs+j][offs+j],0)&&j+1<=n-1 )
23679  {
23680  s = ae_c_d_div(1,a->ptr.pp_complex[offs+j][offs+j]);
23681  ae_v_cmulc(&a->ptr.pp_complex[offs+j][offs+j+1], 1, ae_v_len(offs+j+1,offs+n-1), s);
23682  }
23683 
23684  /*
23685  * Update trailing (M-J-1)x(N-J-1) matrix
23686  */
23687  if( j<ae_minint(m-1, n-1, _state) )
23688  {
23689  ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs+j+1][offs+j], a->stride, "N", ae_v_len(0,m-j-2));
23690  ae_v_cmoveneg(&tmp->ptr.p_complex[m], 1, &a->ptr.pp_complex[offs+j][offs+j+1], 1, "N", ae_v_len(m,m+n-j-2));
23691  cmatrixrank1(m-j-1, n-j-1, a, offs+j+1, offs+j+1, tmp, 0, tmp, m, _state);
23692  }
23693  }
23694 }
23695 
23696 
23697 /*************************************************************************
23698 Real LUP kernel
23699 
23700  -- ALGLIB routine --
23701  10.01.2010
23702  Bochkanov Sergey
23703 *************************************************************************/
23704 static void trfac_rmatrixlup2(/* Real */ ae_matrix* a,
23705  ae_int_t offs,
23706  ae_int_t m,
23707  ae_int_t n,
23708  /* Integer */ ae_vector* pivots,
23709  /* Real */ ae_vector* tmp,
23710  ae_state *_state)
23711 {
23712  ae_int_t i;
23713  ae_int_t j;
23714  ae_int_t jp;
23715  double s;
23716 
23717 
23718 
23719  /*
23720  * Quick return if possible
23721  */
23722  if( m==0||n==0 )
23723  {
23724  return;
23725  }
23726 
23727  /*
23728  * main cycle
23729  */
23730  for(j=0; j<=ae_minint(m-1, n-1, _state); j++)
23731  {
23732 
23733  /*
23734  * Find pivot, swap columns
23735  */
23736  jp = j;
23737  for(i=j+1; i<=n-1; i++)
23738  {
23739  if( ae_fp_greater(ae_fabs(a->ptr.pp_double[offs+j][offs+i], _state),ae_fabs(a->ptr.pp_double[offs+j][offs+jp], _state)) )
23740  {
23741  jp = i;
23742  }
23743  }
23744  pivots->ptr.p_int[offs+j] = offs+jp;
23745  if( jp!=j )
23746  {
23747  ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs][offs+j], a->stride, ae_v_len(0,m-1));
23748  ae_v_move(&a->ptr.pp_double[offs][offs+j], a->stride, &a->ptr.pp_double[offs][offs+jp], a->stride, ae_v_len(offs,offs+m-1));
23749  ae_v_move(&a->ptr.pp_double[offs][offs+jp], a->stride, &tmp->ptr.p_double[0], 1, ae_v_len(offs,offs+m-1));
23750  }
23751 
23752  /*
23753  * LU decomposition of 1x(N-J) matrix
23754  */
23755  if( ae_fp_neq(a->ptr.pp_double[offs+j][offs+j],0)&&j+1<=n-1 )
23756  {
23757  s = 1/a->ptr.pp_double[offs+j][offs+j];
23758  ae_v_muld(&a->ptr.pp_double[offs+j][offs+j+1], 1, ae_v_len(offs+j+1,offs+n-1), s);
23759  }
23760 
23761  /*
23762  * Update trailing (M-J-1)x(N-J-1) matrix
23763  */
23764  if( j<ae_minint(m-1, n-1, _state) )
23765  {
23766  ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs+j+1][offs+j], a->stride, ae_v_len(0,m-j-2));
23767  ae_v_moveneg(&tmp->ptr.p_double[m], 1, &a->ptr.pp_double[offs+j][offs+j+1], 1, ae_v_len(m,m+n-j-2));
23768  rmatrixrank1(m-j-1, n-j-1, a, offs+j+1, offs+j+1, tmp, 0, tmp, m, _state);
23769  }
23770  }
23771 }
23772 
23773 
23774 /*************************************************************************
23775 Complex PLU kernel
23776 
23777  -- LAPACK routine (version 3.0) --
23778  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
23779  Courant Institute, Argonne National Lab, and Rice University
23780  June 30, 1992
23781 *************************************************************************/
23782 static void trfac_cmatrixplu2(/* Complex */ ae_matrix* a,
23783  ae_int_t offs,
23784  ae_int_t m,
23785  ae_int_t n,
23786  /* Integer */ ae_vector* pivots,
23787  /* Complex */ ae_vector* tmp,
23788  ae_state *_state)
23789 {
23790  ae_int_t i;
23791  ae_int_t j;
23792  ae_int_t jp;
23793  ae_complex s;
23794 
23795 
23796 
23797  /*
23798  * Quick return if possible
23799  */
23800  if( m==0||n==0 )
23801  {
23802  return;
23803  }
23804  for(j=0; j<=ae_minint(m-1, n-1, _state); j++)
23805  {
23806 
23807  /*
23808  * Find pivot and test for singularity.
23809  */
23810  jp = j;
23811  for(i=j+1; i<=m-1; i++)
23812  {
23813  if( ae_fp_greater(ae_c_abs(a->ptr.pp_complex[offs+i][offs+j], _state),ae_c_abs(a->ptr.pp_complex[offs+jp][offs+j], _state)) )
23814  {
23815  jp = i;
23816  }
23817  }
23818  pivots->ptr.p_int[offs+j] = offs+jp;
23819  if( ae_c_neq_d(a->ptr.pp_complex[offs+jp][offs+j],0) )
23820  {
23821 
23822  /*
23823  *Apply the interchange to rows
23824  */
23825  if( jp!=j )
23826  {
23827  for(i=0; i<=n-1; i++)
23828  {
23829  s = a->ptr.pp_complex[offs+j][offs+i];
23830  a->ptr.pp_complex[offs+j][offs+i] = a->ptr.pp_complex[offs+jp][offs+i];
23831  a->ptr.pp_complex[offs+jp][offs+i] = s;
23832  }
23833  }
23834 
23835  /*
23836  *Compute elements J+1:M of J-th column.
23837  */
23838  if( j+1<=m-1 )
23839  {
23840  s = ae_c_d_div(1,a->ptr.pp_complex[offs+j][offs+j]);
23841  ae_v_cmulc(&a->ptr.pp_complex[offs+j+1][offs+j], a->stride, ae_v_len(offs+j+1,offs+m-1), s);
23842  }
23843  }
23844  if( j<ae_minint(m, n, _state)-1 )
23845  {
23846 
23847  /*
23848  *Update trailing submatrix.
23849  */
23850  ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs+j+1][offs+j], a->stride, "N", ae_v_len(0,m-j-2));
23851  ae_v_cmoveneg(&tmp->ptr.p_complex[m], 1, &a->ptr.pp_complex[offs+j][offs+j+1], 1, "N", ae_v_len(m,m+n-j-2));
23852  cmatrixrank1(m-j-1, n-j-1, a, offs+j+1, offs+j+1, tmp, 0, tmp, m, _state);
23853  }
23854  }
23855 }
23856 
23857 
23858 /*************************************************************************
23859 Real PLU kernel
23860 
23861  -- LAPACK routine (version 3.0) --
23862  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
23863  Courant Institute, Argonne National Lab, and Rice University
23864  June 30, 1992
23865 *************************************************************************/
23866 static void trfac_rmatrixplu2(/* Real */ ae_matrix* a,
23867  ae_int_t offs,
23868  ae_int_t m,
23869  ae_int_t n,
23870  /* Integer */ ae_vector* pivots,
23871  /* Real */ ae_vector* tmp,
23872  ae_state *_state)
23873 {
23874  ae_int_t i;
23875  ae_int_t j;
23876  ae_int_t jp;
23877  double s;
23878 
23879 
23880 
23881  /*
23882  * Quick return if possible
23883  */
23884  if( m==0||n==0 )
23885  {
23886  return;
23887  }
23888  for(j=0; j<=ae_minint(m-1, n-1, _state); j++)
23889  {
23890 
23891  /*
23892  * Find pivot and test for singularity.
23893  */
23894  jp = j;
23895  for(i=j+1; i<=m-1; i++)
23896  {
23897  if( ae_fp_greater(ae_fabs(a->ptr.pp_double[offs+i][offs+j], _state),ae_fabs(a->ptr.pp_double[offs+jp][offs+j], _state)) )
23898  {
23899  jp = i;
23900  }
23901  }
23902  pivots->ptr.p_int[offs+j] = offs+jp;
23903  if( ae_fp_neq(a->ptr.pp_double[offs+jp][offs+j],0) )
23904  {
23905 
23906  /*
23907  *Apply the interchange to rows
23908  */
23909  if( jp!=j )
23910  {
23911  for(i=0; i<=n-1; i++)
23912  {
23913  s = a->ptr.pp_double[offs+j][offs+i];
23914  a->ptr.pp_double[offs+j][offs+i] = a->ptr.pp_double[offs+jp][offs+i];
23915  a->ptr.pp_double[offs+jp][offs+i] = s;
23916  }
23917  }
23918 
23919  /*
23920  *Compute elements J+1:M of J-th column.
23921  */
23922  if( j+1<=m-1 )
23923  {
23924  s = 1/a->ptr.pp_double[offs+j][offs+j];
23925  ae_v_muld(&a->ptr.pp_double[offs+j+1][offs+j], a->stride, ae_v_len(offs+j+1,offs+m-1), s);
23926  }
23927  }
23928  if( j<ae_minint(m, n, _state)-1 )
23929  {
23930 
23931  /*
23932  *Update trailing submatrix.
23933  */
23934  ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs+j+1][offs+j], a->stride, ae_v_len(0,m-j-2));
23935  ae_v_moveneg(&tmp->ptr.p_double[m], 1, &a->ptr.pp_double[offs+j][offs+j+1], 1, ae_v_len(m,m+n-j-2));
23936  rmatrixrank1(m-j-1, n-j-1, a, offs+j+1, offs+j+1, tmp, 0, tmp, m, _state);
23937  }
23938  }
23939 }
23940 
23941 
23942 /*************************************************************************
23943 Recursive computational subroutine for HPDMatrixCholesky
23944 
23945  -- ALGLIB routine --
23946  15.12.2009
23947  Bochkanov Sergey
23948 *************************************************************************/
23949 static ae_bool trfac_hpdmatrixcholeskyrec(/* Complex */ ae_matrix* a,
23950  ae_int_t offs,
23951  ae_int_t n,
23952  ae_bool isupper,
23953  /* Complex */ ae_vector* tmp,
23954  ae_state *_state)
23955 {
23956  ae_int_t n1;
23957  ae_int_t n2;
23958  ae_bool result;
23959 
23960 
23961 
23962  /*
23963  * check N
23964  */
23965  if( n<1 )
23966  {
23967  result = ae_false;
23968  return result;
23969  }
23970 
23971  /*
23972  * Prepare buffer
23973  */
23974  if( tmp->cnt<2*n )
23975  {
23976  ae_vector_set_length(tmp, 2*n, _state);
23977  }
23978 
23979  /*
23980  * special cases
23981  */
23982  if( n==1 )
23983  {
23984  if( ae_fp_greater(a->ptr.pp_complex[offs][offs].x,0) )
23985  {
23986  a->ptr.pp_complex[offs][offs] = ae_complex_from_d(ae_sqrt(a->ptr.pp_complex[offs][offs].x, _state));
23987  result = ae_true;
23988  }
23989  else
23990  {
23991  result = ae_false;
23992  }
23993  return result;
23994  }
23995  if( n<=ablascomplexblocksize(a, _state) )
23996  {
23997  result = trfac_hpdmatrixcholesky2(a, offs, n, isupper, tmp, _state);
23998  return result;
23999  }
24000 
24001  /*
24002  * general case: split task in cache-oblivious manner
24003  */
24004  result = ae_true;
24005  ablascomplexsplitlength(a, n, &n1, &n2, _state);
24006  result = trfac_hpdmatrixcholeskyrec(a, offs, n1, isupper, tmp, _state);
24007  if( !result )
24008  {
24009  return result;
24010  }
24011  if( n2>0 )
24012  {
24013  if( isupper )
24014  {
24015  cmatrixlefttrsm(n1, n2, a, offs, offs, isupper, ae_false, 2, a, offs, offs+n1, _state);
24016  cmatrixsyrk(n2, n1, -1.0, a, offs, offs+n1, 2, 1.0, a, offs+n1, offs+n1, isupper, _state);
24017  }
24018  else
24019  {
24020  cmatrixrighttrsm(n2, n1, a, offs, offs, isupper, ae_false, 2, a, offs+n1, offs, _state);
24021  cmatrixsyrk(n2, n1, -1.0, a, offs+n1, offs, 0, 1.0, a, offs+n1, offs+n1, isupper, _state);
24022  }
24023  result = trfac_hpdmatrixcholeskyrec(a, offs+n1, n2, isupper, tmp, _state);
24024  if( !result )
24025  {
24026  return result;
24027  }
24028  }
24029  return result;
24030 }
24031 
24032 
24033 /*************************************************************************
24034 Level-2 Hermitian Cholesky subroutine.
24035 
24036  -- LAPACK routine (version 3.0) --
24037  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
24038  Courant Institute, Argonne National Lab, and Rice University
24039  February 29, 1992
24040 *************************************************************************/
24041 static ae_bool trfac_hpdmatrixcholesky2(/* Complex */ ae_matrix* aaa,
24042  ae_int_t offs,
24043  ae_int_t n,
24044  ae_bool isupper,
24045  /* Complex */ ae_vector* tmp,
24046  ae_state *_state)
24047 {
24048  ae_int_t i;
24049  ae_int_t j;
24050  double ajj;
24051  ae_complex v;
24052  double r;
24053  ae_bool result;
24054 
24055 
24056  result = ae_true;
24057  if( n<0 )
24058  {
24059  result = ae_false;
24060  return result;
24061  }
24062 
24063  /*
24064  * Quick return if possible
24065  */
24066  if( n==0 )
24067  {
24068  return result;
24069  }
24070  if( isupper )
24071  {
24072 
24073  /*
24074  * Compute the Cholesky factorization A = U'*U.
24075  */
24076  for(j=0; j<=n-1; j++)
24077  {
24078 
24079  /*
24080  * Compute U(J,J) and test for non-positive-definiteness.
24081  */
24082  v = ae_v_cdotproduct(&aaa->ptr.pp_complex[offs][offs+j], aaa->stride, "Conj", &aaa->ptr.pp_complex[offs][offs+j], aaa->stride, "N", ae_v_len(offs,offs+j-1));
24083  ajj = ae_c_sub(aaa->ptr.pp_complex[offs+j][offs+j],v).x;
24084  if( ae_fp_less_eq(ajj,0) )
24085  {
24086  aaa->ptr.pp_complex[offs+j][offs+j] = ae_complex_from_d(ajj);
24087  result = ae_false;
24088  return result;
24089  }
24090  ajj = ae_sqrt(ajj, _state);
24091  aaa->ptr.pp_complex[offs+j][offs+j] = ae_complex_from_d(ajj);
24092 
24093  /*
24094  * Compute elements J+1:N-1 of row J.
24095  */
24096  if( j<n-1 )
24097  {
24098  if( j>0 )
24099  {
24100  ae_v_cmoveneg(&tmp->ptr.p_complex[0], 1, &aaa->ptr.pp_complex[offs][offs+j], aaa->stride, "Conj", ae_v_len(0,j-1));
24101  cmatrixmv(n-j-1, j, aaa, offs, offs+j+1, 1, tmp, 0, tmp, n, _state);
24102  ae_v_cadd(&aaa->ptr.pp_complex[offs+j][offs+j+1], 1, &tmp->ptr.p_complex[n], 1, "N", ae_v_len(offs+j+1,offs+n-1));
24103  }
24104  r = 1/ajj;
24105  ae_v_cmuld(&aaa->ptr.pp_complex[offs+j][offs+j+1], 1, ae_v_len(offs+j+1,offs+n-1), r);
24106  }
24107  }
24108  }
24109  else
24110  {
24111 
24112  /*
24113  * Compute the Cholesky factorization A = L*L'.
24114  */
24115  for(j=0; j<=n-1; j++)
24116  {
24117 
24118  /*
24119  * Compute L(J+1,J+1) and test for non-positive-definiteness.
24120  */
24121  v = ae_v_cdotproduct(&aaa->ptr.pp_complex[offs+j][offs], 1, "Conj", &aaa->ptr.pp_complex[offs+j][offs], 1, "N", ae_v_len(offs,offs+j-1));
24122  ajj = ae_c_sub(aaa->ptr.pp_complex[offs+j][offs+j],v).x;
24123  if( ae_fp_less_eq(ajj,0) )
24124  {
24125  aaa->ptr.pp_complex[offs+j][offs+j] = ae_complex_from_d(ajj);
24126  result = ae_false;
24127  return result;
24128  }
24129  ajj = ae_sqrt(ajj, _state);
24130  aaa->ptr.pp_complex[offs+j][offs+j] = ae_complex_from_d(ajj);
24131 
24132  /*
24133  * Compute elements J+1:N of column J.
24134  */
24135  if( j<n-1 )
24136  {
24137  if( j>0 )
24138  {
24139  ae_v_cmove(&tmp->ptr.p_complex[0], 1, &aaa->ptr.pp_complex[offs+j][offs], 1, "Conj", ae_v_len(0,j-1));
24140  cmatrixmv(n-j-1, j, aaa, offs+j+1, offs, 0, tmp, 0, tmp, n, _state);
24141  for(i=0; i<=n-j-2; i++)
24142  {
24143  aaa->ptr.pp_complex[offs+j+1+i][offs+j] = ae_c_div_d(ae_c_sub(aaa->ptr.pp_complex[offs+j+1+i][offs+j],tmp->ptr.p_complex[n+i]),ajj);
24144  }
24145  }
24146  else
24147  {
24148  for(i=0; i<=n-j-2; i++)
24149  {
24150  aaa->ptr.pp_complex[offs+j+1+i][offs+j] = ae_c_div_d(aaa->ptr.pp_complex[offs+j+1+i][offs+j],ajj);
24151  }
24152  }
24153  }
24154  }
24155  }
24156  return result;
24157 }
24158 
24159 
24160 /*************************************************************************
24161 Level-2 Cholesky subroutine
24162 
24163  -- LAPACK routine (version 3.0) --
24164  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
24165  Courant Institute, Argonne National Lab, and Rice University
24166  February 29, 1992
24167 *************************************************************************/
24168 static ae_bool trfac_spdmatrixcholesky2(/* Real */ ae_matrix* aaa,
24169  ae_int_t offs,
24170  ae_int_t n,
24171  ae_bool isupper,
24172  /* Real */ ae_vector* tmp,
24173  ae_state *_state)
24174 {
24175  ae_int_t i;
24176  ae_int_t j;
24177  double ajj;
24178  double v;
24179  double r;
24180  ae_bool result;
24181 
24182 
24183  result = ae_true;
24184  if( n<0 )
24185  {
24186  result = ae_false;
24187  return result;
24188  }
24189 
24190  /*
24191  * Quick return if possible
24192  */
24193  if( n==0 )
24194  {
24195  return result;
24196  }
24197  if( isupper )
24198  {
24199 
24200  /*
24201  * Compute the Cholesky factorization A = U'*U.
24202  */
24203  for(j=0; j<=n-1; j++)
24204  {
24205 
24206  /*
24207  * Compute U(J,J) and test for non-positive-definiteness.
24208  */
24209  v = ae_v_dotproduct(&aaa->ptr.pp_double[offs][offs+j], aaa->stride, &aaa->ptr.pp_double[offs][offs+j], aaa->stride, ae_v_len(offs,offs+j-1));
24210  ajj = aaa->ptr.pp_double[offs+j][offs+j]-v;
24211  if( ae_fp_less_eq(ajj,0) )
24212  {
24213  aaa->ptr.pp_double[offs+j][offs+j] = ajj;
24214  result = ae_false;
24215  return result;
24216  }
24217  ajj = ae_sqrt(ajj, _state);
24218  aaa->ptr.pp_double[offs+j][offs+j] = ajj;
24219 
24220  /*
24221  * Compute elements J+1:N-1 of row J.
24222  */
24223  if( j<n-1 )
24224  {
24225  if( j>0 )
24226  {
24227  ae_v_moveneg(&tmp->ptr.p_double[0], 1, &aaa->ptr.pp_double[offs][offs+j], aaa->stride, ae_v_len(0,j-1));
24228  rmatrixmv(n-j-1, j, aaa, offs, offs+j+1, 1, tmp, 0, tmp, n, _state);
24229  ae_v_add(&aaa->ptr.pp_double[offs+j][offs+j+1], 1, &tmp->ptr.p_double[n], 1, ae_v_len(offs+j+1,offs+n-1));
24230  }
24231  r = 1/ajj;
24232  ae_v_muld(&aaa->ptr.pp_double[offs+j][offs+j+1], 1, ae_v_len(offs+j+1,offs+n-1), r);
24233  }
24234  }
24235  }
24236  else
24237  {
24238 
24239  /*
24240  * Compute the Cholesky factorization A = L*L'.
24241  */
24242  for(j=0; j<=n-1; j++)
24243  {
24244 
24245  /*
24246  * Compute L(J+1,J+1) and test for non-positive-definiteness.
24247  */
24248  v = ae_v_dotproduct(&aaa->ptr.pp_double[offs+j][offs], 1, &aaa->ptr.pp_double[offs+j][offs], 1, ae_v_len(offs,offs+j-1));
24249  ajj = aaa->ptr.pp_double[offs+j][offs+j]-v;
24250  if( ae_fp_less_eq(ajj,0) )
24251  {
24252  aaa->ptr.pp_double[offs+j][offs+j] = ajj;
24253  result = ae_false;
24254  return result;
24255  }
24256  ajj = ae_sqrt(ajj, _state);
24257  aaa->ptr.pp_double[offs+j][offs+j] = ajj;
24258 
24259  /*
24260  * Compute elements J+1:N of column J.
24261  */
24262  if( j<n-1 )
24263  {
24264  if( j>0 )
24265  {
24266  ae_v_move(&tmp->ptr.p_double[0], 1, &aaa->ptr.pp_double[offs+j][offs], 1, ae_v_len(0,j-1));
24267  rmatrixmv(n-j-1, j, aaa, offs+j+1, offs, 0, tmp, 0, tmp, n, _state);
24268  for(i=0; i<=n-j-2; i++)
24269  {
24270  aaa->ptr.pp_double[offs+j+1+i][offs+j] = (aaa->ptr.pp_double[offs+j+1+i][offs+j]-tmp->ptr.p_double[n+i])/ajj;
24271  }
24272  }
24273  else
24274  {
24275  for(i=0; i<=n-j-2; i++)
24276  {
24277  aaa->ptr.pp_double[offs+j+1+i][offs+j] = aaa->ptr.pp_double[offs+j+1+i][offs+j]/ajj;
24278  }
24279  }
24280  }
24281  }
24282  }
24283  return result;
24284 }
24285 
24286 
24287 
24288 
24289 /*************************************************************************
24290 Estimate of a matrix condition number (1-norm)
24291 
24292 The algorithm calculates a lower bound of the condition number. In this case,
24293 the algorithm does not return a lower bound of the condition number, but an
24294 inverse number (to avoid an overflow in case of a singular matrix).
24295 
24296 Input parameters:
24297  A - matrix. Array whose indexes range within [0..N-1, 0..N-1].
24298  N - size of matrix A.
24299 
24300 Result: 1/LowerBound(cond(A))
24301 
24302 NOTE:
24303  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
24304  0.0 is returned in such cases.
24305 *************************************************************************/
24306 double rmatrixrcond1(/* Real */ ae_matrix* a,
24307  ae_int_t n,
24308  ae_state *_state)
24309 {
24310  ae_frame _frame_block;
24311  ae_matrix _a;
24312  ae_int_t i;
24313  ae_int_t j;
24314  double v;
24315  double nrm;
24316  ae_vector pivots;
24317  ae_vector t;
24318  double result;
24319 
24320  ae_frame_make(_state, &_frame_block);
24321  ae_matrix_init_copy(&_a, a, _state, ae_true);
24322  a = &_a;
24323  ae_vector_init(&pivots, 0, DT_INT, _state, ae_true);
24324  ae_vector_init(&t, 0, DT_REAL, _state, ae_true);
24325 
24326  ae_assert(n>=1, "RMatrixRCond1: N<1!", _state);
24327  ae_vector_set_length(&t, n, _state);
24328  for(i=0; i<=n-1; i++)
24329  {
24330  t.ptr.p_double[i] = 0;
24331  }
24332  for(i=0; i<=n-1; i++)
24333  {
24334  for(j=0; j<=n-1; j++)
24335  {
24336  t.ptr.p_double[j] = t.ptr.p_double[j]+ae_fabs(a->ptr.pp_double[i][j], _state);
24337  }
24338  }
24339  nrm = 0;
24340  for(i=0; i<=n-1; i++)
24341  {
24342  nrm = ae_maxreal(nrm, t.ptr.p_double[i], _state);
24343  }
24344  rmatrixlu(a, n, n, &pivots, _state);
24345  rcond_rmatrixrcondluinternal(a, n, ae_true, ae_true, nrm, &v, _state);
24346  result = v;
24347  ae_frame_leave(_state);
24348  return result;
24349 }
24350 
24351 
24352 /*************************************************************************
24353 Estimate of a matrix condition number (infinity-norm).
24354 
24355 The algorithm calculates a lower bound of the condition number. In this case,
24356 the algorithm does not return a lower bound of the condition number, but an
24357 inverse number (to avoid an overflow in case of a singular matrix).
24358 
24359 Input parameters:
24360  A - matrix. Array whose indexes range within [0..N-1, 0..N-1].
24361  N - size of matrix A.
24362 
24363 Result: 1/LowerBound(cond(A))
24364 
24365 NOTE:
24366  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
24367  0.0 is returned in such cases.
24368 *************************************************************************/
24369 double rmatrixrcondinf(/* Real */ ae_matrix* a,
24370  ae_int_t n,
24371  ae_state *_state)
24372 {
24373  ae_frame _frame_block;
24374  ae_matrix _a;
24375  ae_int_t i;
24376  ae_int_t j;
24377  double v;
24378  double nrm;
24379  ae_vector pivots;
24380  double result;
24381 
24382  ae_frame_make(_state, &_frame_block);
24383  ae_matrix_init_copy(&_a, a, _state, ae_true);
24384  a = &_a;
24385  ae_vector_init(&pivots, 0, DT_INT, _state, ae_true);
24386 
24387  ae_assert(n>=1, "RMatrixRCondInf: N<1!", _state);
24388  nrm = 0;
24389  for(i=0; i<=n-1; i++)
24390  {
24391  v = 0;
24392  for(j=0; j<=n-1; j++)
24393  {
24394  v = v+ae_fabs(a->ptr.pp_double[i][j], _state);
24395  }
24396  nrm = ae_maxreal(nrm, v, _state);
24397  }
24398  rmatrixlu(a, n, n, &pivots, _state);
24399  rcond_rmatrixrcondluinternal(a, n, ae_false, ae_true, nrm, &v, _state);
24400  result = v;
24401  ae_frame_leave(_state);
24402  return result;
24403 }
24404 
24405 
24406 /*************************************************************************
24407 Condition number estimate of a symmetric positive definite matrix.
24408 
24409 The algorithm calculates a lower bound of the condition number. In this case,
24410 the algorithm does not return a lower bound of the condition number, but an
24411 inverse number (to avoid an overflow in case of a singular matrix).
24412 
24413 It should be noted that 1-norm and inf-norm of condition numbers of symmetric
24414 matrices are equal, so the algorithm doesn't take into account the
24415 differences between these types of norms.
24416 
24417 Input parameters:
24418  A - symmetric positive definite matrix which is given by its
24419  upper or lower triangle depending on the value of
24420  IsUpper. Array with elements [0..N-1, 0..N-1].
24421  N - size of matrix A.
24422  IsUpper - storage format.
24423 
24424 Result:
24425  1/LowerBound(cond(A)), if matrix A is positive definite,
24426  -1, if matrix A is not positive definite, and its condition number
24427  could not be found by this algorithm.
24428 
24429 NOTE:
24430  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
24431  0.0 is returned in such cases.
24432 *************************************************************************/
24433 double spdmatrixrcond(/* Real */ ae_matrix* a,
24434  ae_int_t n,
24435  ae_bool isupper,
24436  ae_state *_state)
24437 {
24438  ae_frame _frame_block;
24439  ae_matrix _a;
24440  ae_int_t i;
24441  ae_int_t j;
24442  ae_int_t j1;
24443  ae_int_t j2;
24444  double v;
24445  double nrm;
24446  ae_vector t;
24447  double result;
24448 
24449  ae_frame_make(_state, &_frame_block);
24450  ae_matrix_init_copy(&_a, a, _state, ae_true);
24451  a = &_a;
24452  ae_vector_init(&t, 0, DT_REAL, _state, ae_true);
24453 
24454  ae_vector_set_length(&t, n, _state);
24455  for(i=0; i<=n-1; i++)
24456  {
24457  t.ptr.p_double[i] = 0;
24458  }
24459  for(i=0; i<=n-1; i++)
24460  {
24461  if( isupper )
24462  {
24463  j1 = i;
24464  j2 = n-1;
24465  }
24466  else
24467  {
24468  j1 = 0;
24469  j2 = i;
24470  }
24471  for(j=j1; j<=j2; j++)
24472  {
24473  if( i==j )
24474  {
24475  t.ptr.p_double[i] = t.ptr.p_double[i]+ae_fabs(a->ptr.pp_double[i][i], _state);
24476  }
24477  else
24478  {
24479  t.ptr.p_double[i] = t.ptr.p_double[i]+ae_fabs(a->ptr.pp_double[i][j], _state);
24480  t.ptr.p_double[j] = t.ptr.p_double[j]+ae_fabs(a->ptr.pp_double[i][j], _state);
24481  }
24482  }
24483  }
24484  nrm = 0;
24485  for(i=0; i<=n-1; i++)
24486  {
24487  nrm = ae_maxreal(nrm, t.ptr.p_double[i], _state);
24488  }
24489  if( spdmatrixcholesky(a, n, isupper, _state) )
24490  {
24491  rcond_spdmatrixrcondcholeskyinternal(a, n, isupper, ae_true, nrm, &v, _state);
24492  result = v;
24493  }
24494  else
24495  {
24496  result = -1;
24497  }
24498  ae_frame_leave(_state);
24499  return result;
24500 }
24501 
24502 
24503 /*************************************************************************
24504 Triangular matrix: estimate of a condition number (1-norm)
24505 
24506 The algorithm calculates a lower bound of the condition number. In this case,
24507 the algorithm does not return a lower bound of the condition number, but an
24508 inverse number (to avoid an overflow in case of a singular matrix).
24509 
24510 Input parameters:
24511  A - matrix. Array[0..N-1, 0..N-1].
24512  N - size of A.
24513  IsUpper - True, if the matrix is upper triangular.
24514  IsUnit - True, if the matrix has a unit diagonal.
24515 
24516 Result: 1/LowerBound(cond(A))
24517 
24518 NOTE:
24519  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
24520  0.0 is returned in such cases.
24521 *************************************************************************/
24522 double rmatrixtrrcond1(/* Real */ ae_matrix* a,
24523  ae_int_t n,
24524  ae_bool isupper,
24525  ae_bool isunit,
24526  ae_state *_state)
24527 {
24528  ae_frame _frame_block;
24529  ae_int_t i;
24530  ae_int_t j;
24531  double v;
24532  double nrm;
24533  ae_vector pivots;
24534  ae_vector t;
24535  ae_int_t j1;
24536  ae_int_t j2;
24537  double result;
24538 
24539  ae_frame_make(_state, &_frame_block);
24540  ae_vector_init(&pivots, 0, DT_INT, _state, ae_true);
24541  ae_vector_init(&t, 0, DT_REAL, _state, ae_true);
24542 
24543  ae_assert(n>=1, "RMatrixTRRCond1: N<1!", _state);
24544  ae_vector_set_length(&t, n, _state);
24545  for(i=0; i<=n-1; i++)
24546  {
24547  t.ptr.p_double[i] = 0;
24548  }
24549  for(i=0; i<=n-1; i++)
24550  {
24551  if( isupper )
24552  {
24553  j1 = i+1;
24554  j2 = n-1;
24555  }
24556  else
24557  {
24558  j1 = 0;
24559  j2 = i-1;
24560  }
24561  for(j=j1; j<=j2; j++)
24562  {
24563  t.ptr.p_double[j] = t.ptr.p_double[j]+ae_fabs(a->ptr.pp_double[i][j], _state);
24564  }
24565  if( isunit )
24566  {
24567  t.ptr.p_double[i] = t.ptr.p_double[i]+1;
24568  }
24569  else
24570  {
24571  t.ptr.p_double[i] = t.ptr.p_double[i]+ae_fabs(a->ptr.pp_double[i][i], _state);
24572  }
24573  }
24574  nrm = 0;
24575  for(i=0; i<=n-1; i++)
24576  {
24577  nrm = ae_maxreal(nrm, t.ptr.p_double[i], _state);
24578  }
24579  rcond_rmatrixrcondtrinternal(a, n, isupper, isunit, ae_true, nrm, &v, _state);
24580  result = v;
24581  ae_frame_leave(_state);
24582  return result;
24583 }
24584 
24585 
24586 /*************************************************************************
24587 Triangular matrix: estimate of a matrix condition number (infinity-norm).
24588 
24589 The algorithm calculates a lower bound of the condition number. In this case,
24590 the algorithm does not return a lower bound of the condition number, but an
24591 inverse number (to avoid an overflow in case of a singular matrix).
24592 
24593 Input parameters:
24594  A - matrix. Array whose indexes range within [0..N-1, 0..N-1].
24595  N - size of matrix A.
24596  IsUpper - True, if the matrix is upper triangular.
24597  IsUnit - True, if the matrix has a unit diagonal.
24598 
24599 Result: 1/LowerBound(cond(A))
24600 
24601 NOTE:
24602  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
24603  0.0 is returned in such cases.
24604 *************************************************************************/
24605 double rmatrixtrrcondinf(/* Real */ ae_matrix* a,
24606  ae_int_t n,
24607  ae_bool isupper,
24608  ae_bool isunit,
24609  ae_state *_state)
24610 {
24611  ae_frame _frame_block;
24612  ae_int_t i;
24613  ae_int_t j;
24614  double v;
24615  double nrm;
24616  ae_vector pivots;
24617  ae_int_t j1;
24618  ae_int_t j2;
24619  double result;
24620 
24621  ae_frame_make(_state, &_frame_block);
24622  ae_vector_init(&pivots, 0, DT_INT, _state, ae_true);
24623 
24624  ae_assert(n>=1, "RMatrixTRRCondInf: N<1!", _state);
24625  nrm = 0;
24626  for(i=0; i<=n-1; i++)
24627  {
24628  if( isupper )
24629  {
24630  j1 = i+1;
24631  j2 = n-1;
24632  }
24633  else
24634  {
24635  j1 = 0;
24636  j2 = i-1;
24637  }
24638  v = 0;
24639  for(j=j1; j<=j2; j++)
24640  {
24641  v = v+ae_fabs(a->ptr.pp_double[i][j], _state);
24642  }
24643  if( isunit )
24644  {
24645  v = v+1;
24646  }
24647  else
24648  {
24649  v = v+ae_fabs(a->ptr.pp_double[i][i], _state);
24650  }
24651  nrm = ae_maxreal(nrm, v, _state);
24652  }
24653  rcond_rmatrixrcondtrinternal(a, n, isupper, isunit, ae_false, nrm, &v, _state);
24654  result = v;
24655  ae_frame_leave(_state);
24656  return result;
24657 }
24658 
24659 
24660 /*************************************************************************
24661 Condition number estimate of a Hermitian positive definite matrix.
24662 
24663 The algorithm calculates a lower bound of the condition number. In this case,
24664 the algorithm does not return a lower bound of the condition number, but an
24665 inverse number (to avoid an overflow in case of a singular matrix).
24666 
24667 It should be noted that 1-norm and inf-norm of condition numbers of symmetric
24668 matrices are equal, so the algorithm doesn't take into account the
24669 differences between these types of norms.
24670 
24671 Input parameters:
24672  A - Hermitian positive definite matrix which is given by its
24673  upper or lower triangle depending on the value of
24674  IsUpper. Array with elements [0..N-1, 0..N-1].
24675  N - size of matrix A.
24676  IsUpper - storage format.
24677 
24678 Result:
24679  1/LowerBound(cond(A)), if matrix A is positive definite,
24680  -1, if matrix A is not positive definite, and its condition number
24681  could not be found by this algorithm.
24682 
24683 NOTE:
24684  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
24685  0.0 is returned in such cases.
24686 *************************************************************************/
24687 double hpdmatrixrcond(/* Complex */ ae_matrix* a,
24688  ae_int_t n,
24689  ae_bool isupper,
24690  ae_state *_state)
24691 {
24692  ae_frame _frame_block;
24693  ae_matrix _a;
24694  ae_int_t i;
24695  ae_int_t j;
24696  ae_int_t j1;
24697  ae_int_t j2;
24698  double v;
24699  double nrm;
24700  ae_vector t;
24701  double result;
24702 
24703  ae_frame_make(_state, &_frame_block);
24704  ae_matrix_init_copy(&_a, a, _state, ae_true);
24705  a = &_a;
24706  ae_vector_init(&t, 0, DT_REAL, _state, ae_true);
24707 
24708  ae_vector_set_length(&t, n, _state);
24709  for(i=0; i<=n-1; i++)
24710  {
24711  t.ptr.p_double[i] = 0;
24712  }
24713  for(i=0; i<=n-1; i++)
24714  {
24715  if( isupper )
24716  {
24717  j1 = i;
24718  j2 = n-1;
24719  }
24720  else
24721  {
24722  j1 = 0;
24723  j2 = i;
24724  }
24725  for(j=j1; j<=j2; j++)
24726  {
24727  if( i==j )
24728  {
24729  t.ptr.p_double[i] = t.ptr.p_double[i]+ae_c_abs(a->ptr.pp_complex[i][i], _state);
24730  }
24731  else
24732  {
24733  t.ptr.p_double[i] = t.ptr.p_double[i]+ae_c_abs(a->ptr.pp_complex[i][j], _state);
24734  t.ptr.p_double[j] = t.ptr.p_double[j]+ae_c_abs(a->ptr.pp_complex[i][j], _state);
24735  }
24736  }
24737  }
24738  nrm = 0;
24739  for(i=0; i<=n-1; i++)
24740  {
24741  nrm = ae_maxreal(nrm, t.ptr.p_double[i], _state);
24742  }
24743  if( hpdmatrixcholesky(a, n, isupper, _state) )
24744  {
24745  rcond_hpdmatrixrcondcholeskyinternal(a, n, isupper, ae_true, nrm, &v, _state);
24746  result = v;
24747  }
24748  else
24749  {
24750  result = -1;
24751  }
24752  ae_frame_leave(_state);
24753  return result;
24754 }
24755 
24756 
24757 /*************************************************************************
24758 Estimate of a matrix condition number (1-norm)
24759 
24760 The algorithm calculates a lower bound of the condition number. In this case,
24761 the algorithm does not return a lower bound of the condition number, but an
24762 inverse number (to avoid an overflow in case of a singular matrix).
24763 
24764 Input parameters:
24765  A - matrix. Array whose indexes range within [0..N-1, 0..N-1].
24766  N - size of matrix A.
24767 
24768 Result: 1/LowerBound(cond(A))
24769 
24770 NOTE:
24771  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
24772  0.0 is returned in such cases.
24773 *************************************************************************/
24774 double cmatrixrcond1(/* Complex */ ae_matrix* a,
24775  ae_int_t n,
24776  ae_state *_state)
24777 {
24778  ae_frame _frame_block;
24779  ae_matrix _a;
24780  ae_int_t i;
24781  ae_int_t j;
24782  double v;
24783  double nrm;
24784  ae_vector pivots;
24785  ae_vector t;
24786  double result;
24787 
24788  ae_frame_make(_state, &_frame_block);
24789  ae_matrix_init_copy(&_a, a, _state, ae_true);
24790  a = &_a;
24791  ae_vector_init(&pivots, 0, DT_INT, _state, ae_true);
24792  ae_vector_init(&t, 0, DT_REAL, _state, ae_true);
24793 
24794  ae_assert(n>=1, "CMatrixRCond1: N<1!", _state);
24795  ae_vector_set_length(&t, n, _state);
24796  for(i=0; i<=n-1; i++)
24797  {
24798  t.ptr.p_double[i] = 0;
24799  }
24800  for(i=0; i<=n-1; i++)
24801  {
24802  for(j=0; j<=n-1; j++)
24803  {
24804  t.ptr.p_double[j] = t.ptr.p_double[j]+ae_c_abs(a->ptr.pp_complex[i][j], _state);
24805  }
24806  }
24807  nrm = 0;
24808  for(i=0; i<=n-1; i++)
24809  {
24810  nrm = ae_maxreal(nrm, t.ptr.p_double[i], _state);
24811  }
24812  cmatrixlu(a, n, n, &pivots, _state);
24813  rcond_cmatrixrcondluinternal(a, n, ae_true, ae_true, nrm, &v, _state);
24814  result = v;
24815  ae_frame_leave(_state);
24816  return result;
24817 }
24818 
24819 
24820 /*************************************************************************
24821 Estimate of a matrix condition number (infinity-norm).
24822 
24823 The algorithm calculates a lower bound of the condition number. In this case,
24824 the algorithm does not return a lower bound of the condition number, but an
24825 inverse number (to avoid an overflow in case of a singular matrix).
24826 
24827 Input parameters:
24828  A - matrix. Array whose indexes range within [0..N-1, 0..N-1].
24829  N - size of matrix A.
24830 
24831 Result: 1/LowerBound(cond(A))
24832 
24833 NOTE:
24834  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
24835  0.0 is returned in such cases.
24836 *************************************************************************/
24837 double cmatrixrcondinf(/* Complex */ ae_matrix* a,
24838  ae_int_t n,
24839  ae_state *_state)
24840 {
24841  ae_frame _frame_block;
24842  ae_matrix _a;
24843  ae_int_t i;
24844  ae_int_t j;
24845  double v;
24846  double nrm;
24847  ae_vector pivots;
24848  double result;
24849 
24850  ae_frame_make(_state, &_frame_block);
24851  ae_matrix_init_copy(&_a, a, _state, ae_true);
24852  a = &_a;
24853  ae_vector_init(&pivots, 0, DT_INT, _state, ae_true);
24854 
24855  ae_assert(n>=1, "CMatrixRCondInf: N<1!", _state);
24856  nrm = 0;
24857  for(i=0; i<=n-1; i++)
24858  {
24859  v = 0;
24860  for(j=0; j<=n-1; j++)
24861  {
24862  v = v+ae_c_abs(a->ptr.pp_complex[i][j], _state);
24863  }
24864  nrm = ae_maxreal(nrm, v, _state);
24865  }
24866  cmatrixlu(a, n, n, &pivots, _state);
24867  rcond_cmatrixrcondluinternal(a, n, ae_false, ae_true, nrm, &v, _state);
24868  result = v;
24869  ae_frame_leave(_state);
24870  return result;
24871 }
24872 
24873 
24874 /*************************************************************************
24875 Estimate of the condition number of a matrix given by its LU decomposition (1-norm)
24876 
24877 The algorithm calculates a lower bound of the condition number. In this case,
24878 the algorithm does not return a lower bound of the condition number, but an
24879 inverse number (to avoid an overflow in case of a singular matrix).
24880 
24881 Input parameters:
24882  LUA - LU decomposition of a matrix in compact form. Output of
24883  the RMatrixLU subroutine.
24884  N - size of matrix A.
24885 
24886 Result: 1/LowerBound(cond(A))
24887 
24888 NOTE:
24889  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
24890  0.0 is returned in such cases.
24891 *************************************************************************/
24892 double rmatrixlurcond1(/* Real */ ae_matrix* lua,
24893  ae_int_t n,
24894  ae_state *_state)
24895 {
24896  double v;
24897  double result;
24898 
24899 
24900  rcond_rmatrixrcondluinternal(lua, n, ae_true, ae_false, 0, &v, _state);
24901  result = v;
24902  return result;
24903 }
24904 
24905 
24906 /*************************************************************************
24907 Estimate of the condition number of a matrix given by its LU decomposition
24908 (infinity norm).
24909 
24910 The algorithm calculates a lower bound of the condition number. In this case,
24911 the algorithm does not return a lower bound of the condition number, but an
24912 inverse number (to avoid an overflow in case of a singular matrix).
24913 
24914 Input parameters:
24915  LUA - LU decomposition of a matrix in compact form. Output of
24916  the RMatrixLU subroutine.
24917  N - size of matrix A.
24918 
24919 Result: 1/LowerBound(cond(A))
24920 
24921 NOTE:
24922  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
24923  0.0 is returned in such cases.
24924 *************************************************************************/
24925 double rmatrixlurcondinf(/* Real */ ae_matrix* lua,
24926  ae_int_t n,
24927  ae_state *_state)
24928 {
24929  double v;
24930  double result;
24931 
24932 
24933  rcond_rmatrixrcondluinternal(lua, n, ae_false, ae_false, 0, &v, _state);
24934  result = v;
24935  return result;
24936 }
24937 
24938 
24939 /*************************************************************************
24940 Condition number estimate of a symmetric positive definite matrix given by
24941 Cholesky decomposition.
24942 
24943 The algorithm calculates a lower bound of the condition number. In this
24944 case, the algorithm does not return a lower bound of the condition number,
24945 but an inverse number (to avoid an overflow in case of a singular matrix).
24946 
24947 It should be noted that 1-norm and inf-norm condition numbers of symmetric
24948 matrices are equal, so the algorithm doesn't take into account the
24949 differences between these types of norms.
24950 
24951 Input parameters:
24952  CD - Cholesky decomposition of matrix A,
24953  output of SMatrixCholesky subroutine.
24954  N - size of matrix A.
24955 
24956 Result: 1/LowerBound(cond(A))
24957 
24958 NOTE:
24959  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
24960  0.0 is returned in such cases.
24961 *************************************************************************/
24962 double spdmatrixcholeskyrcond(/* Real */ ae_matrix* a,
24963  ae_int_t n,
24964  ae_bool isupper,
24965  ae_state *_state)
24966 {
24967  double v;
24968  double result;
24969 
24970 
24971  rcond_spdmatrixrcondcholeskyinternal(a, n, isupper, ae_false, 0, &v, _state);
24972  result = v;
24973  return result;
24974 }
24975 
24976 
24977 /*************************************************************************
24978 Condition number estimate of a Hermitian positive definite matrix given by
24979 Cholesky decomposition.
24980 
24981 The algorithm calculates a lower bound of the condition number. In this
24982 case, the algorithm does not return a lower bound of the condition number,
24983 but an inverse number (to avoid an overflow in case of a singular matrix).
24984 
24985 It should be noted that 1-norm and inf-norm condition numbers of symmetric
24986 matrices are equal, so the algorithm doesn't take into account the
24987 differences between these types of norms.
24988 
24989 Input parameters:
24990  CD - Cholesky decomposition of matrix A,
24991  output of SMatrixCholesky subroutine.
24992  N - size of matrix A.
24993 
24994 Result: 1/LowerBound(cond(A))
24995 
24996 NOTE:
24997  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
24998  0.0 is returned in such cases.
24999 *************************************************************************/
25000 double hpdmatrixcholeskyrcond(/* Complex */ ae_matrix* a,
25001  ae_int_t n,
25002  ae_bool isupper,
25003  ae_state *_state)
25004 {
25005  double v;
25006  double result;
25007 
25008 
25009  rcond_hpdmatrixrcondcholeskyinternal(a, n, isupper, ae_false, 0, &v, _state);
25010  result = v;
25011  return result;
25012 }
25013 
25014 
25015 /*************************************************************************
25016 Estimate of the condition number of a matrix given by its LU decomposition (1-norm)
25017 
25018 The algorithm calculates a lower bound of the condition number. In this case,
25019 the algorithm does not return a lower bound of the condition number, but an
25020 inverse number (to avoid an overflow in case of a singular matrix).
25021 
25022 Input parameters:
25023  LUA - LU decomposition of a matrix in compact form. Output of
25024  the CMatrixLU subroutine.
25025  N - size of matrix A.
25026 
25027 Result: 1/LowerBound(cond(A))
25028 
25029 NOTE:
25030  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
25031  0.0 is returned in such cases.
25032 *************************************************************************/
25033 double cmatrixlurcond1(/* Complex */ ae_matrix* lua,
25034  ae_int_t n,
25035  ae_state *_state)
25036 {
25037  double v;
25038  double result;
25039 
25040 
25041  ae_assert(n>=1, "CMatrixLURCond1: N<1!", _state);
25042  rcond_cmatrixrcondluinternal(lua, n, ae_true, ae_false, 0.0, &v, _state);
25043  result = v;
25044  return result;
25045 }
25046 
25047 
25048 /*************************************************************************
25049 Estimate of the condition number of a matrix given by its LU decomposition
25050 (infinity norm).
25051 
25052 The algorithm calculates a lower bound of the condition number. In this case,
25053 the algorithm does not return a lower bound of the condition number, but an
25054 inverse number (to avoid an overflow in case of a singular matrix).
25055 
25056 Input parameters:
25057  LUA - LU decomposition of a matrix in compact form. Output of
25058  the CMatrixLU subroutine.
25059  N - size of matrix A.
25060 
25061 Result: 1/LowerBound(cond(A))
25062 
25063 NOTE:
25064  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
25065  0.0 is returned in such cases.
25066 *************************************************************************/
25067 double cmatrixlurcondinf(/* Complex */ ae_matrix* lua,
25068  ae_int_t n,
25069  ae_state *_state)
25070 {
25071  double v;
25072  double result;
25073 
25074 
25075  ae_assert(n>=1, "CMatrixLURCondInf: N<1!", _state);
25076  rcond_cmatrixrcondluinternal(lua, n, ae_false, ae_false, 0.0, &v, _state);
25077  result = v;
25078  return result;
25079 }
25080 
25081 
25082 /*************************************************************************
25083 Triangular matrix: estimate of a condition number (1-norm)
25084 
25085 The algorithm calculates a lower bound of the condition number. In this case,
25086 the algorithm does not return a lower bound of the condition number, but an
25087 inverse number (to avoid an overflow in case of a singular matrix).
25088 
25089 Input parameters:
25090  A - matrix. Array[0..N-1, 0..N-1].
25091  N - size of A.
25092  IsUpper - True, if the matrix is upper triangular.
25093  IsUnit - True, if the matrix has a unit diagonal.
25094 
25095 Result: 1/LowerBound(cond(A))
25096 
25097 NOTE:
25098  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
25099  0.0 is returned in such cases.
25100 *************************************************************************/
25101 double cmatrixtrrcond1(/* Complex */ ae_matrix* a,
25102  ae_int_t n,
25103  ae_bool isupper,
25104  ae_bool isunit,
25105  ae_state *_state)
25106 {
25107  ae_frame _frame_block;
25108  ae_int_t i;
25109  ae_int_t j;
25110  double v;
25111  double nrm;
25112  ae_vector pivots;
25113  ae_vector t;
25114  ae_int_t j1;
25115  ae_int_t j2;
25116  double result;
25117 
25118  ae_frame_make(_state, &_frame_block);
25119  ae_vector_init(&pivots, 0, DT_INT, _state, ae_true);
25120  ae_vector_init(&t, 0, DT_REAL, _state, ae_true);
25121 
25122  ae_assert(n>=1, "RMatrixTRRCond1: N<1!", _state);
25123  ae_vector_set_length(&t, n, _state);
25124  for(i=0; i<=n-1; i++)
25125  {
25126  t.ptr.p_double[i] = 0;
25127  }
25128  for(i=0; i<=n-1; i++)
25129  {
25130  if( isupper )
25131  {
25132  j1 = i+1;
25133  j2 = n-1;
25134  }
25135  else
25136  {
25137  j1 = 0;
25138  j2 = i-1;
25139  }
25140  for(j=j1; j<=j2; j++)
25141  {
25142  t.ptr.p_double[j] = t.ptr.p_double[j]+ae_c_abs(a->ptr.pp_complex[i][j], _state);
25143  }
25144  if( isunit )
25145  {
25146  t.ptr.p_double[i] = t.ptr.p_double[i]+1;
25147  }
25148  else
25149  {
25150  t.ptr.p_double[i] = t.ptr.p_double[i]+ae_c_abs(a->ptr.pp_complex[i][i], _state);
25151  }
25152  }
25153  nrm = 0;
25154  for(i=0; i<=n-1; i++)
25155  {
25156  nrm = ae_maxreal(nrm, t.ptr.p_double[i], _state);
25157  }
25158  rcond_cmatrixrcondtrinternal(a, n, isupper, isunit, ae_true, nrm, &v, _state);
25159  result = v;
25160  ae_frame_leave(_state);
25161  return result;
25162 }
25163 
25164 
25165 /*************************************************************************
25166 Triangular matrix: estimate of a matrix condition number (infinity-norm).
25167 
25168 The algorithm calculates a lower bound of the condition number. In this case,
25169 the algorithm does not return a lower bound of the condition number, but an
25170 inverse number (to avoid an overflow in case of a singular matrix).
25171 
25172 Input parameters:
25173  A - matrix. Array whose indexes range within [0..N-1, 0..N-1].
25174  N - size of matrix A.
25175  IsUpper - True, if the matrix is upper triangular.
25176  IsUnit - True, if the matrix has a unit diagonal.
25177 
25178 Result: 1/LowerBound(cond(A))
25179 
25180 NOTE:
25181  if k(A) is very large, then matrix is assumed degenerate, k(A)=INF,
25182  0.0 is returned in such cases.
25183 *************************************************************************/
25184 double cmatrixtrrcondinf(/* Complex */ ae_matrix* a,
25185  ae_int_t n,
25186  ae_bool isupper,
25187  ae_bool isunit,
25188  ae_state *_state)
25189 {
25190  ae_frame _frame_block;
25191  ae_int_t i;
25192  ae_int_t j;
25193  double v;
25194  double nrm;
25195  ae_vector pivots;
25196  ae_int_t j1;
25197  ae_int_t j2;
25198  double result;
25199 
25200  ae_frame_make(_state, &_frame_block);
25201  ae_vector_init(&pivots, 0, DT_INT, _state, ae_true);
25202 
25203  ae_assert(n>=1, "RMatrixTRRCondInf: N<1!", _state);
25204  nrm = 0;
25205  for(i=0; i<=n-1; i++)
25206  {
25207  if( isupper )
25208  {
25209  j1 = i+1;
25210  j2 = n-1;
25211  }
25212  else
25213  {
25214  j1 = 0;
25215  j2 = i-1;
25216  }
25217  v = 0;
25218  for(j=j1; j<=j2; j++)
25219  {
25220  v = v+ae_c_abs(a->ptr.pp_complex[i][j], _state);
25221  }
25222  if( isunit )
25223  {
25224  v = v+1;
25225  }
25226  else
25227  {
25228  v = v+ae_c_abs(a->ptr.pp_complex[i][i], _state);
25229  }
25230  nrm = ae_maxreal(nrm, v, _state);
25231  }
25232  rcond_cmatrixrcondtrinternal(a, n, isupper, isunit, ae_false, nrm, &v, _state);
25233  result = v;
25234  ae_frame_leave(_state);
25235  return result;
25236 }
25237 
25238 
25239 /*************************************************************************
25240 Threshold for rcond: matrices with condition number beyond this threshold
25241 are considered singular.
25242 
25243 Threshold must be far enough from underflow, at least Sqr(Threshold) must
25244 be greater than underflow.
25245 *************************************************************************/
25246 double rcondthreshold(ae_state *_state)
25247 {
25248  double result;
25249 
25250 
25251  result = ae_sqrt(ae_sqrt(ae_minrealnumber, _state), _state);
25252  return result;
25253 }
25254 
25255 
25256 /*************************************************************************
25257 Internal subroutine for condition number estimation
25258 
25259  -- LAPACK routine (version 3.0) --
25260  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
25261  Courant Institute, Argonne National Lab, and Rice University
25262  February 29, 1992
25263 *************************************************************************/
25264 static void rcond_rmatrixrcondtrinternal(/* Real */ ae_matrix* a,
25265  ae_int_t n,
25266  ae_bool isupper,
25267  ae_bool isunit,
25268  ae_bool onenorm,
25269  double anorm,
25270  double* rc,
25271  ae_state *_state)
25272 {
25273  ae_frame _frame_block;
25274  ae_vector ex;
25275  ae_vector ev;
25276  ae_vector iwork;
25277  ae_vector tmp;
25278  ae_int_t i;
25279  ae_int_t j;
25280  ae_int_t kase;
25281  ae_int_t kase1;
25282  ae_int_t j1;
25283  ae_int_t j2;
25284  double ainvnm;
25285  double maxgrowth;
25286  double s;
25287 
25288  ae_frame_make(_state, &_frame_block);
25289  *rc = 0;
25290  ae_vector_init(&ex, 0, DT_REAL, _state, ae_true);
25291  ae_vector_init(&ev, 0, DT_REAL, _state, ae_true);
25292  ae_vector_init(&iwork, 0, DT_INT, _state, ae_true);
25293  ae_vector_init(&tmp, 0, DT_REAL, _state, ae_true);
25294 
25295 
25296  /*
25297  * RC=0 if something happens
25298  */
25299  *rc = 0;
25300 
25301  /*
25302  * init
25303  */
25304  if( onenorm )
25305  {
25306  kase1 = 1;
25307  }
25308  else
25309  {
25310  kase1 = 2;
25311  }
25312  ae_vector_set_length(&iwork, n+1, _state);
25313  ae_vector_set_length(&tmp, n, _state);
25314 
25315  /*
25316  * prepare parameters for triangular solver
25317  */
25318  maxgrowth = 1/rcondthreshold(_state);
25319  s = 0;
25320  for(i=0; i<=n-1; i++)
25321  {
25322  if( isupper )
25323  {
25324  j1 = i+1;
25325  j2 = n-1;
25326  }
25327  else
25328  {
25329  j1 = 0;
25330  j2 = i-1;
25331  }
25332  for(j=j1; j<=j2; j++)
25333  {
25334  s = ae_maxreal(s, ae_fabs(a->ptr.pp_double[i][j], _state), _state);
25335  }
25336  if( isunit )
25337  {
25338  s = ae_maxreal(s, 1, _state);
25339  }
25340  else
25341  {
25342  s = ae_maxreal(s, ae_fabs(a->ptr.pp_double[i][i], _state), _state);
25343  }
25344  }
25345  if( ae_fp_eq(s,0) )
25346  {
25347  s = 1;
25348  }
25349  s = 1/s;
25350 
25351  /*
25352  * Scale according to S
25353  */
25354  anorm = anorm*s;
25355 
25356  /*
25357  * Quick return if possible
25358  * We assume that ANORM<>0 after this block
25359  */
25360  if( ae_fp_eq(anorm,0) )
25361  {
25362  ae_frame_leave(_state);
25363  return;
25364  }
25365  if( n==1 )
25366  {
25367  *rc = 1;
25368  ae_frame_leave(_state);
25369  return;
25370  }
25371 
25372  /*
25373  * Estimate the norm of inv(A).
25374  */
25375  ainvnm = 0;
25376  kase = 0;
25377  for(;;)
25378  {
25379  rcond_rmatrixestimatenorm(n, &ev, &ex, &iwork, &ainvnm, &kase, _state);
25380  if( kase==0 )
25381  {
25382  break;
25383  }
25384 
25385  /*
25386  * from 1-based array to 0-based
25387  */
25388  for(i=0; i<=n-1; i++)
25389  {
25390  ex.ptr.p_double[i] = ex.ptr.p_double[i+1];
25391  }
25392 
25393  /*
25394  * multiply by inv(A) or inv(A')
25395  */
25396  if( kase==kase1 )
25397  {
25398 
25399  /*
25400  * multiply by inv(A)
25401  */
25402  if( !rmatrixscaledtrsafesolve(a, s, n, &ex, isupper, 0, isunit, maxgrowth, _state) )
25403  {
25404  ae_frame_leave(_state);
25405  return;
25406  }
25407  }
25408  else
25409  {
25410 
25411  /*
25412  * multiply by inv(A')
25413  */
25414  if( !rmatrixscaledtrsafesolve(a, s, n, &ex, isupper, 1, isunit, maxgrowth, _state) )
25415  {
25416  ae_frame_leave(_state);
25417  return;
25418  }
25419  }
25420 
25421  /*
25422  * from 0-based array to 1-based
25423  */
25424  for(i=n-1; i>=0; i--)
25425  {
25426  ex.ptr.p_double[i+1] = ex.ptr.p_double[i];
25427  }
25428  }
25429 
25430  /*
25431  * Compute the estimate of the reciprocal condition number.
25432  */
25433  if( ae_fp_neq(ainvnm,0) )
25434  {
25435  *rc = 1/ainvnm;
25436  *rc = *rc/anorm;
25437  if( ae_fp_less(*rc,rcondthreshold(_state)) )
25438  {
25439  *rc = 0;
25440  }
25441  }
25442  ae_frame_leave(_state);
25443 }
25444 
25445 
25446 /*************************************************************************
25447 Condition number estimation
25448 
25449  -- LAPACK routine (version 3.0) --
25450  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
25451  Courant Institute, Argonne National Lab, and Rice University
25452  March 31, 1993
25453 *************************************************************************/
25454 static void rcond_cmatrixrcondtrinternal(/* Complex */ ae_matrix* a,
25455  ae_int_t n,
25456  ae_bool isupper,
25457  ae_bool isunit,
25458  ae_bool onenorm,
25459  double anorm,
25460  double* rc,
25461  ae_state *_state)
25462 {
25463  ae_frame _frame_block;
25464  ae_vector ex;
25465  ae_vector cwork2;
25466  ae_vector cwork3;
25467  ae_vector cwork4;
25468  ae_vector isave;
25469  ae_vector rsave;
25470  ae_int_t kase;
25471  ae_int_t kase1;
25472  double ainvnm;
25473  ae_int_t i;
25474  ae_int_t j;
25475  ae_int_t j1;
25476  ae_int_t j2;
25477  double s;
25478  double maxgrowth;
25479 
25480  ae_frame_make(_state, &_frame_block);
25481  *rc = 0;
25482  ae_vector_init(&ex, 0, DT_COMPLEX, _state, ae_true);
25483  ae_vector_init(&cwork2, 0, DT_COMPLEX, _state, ae_true);
25484  ae_vector_init(&cwork3, 0, DT_COMPLEX, _state, ae_true);
25485  ae_vector_init(&cwork4, 0, DT_COMPLEX, _state, ae_true);
25486  ae_vector_init(&isave, 0, DT_INT, _state, ae_true);
25487  ae_vector_init(&rsave, 0, DT_REAL, _state, ae_true);
25488 
25489 
25490  /*
25491  * RC=0 if something happens
25492  */
25493  *rc = 0;
25494 
25495  /*
25496  * init
25497  */
25498  if( n<=0 )
25499  {
25500  ae_frame_leave(_state);
25501  return;
25502  }
25503  if( n==0 )
25504  {
25505  *rc = 1;
25506  ae_frame_leave(_state);
25507  return;
25508  }
25509  ae_vector_set_length(&cwork2, n+1, _state);
25510 
25511  /*
25512  * prepare parameters for triangular solver
25513  */
25514  maxgrowth = 1/rcondthreshold(_state);
25515  s = 0;
25516  for(i=0; i<=n-1; i++)
25517  {
25518  if( isupper )
25519  {
25520  j1 = i+1;
25521  j2 = n-1;
25522  }
25523  else
25524  {
25525  j1 = 0;
25526  j2 = i-1;
25527  }
25528  for(j=j1; j<=j2; j++)
25529  {
25530  s = ae_maxreal(s, ae_c_abs(a->ptr.pp_complex[i][j], _state), _state);
25531  }
25532  if( isunit )
25533  {
25534  s = ae_maxreal(s, 1, _state);
25535  }
25536  else
25537  {
25538  s = ae_maxreal(s, ae_c_abs(a->ptr.pp_complex[i][i], _state), _state);
25539  }
25540  }
25541  if( ae_fp_eq(s,0) )
25542  {
25543  s = 1;
25544  }
25545  s = 1/s;
25546 
25547  /*
25548  * Scale according to S
25549  */
25550  anorm = anorm*s;
25551 
25552  /*
25553  * Quick return if possible
25554  */
25555  if( ae_fp_eq(anorm,0) )
25556  {
25557  ae_frame_leave(_state);
25558  return;
25559  }
25560 
25561  /*
25562  * Estimate the norm of inv(A).
25563  */
25564  ainvnm = 0;
25565  if( onenorm )
25566  {
25567  kase1 = 1;
25568  }
25569  else
25570  {
25571  kase1 = 2;
25572  }
25573  kase = 0;
25574  for(;;)
25575  {
25576  rcond_cmatrixestimatenorm(n, &cwork4, &ex, &ainvnm, &kase, &isave, &rsave, _state);
25577  if( kase==0 )
25578  {
25579  break;
25580  }
25581 
25582  /*
25583  * From 1-based to 0-based
25584  */
25585  for(i=0; i<=n-1; i++)
25586  {
25587  ex.ptr.p_complex[i] = ex.ptr.p_complex[i+1];
25588  }
25589 
25590  /*
25591  * multiply by inv(A) or inv(A')
25592  */
25593  if( kase==kase1 )
25594  {
25595 
25596  /*
25597  * multiply by inv(A)
25598  */
25599  if( !cmatrixscaledtrsafesolve(a, s, n, &ex, isupper, 0, isunit, maxgrowth, _state) )
25600  {
25601  ae_frame_leave(_state);
25602  return;
25603  }
25604  }
25605  else
25606  {
25607 
25608  /*
25609  * multiply by inv(A')
25610  */
25611  if( !cmatrixscaledtrsafesolve(a, s, n, &ex, isupper, 2, isunit, maxgrowth, _state) )
25612  {
25613  ae_frame_leave(_state);
25614  return;
25615  }
25616  }
25617 
25618  /*
25619  * from 0-based to 1-based
25620  */
25621  for(i=n-1; i>=0; i--)
25622  {
25623  ex.ptr.p_complex[i+1] = ex.ptr.p_complex[i];
25624  }
25625  }
25626 
25627  /*
25628  * Compute the estimate of the reciprocal condition number.
25629  */
25630  if( ae_fp_neq(ainvnm,0) )
25631  {
25632  *rc = 1/ainvnm;
25633  *rc = *rc/anorm;
25634  if( ae_fp_less(*rc,rcondthreshold(_state)) )
25635  {
25636  *rc = 0;
25637  }
25638  }
25639  ae_frame_leave(_state);
25640 }
25641 
25642 
25643 /*************************************************************************
25644 Internal subroutine for condition number estimation
25645 
25646  -- LAPACK routine (version 3.0) --
25647  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
25648  Courant Institute, Argonne National Lab, and Rice University
25649  February 29, 1992
25650 *************************************************************************/
25651 static void rcond_spdmatrixrcondcholeskyinternal(/* Real */ ae_matrix* cha,
25652  ae_int_t n,
25653  ae_bool isupper,
25654  ae_bool isnormprovided,
25655  double anorm,
25656  double* rc,
25657  ae_state *_state)
25658 {
25659  ae_frame _frame_block;
25660  ae_int_t i;
25661  ae_int_t j;
25662  ae_int_t kase;
25663  double ainvnm;
25664  ae_vector ex;
25665  ae_vector ev;
25666  ae_vector tmp;
25667  ae_vector iwork;
25668  double sa;
25669  double v;
25670  double maxgrowth;
25671 
25672  ae_frame_make(_state, &_frame_block);
25673  *rc = 0;
25674  ae_vector_init(&ex, 0, DT_REAL, _state, ae_true);
25675  ae_vector_init(&ev, 0, DT_REAL, _state, ae_true);
25676  ae_vector_init(&tmp, 0, DT_REAL, _state, ae_true);
25677  ae_vector_init(&iwork, 0, DT_INT, _state, ae_true);
25678 
25679  ae_assert(n>=1, "Assertion failed", _state);
25680  ae_vector_set_length(&tmp, n, _state);
25681 
25682  /*
25683  * RC=0 if something happens
25684  */
25685  *rc = 0;
25686 
25687  /*
25688  * prepare parameters for triangular solver
25689  */
25690  maxgrowth = 1/rcondthreshold(_state);
25691  sa = 0;
25692  if( isupper )
25693  {
25694  for(i=0; i<=n-1; i++)
25695  {
25696  for(j=i; j<=n-1; j++)
25697  {
25698  sa = ae_maxreal(sa, ae_c_abs(ae_complex_from_d(cha->ptr.pp_double[i][j]), _state), _state);
25699  }
25700  }
25701  }
25702  else
25703  {
25704  for(i=0; i<=n-1; i++)
25705  {
25706  for(j=0; j<=i; j++)
25707  {
25708  sa = ae_maxreal(sa, ae_c_abs(ae_complex_from_d(cha->ptr.pp_double[i][j]), _state), _state);
25709  }
25710  }
25711  }
25712  if( ae_fp_eq(sa,0) )
25713  {
25714  sa = 1;
25715  }
25716  sa = 1/sa;
25717 
25718  /*
25719  * Estimate the norm of A.
25720  */
25721  if( !isnormprovided )
25722  {
25723  kase = 0;
25724  anorm = 0;
25725  for(;;)
25726  {
25727  rcond_rmatrixestimatenorm(n, &ev, &ex, &iwork, &anorm, &kase, _state);
25728  if( kase==0 )
25729  {
25730  break;
25731  }
25732  if( isupper )
25733  {
25734 
25735  /*
25736  * Multiply by U
25737  */
25738  for(i=1; i<=n; i++)
25739  {
25740  v = ae_v_dotproduct(&cha->ptr.pp_double[i-1][i-1], 1, &ex.ptr.p_double[i], 1, ae_v_len(i-1,n-1));
25741  ex.ptr.p_double[i] = v;
25742  }
25743  ae_v_muld(&ex.ptr.p_double[1], 1, ae_v_len(1,n), sa);
25744 
25745  /*
25746  * Multiply by U'
25747  */
25748  for(i=0; i<=n-1; i++)
25749  {
25750  tmp.ptr.p_double[i] = 0;
25751  }
25752  for(i=0; i<=n-1; i++)
25753  {
25754  v = ex.ptr.p_double[i+1];
25755  ae_v_addd(&tmp.ptr.p_double[i], 1, &cha->ptr.pp_double[i][i], 1, ae_v_len(i,n-1), v);
25756  }
25757  ae_v_move(&ex.ptr.p_double[1], 1, &tmp.ptr.p_double[0], 1, ae_v_len(1,n));
25758  ae_v_muld(&ex.ptr.p_double[1], 1, ae_v_len(1,n), sa);
25759  }
25760  else
25761  {
25762 
25763  /*
25764  * Multiply by L'
25765  */
25766  for(i=0; i<=n-1; i++)
25767  {
25768  tmp.ptr.p_double[i] = 0;
25769  }
25770  for(i=0; i<=n-1; i++)
25771  {
25772  v = ex.ptr.p_double[i+1];
25773  ae_v_addd(&tmp.ptr.p_double[0], 1, &cha->ptr.pp_double[i][0], 1, ae_v_len(0,i), v);
25774  }
25775  ae_v_move(&ex.ptr.p_double[1], 1, &tmp.ptr.p_double[0], 1, ae_v_len(1,n));
25776  ae_v_muld(&ex.ptr.p_double[1], 1, ae_v_len(1,n), sa);
25777 
25778  /*
25779  * Multiply by L
25780  */
25781  for(i=n; i>=1; i--)
25782  {
25783  v = ae_v_dotproduct(&cha->ptr.pp_double[i-1][0], 1, &ex.ptr.p_double[1], 1, ae_v_len(0,i-1));
25784  ex.ptr.p_double[i] = v;
25785  }
25786  ae_v_muld(&ex.ptr.p_double[1], 1, ae_v_len(1,n), sa);
25787  }
25788  }
25789  }
25790 
25791  /*
25792  * Quick return if possible
25793  */
25794  if( ae_fp_eq(anorm,0) )
25795  {
25796  ae_frame_leave(_state);
25797  return;
25798  }
25799  if( n==1 )
25800  {
25801  *rc = 1;
25802  ae_frame_leave(_state);
25803  return;
25804  }
25805 
25806  /*
25807  * Estimate the 1-norm of inv(A).
25808  */
25809  kase = 0;
25810  for(;;)
25811  {
25812  rcond_rmatrixestimatenorm(n, &ev, &ex, &iwork, &ainvnm, &kase, _state);
25813  if( kase==0 )
25814  {
25815  break;
25816  }
25817  for(i=0; i<=n-1; i++)
25818  {
25819  ex.ptr.p_double[i] = ex.ptr.p_double[i+1];
25820  }
25821  if( isupper )
25822  {
25823 
25824  /*
25825  * Multiply by inv(U').
25826  */
25827  if( !rmatrixscaledtrsafesolve(cha, sa, n, &ex, isupper, 1, ae_false, maxgrowth, _state) )
25828  {
25829  ae_frame_leave(_state);
25830  return;
25831  }
25832 
25833  /*
25834  * Multiply by inv(U).
25835  */
25836  if( !rmatrixscaledtrsafesolve(cha, sa, n, &ex, isupper, 0, ae_false, maxgrowth, _state) )
25837  {
25838  ae_frame_leave(_state);
25839  return;
25840  }
25841  }
25842  else
25843  {
25844 
25845  /*
25846  * Multiply by inv(L).
25847  */
25848  if( !rmatrixscaledtrsafesolve(cha, sa, n, &ex, isupper, 0, ae_false, maxgrowth, _state) )
25849  {
25850  ae_frame_leave(_state);
25851  return;
25852  }
25853 
25854  /*
25855  * Multiply by inv(L').
25856  */
25857  if( !rmatrixscaledtrsafesolve(cha, sa, n, &ex, isupper, 1, ae_false, maxgrowth, _state) )
25858  {
25859  ae_frame_leave(_state);
25860  return;
25861  }
25862  }
25863  for(i=n-1; i>=0; i--)
25864  {
25865  ex.ptr.p_double[i+1] = ex.ptr.p_double[i];
25866  }
25867  }
25868 
25869  /*
25870  * Compute the estimate of the reciprocal condition number.
25871  */
25872  if( ae_fp_neq(ainvnm,0) )
25873  {
25874  v = 1/ainvnm;
25875  *rc = v/anorm;
25876  if( ae_fp_less(*rc,rcondthreshold(_state)) )
25877  {
25878  *rc = 0;
25879  }
25880  }
25881  ae_frame_leave(_state);
25882 }
25883 
25884 
25885 /*************************************************************************
25886 Internal subroutine for condition number estimation
25887 
25888  -- LAPACK routine (version 3.0) --
25889  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
25890  Courant Institute, Argonne National Lab, and Rice University
25891  February 29, 1992
25892 *************************************************************************/
25893 static void rcond_hpdmatrixrcondcholeskyinternal(/* Complex */ ae_matrix* cha,
25894  ae_int_t n,
25895  ae_bool isupper,
25896  ae_bool isnormprovided,
25897  double anorm,
25898  double* rc,
25899  ae_state *_state)
25900 {
25901  ae_frame _frame_block;
25902  ae_vector isave;
25903  ae_vector rsave;
25904  ae_vector ex;
25905  ae_vector ev;
25906  ae_vector tmp;
25907  ae_int_t kase;
25908  double ainvnm;
25909  ae_complex v;
25910  ae_int_t i;
25911  ae_int_t j;
25912  double sa;
25913  double maxgrowth;
25914 
25915  ae_frame_make(_state, &_frame_block);
25916  *rc = 0;
25917  ae_vector_init(&isave, 0, DT_INT, _state, ae_true);
25918  ae_vector_init(&rsave, 0, DT_REAL, _state, ae_true);
25919  ae_vector_init(&ex, 0, DT_COMPLEX, _state, ae_true);
25920  ae_vector_init(&ev, 0, DT_COMPLEX, _state, ae_true);
25921  ae_vector_init(&tmp, 0, DT_COMPLEX, _state, ae_true);
25922 
25923  ae_assert(n>=1, "Assertion failed", _state);
25924  ae_vector_set_length(&tmp, n, _state);
25925 
25926  /*
25927  * RC=0 if something happens
25928  */
25929  *rc = 0;
25930 
25931  /*
25932  * prepare parameters for triangular solver
25933  */
25934  maxgrowth = 1/rcondthreshold(_state);
25935  sa = 0;
25936  if( isupper )
25937  {
25938  for(i=0; i<=n-1; i++)
25939  {
25940  for(j=i; j<=n-1; j++)
25941  {
25942  sa = ae_maxreal(sa, ae_c_abs(cha->ptr.pp_complex[i][j], _state), _state);
25943  }
25944  }
25945  }
25946  else
25947  {
25948  for(i=0; i<=n-1; i++)
25949  {
25950  for(j=0; j<=i; j++)
25951  {
25952  sa = ae_maxreal(sa, ae_c_abs(cha->ptr.pp_complex[i][j], _state), _state);
25953  }
25954  }
25955  }
25956  if( ae_fp_eq(sa,0) )
25957  {
25958  sa = 1;
25959  }
25960  sa = 1/sa;
25961 
25962  /*
25963  * Estimate the norm of A
25964  */
25965  if( !isnormprovided )
25966  {
25967  anorm = 0;
25968  kase = 0;
25969  for(;;)
25970  {
25971  rcond_cmatrixestimatenorm(n, &ev, &ex, &anorm, &kase, &isave, &rsave, _state);
25972  if( kase==0 )
25973  {
25974  break;
25975  }
25976  if( isupper )
25977  {
25978 
25979  /*
25980  * Multiply by U
25981  */
25982  for(i=1; i<=n; i++)
25983  {
25984  v = ae_v_cdotproduct(&cha->ptr.pp_complex[i-1][i-1], 1, "N", &ex.ptr.p_complex[i], 1, "N", ae_v_len(i-1,n-1));
25985  ex.ptr.p_complex[i] = v;
25986  }
25987  ae_v_cmuld(&ex.ptr.p_complex[1], 1, ae_v_len(1,n), sa);
25988 
25989  /*
25990  * Multiply by U'
25991  */
25992  for(i=0; i<=n-1; i++)
25993  {
25994  tmp.ptr.p_complex[i] = ae_complex_from_d(0);
25995  }
25996  for(i=0; i<=n-1; i++)
25997  {
25998  v = ex.ptr.p_complex[i+1];
25999  ae_v_caddc(&tmp.ptr.p_complex[i], 1, &cha->ptr.pp_complex[i][i], 1, "Conj", ae_v_len(i,n-1), v);
26000  }
26001  ae_v_cmove(&ex.ptr.p_complex[1], 1, &tmp.ptr.p_complex[0], 1, "N", ae_v_len(1,n));
26002  ae_v_cmuld(&ex.ptr.p_complex[1], 1, ae_v_len(1,n), sa);
26003  }
26004  else
26005  {
26006 
26007  /*
26008  * Multiply by L'
26009  */
26010  for(i=0; i<=n-1; i++)
26011  {
26012  tmp.ptr.p_complex[i] = ae_complex_from_d(0);
26013  }
26014  for(i=0; i<=n-1; i++)
26015  {
26016  v = ex.ptr.p_complex[i+1];
26017  ae_v_caddc(&tmp.ptr.p_complex[0], 1, &cha->ptr.pp_complex[i][0], 1, "Conj", ae_v_len(0,i), v);
26018  }
26019  ae_v_cmove(&ex.ptr.p_complex[1], 1, &tmp.ptr.p_complex[0], 1, "N", ae_v_len(1,n));
26020  ae_v_cmuld(&ex.ptr.p_complex[1], 1, ae_v_len(1,n), sa);
26021 
26022  /*
26023  * Multiply by L
26024  */
26025  for(i=n; i>=1; i--)
26026  {
26027  v = ae_v_cdotproduct(&cha->ptr.pp_complex[i-1][0], 1, "N", &ex.ptr.p_complex[1], 1, "N", ae_v_len(0,i-1));
26028  ex.ptr.p_complex[i] = v;
26029  }
26030  ae_v_cmuld(&ex.ptr.p_complex[1], 1, ae_v_len(1,n), sa);
26031  }
26032  }
26033  }
26034 
26035  /*
26036  * Quick return if possible
26037  * After this block we assume that ANORM<>0
26038  */
26039  if( ae_fp_eq(anorm,0) )
26040  {
26041  ae_frame_leave(_state);
26042  return;
26043  }
26044  if( n==1 )
26045  {
26046  *rc = 1;
26047  ae_frame_leave(_state);
26048  return;
26049  }
26050 
26051  /*
26052  * Estimate the norm of inv(A).
26053  */
26054  ainvnm = 0;
26055  kase = 0;
26056  for(;;)
26057  {
26058  rcond_cmatrixestimatenorm(n, &ev, &ex, &ainvnm, &kase, &isave, &rsave, _state);
26059  if( kase==0 )
26060  {
26061  break;
26062  }
26063  for(i=0; i<=n-1; i++)
26064  {
26065  ex.ptr.p_complex[i] = ex.ptr.p_complex[i+1];
26066  }
26067  if( isupper )
26068  {
26069 
26070  /*
26071  * Multiply by inv(U').
26072  */
26073  if( !cmatrixscaledtrsafesolve(cha, sa, n, &ex, isupper, 2, ae_false, maxgrowth, _state) )
26074  {
26075  ae_frame_leave(_state);
26076  return;
26077  }
26078 
26079  /*
26080  * Multiply by inv(U).
26081  */
26082  if( !cmatrixscaledtrsafesolve(cha, sa, n, &ex, isupper, 0, ae_false, maxgrowth, _state) )
26083  {
26084  ae_frame_leave(_state);
26085  return;
26086  }
26087  }
26088  else
26089  {
26090 
26091  /*
26092  * Multiply by inv(L).
26093  */
26094  if( !cmatrixscaledtrsafesolve(cha, sa, n, &ex, isupper, 0, ae_false, maxgrowth, _state) )
26095  {
26096  ae_frame_leave(_state);
26097  return;
26098  }
26099 
26100  /*
26101  * Multiply by inv(L').
26102  */
26103  if( !cmatrixscaledtrsafesolve(cha, sa, n, &ex, isupper, 2, ae_false, maxgrowth, _state) )
26104  {
26105  ae_frame_leave(_state);
26106  return;
26107  }
26108  }
26109  for(i=n-1; i>=0; i--)
26110  {
26111  ex.ptr.p_complex[i+1] = ex.ptr.p_complex[i];
26112  }
26113  }
26114 
26115  /*
26116  * Compute the estimate of the reciprocal condition number.
26117  */
26118  if( ae_fp_neq(ainvnm,0) )
26119  {
26120  *rc = 1/ainvnm;
26121  *rc = *rc/anorm;
26122  if( ae_fp_less(*rc,rcondthreshold(_state)) )
26123  {
26124  *rc = 0;
26125  }
26126  }
26127  ae_frame_leave(_state);
26128 }
26129 
26130 
26131 /*************************************************************************
26132 Internal subroutine for condition number estimation
26133 
26134  -- LAPACK routine (version 3.0) --
26135  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
26136  Courant Institute, Argonne National Lab, and Rice University
26137  February 29, 1992
26138 *************************************************************************/
26139 static void rcond_rmatrixrcondluinternal(/* Real */ ae_matrix* lua,
26140  ae_int_t n,
26141  ae_bool onenorm,
26142  ae_bool isanormprovided,
26143  double anorm,
26144  double* rc,
26145  ae_state *_state)
26146 {
26147  ae_frame _frame_block;
26148  ae_vector ex;
26149  ae_vector ev;
26150  ae_vector iwork;
26151  ae_vector tmp;
26152  double v;
26153  ae_int_t i;
26154  ae_int_t j;
26155  ae_int_t kase;
26156  ae_int_t kase1;
26157  double ainvnm;
26158  double maxgrowth;
26159  double su;
26160  double sl;
26161  ae_bool mupper;
26162  ae_bool munit;
26163 
26164  ae_frame_make(_state, &_frame_block);
26165  *rc = 0;
26166  ae_vector_init(&ex, 0, DT_REAL, _state, ae_true);
26167  ae_vector_init(&ev, 0, DT_REAL, _state, ae_true);
26168  ae_vector_init(&iwork, 0, DT_INT, _state, ae_true);
26169  ae_vector_init(&tmp, 0, DT_REAL, _state, ae_true);
26170 
26171 
26172  /*
26173  * RC=0 if something happens
26174  */
26175  *rc = 0;
26176 
26177  /*
26178  * init
26179  */
26180  if( onenorm )
26181  {
26182  kase1 = 1;
26183  }
26184  else
26185  {
26186  kase1 = 2;
26187  }
26188  mupper = ae_true;
26189  munit = ae_true;
26190  ae_vector_set_length(&iwork, n+1, _state);
26191  ae_vector_set_length(&tmp, n, _state);
26192 
26193  /*
26194  * prepare parameters for triangular solver
26195  */
26196  maxgrowth = 1/rcondthreshold(_state);
26197  su = 0;
26198  sl = 1;
26199  for(i=0; i<=n-1; i++)
26200  {
26201  for(j=0; j<=i-1; j++)
26202  {
26203  sl = ae_maxreal(sl, ae_fabs(lua->ptr.pp_double[i][j], _state), _state);
26204  }
26205  for(j=i; j<=n-1; j++)
26206  {
26207  su = ae_maxreal(su, ae_fabs(lua->ptr.pp_double[i][j], _state), _state);
26208  }
26209  }
26210  if( ae_fp_eq(su,0) )
26211  {
26212  su = 1;
26213  }
26214  su = 1/su;
26215  sl = 1/sl;
26216 
26217  /*
26218  * Estimate the norm of A.
26219  */
26220  if( !isanormprovided )
26221  {
26222  kase = 0;
26223  anorm = 0;
26224  for(;;)
26225  {
26226  rcond_rmatrixestimatenorm(n, &ev, &ex, &iwork, &anorm, &kase, _state);
26227  if( kase==0 )
26228  {
26229  break;
26230  }
26231  if( kase==kase1 )
26232  {
26233 
26234  /*
26235  * Multiply by U
26236  */
26237  for(i=1; i<=n; i++)
26238  {
26239  v = ae_v_dotproduct(&lua->ptr.pp_double[i-1][i-1], 1, &ex.ptr.p_double[i], 1, ae_v_len(i-1,n-1));
26240  ex.ptr.p_double[i] = v;
26241  }
26242 
26243  /*
26244  * Multiply by L
26245  */
26246  for(i=n; i>=1; i--)
26247  {
26248  if( i>1 )
26249  {
26250  v = ae_v_dotproduct(&lua->ptr.pp_double[i-1][0], 1, &ex.ptr.p_double[1], 1, ae_v_len(0,i-2));
26251  }
26252  else
26253  {
26254  v = 0;
26255  }
26256  ex.ptr.p_double[i] = ex.ptr.p_double[i]+v;
26257  }
26258  }
26259  else
26260  {
26261 
26262  /*
26263  * Multiply by L'
26264  */
26265  for(i=0; i<=n-1; i++)
26266  {
26267  tmp.ptr.p_double[i] = 0;
26268  }
26269  for(i=0; i<=n-1; i++)
26270  {
26271  v = ex.ptr.p_double[i+1];
26272  if( i>=1 )
26273  {
26274  ae_v_addd(&tmp.ptr.p_double[0], 1, &lua->ptr.pp_double[i][0], 1, ae_v_len(0,i-1), v);
26275  }
26276  tmp.ptr.p_double[i] = tmp.ptr.p_double[i]+v;
26277  }
26278  ae_v_move(&ex.ptr.p_double[1], 1, &tmp.ptr.p_double[0], 1, ae_v_len(1,n));
26279 
26280  /*
26281  * Multiply by U'
26282  */
26283  for(i=0; i<=n-1; i++)
26284  {
26285  tmp.ptr.p_double[i] = 0;
26286  }
26287  for(i=0; i<=n-1; i++)
26288  {
26289  v = ex.ptr.p_double[i+1];
26290  ae_v_addd(&tmp.ptr.p_double[i], 1, &lua->ptr.pp_double[i][i], 1, ae_v_len(i,n-1), v);
26291  }
26292  ae_v_move(&ex.ptr.p_double[1], 1, &tmp.ptr.p_double[0], 1, ae_v_len(1,n));
26293  }
26294  }
26295  }
26296 
26297  /*
26298  * Scale according to SU/SL
26299  */
26300  anorm = anorm*su*sl;
26301 
26302  /*
26303  * Quick return if possible
26304  * We assume that ANORM<>0 after this block
26305  */
26306  if( ae_fp_eq(anorm,0) )
26307  {
26308  ae_frame_leave(_state);
26309  return;
26310  }
26311  if( n==1 )
26312  {
26313  *rc = 1;
26314  ae_frame_leave(_state);
26315  return;
26316  }
26317 
26318  /*
26319  * Estimate the norm of inv(A).
26320  */
26321  ainvnm = 0;
26322  kase = 0;
26323  for(;;)
26324  {
26325  rcond_rmatrixestimatenorm(n, &ev, &ex, &iwork, &ainvnm, &kase, _state);
26326  if( kase==0 )
26327  {
26328  break;
26329  }
26330 
26331  /*
26332  * from 1-based array to 0-based
26333  */
26334  for(i=0; i<=n-1; i++)
26335  {
26336  ex.ptr.p_double[i] = ex.ptr.p_double[i+1];
26337  }
26338 
26339  /*
26340  * multiply by inv(A) or inv(A')
26341  */
26342  if( kase==kase1 )
26343  {
26344 
26345  /*
26346  * Multiply by inv(L).
26347  */
26348  if( !rmatrixscaledtrsafesolve(lua, sl, n, &ex, !mupper, 0, munit, maxgrowth, _state) )
26349  {
26350  ae_frame_leave(_state);
26351  return;
26352  }
26353 
26354  /*
26355  * Multiply by inv(U).
26356  */
26357  if( !rmatrixscaledtrsafesolve(lua, su, n, &ex, mupper, 0, !munit, maxgrowth, _state) )
26358  {
26359  ae_frame_leave(_state);
26360  return;
26361  }
26362  }
26363  else
26364  {
26365 
26366  /*
26367  * Multiply by inv(U').
26368  */
26369  if( !rmatrixscaledtrsafesolve(lua, su, n, &ex, mupper, 1, !munit, maxgrowth, _state) )
26370  {
26371  ae_frame_leave(_state);
26372  return;
26373  }
26374 
26375  /*
26376  * Multiply by inv(L').
26377  */
26378  if( !rmatrixscaledtrsafesolve(lua, sl, n, &ex, !mupper, 1, munit, maxgrowth, _state) )
26379  {
26380  ae_frame_leave(_state);
26381  return;
26382  }
26383  }
26384 
26385  /*
26386  * from 0-based array to 1-based
26387  */
26388  for(i=n-1; i>=0; i--)
26389  {
26390  ex.ptr.p_double[i+1] = ex.ptr.p_double[i];
26391  }
26392  }
26393 
26394  /*
26395  * Compute the estimate of the reciprocal condition number.
26396  */
26397  if( ae_fp_neq(ainvnm,0) )
26398  {
26399  *rc = 1/ainvnm;
26400  *rc = *rc/anorm;
26401  if( ae_fp_less(*rc,rcondthreshold(_state)) )
26402  {
26403  *rc = 0;
26404  }
26405  }
26406  ae_frame_leave(_state);
26407 }
26408 
26409 
26410 /*************************************************************************
26411 Condition number estimation
26412 
26413  -- LAPACK routine (version 3.0) --
26414  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
26415  Courant Institute, Argonne National Lab, and Rice University
26416  March 31, 1993
26417 *************************************************************************/
26418 static void rcond_cmatrixrcondluinternal(/* Complex */ ae_matrix* lua,
26419  ae_int_t n,
26420  ae_bool onenorm,
26421  ae_bool isanormprovided,
26422  double anorm,
26423  double* rc,
26424  ae_state *_state)
26425 {
26426  ae_frame _frame_block;
26427  ae_vector ex;
26428  ae_vector cwork2;
26429  ae_vector cwork3;
26430  ae_vector cwork4;
26431  ae_vector isave;
26432  ae_vector rsave;
26433  ae_int_t kase;
26434  ae_int_t kase1;
26435  double ainvnm;
26436  ae_complex v;
26437  ae_int_t i;
26438  ae_int_t j;
26439  double su;
26440  double sl;
26441  double maxgrowth;
26442 
26443  ae_frame_make(_state, &_frame_block);
26444  *rc = 0;
26445  ae_vector_init(&ex, 0, DT_COMPLEX, _state, ae_true);
26446  ae_vector_init(&cwork2, 0, DT_COMPLEX, _state, ae_true);
26447  ae_vector_init(&cwork3, 0, DT_COMPLEX, _state, ae_true);
26448  ae_vector_init(&cwork4, 0, DT_COMPLEX, _state, ae_true);
26449  ae_vector_init(&isave, 0, DT_INT, _state, ae_true);
26450  ae_vector_init(&rsave, 0, DT_REAL, _state, ae_true);
26451 
26452  if( n<=0 )
26453  {
26454  ae_frame_leave(_state);
26455  return;
26456  }
26457  ae_vector_set_length(&cwork2, n+1, _state);
26458  *rc = 0;
26459  if( n==0 )
26460  {
26461  *rc = 1;
26462  ae_frame_leave(_state);
26463  return;
26464  }
26465 
26466  /*
26467  * prepare parameters for triangular solver
26468  */
26469  maxgrowth = 1/rcondthreshold(_state);
26470  su = 0;
26471  sl = 1;
26472  for(i=0; i<=n-1; i++)
26473  {
26474  for(j=0; j<=i-1; j++)
26475  {
26476  sl = ae_maxreal(sl, ae_c_abs(lua->ptr.pp_complex[i][j], _state), _state);
26477  }
26478  for(j=i; j<=n-1; j++)
26479  {
26480  su = ae_maxreal(su, ae_c_abs(lua->ptr.pp_complex[i][j], _state), _state);
26481  }
26482  }
26483  if( ae_fp_eq(su,0) )
26484  {
26485  su = 1;
26486  }
26487  su = 1/su;
26488  sl = 1/sl;
26489 
26490  /*
26491  * Estimate the norm of SU*SL*A.
26492  */
26493  if( !isanormprovided )
26494  {
26495  anorm = 0;
26496  if( onenorm )
26497  {
26498  kase1 = 1;
26499  }
26500  else
26501  {
26502  kase1 = 2;
26503  }
26504  kase = 0;
26505  do
26506  {
26507  rcond_cmatrixestimatenorm(n, &cwork4, &ex, &anorm, &kase, &isave, &rsave, _state);
26508  if( kase!=0 )
26509  {
26510  if( kase==kase1 )
26511  {
26512 
26513  /*
26514  * Multiply by U
26515  */
26516  for(i=1; i<=n; i++)
26517  {
26518  v = ae_v_cdotproduct(&lua->ptr.pp_complex[i-1][i-1], 1, "N", &ex.ptr.p_complex[i], 1, "N", ae_v_len(i-1,n-1));
26519  ex.ptr.p_complex[i] = v;
26520  }
26521 
26522  /*
26523  * Multiply by L
26524  */
26525  for(i=n; i>=1; i--)
26526  {
26527  v = ae_complex_from_d(0);
26528  if( i>1 )
26529  {
26530  v = ae_v_cdotproduct(&lua->ptr.pp_complex[i-1][0], 1, "N", &ex.ptr.p_complex[1], 1, "N", ae_v_len(0,i-2));
26531  }
26532  ex.ptr.p_complex[i] = ae_c_add(v,ex.ptr.p_complex[i]);
26533  }
26534  }
26535  else
26536  {
26537 
26538  /*
26539  * Multiply by L'
26540  */
26541  for(i=1; i<=n; i++)
26542  {
26543  cwork2.ptr.p_complex[i] = ae_complex_from_d(0);
26544  }
26545  for(i=1; i<=n; i++)
26546  {
26547  v = ex.ptr.p_complex[i];
26548  if( i>1 )
26549  {
26550  ae_v_caddc(&cwork2.ptr.p_complex[1], 1, &lua->ptr.pp_complex[i-1][0], 1, "Conj", ae_v_len(1,i-1), v);
26551  }
26552  cwork2.ptr.p_complex[i] = ae_c_add(cwork2.ptr.p_complex[i],v);
26553  }
26554 
26555  /*
26556  * Multiply by U'
26557  */
26558  for(i=1; i<=n; i++)
26559  {
26560  ex.ptr.p_complex[i] = ae_complex_from_d(0);
26561  }
26562  for(i=1; i<=n; i++)
26563  {
26564  v = cwork2.ptr.p_complex[i];
26565  ae_v_caddc(&ex.ptr.p_complex[i], 1, &lua->ptr.pp_complex[i-1][i-1], 1, "Conj", ae_v_len(i,n), v);
26566  }
26567  }
26568  }
26569  }
26570  while(kase!=0);
26571  }
26572 
26573  /*
26574  * Scale according to SU/SL
26575  */
26576  anorm = anorm*su*sl;
26577 
26578  /*
26579  * Quick return if possible
26580  */
26581  if( ae_fp_eq(anorm,0) )
26582  {
26583  ae_frame_leave(_state);
26584  return;
26585  }
26586 
26587  /*
26588  * Estimate the norm of inv(A).
26589  */
26590  ainvnm = 0;
26591  if( onenorm )
26592  {
26593  kase1 = 1;
26594  }
26595  else
26596  {
26597  kase1 = 2;
26598  }
26599  kase = 0;
26600  for(;;)
26601  {
26602  rcond_cmatrixestimatenorm(n, &cwork4, &ex, &ainvnm, &kase, &isave, &rsave, _state);
26603  if( kase==0 )
26604  {
26605  break;
26606  }
26607 
26608  /*
26609  * From 1-based to 0-based
26610  */
26611  for(i=0; i<=n-1; i++)
26612  {
26613  ex.ptr.p_complex[i] = ex.ptr.p_complex[i+1];
26614  }
26615 
26616  /*
26617  * multiply by inv(A) or inv(A')
26618  */
26619  if( kase==kase1 )
26620  {
26621 
26622  /*
26623  * Multiply by inv(L).
26624  */
26625  if( !cmatrixscaledtrsafesolve(lua, sl, n, &ex, ae_false, 0, ae_true, maxgrowth, _state) )
26626  {
26627  *rc = 0;
26628  ae_frame_leave(_state);
26629  return;
26630  }
26631 
26632  /*
26633  * Multiply by inv(U).
26634  */
26635  if( !cmatrixscaledtrsafesolve(lua, su, n, &ex, ae_true, 0, ae_false, maxgrowth, _state) )
26636  {
26637  *rc = 0;
26638  ae_frame_leave(_state);
26639  return;
26640  }
26641  }
26642  else
26643  {
26644 
26645  /*
26646  * Multiply by inv(U').
26647  */
26648  if( !cmatrixscaledtrsafesolve(lua, su, n, &ex, ae_true, 2, ae_false, maxgrowth, _state) )
26649  {
26650  *rc = 0;
26651  ae_frame_leave(_state);
26652  return;
26653  }
26654 
26655  /*
26656  * Multiply by inv(L').
26657  */
26658  if( !cmatrixscaledtrsafesolve(lua, sl, n, &ex, ae_false, 2, ae_true, maxgrowth, _state) )
26659  {
26660  *rc = 0;
26661  ae_frame_leave(_state);
26662  return;
26663  }
26664  }
26665 
26666  /*
26667  * from 0-based to 1-based
26668  */
26669  for(i=n-1; i>=0; i--)
26670  {
26671  ex.ptr.p_complex[i+1] = ex.ptr.p_complex[i];
26672  }
26673  }
26674 
26675  /*
26676  * Compute the estimate of the reciprocal condition number.
26677  */
26678  if( ae_fp_neq(ainvnm,0) )
26679  {
26680  *rc = 1/ainvnm;
26681  *rc = *rc/anorm;
26682  if( ae_fp_less(*rc,rcondthreshold(_state)) )
26683  {
26684  *rc = 0;
26685  }
26686  }
26687  ae_frame_leave(_state);
26688 }
26689 
26690 
26691 /*************************************************************************
26692 Internal subroutine for matrix norm estimation
26693 
26694  -- LAPACK auxiliary routine (version 3.0) --
26695  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
26696  Courant Institute, Argonne National Lab, and Rice University
26697  February 29, 1992
26698 *************************************************************************/
26699 static void rcond_rmatrixestimatenorm(ae_int_t n,
26700  /* Real */ ae_vector* v,
26701  /* Real */ ae_vector* x,
26702  /* Integer */ ae_vector* isgn,
26703  double* est,
26704  ae_int_t* kase,
26705  ae_state *_state)
26706 {
26707  ae_int_t itmax;
26708  ae_int_t i;
26709  double t;
26710  ae_bool flg;
26711  ae_int_t positer;
26712  ae_int_t posj;
26713  ae_int_t posjlast;
26714  ae_int_t posjump;
26715  ae_int_t posaltsgn;
26716  ae_int_t posestold;
26717  ae_int_t postemp;
26718 
26719 
26720  itmax = 5;
26721  posaltsgn = n+1;
26722  posestold = n+2;
26723  postemp = n+3;
26724  positer = n+1;
26725  posj = n+2;
26726  posjlast = n+3;
26727  posjump = n+4;
26728  if( *kase==0 )
26729  {
26730  ae_vector_set_length(v, n+4, _state);
26731  ae_vector_set_length(x, n+1, _state);
26732  ae_vector_set_length(isgn, n+5, _state);
26733  t = (double)1/(double)n;
26734  for(i=1; i<=n; i++)
26735  {
26736  x->ptr.p_double[i] = t;
26737  }
26738  *kase = 1;
26739  isgn->ptr.p_int[posjump] = 1;
26740  return;
26741  }
26742 
26743  /*
26744  * ................ ENTRY (JUMP = 1)
26745  * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X.
26746  */
26747  if( isgn->ptr.p_int[posjump]==1 )
26748  {
26749  if( n==1 )
26750  {
26751  v->ptr.p_double[1] = x->ptr.p_double[1];
26752  *est = ae_fabs(v->ptr.p_double[1], _state);
26753  *kase = 0;
26754  return;
26755  }
26756  *est = 0;
26757  for(i=1; i<=n; i++)
26758  {
26759  *est = *est+ae_fabs(x->ptr.p_double[i], _state);
26760  }
26761  for(i=1; i<=n; i++)
26762  {
26763  if( ae_fp_greater_eq(x->ptr.p_double[i],0) )
26764  {
26765  x->ptr.p_double[i] = 1;
26766  }
26767  else
26768  {
26769  x->ptr.p_double[i] = -1;
26770  }
26771  isgn->ptr.p_int[i] = ae_sign(x->ptr.p_double[i], _state);
26772  }
26773  *kase = 2;
26774  isgn->ptr.p_int[posjump] = 2;
26775  return;
26776  }
26777 
26778  /*
26779  * ................ ENTRY (JUMP = 2)
26780  * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X.
26781  */
26782  if( isgn->ptr.p_int[posjump]==2 )
26783  {
26784  isgn->ptr.p_int[posj] = 1;
26785  for(i=2; i<=n; i++)
26786  {
26787  if( ae_fp_greater(ae_fabs(x->ptr.p_double[i], _state),ae_fabs(x->ptr.p_double[isgn->ptr.p_int[posj]], _state)) )
26788  {
26789  isgn->ptr.p_int[posj] = i;
26790  }
26791  }
26792  isgn->ptr.p_int[positer] = 2;
26793 
26794  /*
26795  * MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
26796  */
26797  for(i=1; i<=n; i++)
26798  {
26799  x->ptr.p_double[i] = 0;
26800  }
26801  x->ptr.p_double[isgn->ptr.p_int[posj]] = 1;
26802  *kase = 1;
26803  isgn->ptr.p_int[posjump] = 3;
26804  return;
26805  }
26806 
26807  /*
26808  * ................ ENTRY (JUMP = 3)
26809  * X HAS BEEN OVERWRITTEN BY A*X.
26810  */
26811  if( isgn->ptr.p_int[posjump]==3 )
26812  {
26813  ae_v_move(&v->ptr.p_double[1], 1, &x->ptr.p_double[1], 1, ae_v_len(1,n));
26814  v->ptr.p_double[posestold] = *est;
26815  *est = 0;
26816  for(i=1; i<=n; i++)
26817  {
26818  *est = *est+ae_fabs(v->ptr.p_double[i], _state);
26819  }
26820  flg = ae_false;
26821  for(i=1; i<=n; i++)
26822  {
26823  if( (ae_fp_greater_eq(x->ptr.p_double[i],0)&&isgn->ptr.p_int[i]<0)||(ae_fp_less(x->ptr.p_double[i],0)&&isgn->ptr.p_int[i]>=0) )
26824  {
26825  flg = ae_true;
26826  }
26827  }
26828 
26829  /*
26830  * REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
26831  * OR MAY BE CYCLING.
26832  */
26833  if( !flg||ae_fp_less_eq(*est,v->ptr.p_double[posestold]) )
26834  {
26835  v->ptr.p_double[posaltsgn] = 1;
26836  for(i=1; i<=n; i++)
26837  {
26838  x->ptr.p_double[i] = v->ptr.p_double[posaltsgn]*(1+(double)(i-1)/(double)(n-1));
26839  v->ptr.p_double[posaltsgn] = -v->ptr.p_double[posaltsgn];
26840  }
26841  *kase = 1;
26842  isgn->ptr.p_int[posjump] = 5;
26843  return;
26844  }
26845  for(i=1; i<=n; i++)
26846  {
26847  if( ae_fp_greater_eq(x->ptr.p_double[i],0) )
26848  {
26849  x->ptr.p_double[i] = 1;
26850  isgn->ptr.p_int[i] = 1;
26851  }
26852  else
26853  {
26854  x->ptr.p_double[i] = -1;
26855  isgn->ptr.p_int[i] = -1;
26856  }
26857  }
26858  *kase = 2;
26859  isgn->ptr.p_int[posjump] = 4;
26860  return;
26861  }
26862 
26863  /*
26864  * ................ ENTRY (JUMP = 4)
26865  * X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X.
26866  */
26867  if( isgn->ptr.p_int[posjump]==4 )
26868  {
26869  isgn->ptr.p_int[posjlast] = isgn->ptr.p_int[posj];
26870  isgn->ptr.p_int[posj] = 1;
26871  for(i=2; i<=n; i++)
26872  {
26873  if( ae_fp_greater(ae_fabs(x->ptr.p_double[i], _state),ae_fabs(x->ptr.p_double[isgn->ptr.p_int[posj]], _state)) )
26874  {
26875  isgn->ptr.p_int[posj] = i;
26876  }
26877  }
26878  if( ae_fp_neq(x->ptr.p_double[isgn->ptr.p_int[posjlast]],ae_fabs(x->ptr.p_double[isgn->ptr.p_int[posj]], _state))&&isgn->ptr.p_int[positer]<itmax )
26879  {
26880  isgn->ptr.p_int[positer] = isgn->ptr.p_int[positer]+1;
26881  for(i=1; i<=n; i++)
26882  {
26883  x->ptr.p_double[i] = 0;
26884  }
26885  x->ptr.p_double[isgn->ptr.p_int[posj]] = 1;
26886  *kase = 1;
26887  isgn->ptr.p_int[posjump] = 3;
26888  return;
26889  }
26890 
26891  /*
26892  * ITERATION COMPLETE. FINAL STAGE.
26893  */
26894  v->ptr.p_double[posaltsgn] = 1;
26895  for(i=1; i<=n; i++)
26896  {
26897  x->ptr.p_double[i] = v->ptr.p_double[posaltsgn]*(1+(double)(i-1)/(double)(n-1));
26898  v->ptr.p_double[posaltsgn] = -v->ptr.p_double[posaltsgn];
26899  }
26900  *kase = 1;
26901  isgn->ptr.p_int[posjump] = 5;
26902  return;
26903  }
26904 
26905  /*
26906  * ................ ENTRY (JUMP = 5)
26907  * X HAS BEEN OVERWRITTEN BY A*X.
26908  */
26909  if( isgn->ptr.p_int[posjump]==5 )
26910  {
26911  v->ptr.p_double[postemp] = 0;
26912  for(i=1; i<=n; i++)
26913  {
26914  v->ptr.p_double[postemp] = v->ptr.p_double[postemp]+ae_fabs(x->ptr.p_double[i], _state);
26915  }
26916  v->ptr.p_double[postemp] = 2*v->ptr.p_double[postemp]/(3*n);
26917  if( ae_fp_greater(v->ptr.p_double[postemp],*est) )
26918  {
26919  ae_v_move(&v->ptr.p_double[1], 1, &x->ptr.p_double[1], 1, ae_v_len(1,n));
26920  *est = v->ptr.p_double[postemp];
26921  }
26922  *kase = 0;
26923  return;
26924  }
26925 }
26926 
26927 
26928 static void rcond_cmatrixestimatenorm(ae_int_t n,
26929  /* Complex */ ae_vector* v,
26930  /* Complex */ ae_vector* x,
26931  double* est,
26932  ae_int_t* kase,
26933  /* Integer */ ae_vector* isave,
26934  /* Real */ ae_vector* rsave,
26935  ae_state *_state)
26936 {
26937  ae_int_t itmax;
26938  ae_int_t i;
26939  ae_int_t iter;
26940  ae_int_t j;
26941  ae_int_t jlast;
26942  ae_int_t jump;
26943  double absxi;
26944  double altsgn;
26945  double estold;
26946  double safmin;
26947  double temp;
26948 
26949 
26950 
26951  /*
26952  *Executable Statements ..
26953  */
26954  itmax = 5;
26955  safmin = ae_minrealnumber;
26956  if( *kase==0 )
26957  {
26958  ae_vector_set_length(v, n+1, _state);
26959  ae_vector_set_length(x, n+1, _state);
26960  ae_vector_set_length(isave, 5, _state);
26961  ae_vector_set_length(rsave, 4, _state);
26962  for(i=1; i<=n; i++)
26963  {
26964  x->ptr.p_complex[i] = ae_complex_from_d((double)1/(double)n);
26965  }
26966  *kase = 1;
26967  jump = 1;
26968  rcond_internalcomplexrcondsaveall(isave, rsave, &i, &iter, &j, &jlast, &jump, &absxi, &altsgn, &estold, &temp, _state);
26969  return;
26970  }
26971  rcond_internalcomplexrcondloadall(isave, rsave, &i, &iter, &j, &jlast, &jump, &absxi, &altsgn, &estold, &temp, _state);
26972 
26973  /*
26974  * ENTRY (JUMP = 1)
26975  * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X.
26976  */
26977  if( jump==1 )
26978  {
26979  if( n==1 )
26980  {
26981  v->ptr.p_complex[1] = x->ptr.p_complex[1];
26982  *est = ae_c_abs(v->ptr.p_complex[1], _state);
26983  *kase = 0;
26984  rcond_internalcomplexrcondsaveall(isave, rsave, &i, &iter, &j, &jlast, &jump, &absxi, &altsgn, &estold, &temp, _state);
26985  return;
26986  }
26987  *est = rcond_internalcomplexrcondscsum1(x, n, _state);
26988  for(i=1; i<=n; i++)
26989  {
26990  absxi = ae_c_abs(x->ptr.p_complex[i], _state);
26991  if( ae_fp_greater(absxi,safmin) )
26992  {
26993  x->ptr.p_complex[i] = ae_c_div_d(x->ptr.p_complex[i],absxi);
26994  }
26995  else
26996  {
26997  x->ptr.p_complex[i] = ae_complex_from_d(1);
26998  }
26999  }
27000  *kase = 2;
27001  jump = 2;
27002  rcond_internalcomplexrcondsaveall(isave, rsave, &i, &iter, &j, &jlast, &jump, &absxi, &altsgn, &estold, &temp, _state);
27003  return;
27004  }
27005 
27006  /*
27007  * ENTRY (JUMP = 2)
27008  * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
27009  */
27010  if( jump==2 )
27011  {
27012  j = rcond_internalcomplexrcondicmax1(x, n, _state);
27013  iter = 2;
27014 
27015  /*
27016  * MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
27017  */
27018  for(i=1; i<=n; i++)
27019  {
27020  x->ptr.p_complex[i] = ae_complex_from_d(0);
27021  }
27022  x->ptr.p_complex[j] = ae_complex_from_d(1);
27023  *kase = 1;
27024  jump = 3;
27025  rcond_internalcomplexrcondsaveall(isave, rsave, &i, &iter, &j, &jlast, &jump, &absxi, &altsgn, &estold, &temp, _state);
27026  return;
27027  }
27028 
27029  /*
27030  * ENTRY (JUMP = 3)
27031  * X HAS BEEN OVERWRITTEN BY A*X.
27032  */
27033  if( jump==3 )
27034  {
27035  ae_v_cmove(&v->ptr.p_complex[1], 1, &x->ptr.p_complex[1], 1, "N", ae_v_len(1,n));
27036  estold = *est;
27037  *est = rcond_internalcomplexrcondscsum1(v, n, _state);
27038 
27039  /*
27040  * TEST FOR CYCLING.
27041  */
27042  if( ae_fp_less_eq(*est,estold) )
27043  {
27044 
27045  /*
27046  * ITERATION COMPLETE. FINAL STAGE.
27047  */
27048  altsgn = 1;
27049  for(i=1; i<=n; i++)
27050  {
27051  x->ptr.p_complex[i] = ae_complex_from_d(altsgn*(1+(double)(i-1)/(double)(n-1)));
27052  altsgn = -altsgn;
27053  }
27054  *kase = 1;
27055  jump = 5;
27056  rcond_internalcomplexrcondsaveall(isave, rsave, &i, &iter, &j, &jlast, &jump, &absxi, &altsgn, &estold, &temp, _state);
27057  return;
27058  }
27059  for(i=1; i<=n; i++)
27060  {
27061  absxi = ae_c_abs(x->ptr.p_complex[i], _state);
27062  if( ae_fp_greater(absxi,safmin) )
27063  {
27064  x->ptr.p_complex[i] = ae_c_div_d(x->ptr.p_complex[i],absxi);
27065  }
27066  else
27067  {
27068  x->ptr.p_complex[i] = ae_complex_from_d(1);
27069  }
27070  }
27071  *kase = 2;
27072  jump = 4;
27073  rcond_internalcomplexrcondsaveall(isave, rsave, &i, &iter, &j, &jlast, &jump, &absxi, &altsgn, &estold, &temp, _state);
27074  return;
27075  }
27076 
27077  /*
27078  * ENTRY (JUMP = 4)
27079  * X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
27080  */
27081  if( jump==4 )
27082  {
27083  jlast = j;
27084  j = rcond_internalcomplexrcondicmax1(x, n, _state);
27085  if( ae_fp_neq(ae_c_abs(x->ptr.p_complex[jlast], _state),ae_c_abs(x->ptr.p_complex[j], _state))&&iter<itmax )
27086  {
27087  iter = iter+1;
27088 
27089  /*
27090  * MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
27091  */
27092  for(i=1; i<=n; i++)
27093  {
27094  x->ptr.p_complex[i] = ae_complex_from_d(0);
27095  }
27096  x->ptr.p_complex[j] = ae_complex_from_d(1);
27097  *kase = 1;
27098  jump = 3;
27099  rcond_internalcomplexrcondsaveall(isave, rsave, &i, &iter, &j, &jlast, &jump, &absxi, &altsgn, &estold, &temp, _state);
27100  return;
27101  }
27102 
27103  /*
27104  * ITERATION COMPLETE. FINAL STAGE.
27105  */
27106  altsgn = 1;
27107  for(i=1; i<=n; i++)
27108  {
27109  x->ptr.p_complex[i] = ae_complex_from_d(altsgn*(1+(double)(i-1)/(double)(n-1)));
27110  altsgn = -altsgn;
27111  }
27112  *kase = 1;
27113  jump = 5;
27114  rcond_internalcomplexrcondsaveall(isave, rsave, &i, &iter, &j, &jlast, &jump, &absxi, &altsgn, &estold, &temp, _state);
27115  return;
27116  }
27117 
27118  /*
27119  * ENTRY (JUMP = 5)
27120  * X HAS BEEN OVERWRITTEN BY A*X.
27121  */
27122  if( jump==5 )
27123  {
27124  temp = 2*(rcond_internalcomplexrcondscsum1(x, n, _state)/(3*n));
27125  if( ae_fp_greater(temp,*est) )
27126  {
27127  ae_v_cmove(&v->ptr.p_complex[1], 1, &x->ptr.p_complex[1], 1, "N", ae_v_len(1,n));
27128  *est = temp;
27129  }
27130  *kase = 0;
27131  rcond_internalcomplexrcondsaveall(isave, rsave, &i, &iter, &j, &jlast, &jump, &absxi, &altsgn, &estold, &temp, _state);
27132  return;
27133  }
27134 }
27135 
27136 
27137 static double rcond_internalcomplexrcondscsum1(/* Complex */ ae_vector* x,
27138  ae_int_t n,
27139  ae_state *_state)
27140 {
27141  ae_int_t i;
27142  double result;
27143 
27144 
27145  result = 0;
27146  for(i=1; i<=n; i++)
27147  {
27148  result = result+ae_c_abs(x->ptr.p_complex[i], _state);
27149  }
27150  return result;
27151 }
27152 
27153 
27154 static ae_int_t rcond_internalcomplexrcondicmax1(/* Complex */ ae_vector* x,
27155  ae_int_t n,
27156  ae_state *_state)
27157 {
27158  ae_int_t i;
27159  double m;
27160  ae_int_t result;
27161 
27162 
27163  result = 1;
27164  m = ae_c_abs(x->ptr.p_complex[1], _state);
27165  for(i=2; i<=n; i++)
27166  {
27167  if( ae_fp_greater(ae_c_abs(x->ptr.p_complex[i], _state),m) )
27168  {
27169  result = i;
27170  m = ae_c_abs(x->ptr.p_complex[i], _state);
27171  }
27172  }
27173  return result;
27174 }
27175 
27176 
27177 static void rcond_internalcomplexrcondsaveall(/* Integer */ ae_vector* isave,
27178  /* Real */ ae_vector* rsave,
27179  ae_int_t* i,
27180  ae_int_t* iter,
27181  ae_int_t* j,
27182  ae_int_t* jlast,
27183  ae_int_t* jump,
27184  double* absxi,
27185  double* altsgn,
27186  double* estold,
27187  double* temp,
27188  ae_state *_state)
27189 {
27190 
27191 
27192  isave->ptr.p_int[0] = *i;
27193  isave->ptr.p_int[1] = *iter;
27194  isave->ptr.p_int[2] = *j;
27195  isave->ptr.p_int[3] = *jlast;
27196  isave->ptr.p_int[4] = *jump;
27197  rsave->ptr.p_double[0] = *absxi;
27198  rsave->ptr.p_double[1] = *altsgn;
27199  rsave->ptr.p_double[2] = *estold;
27200  rsave->ptr.p_double[3] = *temp;
27201 }
27202 
27203 
27204 static void rcond_internalcomplexrcondloadall(/* Integer */ ae_vector* isave,
27205  /* Real */ ae_vector* rsave,
27206  ae_int_t* i,
27207  ae_int_t* iter,
27208  ae_int_t* j,
27209  ae_int_t* jlast,
27210  ae_int_t* jump,
27211  double* absxi,
27212  double* altsgn,
27213  double* estold,
27214  double* temp,
27215  ae_state *_state)
27216 {
27217 
27218 
27219  *i = isave->ptr.p_int[0];
27220  *iter = isave->ptr.p_int[1];
27221  *j = isave->ptr.p_int[2];
27222  *jlast = isave->ptr.p_int[3];
27223  *jump = isave->ptr.p_int[4];
27224  *absxi = rsave->ptr.p_double[0];
27225  *altsgn = rsave->ptr.p_double[1];
27226  *estold = rsave->ptr.p_double[2];
27227  *temp = rsave->ptr.p_double[3];
27228 }
27229 
27230 
27231 
27232 
27233 /*************************************************************************
27234 Inversion of a matrix given by its LU decomposition.
27235 
27236 INPUT PARAMETERS:
27237  A - LU decomposition of the matrix
27238  (output of RMatrixLU subroutine).
27239  Pivots - table of permutations
27240  (the output of RMatrixLU subroutine).
27241  N - size of matrix A (optional) :
27242  * if given, only principal NxN submatrix is processed and
27243  overwritten. other elements are unchanged.
27244  * if not given, size is automatically determined from
27245  matrix size (A must be square matrix)
27246 
27247 OUTPUT PARAMETERS:
27248  Info - return code:
27249  * -3 A is singular, or VERY close to singular.
27250  it is filled by zeros in such cases.
27251  * 1 task is solved (but matrix A may be ill-conditioned,
27252  check R1/RInf parameters for condition numbers).
27253  Rep - solver report, see below for more info
27254  A - inverse of matrix A.
27255  Array whose indexes range within [0..N-1, 0..N-1].
27256 
27257 SOLVER REPORT
27258 
27259 Subroutine sets following fields of the Rep structure:
27260 * R1 reciprocal of condition number: 1/cond(A), 1-norm.
27261 * RInf reciprocal of condition number: 1/cond(A), inf-norm.
27262 
27263  -- ALGLIB routine --
27264  05.02.2010
27265  Bochkanov Sergey
27266 *************************************************************************/
27267 void rmatrixluinverse(/* Real */ ae_matrix* a,
27268  /* Integer */ ae_vector* pivots,
27269  ae_int_t n,
27270  ae_int_t* info,
27271  matinvreport* rep,
27272  ae_state *_state)
27273 {
27274  ae_frame _frame_block;
27275  ae_vector work;
27276  ae_int_t i;
27277  ae_int_t j;
27278  ae_int_t k;
27279  double v;
27280 
27281  ae_frame_make(_state, &_frame_block);
27282  *info = 0;
27283  _matinvreport_clear(rep);
27284  ae_vector_init(&work, 0, DT_REAL, _state, ae_true);
27285 
27286  ae_assert(n>0, "RMatrixLUInverse: N<=0!", _state);
27287  ae_assert(a->cols>=n, "RMatrixLUInverse: cols(A)<N!", _state);
27288  ae_assert(a->rows>=n, "RMatrixLUInverse: rows(A)<N!", _state);
27289  ae_assert(pivots->cnt>=n, "RMatrixLUInverse: len(Pivots)<N!", _state);
27290  ae_assert(apservisfinitematrix(a, n, n, _state), "RMatrixLUInverse: A contains infinite or NaN values!", _state);
27291  *info = 1;
27292  for(i=0; i<=n-1; i++)
27293  {
27294  if( pivots->ptr.p_int[i]>n-1||pivots->ptr.p_int[i]<i )
27295  {
27296  *info = -1;
27297  }
27298  }
27299  ae_assert(*info>0, "RMatrixLUInverse: incorrect Pivots array!", _state);
27300 
27301  /*
27302  * calculate condition numbers
27303  */
27304  rep->r1 = rmatrixlurcond1(a, n, _state);
27305  rep->rinf = rmatrixlurcondinf(a, n, _state);
27306  if( ae_fp_less(rep->r1,rcondthreshold(_state))||ae_fp_less(rep->rinf,rcondthreshold(_state)) )
27307  {
27308  for(i=0; i<=n-1; i++)
27309  {
27310  for(j=0; j<=n-1; j++)
27311  {
27312  a->ptr.pp_double[i][j] = 0;
27313  }
27314  }
27315  rep->r1 = 0;
27316  rep->rinf = 0;
27317  *info = -3;
27318  ae_frame_leave(_state);
27319  return;
27320  }
27321 
27322  /*
27323  * Call cache-oblivious code
27324  */
27325  ae_vector_set_length(&work, n, _state);
27326  matinv_rmatrixluinverserec(a, 0, n, &work, info, rep, _state);
27327 
27328  /*
27329  * apply permutations
27330  */
27331  for(i=0; i<=n-1; i++)
27332  {
27333  for(j=n-2; j>=0; j--)
27334  {
27335  k = pivots->ptr.p_int[j];
27336  v = a->ptr.pp_double[i][j];
27337  a->ptr.pp_double[i][j] = a->ptr.pp_double[i][k];
27338  a->ptr.pp_double[i][k] = v;
27339  }
27340  }
27341  ae_frame_leave(_state);
27342 }
27343 
27344 
27345 /*************************************************************************
27346 Inversion of a general matrix.
27347 
27348 Input parameters:
27349  A - matrix.
27350  N - size of matrix A (optional) :
27351  * if given, only principal NxN submatrix is processed and
27352  overwritten. other elements are unchanged.
27353  * if not given, size is automatically determined from
27354  matrix size (A must be square matrix)
27355 
27356 Output parameters:
27357  Info - return code, same as in RMatrixLUInverse
27358  Rep - solver report, same as in RMatrixLUInverse
27359  A - inverse of matrix A, same as in RMatrixLUInverse
27360 
27361 Result:
27362  True, if the matrix is not singular.
27363  False, if the matrix is singular.
27364 
27365  -- ALGLIB --
27366  Copyright 2005-2010 by Bochkanov Sergey
27367 *************************************************************************/
27368 void rmatrixinverse(/* Real */ ae_matrix* a,
27369  ae_int_t n,
27370  ae_int_t* info,
27371  matinvreport* rep,
27372  ae_state *_state)
27373 {
27374  ae_frame _frame_block;
27375  ae_vector pivots;
27376 
27377  ae_frame_make(_state, &_frame_block);
27378  *info = 0;
27379  _matinvreport_clear(rep);
27380  ae_vector_init(&pivots, 0, DT_INT, _state, ae_true);
27381 
27382  ae_assert(n>0, "RMatrixInverse: N<=0!", _state);
27383  ae_assert(a->cols>=n, "RMatrixInverse: cols(A)<N!", _state);
27384  ae_assert(a->rows>=n, "RMatrixInverse: rows(A)<N!", _state);
27385  ae_assert(apservisfinitematrix(a, n, n, _state), "RMatrixInverse: A contains infinite or NaN values!", _state);
27386  rmatrixlu(a, n, n, &pivots, _state);
27387  rmatrixluinverse(a, &pivots, n, info, rep, _state);
27388  ae_frame_leave(_state);
27389 }
27390 
27391 
27392 /*************************************************************************
27393 Inversion of a matrix given by its LU decomposition.
27394 
27395 INPUT PARAMETERS:
27396  A - LU decomposition of the matrix
27397  (output of CMatrixLU subroutine).
27398  Pivots - table of permutations
27399  (the output of CMatrixLU subroutine).
27400  N - size of matrix A (optional) :
27401  * if given, only principal NxN submatrix is processed and
27402  overwritten. other elements are unchanged.
27403  * if not given, size is automatically determined from
27404  matrix size (A must be square matrix)
27405 
27406 OUTPUT PARAMETERS:
27407  Info - return code, same as in RMatrixLUInverse
27408  Rep - solver report, same as in RMatrixLUInverse
27409  A - inverse of matrix A, same as in RMatrixLUInverse
27410 
27411  -- ALGLIB routine --
27412  05.02.2010
27413  Bochkanov Sergey
27414 *************************************************************************/
27415 void cmatrixluinverse(/* Complex */ ae_matrix* a,
27416  /* Integer */ ae_vector* pivots,
27417  ae_int_t n,
27418  ae_int_t* info,
27419  matinvreport* rep,
27420  ae_state *_state)
27421 {
27422  ae_frame _frame_block;
27423  ae_vector work;
27424  ae_int_t i;
27425  ae_int_t j;
27426  ae_int_t k;
27427  ae_complex v;
27428 
27429  ae_frame_make(_state, &_frame_block);
27430  *info = 0;
27431  _matinvreport_clear(rep);
27432  ae_vector_init(&work, 0, DT_COMPLEX, _state, ae_true);
27433 
27434  ae_assert(n>0, "CMatrixLUInverse: N<=0!", _state);
27435  ae_assert(a->cols>=n, "CMatrixLUInverse: cols(A)<N!", _state);
27436  ae_assert(a->rows>=n, "CMatrixLUInverse: rows(A)<N!", _state);
27437  ae_assert(pivots->cnt>=n, "CMatrixLUInverse: len(Pivots)<N!", _state);
27438  ae_assert(apservisfinitecmatrix(a, n, n, _state), "CMatrixLUInverse: A contains infinite or NaN values!", _state);
27439  *info = 1;
27440  for(i=0; i<=n-1; i++)
27441  {
27442  if( pivots->ptr.p_int[i]>n-1||pivots->ptr.p_int[i]<i )
27443  {
27444  *info = -1;
27445  }
27446  }
27447  ae_assert(*info>0, "CMatrixLUInverse: incorrect Pivots array!", _state);
27448 
27449  /*
27450  * calculate condition numbers
27451  */
27452  rep->r1 = cmatrixlurcond1(a, n, _state);
27453  rep->rinf = cmatrixlurcondinf(a, n, _state);
27454  if( ae_fp_less(rep->r1,rcondthreshold(_state))||ae_fp_less(rep->rinf,rcondthreshold(_state)) )
27455  {
27456  for(i=0; i<=n-1; i++)
27457  {
27458  for(j=0; j<=n-1; j++)
27459  {
27460  a->ptr.pp_complex[i][j] = ae_complex_from_d(0);
27461  }
27462  }
27463  rep->r1 = 0;
27464  rep->rinf = 0;
27465  *info = -3;
27466  ae_frame_leave(_state);
27467  return;
27468  }
27469 
27470  /*
27471  * Call cache-oblivious code
27472  */
27473  ae_vector_set_length(&work, n, _state);
27474  matinv_cmatrixluinverserec(a, 0, n, &work, info, rep, _state);
27475 
27476  /*
27477  * apply permutations
27478  */
27479  for(i=0; i<=n-1; i++)
27480  {
27481  for(j=n-2; j>=0; j--)
27482  {
27483  k = pivots->ptr.p_int[j];
27484  v = a->ptr.pp_complex[i][j];
27485  a->ptr.pp_complex[i][j] = a->ptr.pp_complex[i][k];
27486  a->ptr.pp_complex[i][k] = v;
27487  }
27488  }
27489  ae_frame_leave(_state);
27490 }
27491 
27492 
27493 /*************************************************************************
27494 Inversion of a general matrix.
27495 
27496 Input parameters:
27497  A - matrix
27498  N - size of matrix A (optional) :
27499  * if given, only principal NxN submatrix is processed and
27500  overwritten. other elements are unchanged.
27501  * if not given, size is automatically determined from
27502  matrix size (A must be square matrix)
27503 
27504 Output parameters:
27505  Info - return code, same as in RMatrixLUInverse
27506  Rep - solver report, same as in RMatrixLUInverse
27507  A - inverse of matrix A, same as in RMatrixLUInverse
27508 
27509  -- ALGLIB --
27510  Copyright 2005 by Bochkanov Sergey
27511 *************************************************************************/
27512 void cmatrixinverse(/* Complex */ ae_matrix* a,
27513  ae_int_t n,
27514  ae_int_t* info,
27515  matinvreport* rep,
27516  ae_state *_state)
27517 {
27518  ae_frame _frame_block;
27519  ae_vector pivots;
27520 
27521  ae_frame_make(_state, &_frame_block);
27522  *info = 0;
27523  _matinvreport_clear(rep);
27524  ae_vector_init(&pivots, 0, DT_INT, _state, ae_true);
27525 
27526  ae_assert(n>0, "CRMatrixInverse: N<=0!", _state);
27527  ae_assert(a->cols>=n, "CRMatrixInverse: cols(A)<N!", _state);
27528  ae_assert(a->rows>=n, "CRMatrixInverse: rows(A)<N!", _state);
27529  ae_assert(apservisfinitecmatrix(a, n, n, _state), "CMatrixInverse: A contains infinite or NaN values!", _state);
27530  cmatrixlu(a, n, n, &pivots, _state);
27531  cmatrixluinverse(a, &pivots, n, info, rep, _state);
27532  ae_frame_leave(_state);
27533 }
27534 
27535 
27536 /*************************************************************************
27537 Inversion of a symmetric positive definite matrix which is given
27538 by Cholesky decomposition.
27539 
27540 Input parameters:
27541  A - Cholesky decomposition of the matrix to be inverted:
27542  A=U’*U or A = L*L'.
27543  Output of SPDMatrixCholesky subroutine.
27544  N - size of matrix A (optional) :
27545  * if given, only principal NxN submatrix is processed and
27546  overwritten. other elements are unchanged.
27547  * if not given, size is automatically determined from
27548  matrix size (A must be square matrix)
27549  IsUpper - storage type (optional):
27550  * if True, symmetric matrix A is given by its upper
27551  triangle, and the lower triangle isn’t used/changed by
27552  function
27553  * if False, symmetric matrix A is given by its lower
27554  triangle, and the upper triangle isn’t used/changed by
27555  function
27556  * if not given, lower half is used.
27557 
27558 Output parameters:
27559  Info - return code, same as in RMatrixLUInverse
27560  Rep - solver report, same as in RMatrixLUInverse
27561  A - inverse of matrix A, same as in RMatrixLUInverse
27562 
27563  -- ALGLIB routine --
27564  10.02.2010
27565  Bochkanov Sergey
27566 *************************************************************************/
27567 void spdmatrixcholeskyinverse(/* Real */ ae_matrix* a,
27568  ae_int_t n,
27569  ae_bool isupper,
27570  ae_int_t* info,
27571  matinvreport* rep,
27572  ae_state *_state)
27573 {
27574  ae_frame _frame_block;
27575  ae_int_t i;
27576  ae_int_t j;
27577  ae_vector tmp;
27578  matinvreport rep2;
27579  ae_bool f;
27580 
27581  ae_frame_make(_state, &_frame_block);
27582  *info = 0;
27583  _matinvreport_clear(rep);
27584  ae_vector_init(&tmp, 0, DT_REAL, _state, ae_true);
27585  _matinvreport_init(&rep2, _state, ae_true);
27586 
27587  ae_assert(n>0, "SPDMatrixCholeskyInverse: N<=0!", _state);
27588  ae_assert(a->cols>=n, "SPDMatrixCholeskyInverse: cols(A)<N!", _state);
27589  ae_assert(a->rows>=n, "SPDMatrixCholeskyInverse: rows(A)<N!", _state);
27590  *info = 1;
27591  f = ae_true;
27592  for(i=0; i<=n-1; i++)
27593  {
27594  f = f&&ae_isfinite(a->ptr.pp_double[i][i], _state);
27595  }
27596  ae_assert(f, "SPDMatrixCholeskyInverse: A contains infinite or NaN values!", _state);
27597 
27598  /*
27599  * calculate condition numbers
27600  */
27601  rep->r1 = spdmatrixcholeskyrcond(a, n, isupper, _state);
27602  rep->rinf = rep->r1;
27603  if( ae_fp_less(rep->r1,rcondthreshold(_state))||ae_fp_less(rep->rinf,rcondthreshold(_state)) )
27604  {
27605  if( isupper )
27606  {
27607  for(i=0; i<=n-1; i++)
27608  {
27609  for(j=i; j<=n-1; j++)
27610  {
27611  a->ptr.pp_double[i][j] = 0;
27612  }
27613  }
27614  }
27615  else
27616  {
27617  for(i=0; i<=n-1; i++)
27618  {
27619  for(j=0; j<=i; j++)
27620  {
27621  a->ptr.pp_double[i][j] = 0;
27622  }
27623  }
27624  }
27625  rep->r1 = 0;
27626  rep->rinf = 0;
27627  *info = -3;
27628  ae_frame_leave(_state);
27629  return;
27630  }
27631 
27632  /*
27633  * Inverse
27634  */
27635  ae_vector_set_length(&tmp, n, _state);
27636  matinv_spdmatrixcholeskyinverserec(a, 0, n, isupper, &tmp, _state);
27637  ae_frame_leave(_state);
27638 }
27639 
27640 
27641 /*************************************************************************
27642 Inversion of a symmetric positive definite matrix.
27643 
27644 Given an upper or lower triangle of a symmetric positive definite matrix,
27645 the algorithm generates matrix A^-1 and saves the upper or lower triangle
27646 depending on the input.
27647 
27648 Input parameters:
27649  A - matrix to be inverted (upper or lower triangle).
27650  Array with elements [0..N-1,0..N-1].
27651  N - size of matrix A (optional) :
27652  * if given, only principal NxN submatrix is processed and
27653  overwritten. other elements are unchanged.
27654  * if not given, size is automatically determined from
27655  matrix size (A must be square matrix)
27656  IsUpper - storage type (optional):
27657  * if True, symmetric matrix A is given by its upper
27658  triangle, and the lower triangle isn’t used/changed by
27659  function
27660  * if False, symmetric matrix A is given by its lower
27661  triangle, and the upper triangle isn’t used/changed by
27662  function
27663  * if not given, both lower and upper triangles must be
27664  filled.
27665 
27666 Output parameters:
27667  Info - return code, same as in RMatrixLUInverse
27668  Rep - solver report, same as in RMatrixLUInverse
27669  A - inverse of matrix A, same as in RMatrixLUInverse
27670 
27671  -- ALGLIB routine --
27672  10.02.2010
27673  Bochkanov Sergey
27674 *************************************************************************/
27675 void spdmatrixinverse(/* Real */ ae_matrix* a,
27676  ae_int_t n,
27677  ae_bool isupper,
27678  ae_int_t* info,
27679  matinvreport* rep,
27680  ae_state *_state)
27681 {
27682 
27683  *info = 0;
27684  _matinvreport_clear(rep);
27685 
27686  ae_assert(n>0, "SPDMatrixInverse: N<=0!", _state);
27687  ae_assert(a->cols>=n, "SPDMatrixInverse: cols(A)<N!", _state);
27688  ae_assert(a->rows>=n, "SPDMatrixInverse: rows(A)<N!", _state);
27689  ae_assert(isfinitertrmatrix(a, n, isupper, _state), "SPDMatrixInverse: A contains infinite or NaN values!", _state);
27690  *info = 1;
27691  if( spdmatrixcholesky(a, n, isupper, _state) )
27692  {
27693  spdmatrixcholeskyinverse(a, n, isupper, info, rep, _state);
27694  }
27695  else
27696  {
27697  *info = -3;
27698  }
27699 }
27700 
27701 
27702 /*************************************************************************
27703 Inversion of a Hermitian positive definite matrix which is given
27704 by Cholesky decomposition.
27705 
27706 Input parameters:
27707  A - Cholesky decomposition of the matrix to be inverted:
27708  A=U’*U or A = L*L'.
27709  Output of HPDMatrixCholesky subroutine.
27710  N - size of matrix A (optional) :
27711  * if given, only principal NxN submatrix is processed and
27712  overwritten. other elements are unchanged.
27713  * if not given, size is automatically determined from
27714  matrix size (A must be square matrix)
27715  IsUpper - storage type (optional):
27716  * if True, symmetric matrix A is given by its upper
27717  triangle, and the lower triangle isn’t used/changed by
27718  function
27719  * if False, symmetric matrix A is given by its lower
27720  triangle, and the upper triangle isn’t used/changed by
27721  function
27722  * if not given, lower half is used.
27723 
27724 Output parameters:
27725  Info - return code, same as in RMatrixLUInverse
27726  Rep - solver report, same as in RMatrixLUInverse
27727  A - inverse of matrix A, same as in RMatrixLUInverse
27728 
27729  -- ALGLIB routine --
27730  10.02.2010
27731  Bochkanov Sergey
27732 *************************************************************************/
27733 void hpdmatrixcholeskyinverse(/* Complex */ ae_matrix* a,
27734  ae_int_t n,
27735  ae_bool isupper,
27736  ae_int_t* info,
27737  matinvreport* rep,
27738  ae_state *_state)
27739 {
27740  ae_frame _frame_block;
27741  ae_int_t i;
27742  ae_int_t j;
27743  matinvreport rep2;
27744  ae_vector tmp;
27745  ae_bool f;
27746 
27747  ae_frame_make(_state, &_frame_block);
27748  *info = 0;
27749  _matinvreport_clear(rep);
27750  _matinvreport_init(&rep2, _state, ae_true);
27751  ae_vector_init(&tmp, 0, DT_COMPLEX, _state, ae_true);
27752 
27753  ae_assert(n>0, "HPDMatrixCholeskyInverse: N<=0!", _state);
27754  ae_assert(a->cols>=n, "HPDMatrixCholeskyInverse: cols(A)<N!", _state);
27755  ae_assert(a->rows>=n, "HPDMatrixCholeskyInverse: rows(A)<N!", _state);
27756  f = ae_true;
27757  for(i=0; i<=n-1; i++)
27758  {
27759  f = (f&&ae_isfinite(a->ptr.pp_complex[i][i].x, _state))&&ae_isfinite(a->ptr.pp_complex[i][i].y, _state);
27760  }
27761  ae_assert(f, "HPDMatrixCholeskyInverse: A contains infinite or NaN values!", _state);
27762  *info = 1;
27763 
27764  /*
27765  * calculate condition numbers
27766  */
27767  rep->r1 = hpdmatrixcholeskyrcond(a, n, isupper, _state);
27768  rep->rinf = rep->r1;
27769  if( ae_fp_less(rep->r1,rcondthreshold(_state))||ae_fp_less(rep->rinf,rcondthreshold(_state)) )
27770  {
27771  if( isupper )
27772  {
27773  for(i=0; i<=n-1; i++)
27774  {
27775  for(j=i; j<=n-1; j++)
27776  {
27777  a->ptr.pp_complex[i][j] = ae_complex_from_d(0);
27778  }
27779  }
27780  }
27781  else
27782  {
27783  for(i=0; i<=n-1; i++)
27784  {
27785  for(j=0; j<=i; j++)
27786  {
27787  a->ptr.pp_complex[i][j] = ae_complex_from_d(0);
27788  }
27789  }
27790  }
27791  rep->r1 = 0;
27792  rep->rinf = 0;
27793  *info = -3;
27794  ae_frame_leave(_state);
27795  return;
27796  }
27797 
27798  /*
27799  * Inverse
27800  */
27801  ae_vector_set_length(&tmp, n, _state);
27802  matinv_hpdmatrixcholeskyinverserec(a, 0, n, isupper, &tmp, _state);
27803  ae_frame_leave(_state);
27804 }
27805 
27806 
27807 /*************************************************************************
27808 Inversion of a Hermitian positive definite matrix.
27809 
27810 Given an upper or lower triangle of a Hermitian positive definite matrix,
27811 the algorithm generates matrix A^-1 and saves the upper or lower triangle
27812 depending on the input.
27813 
27814 Input parameters:
27815  A - matrix to be inverted (upper or lower triangle).
27816  Array with elements [0..N-1,0..N-1].
27817  N - size of matrix A (optional) :
27818  * if given, only principal NxN submatrix is processed and
27819  overwritten. other elements are unchanged.
27820  * if not given, size is automatically determined from
27821  matrix size (A must be square matrix)
27822  IsUpper - storage type (optional):
27823  * if True, symmetric matrix A is given by its upper
27824  triangle, and the lower triangle isn’t used/changed by
27825  function
27826  * if False, symmetric matrix A is given by its lower
27827  triangle, and the upper triangle isn’t used/changed by
27828  function
27829  * if not given, both lower and upper triangles must be
27830  filled.
27831 
27832 Output parameters:
27833  Info - return code, same as in RMatrixLUInverse
27834  Rep - solver report, same as in RMatrixLUInverse
27835  A - inverse of matrix A, same as in RMatrixLUInverse
27836 
27837  -- ALGLIB routine --
27838  10.02.2010
27839  Bochkanov Sergey
27840 *************************************************************************/
27841 void hpdmatrixinverse(/* Complex */ ae_matrix* a,
27842  ae_int_t n,
27843  ae_bool isupper,
27844  ae_int_t* info,
27845  matinvreport* rep,
27846  ae_state *_state)
27847 {
27848 
27849  *info = 0;
27850  _matinvreport_clear(rep);
27851 
27852  ae_assert(n>0, "HPDMatrixInverse: N<=0!", _state);
27853  ae_assert(a->cols>=n, "HPDMatrixInverse: cols(A)<N!", _state);
27854  ae_assert(a->rows>=n, "HPDMatrixInverse: rows(A)<N!", _state);
27855  ae_assert(apservisfinitectrmatrix(a, n, isupper, _state), "HPDMatrixInverse: A contains infinite or NaN values!", _state);
27856  *info = 1;
27857  if( hpdmatrixcholesky(a, n, isupper, _state) )
27858  {
27859  hpdmatrixcholeskyinverse(a, n, isupper, info, rep, _state);
27860  }
27861  else
27862  {
27863  *info = -3;
27864  }
27865 }
27866 
27867 
27868 /*************************************************************************
27869 Triangular matrix inverse (real)
27870 
27871 The subroutine inverts the following types of matrices:
27872  * upper triangular
27873  * upper triangular with unit diagonal
27874  * lower triangular
27875  * lower triangular with unit diagonal
27876 
27877 In case of an upper (lower) triangular matrix, the inverse matrix will
27878 also be upper (lower) triangular, and after the end of the algorithm, the
27879 inverse matrix replaces the source matrix. The elements below (above) the
27880 main diagonal are not changed by the algorithm.
27881 
27882 If the matrix has a unit diagonal, the inverse matrix also has a unit
27883 diagonal, and the diagonal elements are not passed to the algorithm.
27884 
27885 Input parameters:
27886  A - matrix, array[0..N-1, 0..N-1].
27887  N - size of matrix A (optional) :
27888  * if given, only principal NxN submatrix is processed and
27889  overwritten. other elements are unchanged.
27890  * if not given, size is automatically determined from
27891  matrix size (A must be square matrix)
27892  IsUpper - True, if the matrix is upper triangular.
27893  IsUnit - diagonal type (optional):
27894  * if True, matrix has unit diagonal (a[i,i] are NOT used)
27895  * if False, matrix diagonal is arbitrary
27896  * if not given, False is assumed
27897 
27898 Output parameters:
27899  Info - same as for RMatrixLUInverse
27900  Rep - same as for RMatrixLUInverse
27901  A - same as for RMatrixLUInverse.
27902 
27903  -- ALGLIB --
27904  Copyright 05.02.2010 by Bochkanov Sergey
27905 *************************************************************************/
27906 void rmatrixtrinverse(/* Real */ ae_matrix* a,
27907  ae_int_t n,
27908  ae_bool isupper,
27909  ae_bool isunit,
27910  ae_int_t* info,
27911  matinvreport* rep,
27912  ae_state *_state)
27913 {
27914  ae_frame _frame_block;
27915  ae_int_t i;
27916  ae_int_t j;
27917  ae_vector tmp;
27918 
27919  ae_frame_make(_state, &_frame_block);
27920  *info = 0;
27921  _matinvreport_clear(rep);
27922  ae_vector_init(&tmp, 0, DT_REAL, _state, ae_true);
27923 
27924  ae_assert(n>0, "RMatrixTRInverse: N<=0!", _state);
27925  ae_assert(a->cols>=n, "RMatrixTRInverse: cols(A)<N!", _state);
27926  ae_assert(a->rows>=n, "RMatrixTRInverse: rows(A)<N!", _state);
27927  ae_assert(isfinitertrmatrix(a, n, isupper, _state), "RMatrixTRInverse: A contains infinite or NaN values!", _state);
27928  *info = 1;
27929 
27930  /*
27931  * calculate condition numbers
27932  */
27933  rep->r1 = rmatrixtrrcond1(a, n, isupper, isunit, _state);
27934  rep->rinf = rmatrixtrrcondinf(a, n, isupper, isunit, _state);
27935  if( ae_fp_less(rep->r1,rcondthreshold(_state))||ae_fp_less(rep->rinf,rcondthreshold(_state)) )
27936  {
27937  for(i=0; i<=n-1; i++)
27938  {
27939  for(j=0; j<=n-1; j++)
27940  {
27941  a->ptr.pp_double[i][j] = 0;
27942  }
27943  }
27944  rep->r1 = 0;
27945  rep->rinf = 0;
27946  *info = -3;
27947  ae_frame_leave(_state);
27948  return;
27949  }
27950 
27951  /*
27952  * Invert
27953  */
27954  ae_vector_set_length(&tmp, n, _state);
27955  matinv_rmatrixtrinverserec(a, 0, n, isupper, isunit, &tmp, info, rep, _state);
27956  ae_frame_leave(_state);
27957 }
27958 
27959 
27960 /*************************************************************************
27961 Triangular matrix inverse (complex)
27962 
27963 The subroutine inverts the following types of matrices:
27964  * upper triangular
27965  * upper triangular with unit diagonal
27966  * lower triangular
27967  * lower triangular with unit diagonal
27968 
27969 In case of an upper (lower) triangular matrix, the inverse matrix will
27970 also be upper (lower) triangular, and after the end of the algorithm, the
27971 inverse matrix replaces the source matrix. The elements below (above) the
27972 main diagonal are not changed by the algorithm.
27973 
27974 If the matrix has a unit diagonal, the inverse matrix also has a unit
27975 diagonal, and the diagonal elements are not passed to the algorithm.
27976 
27977 Input parameters:
27978  A - matrix, array[0..N-1, 0..N-1].
27979  N - size of matrix A (optional) :
27980  * if given, only principal NxN submatrix is processed and
27981  overwritten. other elements are unchanged.
27982  * if not given, size is automatically determined from
27983  matrix size (A must be square matrix)
27984  IsUpper - True, if the matrix is upper triangular.
27985  IsUnit - diagonal type (optional):
27986  * if True, matrix has unit diagonal (a[i,i] are NOT used)
27987  * if False, matrix diagonal is arbitrary
27988  * if not given, False is assumed
27989 
27990 Output parameters:
27991  Info - same as for RMatrixLUInverse
27992  Rep - same as for RMatrixLUInverse
27993  A - same as for RMatrixLUInverse.
27994 
27995  -- ALGLIB --
27996  Copyright 05.02.2010 by Bochkanov Sergey
27997 *************************************************************************/
27998 void cmatrixtrinverse(/* Complex */ ae_matrix* a,
27999  ae_int_t n,
28000  ae_bool isupper,
28001  ae_bool isunit,
28002  ae_int_t* info,
28003  matinvreport* rep,
28004  ae_state *_state)
28005 {
28006  ae_frame _frame_block;
28007  ae_int_t i;
28008  ae_int_t j;
28009  ae_vector tmp;
28010 
28011  ae_frame_make(_state, &_frame_block);
28012  *info = 0;
28013  _matinvreport_clear(rep);
28014  ae_vector_init(&tmp, 0, DT_COMPLEX, _state, ae_true);
28015 
28016  ae_assert(n>0, "CMatrixTRInverse: N<=0!", _state);
28017  ae_assert(a->cols>=n, "CMatrixTRInverse: cols(A)<N!", _state);
28018  ae_assert(a->rows>=n, "CMatrixTRInverse: rows(A)<N!", _state);
28019  ae_assert(apservisfinitectrmatrix(a, n, isupper, _state), "CMatrixTRInverse: A contains infinite or NaN values!", _state);
28020  *info = 1;
28021 
28022  /*
28023  * calculate condition numbers
28024  */
28025  rep->r1 = cmatrixtrrcond1(a, n, isupper, isunit, _state);
28026  rep->rinf = cmatrixtrrcondinf(a, n, isupper, isunit, _state);
28027  if( ae_fp_less(rep->r1,rcondthreshold(_state))||ae_fp_less(rep->rinf,rcondthreshold(_state)) )
28028  {
28029  for(i=0; i<=n-1; i++)
28030  {
28031  for(j=0; j<=n-1; j++)
28032  {
28033  a->ptr.pp_complex[i][j] = ae_complex_from_d(0);
28034  }
28035  }
28036  rep->r1 = 0;
28037  rep->rinf = 0;
28038  *info = -3;
28039  ae_frame_leave(_state);
28040  return;
28041  }
28042 
28043  /*
28044  * Invert
28045  */
28046  ae_vector_set_length(&tmp, n, _state);
28047  matinv_cmatrixtrinverserec(a, 0, n, isupper, isunit, &tmp, info, rep, _state);
28048  ae_frame_leave(_state);
28049 }
28050 
28051 
28052 /*************************************************************************
28053 Triangular matrix inversion, recursive subroutine
28054 
28055  -- ALGLIB --
28056  05.02.2010, Bochkanov Sergey.
28057  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
28058  Courant Institute, Argonne National Lab, and Rice University
28059  February 29, 1992.
28060 *************************************************************************/
28061 static void matinv_rmatrixtrinverserec(/* Real */ ae_matrix* a,
28062  ae_int_t offs,
28063  ae_int_t n,
28064  ae_bool isupper,
28065  ae_bool isunit,
28066  /* Real */ ae_vector* tmp,
28067  ae_int_t* info,
28068  matinvreport* rep,
28069  ae_state *_state)
28070 {
28071  ae_int_t n1;
28072  ae_int_t n2;
28073  ae_int_t i;
28074  ae_int_t j;
28075  double v;
28076  double ajj;
28077 
28078 
28079  if( n<1 )
28080  {
28081  *info = -1;
28082  return;
28083  }
28084 
28085  /*
28086  * Base case
28087  */
28088  if( n<=ablasblocksize(a, _state) )
28089  {
28090  if( isupper )
28091  {
28092 
28093  /*
28094  * Compute inverse of upper triangular matrix.
28095  */
28096  for(j=0; j<=n-1; j++)
28097  {
28098  if( !isunit )
28099  {
28100  if( ae_fp_eq(a->ptr.pp_double[offs+j][offs+j],0) )
28101  {
28102  *info = -3;
28103  return;
28104  }
28105  a->ptr.pp_double[offs+j][offs+j] = 1/a->ptr.pp_double[offs+j][offs+j];
28106  ajj = -a->ptr.pp_double[offs+j][offs+j];
28107  }
28108  else
28109  {
28110  ajj = -1;
28111  }
28112 
28113  /*
28114  * Compute elements 1:j-1 of j-th column.
28115  */
28116  if( j>0 )
28117  {
28118  ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs+0][offs+j], a->stride, ae_v_len(0,j-1));
28119  for(i=0; i<=j-1; i++)
28120  {
28121  if( i<j-1 )
28122  {
28123  v = ae_v_dotproduct(&a->ptr.pp_double[offs+i][offs+i+1], 1, &tmp->ptr.p_double[i+1], 1, ae_v_len(offs+i+1,offs+j-1));
28124  }
28125  else
28126  {
28127  v = 0;
28128  }
28129  if( !isunit )
28130  {
28131  a->ptr.pp_double[offs+i][offs+j] = v+a->ptr.pp_double[offs+i][offs+i]*tmp->ptr.p_double[i];
28132  }
28133  else
28134  {
28135  a->ptr.pp_double[offs+i][offs+j] = v+tmp->ptr.p_double[i];
28136  }
28137  }
28138  ae_v_muld(&a->ptr.pp_double[offs+0][offs+j], a->stride, ae_v_len(offs+0,offs+j-1), ajj);
28139  }
28140  }
28141  }
28142  else
28143  {
28144 
28145  /*
28146  * Compute inverse of lower triangular matrix.
28147  */
28148  for(j=n-1; j>=0; j--)
28149  {
28150  if( !isunit )
28151  {
28152  if( ae_fp_eq(a->ptr.pp_double[offs+j][offs+j],0) )
28153  {
28154  *info = -3;
28155  return;
28156  }
28157  a->ptr.pp_double[offs+j][offs+j] = 1/a->ptr.pp_double[offs+j][offs+j];
28158  ajj = -a->ptr.pp_double[offs+j][offs+j];
28159  }
28160  else
28161  {
28162  ajj = -1;
28163  }
28164  if( j<n-1 )
28165  {
28166 
28167  /*
28168  * Compute elements j+1:n of j-th column.
28169  */
28170  ae_v_move(&tmp->ptr.p_double[j+1], 1, &a->ptr.pp_double[offs+j+1][offs+j], a->stride, ae_v_len(j+1,n-1));
28171  for(i=j+1; i<=n-1; i++)
28172  {
28173  if( i>j+1 )
28174  {
28175  v = ae_v_dotproduct(&a->ptr.pp_double[offs+i][offs+j+1], 1, &tmp->ptr.p_double[j+1], 1, ae_v_len(offs+j+1,offs+i-1));
28176  }
28177  else
28178  {
28179  v = 0;
28180  }
28181  if( !isunit )
28182  {
28183  a->ptr.pp_double[offs+i][offs+j] = v+a->ptr.pp_double[offs+i][offs+i]*tmp->ptr.p_double[i];
28184  }
28185  else
28186  {
28187  a->ptr.pp_double[offs+i][offs+j] = v+tmp->ptr.p_double[i];
28188  }
28189  }
28190  ae_v_muld(&a->ptr.pp_double[offs+j+1][offs+j], a->stride, ae_v_len(offs+j+1,offs+n-1), ajj);
28191  }
28192  }
28193  }
28194  return;
28195  }
28196 
28197  /*
28198  * Recursive case
28199  */
28200  ablassplitlength(a, n, &n1, &n2, _state);
28201  if( n2>0 )
28202  {
28203  if( isupper )
28204  {
28205  for(i=0; i<=n1-1; i++)
28206  {
28207  ae_v_muld(&a->ptr.pp_double[offs+i][offs+n1], 1, ae_v_len(offs+n1,offs+n-1), -1);
28208  }
28209  rmatrixlefttrsm(n1, n2, a, offs, offs, isupper, isunit, 0, a, offs, offs+n1, _state);
28210  rmatrixrighttrsm(n1, n2, a, offs+n1, offs+n1, isupper, isunit, 0, a, offs, offs+n1, _state);
28211  }
28212  else
28213  {
28214  for(i=0; i<=n2-1; i++)
28215  {
28216  ae_v_muld(&a->ptr.pp_double[offs+n1+i][offs], 1, ae_v_len(offs,offs+n1-1), -1);
28217  }
28218  rmatrixrighttrsm(n2, n1, a, offs, offs, isupper, isunit, 0, a, offs+n1, offs, _state);
28219  rmatrixlefttrsm(n2, n1, a, offs+n1, offs+n1, isupper, isunit, 0, a, offs+n1, offs, _state);
28220  }
28221  matinv_rmatrixtrinverserec(a, offs+n1, n2, isupper, isunit, tmp, info, rep, _state);
28222  }
28223  matinv_rmatrixtrinverserec(a, offs, n1, isupper, isunit, tmp, info, rep, _state);
28224 }
28225 
28226 
28227 /*************************************************************************
28228 Triangular matrix inversion, recursive subroutine
28229 
28230  -- ALGLIB --
28231  05.02.2010, Bochkanov Sergey.
28232  Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
28233  Courant Institute, Argonne National Lab, and Rice University
28234  February 29, 1992.
28235 *************************************************************************/
28236 static void matinv_cmatrixtrinverserec(/* Complex */ ae_matrix* a,
28237  ae_int_t offs,
28238  ae_int_t n,
28239  ae_bool isupper,
28240  ae_bool isunit,
28241  /* Complex */ ae_vector* tmp,
28242  ae_int_t* info,
28243  matinvreport* rep,
28244  ae_state *_state)
28245 {
28246  ae_int_t n1;
28247  ae_int_t n2;
28248  ae_int_t i;
28249  ae_int_t j;
28250  ae_complex v;
28251  ae_complex ajj;
28252 
28253 
28254  if( n<1 )
28255  {
28256  *info = -1;
28257  return;
28258  }
28259 
28260  /*
28261  * Base case
28262  */
28263  if( n<=ablascomplexblocksize(a, _state) )
28264  {
28265  if( isupper )
28266  {
28267 
28268  /*
28269  * Compute inverse of upper triangular matrix.
28270  */
28271  for(j=0; j<=n-1; j++)
28272  {
28273  if( !isunit )
28274  {
28275  if( ae_c_eq_d(a->ptr.pp_complex[offs+j][offs+j],0) )
28276  {
28277  *info = -3;
28278  return;
28279  }
28280  a->ptr.pp_complex[offs+j][offs+j] = ae_c_d_div(1,a->ptr.pp_complex[offs+j][offs+j]);
28281  ajj = ae_c_neg(a->ptr.pp_complex[offs+j][offs+j]);
28282  }
28283  else
28284  {
28285  ajj = ae_complex_from_d(-1);
28286  }
28287 
28288  /*
28289  * Compute elements 1:j-1 of j-th column.
28290  */
28291  if( j>0 )
28292  {
28293  ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs+0][offs+j], a->stride, "N", ae_v_len(0,j-1));
28294  for(i=0; i<=j-1; i++)
28295  {
28296  if( i<j-1 )
28297  {
28298  v = ae_v_cdotproduct(&a->ptr.pp_complex[offs+i][offs+i+1], 1, "N", &tmp->ptr.p_complex[i+1], 1, "N", ae_v_len(offs+i+1,offs+j-1));
28299  }
28300  else
28301  {
28302  v = ae_complex_from_d(0);
28303  }
28304  if( !isunit )
28305  {
28306  a->ptr.pp_complex[offs+i][offs+j] = ae_c_add(v,ae_c_mul(a->ptr.pp_complex[offs+i][offs+i],tmp->ptr.p_complex[i]));
28307  }
28308  else
28309  {
28310  a->ptr.pp_complex[offs+i][offs+j] = ae_c_add(v,tmp->ptr.p_complex[i]);
28311  }
28312  }
28313  ae_v_cmulc(&a->ptr.pp_complex[offs+0][offs+j], a->stride, ae_v_len(offs+0,offs+j-1), ajj);
28314  }
28315  }
28316  }
28317  else
28318  {
28319 
28320  /*
28321  * Compute inverse of lower triangular matrix.
28322  */
28323  for(j=n-1; j>=0; j--)
28324  {
28325  if( !isunit )
28326  {
28327  if( ae_c_eq_d(a->ptr.pp_complex[offs+j][offs+j],0) )
28328  {
28329  *info = -3;
28330  return;
28331  }
28332  a->ptr.pp_complex[offs+j][offs+j] = ae_c_d_div(1,a->ptr.pp_complex[offs+j][offs+j]);
28333  ajj = ae_c_neg(a->ptr.pp_complex[offs+j][offs+j]);
28334  }
28335  else
28336  {
28337  ajj = ae_complex_from_d(-1);
28338  }
28339  if( j<n-1 )
28340  {
28341 
28342  /*
28343  * Compute elements j+1:n of j-th column.
28344  */
28345  ae_v_cmove(&tmp->ptr.p_complex[j+1], 1, &a->ptr.pp_complex[offs+j+1][offs+j], a->stride, "N", ae_v_len(j+1,n-1));
28346  for(i=j+1; i<=n-1; i++)
28347  {
28348  if( i>j+1 )
28349  {
28350  v = ae_v_cdotproduct(&a->ptr.pp_complex[offs+i][offs+j+1], 1, "N", &tmp->ptr.p_complex[j+1], 1, "N", ae_v_len(offs+j+1,offs+i-1));
28351  }
28352  else
28353  {
28354  v = ae_complex_from_d(0);
28355  }
28356  if( !isunit )
28357  {
28358  a->ptr.pp_complex[offs+i][offs+j] = ae_c_add(v,ae_c_mul(a->ptr.pp_complex[offs+i][offs+i],tmp->ptr.p_complex[i]));
28359  }
28360  else
28361  {
28362  a->ptr.pp_complex[offs+i][offs+j] = ae_c_add(v,tmp->ptr.p_complex[i]);
28363  }
28364  }
28365  ae_v_cmulc(&a->ptr.pp_complex[offs+j+1][offs+j], a->stride, ae_v_len(offs+j+1,offs+n-1), ajj);
28366  }
28367  }
28368  }
28369  return;
28370  }
28371 
28372  /*
28373  * Recursive case
28374  */
28375  ablascomplexsplitlength(a, n, &n1, &n2, _state);
28376  if( n2>0 )
28377  {
28378  if( isupper )
28379  {
28380  for(i=0; i<=n1-1; i++)
28381  {
28382  ae_v_cmuld(&a->ptr.pp_complex[offs+i][offs+n1], 1, ae_v_len(offs+n1,offs+n-1), -1);
28383  }
28384  cmatrixlefttrsm(n1, n2, a, offs, offs, isupper, isunit, 0, a, offs, offs+n1, _state);
28385  cmatrixrighttrsm(n1, n2, a, offs+n1, offs+n1, isupper, isunit, 0, a, offs, offs+n1, _state);
28386  }
28387  else
28388  {
28389  for(i=0; i<=n2-1; i++)
28390  {
28391  ae_v_cmuld(&a->ptr.pp_complex[offs+n1+i][offs], 1, ae_v_len(offs,offs+n1-1), -1);
28392  }
28393  cmatrixrighttrsm(n2, n1, a, offs, offs, isupper, isunit, 0, a, offs+n1, offs, _state);
28394  cmatrixlefttrsm(n2, n1, a, offs+n1, offs+n1, isupper, isunit, 0, a, offs+n1, offs, _state);
28395  }
28396  matinv_cmatrixtrinverserec(a, offs+n1, n2, isupper, isunit, tmp, info, rep, _state);
28397  }
28398  matinv_cmatrixtrinverserec(a, offs, n1, isupper, isunit, tmp, info, rep, _state);
28399 }
28400 
28401 
28402 static void matinv_rmatrixluinverserec(/* Real */ ae_matrix* a,
28403  ae_int_t offs,
28404  ae_int_t n,
28405  /* Real */ ae_vector* work,
28406  ae_int_t* info,
28407  matinvreport* rep,
28408  ae_state *_state)
28409 {
28410  ae_int_t i;
28411  ae_int_t j;
28412  double v;
28413  ae_int_t n1;
28414  ae_int_t n2;
28415 
28416 
28417  if( n<1 )
28418  {
28419  *info = -1;
28420  return;
28421  }
28422 
28423  /*
28424  * Base case
28425  */
28426  if( n<=ablasblocksize(a, _state) )
28427  {
28428 
28429  /*
28430  * Form inv(U)
28431  */
28432  matinv_rmatrixtrinverserec(a, offs, n, ae_true, ae_false, work, info, rep, _state);
28433  if( *info<=0 )
28434  {
28435  return;
28436  }
28437 
28438  /*
28439  * Solve the equation inv(A)*L = inv(U) for inv(A).
28440  */
28441  for(j=n-1; j>=0; j--)
28442  {
28443 
28444  /*
28445  * Copy current column of L to WORK and replace with zeros.
28446  */
28447  for(i=j+1; i<=n-1; i++)
28448  {
28449  work->ptr.p_double[i] = a->ptr.pp_double[offs+i][offs+j];
28450  a->ptr.pp_double[offs+i][offs+j] = 0;
28451  }
28452 
28453  /*
28454  * Compute current column of inv(A).
28455  */
28456  if( j<n-1 )
28457  {
28458  for(i=0; i<=n-1; i++)
28459  {
28460  v = ae_v_dotproduct(&a->ptr.pp_double[offs+i][offs+j+1], 1, &work->ptr.p_double[j+1], 1, ae_v_len(offs+j+1,offs+n-1));
28461  a->ptr.pp_double[offs+i][offs+j] = a->ptr.pp_double[offs+i][offs+j]-v;
28462  }
28463  }
28464  }
28465  return;
28466  }
28467 
28468  /*
28469  * Recursive code:
28470  *
28471  * ( L1 ) ( U1 U12 )
28472  * A = ( ) * ( )
28473  * ( L12 L2 ) ( U2 )
28474  *
28475  * ( W X )
28476  * A^-1 = ( )
28477  * ( Y Z )
28478  */
28479  ablassplitlength(a, n, &n1, &n2, _state);
28480  ae_assert(n2>0, "LUInverseRec: internal error!", _state);
28481 
28482  /*
28483  * X := inv(U1)*U12*inv(U2)
28484  */
28485  rmatrixlefttrsm(n1, n2, a, offs, offs, ae_true, ae_false, 0, a, offs, offs+n1, _state);
28486  rmatrixrighttrsm(n1, n2, a, offs+n1, offs+n1, ae_true, ae_false, 0, a, offs, offs+n1, _state);
28487 
28488  /*
28489  * Y := inv(L2)*L12*inv(L1)
28490  */
28491  rmatrixlefttrsm(n2, n1, a, offs+n1, offs+n1, ae_false, ae_true, 0, a, offs+n1, offs, _state);
28492  rmatrixrighttrsm(n2, n1, a, offs, offs, ae_false, ae_true, 0, a, offs+n1, offs, _state);
28493 
28494  /*
28495  * W := inv(L1*U1)+X*Y
28496  */
28497  matinv_rmatrixluinverserec(a, offs, n1, work, info, rep, _state);
28498  if( *info<=0 )
28499  {
28500  return;
28501  }
28502  rmatrixgemm(n1, n1, n2, 1.0, a, offs, offs+n1, 0, a, offs+n1, offs, 0, 1.0, a, offs, offs, _state);
28503 
28504  /*
28505  * X := -X*inv(L2)
28506  * Y := -inv(U2)*Y
28507  */
28508  rmatrixrighttrsm(n1, n2, a, offs+n1, offs+n1, ae_false, ae_true, 0, a, offs, offs+n1, _state);
28509  for(i=0; i<=n1-1; i++)
28510  {
28511  ae_v_muld(&a->ptr.pp_double[offs+i][offs+n1], 1, ae_v_len(offs+n1,offs+n-1), -1);
28512  }
28513  rmatrixlefttrsm(n2, n1, a, offs+n1, offs+n1, ae_true, ae_false, 0, a, offs+n1, offs, _state);
28514  for(i=0; i<=n2-1; i++)
28515  {
28516  ae_v_muld(&a->ptr.pp_double[offs+n1+i][offs], 1, ae_v_len(offs,offs+n1-1), -1);
28517  }
28518 
28519  /*
28520  * Z := inv(L2*U2)
28521  */
28522  matinv_rmatrixluinverserec(a, offs+n1, n2, work, info, rep, _state);
28523 }
28524 
28525 
28526 static void matinv_cmatrixluinverserec(/* Complex */ ae_matrix* a,
28527  ae_int_t offs,
28528  ae_int_t n,
28529  /* Complex */ ae_vector* work,
28530  ae_int_t* info,
28531  matinvreport* rep,
28532  ae_state *_state)
28533 {
28534  ae_int_t i;
28535  ae_int_t j;
28536  ae_complex v;
28537  ae_int_t n1;
28538  ae_int_t n2;
28539 
28540 
28541  if( n<1 )
28542  {
28543  *info = -1;
28544  return;
28545  }
28546 
28547  /*
28548  * Base case
28549  */
28550  if( n<=ablascomplexblocksize(a, _state) )
28551  {
28552 
28553  /*
28554  * Form inv(U)
28555  */
28556  matinv_cmatrixtrinverserec(a, offs, n, ae_true, ae_false, work, info, rep, _state);
28557  if( *info<=0 )
28558  {
28559  return;
28560  }
28561 
28562  /*
28563  * Solve the equation inv(A)*L = inv(U) for inv(A).
28564  */
28565  for(j=n-1; j>=0; j--)
28566  {
28567 
28568  /*
28569  * Copy current column of L to WORK and replace with zeros.
28570  */
28571  for(i=j+1; i<=n-1; i++)
28572  {
28573  work->ptr.p_complex[i] = a->ptr.pp_complex[offs+i][offs+j];
28574  a->ptr.pp_complex[offs+i][offs+j] = ae_complex_from_d(0);
28575  }
28576 
28577  /*
28578  * Compute current column of inv(A).
28579  */
28580  if( j<n-1 )
28581  {
28582  for(i=0; i<=n-1; i++)
28583  {
28584  v = ae_v_cdotproduct(&a->ptr.pp_complex[offs+i][offs+j+1], 1, "N", &work->ptr.p_complex[j+1], 1, "N", ae_v_len(offs+j+1,offs+n-1));
28585  a->ptr.pp_complex[offs+i][offs+j] = ae_c_sub(a->ptr.pp_complex[offs+i][offs+j],v);
28586  }
28587  }
28588  }
28589  return;
28590  }
28591 
28592  /*
28593  * Recursive code:
28594  *
28595  * ( L1 ) ( U1 U12 )
28596  * A = ( ) * ( )
28597  * ( L12 L2 ) ( U2 )
28598  *
28599  * ( W X )
28600  * A^-1 = ( )
28601  * ( Y Z )
28602  */
28603  ablascomplexsplitlength(a, n, &n1, &n2, _state);
28604  ae_assert(n2>0, "LUInverseRec: internal error!", _state);
28605 
28606  /*
28607  * X := inv(U1)*U12*inv(U2)
28608  */
28609  cmatrixlefttrsm(n1, n2, a, offs, offs, ae_true, ae_false, 0, a, offs, offs+n1, _state);
28610  cmatrixrighttrsm(n1, n2, a, offs+n1, offs+n1, ae_true, ae_false, 0, a, offs, offs+n1, _state);
28611 
28612  /*
28613  * Y := inv(L2)*L12*inv(L1)
28614  */
28615  cmatrixlefttrsm(n2, n1, a, offs+n1, offs+n1, ae_false, ae_true, 0, a, offs+n1, offs, _state);
28616  cmatrixrighttrsm(n2, n1, a, offs, offs, ae_false, ae_true, 0, a, offs+n1, offs, _state);
28617 
28618  /*
28619  * W := inv(L1*U1)+X*Y
28620  */
28621  matinv_cmatrixluinverserec(a, offs, n1, work, info, rep, _state);
28622  if( *info<=0 )
28623  {
28624  return;
28625  }
28626  cmatrixgemm(n1, n1, n2, ae_complex_from_d(1.0), a, offs, offs+n1, 0, a, offs+n1, offs, 0, ae_complex_from_d(1.0), a, offs, offs, _state);
28627 
28628  /*
28629  * X := -X*inv(L2)
28630  * Y := -inv(U2)*Y
28631  */
28632  cmatrixrighttrsm(n1, n2, a, offs+n1, offs+n1, ae_false, ae_true, 0, a, offs, offs+n1, _state);
28633  for(i=0; i<=n1-1; i++)
28634  {
28635  ae_v_cmuld(&a->ptr.pp_complex[offs+i][offs+n1], 1, ae_v_len(offs+n1,offs+n-1), -1);
28636  }
28637  cmatrixlefttrsm(n2, n1, a, offs+n1, offs+n1, ae_true, ae_false, 0, a, offs+n1, offs, _state);
28638  for(i=0; i<=n2-1; i++)
28639  {
28640  ae_v_cmuld(&a->ptr.pp_complex[offs+n1+i][offs], 1, ae_v_len(offs,offs+n1-1), -1);
28641  }
28642 
28643  /*
28644  * Z := inv(L2*U2)
28645  */
28646  matinv_cmatrixluinverserec(a, offs+n1, n2, work, info, rep, _state);
28647 }
28648 
28649 
28650 /*************************************************************************
28651 Recursive subroutine for SPD inversion.
28652 
28653  -- ALGLIB routine --
28654  10.02.2010
28655  Bochkanov Sergey
28656 *************************************************************************/
28657 static void matinv_spdmatrixcholeskyinverserec(/* Real */ ae_matrix* a,
28658  ae_int_t offs,
28659  ae_int_t n,
28660  ae_bool isupper,
28661  /* Real */ ae_vector* tmp,
28662  ae_state *_state)
28663 {
28664  ae_frame _frame_block;
28665  ae_int_t i;
28666  ae_int_t j;
28667  double v;
28668  ae_int_t n1;
28669  ae_int_t n2;
28670  ae_int_t info2;
28671  matinvreport rep2;
28672 
28673  ae_frame_make(_state, &_frame_block);
28674  _matinvreport_init(&rep2, _state, ae_true);
28675 
28676  if( n<1 )
28677  {
28678  ae_frame_leave(_state);
28679  return;
28680  }
28681 
28682  /*
28683  * Base case
28684  */
28685  if( n<=ablasblocksize(a, _state) )
28686  {
28687  matinv_rmatrixtrinverserec(a, offs, n, isupper, ae_false, tmp, &info2, &rep2, _state);
28688  if( isupper )
28689  {
28690 
28691  /*
28692  * Compute the product U * U'.
28693  * NOTE: we never assume that diagonal of U is real
28694  */
28695  for(i=0; i<=n-1; i++)
28696  {
28697  if( i==0 )
28698  {
28699 
28700  /*
28701  * 1x1 matrix
28702  */
28703  a->ptr.pp_double[offs+i][offs+i] = ae_sqr(a->ptr.pp_double[offs+i][offs+i], _state);
28704  }
28705  else
28706  {
28707 
28708  /*
28709  * (I+1)x(I+1) matrix,
28710  *
28711  * ( A11 A12 ) ( A11^H ) ( A11*A11^H+A12*A12^H A12*A22^H )
28712  * ( ) * ( ) = ( )
28713  * ( A22 ) ( A12^H A22^H ) ( A22*A12^H A22*A22^H )
28714  *
28715  * A11 is IxI, A22 is 1x1.
28716  */
28717  ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs][offs+i], a->stride, ae_v_len(0,i-1));
28718  for(j=0; j<=i-1; j++)
28719  {
28720  v = a->ptr.pp_double[offs+j][offs+i];
28721  ae_v_addd(&a->ptr.pp_double[offs+j][offs+j], 1, &tmp->ptr.p_double[j], 1, ae_v_len(offs+j,offs+i-1), v);
28722  }
28723  v = a->ptr.pp_double[offs+i][offs+i];
28724  ae_v_muld(&a->ptr.pp_double[offs][offs+i], a->stride, ae_v_len(offs,offs+i-1), v);
28725  a->ptr.pp_double[offs+i][offs+i] = ae_sqr(a->ptr.pp_double[offs+i][offs+i], _state);
28726  }
28727  }
28728  }
28729  else
28730  {
28731 
28732  /*
28733  * Compute the product L' * L
28734  * NOTE: we never assume that diagonal of L is real
28735  */
28736  for(i=0; i<=n-1; i++)
28737  {
28738  if( i==0 )
28739  {
28740 
28741  /*
28742  * 1x1 matrix
28743  */
28744  a->ptr.pp_double[offs+i][offs+i] = ae_sqr(a->ptr.pp_double[offs+i][offs+i], _state);
28745  }
28746  else
28747  {
28748 
28749  /*
28750  * (I+1)x(I+1) matrix,
28751  *
28752  * ( A11^H A21^H ) ( A11 ) ( A11^H*A11+A21^H*A21 A21^H*A22 )
28753  * ( ) * ( ) = ( )
28754  * ( A22^H ) ( A21 A22 ) ( A22^H*A21 A22^H*A22 )
28755  *
28756  * A11 is IxI, A22 is 1x1.
28757  */
28758  ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs+i][offs], 1, ae_v_len(0,i-1));
28759  for(j=0; j<=i-1; j++)
28760  {
28761  v = a->ptr.pp_double[offs+i][offs+j];
28762  ae_v_addd(&a->ptr.pp_double[offs+j][offs], 1, &tmp->ptr.p_double[0], 1, ae_v_len(offs,offs+j), v);
28763  }
28764  v = a->ptr.pp_double[offs+i][offs+i];
28765  ae_v_muld(&a->ptr.pp_double[offs+i][offs], 1, ae_v_len(offs,offs+i-1), v);
28766  a->ptr.pp_double[offs+i][offs+i] = ae_sqr(a->ptr.pp_double[offs+i][offs+i], _state);
28767  }
28768  }
28769  }
28770  ae_frame_leave(_state);
28771  return;
28772  }
28773 
28774  /*
28775  * Recursive code: triangular factor inversion merged with
28776  * UU' or L'L multiplication
28777  */
28778  ablassplitlength(a, n, &n1, &n2, _state);
28779 
28780  /*
28781  * form off-diagonal block of trangular inverse
28782  */
28783  if( isupper )
28784  {
28785  for(i=0; i<=n1-1; i++)
28786  {
28787  ae_v_muld(&a->ptr.pp_double[offs+i][offs+n1], 1, ae_v_len(offs+n1,offs+n-1), -1);
28788  }
28789  rmatrixlefttrsm(n1, n2, a, offs, offs, isupper, ae_false, 0, a, offs, offs+n1, _state);
28790  rmatrixrighttrsm(n1, n2, a, offs+n1, offs+n1, isupper, ae_false, 0, a, offs, offs+n1, _state);
28791  }
28792  else
28793  {
28794  for(i=0; i<=n2-1; i++)
28795  {
28796  ae_v_muld(&a->ptr.pp_double[offs+n1+i][offs], 1, ae_v_len(offs,offs+n1-1), -1);
28797  }
28798  rmatrixrighttrsm(n2, n1, a, offs, offs, isupper, ae_false, 0, a, offs+n1, offs, _state);
28799  rmatrixlefttrsm(n2, n1, a, offs+n1, offs+n1, isupper, ae_false, 0, a, offs+n1, offs, _state);
28800  }
28801 
28802  /*
28803  * invert first diagonal block
28804  */
28805  matinv_spdmatrixcholeskyinverserec(a, offs, n1, isupper, tmp, _state);
28806 
28807  /*
28808  * update first diagonal block with off-diagonal block,
28809  * update off-diagonal block
28810  */
28811  if( isupper )
28812  {
28813  rmatrixsyrk(n1, n2, 1.0, a, offs, offs+n1, 0, 1.0, a, offs, offs, isupper, _state);
28814  rmatrixrighttrsm(n1, n2, a, offs+n1, offs+n1, isupper, ae_false, 1, a, offs, offs+n1, _state);
28815  }
28816  else
28817  {
28818  rmatrixsyrk(n1, n2, 1.0, a, offs+n1, offs, 1, 1.0, a, offs, offs, isupper, _state);
28819  rmatrixlefttrsm(n2, n1, a, offs+n1, offs+n1, isupper, ae_false, 1, a, offs+n1, offs, _state);
28820  }
28821 
28822  /*
28823  * invert second diagonal block
28824  */
28825  matinv_spdmatrixcholeskyinverserec(a, offs+n1, n2, isupper, tmp, _state);
28826  ae_frame_leave(_state);
28827 }
28828 
28829 
28830 /*************************************************************************
28831 Recursive subroutine for HPD inversion.
28832 
28833  -- ALGLIB routine --
28834  10.02.2010
28835  Bochkanov Sergey
28836 *************************************************************************/
28837 static void matinv_hpdmatrixcholeskyinverserec(/* Complex */ ae_matrix* a,
28838  ae_int_t offs,
28839  ae_int_t n,
28840  ae_bool isupper,
28841  /* Complex */ ae_vector* tmp,
28842  ae_state *_state)
28843 {
28844  ae_frame _frame_block;
28845  ae_int_t i;
28846  ae_int_t j;
28847  ae_complex v;
28848  ae_int_t n1;
28849  ae_int_t n2;
28850  ae_int_t info2;
28851  matinvreport rep2;
28852 
28853  ae_frame_make(_state, &_frame_block);
28854  _matinvreport_init(&rep2, _state, ae_true);
28855 
28856  if( n<1 )
28857  {
28858  ae_frame_leave(_state);
28859  return;
28860  }
28861 
28862  /*
28863  * Base case
28864  */
28865  if( n<=ablascomplexblocksize(a, _state) )
28866  {
28867  matinv_cmatrixtrinverserec(a, offs, n, isupper, ae_false, tmp, &info2, &rep2, _state);
28868  if( isupper )
28869  {
28870 
28871  /*
28872  * Compute the product U * U'.
28873  * NOTE: we never assume that diagonal of U is real
28874  */
28875  for(i=0; i<=n-1; i++)
28876  {
28877  if( i==0 )
28878  {
28879 
28880  /*
28881  * 1x1 matrix
28882  */
28883  a->ptr.pp_complex[offs+i][offs+i] = ae_complex_from_d(ae_sqr(a->ptr.pp_complex[offs+i][offs+i].x, _state)+ae_sqr(a->ptr.pp_complex[offs+i][offs+i].y, _state));
28884  }
28885  else
28886  {
28887 
28888  /*
28889  * (I+1)x(I+1) matrix,
28890  *
28891  * ( A11 A12 ) ( A11^H ) ( A11*A11^H+A12*A12^H A12*A22^H )
28892  * ( ) * ( ) = ( )
28893  * ( A22 ) ( A12^H A22^H ) ( A22*A12^H A22*A22^H )
28894  *
28895  * A11 is IxI, A22 is 1x1.
28896  */
28897  ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs][offs+i], a->stride, "Conj", ae_v_len(0,i-1));
28898  for(j=0; j<=i-1; j++)
28899  {
28900  v = a->ptr.pp_complex[offs+j][offs+i];
28901  ae_v_caddc(&a->ptr.pp_complex[offs+j][offs+j], 1, &tmp->ptr.p_complex[j], 1, "N", ae_v_len(offs+j,offs+i-1), v);
28902  }
28903  v = ae_c_conj(a->ptr.pp_complex[offs+i][offs+i], _state);
28904  ae_v_cmulc(&a->ptr.pp_complex[offs][offs+i], a->stride, ae_v_len(offs,offs+i-1), v);
28905  a->ptr.pp_complex[offs+i][offs+i] = ae_complex_from_d(ae_sqr(a->ptr.pp_complex[offs+i][offs+i].x, _state)+ae_sqr(a->ptr.pp_complex[offs+i][offs+i].y, _state));
28906  }
28907  }
28908  }
28909  else
28910  {
28911 
28912  /*
28913  * Compute the product L' * L
28914  * NOTE: we never assume that diagonal of L is real
28915  */
28916  for(i=0; i<=n-1; i++)
28917  {
28918  if( i==0 )
28919  {
28920 
28921  /*
28922  * 1x1 matrix
28923  */
28924  a->ptr.pp_complex[offs+i][offs+i] = ae_complex_from_d(ae_sqr(a->ptr.pp_complex[offs+i][offs+i].x, _state)+ae_sqr(a->ptr.pp_complex[offs+i][offs+i].y, _state));
28925  }
28926  else
28927  {
28928 
28929  /*
28930  * (I+1)x(I+1) matrix,
28931  *
28932  * ( A11^H A21^H ) ( A11 ) ( A11^H*A11+A21^H*A21 A21^H*A22 )
28933  * ( ) * ( ) = ( )
28934  * ( A22^H ) ( A21 A22 ) ( A22^H*A21 A22^H*A22 )
28935  *
28936  * A11 is IxI, A22 is 1x1.
28937  */
28938  ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs+i][offs], 1, "N", ae_v_len(0,i-1));
28939  for(j=0; j<=i-1; j++)
28940  {
28941  v = ae_c_conj(a->ptr.pp_complex[offs+i][offs+j], _state);
28942  ae_v_caddc(&a->ptr.pp_complex[offs+j][offs], 1, &tmp->ptr.p_complex[0], 1, "N", ae_v_len(offs,offs+j), v);
28943  }
28944  v = ae_c_conj(a->ptr.pp_complex[offs+i][offs+i], _state);
28945  ae_v_cmulc(&a->ptr.pp_complex[offs+i][offs], 1, ae_v_len(offs,offs+i-1), v);
28946  a->ptr.pp_complex[offs+i][offs+i] = ae_complex_from_d(ae_sqr(a->ptr.pp_complex[offs+i][offs+i].x, _state)+ae_sqr(a->ptr.pp_complex[offs+i][offs+i].y, _state));
28947  }
28948  }
28949  }
28950  ae_frame_leave(_state);
28951  return;
28952  }
28953 
28954  /*
28955  * Recursive code: triangular factor inversion merged with
28956  * UU' or L'L multiplication
28957  */
28958  ablascomplexsplitlength(a, n, &n1, &n2, _state);
28959 
28960  /*
28961  * form off-diagonal block of trangular inverse
28962  */
28963  if( isupper )
28964  {
28965  for(i=0; i<=n1-1; i++)
28966  {
28967  ae_v_cmuld(&a->ptr.pp_complex[offs+i][offs+n1], 1, ae_v_len(offs+n1,offs+n-1), -1);
28968  }
28969  cmatrixlefttrsm(n1, n2, a, offs, offs, isupper, ae_false, 0, a, offs, offs+n1, _state);
28970  cmatrixrighttrsm(n1, n2, a, offs+n1, offs+n1, isupper, ae_false, 0, a, offs, offs+n1, _state);
28971  }
28972  else
28973  {
28974  for(i=0; i<=n2-1; i++)
28975  {
28976  ae_v_cmuld(&a->ptr.pp_complex[offs+n1+i][offs], 1, ae_v_len(offs,offs+n1-1), -1);
28977  }
28978  cmatrixrighttrsm(n2, n1, a, offs, offs, isupper, ae_false, 0, a, offs+n1, offs, _state);
28979  cmatrixlefttrsm(n2, n1, a, offs+n1, offs+n1, isupper, ae_false, 0, a, offs+n1, offs, _state);
28980  }
28981 
28982  /*
28983  * invert first diagonal block
28984  */
28985  matinv_hpdmatrixcholeskyinverserec(a, offs, n1, isupper, tmp, _state);
28986 
28987  /*
28988  * update first diagonal block with off-diagonal block,
28989  * update off-diagonal block
28990  */
28991  if( isupper )
28992  {
28993  cmatrixsyrk(n1, n2, 1.0, a, offs, offs+n1, 0, 1.0, a, offs, offs, isupper, _state);
28994  cmatrixrighttrsm(n1, n2, a, offs+n1, offs+n1, isupper, ae_false, 2, a, offs, offs+n1, _state);
28995  }
28996  else
28997  {
28998  cmatrixsyrk(n1, n2, 1.0, a, offs+n1, offs, 2, 1.0, a, offs, offs, isupper, _state);
28999  cmatrixlefttrsm(n2, n1, a, offs+n1, offs+n1, isupper, ae_false, 2, a, offs+n1, offs, _state);
29000  }
29001 
29002  /*
29003  * invert second diagonal block
29004  */
29005  matinv_hpdmatrixcholeskyinverserec(a, offs+n1, n2, isupper, tmp, _state);
29006  ae_frame_leave(_state);
29007 }
29008 
29009 
29010 ae_bool _matinvreport_init(void* _p, ae_state *_state, ae_bool make_automatic)
29011 {
29012  matinvreport *p = (matinvreport*)_p;
29013  ae_touch_ptr((void*)p);
29014  return ae_true;
29015 }
29016 
29017 
29018 ae_bool _matinvreport_init_copy(void* _dst, void* _src, ae_state *_state, ae_bool make_automatic)
29019 {
29020  matinvreport *dst = (matinvreport*)_dst;
29021  matinvreport *src = (matinvreport*)_src;
29022  dst->r1 = src->r1;
29023  dst->rinf = src->rinf;
29024  return ae_true;
29025 }
29026 
29027 
29028 void _matinvreport_clear(void* _p)
29029 {
29030  matinvreport *p = (matinvreport*)_p;
29031  ae_touch_ptr((void*)p);
29032 }
29033 
29034 
29035 void _matinvreport_destroy(void* _p)
29036 {
29037  matinvreport *p = (matinvreport*)_p;
29038  ae_touch_ptr((void*)p);
29039 }
29040 
29041 
29042 
29043 
29044 /*************************************************************************
29045 This function creates sparse matrix in a Hash-Table format.
29046 
29047 This function creates Hast-Table matrix, which can be converted to CRS
29048 format after its initialization is over. Typical usage scenario for a
29049 sparse matrix is:
29050 1. creation in a Hash-Table format
29051 2. insertion of the matrix elements
29052 3. conversion to the CRS representation
29053 4. matrix is passed to some linear algebra algorithm
29054 
29055 Some information about different matrix formats can be found below, in
29056 the "NOTES" section.
29057 
29058 INPUT PARAMETERS
29059  M - number of rows in a matrix, M>=1
29060  N - number of columns in a matrix, N>=1
29061  K - K>=0, expected number of non-zero elements in a matrix.
29062  K can be inexact approximation, can be less than actual
29063  number of elements (table will grow when needed) or
29064  even zero).
29065  It is important to understand that although hash-table
29066  may grow automatically, it is better to provide good
29067  estimate of data size.
29068 
29069 OUTPUT PARAMETERS
29070  S - sparse M*N matrix in Hash-Table representation.
29071  All elements of the matrix are zero.
29072 
29073 NOTE 1.
29074 
29075 Sparse matrices can be stored using either Hash-Table representation or
29076 Compressed Row Storage representation. Hast-table is better suited for
29077 querying and dynamic operations (thus, it is used for matrix
29078 initialization), but it is inefficient when you want to make some linear
29079 algebra operations.
29080 
29081 From the other side, CRS is better suited for linear algebra operations,
29082 but initialization is less convenient - you have to tell row sizes at the
29083 initialization, and you can fill matrix only row by row, from left to
29084 right. CRS is also very inefficient when you want to find matrix element
29085 by its index.
29086 
29087 Thus, Hash-Table representation does not support linear algebra
29088 operations, while CRS format does not support modification of the table.
29089 Tables below outline information about these two formats:
29090 
29091  OPERATIONS WITH MATRIX HASH CRS
29092  create + +
29093  read element + +
29094  modify element +
29095  add value to element +
29096  A*x (dense vector) +
29097  A'*x (dense vector) +
29098  A*X (dense matrix) +
29099  A'*X (dense matrix) +
29100 
29101 NOTE 2.
29102 
29103 Hash-tables use memory inefficiently, and they have to keep some amount
29104 of the "spare memory" in order to have good performance. Hash table for
29105 matrix with K non-zero elements will need C*K*(8+2*sizeof(int)) bytes,
29106 where C is a small constant, about 1.5-2 in magnitude.
29107 
29108 CRS storage, from the other side, is more memory-efficient, and needs
29109 just K*(8+sizeof(int))+M*sizeof(int) bytes, where M is a number of rows
29110 in a matrix.
29111 
29112 When you convert from the Hash-Table to CRS representation, all unneeded
29113 memory will be freed.
29114 
29115  -- ALGLIB PROJECT --
29116  Copyright 14.10.2011 by Bochkanov Sergey
29117 *************************************************************************/
29118 void sparsecreate(ae_int_t m,
29119  ae_int_t n,
29120  ae_int_t k,
29121  sparsematrix* s,
29122  ae_state *_state)
29123 {
29124  ae_int_t i;
29125  ae_int_t sz;
29126 
29127  _sparsematrix_clear(s);
29128 
29129  ae_assert(m>0, "SparseCreate: M<=0", _state);
29130  ae_assert(n>0, "SparseCreate: N<=0", _state);
29131  ae_assert(k>=0, "SparseCreate: K<0", _state);
29132  sz = ae_round(k/sparse_desiredloadfactor+sparse_additional, _state);
29133  s->matrixtype = 0;
29134  s->m = m;
29135  s->n = n;
29136  s->nfree = sz;
29137  ae_vector_set_length(&s->vals, sz, _state);
29138  ae_vector_set_length(&s->idx, 2*sz, _state);
29139  for(i=0; i<=sz-1; i++)
29140  {
29141  s->idx.ptr.p_int[2*i] = -1;
29142  }
29143 }
29144 
29145 
29146 /*************************************************************************
29147 This function creates sparse matrix in a CRS format (expert function for
29148 situations when you are running out of memory).
29149 
29150 This function creates CRS matrix. Typical usage scenario for a CRS matrix
29151 is:
29152 1. creation (you have to tell number of non-zero elements at each row at
29153  this moment)
29154 2. insertion of the matrix elements (row by row, from left to right)
29155 3. matrix is passed to some linear algebra algorithm
29156 
29157 This function is a memory-efficient alternative to SparseCreate(), but it
29158 is more complex because it requires you to know in advance how large your
29159 matrix is. Some information about different matrix formats can be found
29160 below, in the "NOTES" section.
29161 
29162 INPUT PARAMETERS
29163  M - number of rows in a matrix, M>=1
29164  N - number of columns in a matrix, N>=1
29165  NER - number of elements at each row, array[M], NER[I]>=0
29166 
29167 OUTPUT PARAMETERS
29168  S - sparse M*N matrix in CRS representation.
29169  You have to fill ALL non-zero elements by calling
29170  SparseSet() BEFORE you try to use this matrix.
29171 
29172 NOTE 1.
29173 
29174 Sparse matrices can be stored using either Hash-Table representation or
29175 Compressed Row Storage representation. Hast-table is better suited for
29176 querying and dynamic operations (thus, it is used for matrix
29177 initialization), but it is inefficient when you want to make some linear
29178 algebra operations.
29179 
29180 From the other side, CRS is better suited for linear algebra operations,
29181 but initialization is less convenient - you have to tell row sizes at the
29182 initialization, and you can fill matrix only row by row, from left to
29183 right. CRS is also very inefficient when you want to find matrix element
29184 by its index.
29185 
29186 Thus, Hash-Table representation does not support linear algebra
29187 operations, while CRS format does not support modification of the table.
29188 Tables below outline information about these two formats:
29189 
29190  OPERATIONS WITH MATRIX HASH CRS
29191  create + +
29192  read element + +
29193  modify element +
29194  add value to element +
29195  A*x (dense vector) +
29196  A'*x (dense vector) +
29197  A*X (dense matrix) +
29198  A'*X (dense matrix) +
29199 
29200 NOTE 2.
29201 
29202 Hash-tables use memory inefficiently, and they have to keep some amount
29203 of the "spare memory" in order to have good performance. Hash table for
29204 matrix with K non-zero elements will need C*K*(8+2*sizeof(int)) bytes,
29205 where C is a small constant, about 1.5-2 in magnitude.
29206 
29207 CRS storage, from the other side, is more memory-efficient, and needs
29208 just K*(8+sizeof(int))+M*sizeof(int) bytes, where M is a number of rows
29209 in a matrix.
29210 
29211 When you convert from the Hash-Table to CRS representation, all unneeded
29212 memory will be freed.
29213 
29214  -- ALGLIB PROJECT --
29215  Copyright 14.10.2011 by Bochkanov Sergey
29216 *************************************************************************/
29217 void sparsecreatecrs(ae_int_t m,
29218  ae_int_t n,
29219  /* Integer */ ae_vector* ner,
29220  sparsematrix* s,
29221  ae_state *_state)
29222 {
29223  ae_int_t i;
29224  ae_int_t noe;
29225 
29226  _sparsematrix_clear(s);
29227 
29228  ae_assert(m>0, "SparseCreateCRS: M<=0", _state);
29229  ae_assert(n>0, "SparseCreateCRS: N<=0", _state);
29230  ae_assert(ner->cnt>=m, "SparseCreateCRS: Length(NER)<M", _state);
29231  noe = 0;
29232  s->matrixtype = 1;
29233  s->ninitialized = 0;
29234  s->m = m;
29235  s->n = n;
29236  ae_vector_set_length(&s->ridx, s->m+1, _state);
29237  s->ridx.ptr.p_int[0] = 0;
29238  for(i=0; i<=s->m-1; i++)
29239  {
29240  ae_assert(ner->ptr.p_int[i]>=0, "SparseCreateCRS: NER[] contains negative elements", _state);
29241  noe = noe+ner->ptr.p_int[i];
29242  s->ridx.ptr.p_int[i+1] = s->ridx.ptr.p_int[i]+ner->ptr.p_int[i];
29243  }
29244  ae_vector_set_length(&s->vals, noe, _state);
29245  ae_vector_set_length(&s->idx, noe, _state);
29246  if( noe==0 )
29247  {
29248  sparse_sparseinitduidx(s, _state);
29249  }
29250 }
29251 
29252 
29253 /*************************************************************************
29254 This function copies S0 to S1.
29255 
29256 NOTE: this function does not verify its arguments, it just copies all
29257 fields of the structure.
29258 
29259  -- ALGLIB PROJECT --
29260  Copyright 14.10.2011 by Bochkanov Sergey
29261 *************************************************************************/
29262 void sparsecopy(sparsematrix* s0, sparsematrix* s1, ae_state *_state)
29263 {
29264  ae_int_t l;
29265  ae_int_t i;
29266 
29267  _sparsematrix_clear(s1);
29268 
29269  s1->matrixtype = s0->matrixtype;
29270  s1->m = s0->m;
29271  s1->n = s0->n;
29272  s1->nfree = s0->nfree;
29273  s1->ninitialized = s0->ninitialized;
29274 
29275  /*
29276  * Initialization for arrays
29277  */
29278  l = s0->vals.cnt;
29279  ae_vector_set_length(&s1->vals, l, _state);
29280  for(i=0; i<=l-1; i++)
29281  {
29282  s1->vals.ptr.p_double[i] = s0->vals.ptr.p_double[i];
29283  }
29284  l = s0->ridx.cnt;
29285  ae_vector_set_length(&s1->ridx, l, _state);
29286  for(i=0; i<=l-1; i++)
29287  {
29288  s1->ridx.ptr.p_int[i] = s0->ridx.ptr.p_int[i];
29289  }
29290  l = s0->idx.cnt;
29291  ae_vector_set_length(&s1->idx, l, _state);
29292  for(i=0; i<=l-1; i++)
29293  {
29294  s1->idx.ptr.p_int[i] = s0->idx.ptr.p_int[i];
29295  }
29296 
29297  /*
29298  * Initialization for CRS-parameters
29299  */
29300  l = s0->uidx.cnt;
29301  ae_vector_set_length(&s1->uidx, l, _state);
29302  for(i=0; i<=l-1; i++)
29303  {
29304  s1->uidx.ptr.p_int[i] = s0->uidx.ptr.p_int[i];
29305  }
29306  l = s0->didx.cnt;
29307  ae_vector_set_length(&s1->didx, l, _state);
29308  for(i=0; i<=l-1; i++)
29309  {
29310  s1->didx.ptr.p_int[i] = s0->didx.ptr.p_int[i];
29311  }
29312 }
29313 
29314 
29315 /*************************************************************************
29316 This function adds value to S[i,j] - element of the sparse matrix. Matrix
29317 must be in a Hash-Table mode.
29318 
29319 In case S[i,j] already exists in the table, V i added to its value. In
29320 case S[i,j] is non-existent, it is inserted in the table. Table
29321 automatically grows when necessary.
29322 
29323 INPUT PARAMETERS
29324  S - sparse M*N matrix in Hash-Table representation.
29325  Exception will be thrown for CRS matrix.
29326  I - row index of the element to modify, 0<=I<M
29327  J - column index of the element to modify, 0<=J<N
29328  V - value to add, must be finite number
29329 
29330 OUTPUT PARAMETERS
29331  S - modified matrix
29332 
29333 NOTE 1: when S[i,j] is exactly zero after modification, it is deleted
29334 from the table.
29335 
29336  -- ALGLIB PROJECT --
29337  Copyright 14.10.2011 by Bochkanov Sergey
29338 *************************************************************************/
29339 void sparseadd(sparsematrix* s,
29340  ae_int_t i,
29341  ae_int_t j,
29342  double v,
29343  ae_state *_state)
29344 {
29345  ae_int_t hashcode;
29346  ae_int_t tcode;
29347  ae_int_t k;
29348 
29349 
29350  ae_assert(s->matrixtype==0, "SparseAdd: matrix must be in the Hash-Table mode to do this operation", _state);
29351  ae_assert(i>=0, "SparseAdd: I<0", _state);
29352  ae_assert(i<s->m, "SparseAdd: I>=M", _state);
29353  ae_assert(j>=0, "SparseAdd: J<0", _state);
29354  ae_assert(j<s->n, "SparseAdd: J>=N", _state);
29355  ae_assert(ae_isfinite(v, _state), "SparseAdd: V is not finite number", _state);
29356  if( ae_fp_eq(v,0) )
29357  {
29358  return;
29359  }
29360  tcode = -1;
29361  k = s->vals.cnt;
29362  if( ae_fp_greater_eq((1-sparse_maxloadfactor)*k,s->nfree) )
29363  {
29364  sparseresizematrix(s, _state);
29365  k = s->vals.cnt;
29366  }
29367  hashcode = sparse_hash(i, j, k, _state);
29368  for(;;)
29369  {
29370  if( s->idx.ptr.p_int[2*hashcode]==-1 )
29371  {
29372  if( tcode!=-1 )
29373  {
29374  hashcode = tcode;
29375  }
29376  s->vals.ptr.p_double[hashcode] = v;
29377  s->idx.ptr.p_int[2*hashcode] = i;
29378  s->idx.ptr.p_int[2*hashcode+1] = j;
29379  if( tcode==-1 )
29380  {
29381  s->nfree = s->nfree-1;
29382  }
29383  return;
29384  }
29385  else
29386  {
29387  if( s->idx.ptr.p_int[2*hashcode]==i&&s->idx.ptr.p_int[2*hashcode+1]==j )
29388  {
29389  s->vals.ptr.p_double[hashcode] = s->vals.ptr.p_double[hashcode]+v;
29390  if( ae_fp_eq(s->vals.ptr.p_double[hashcode],0) )
29391  {
29392  s->idx.ptr.p_int[2*hashcode] = -2;
29393  }
29394  return;
29395  }
29396 
29397  /*
29398  * Is it deleted element?
29399  */
29400  if( tcode==-1&&s->idx.ptr.p_int[2*hashcode]==-2 )
29401  {
29402  tcode = hashcode;
29403  }
29404 
29405  /*
29406  * Next step
29407  */
29408  hashcode = (hashcode+1)%k;
29409  }
29410  }
29411 }
29412 
29413 
29414 /*************************************************************************
29415 This function modifies S[i,j] - element of the sparse matrix.
29416 
29417 For Hash-based storage format:
29418 * new value can be zero or non-zero. In case new value of S[i,j] is zero,
29419  this element is deleted from the table.
29420 * this function has no effect when called with zero V for non-existent
29421  element.
29422 
29423 For CRS-bases storage format:
29424 * new value MUST be non-zero. Exception will be thrown for zero V.
29425 * elements must be initialized in correct order - from top row to bottom,
29426  within row - from left to right.
29427 
29428 INPUT PARAMETERS
29429  S - sparse M*N matrix in Hash-Table or CRS representation.
29430  I - row index of the element to modify, 0<=I<M
29431  J - column index of the element to modify, 0<=J<N
29432  V - value to set, must be finite number, can be zero
29433 
29434 OUTPUT PARAMETERS
29435  S - modified matrix
29436 
29437  -- ALGLIB PROJECT --
29438  Copyright 14.10.2011 by Bochkanov Sergey
29439 *************************************************************************/
29440 void sparseset(sparsematrix* s,
29441  ae_int_t i,
29442  ae_int_t j,
29443  double v,
29444  ae_state *_state)
29445 {
29446  ae_int_t hashcode;
29447  ae_int_t tcode;
29448  ae_int_t k;
29449 
29450 
29451  ae_assert(i>=0, "SparseSet: I<0", _state);
29452  ae_assert(i<s->m, "SparseSet: I>=M", _state);
29453  ae_assert(j>=0, "SparseSet: J<0", _state);
29454  ae_assert(j<s->n, "SparseSet: J>=N", _state);
29455  ae_assert(ae_isfinite(v, _state), "SparseSet: V is not finite number", _state);
29456 
29457  /*
29458  * Hash-table matrix
29459  */
29460  if( s->matrixtype==0 )
29461  {
29462  tcode = -1;
29463  k = s->vals.cnt;
29464  if( ae_fp_greater_eq((1-sparse_maxloadfactor)*k,s->nfree) )
29465  {
29466  sparseresizematrix(s, _state);
29467  k = s->vals.cnt;
29468  }
29469  hashcode = sparse_hash(i, j, k, _state);
29470  for(;;)
29471  {
29472  if( s->idx.ptr.p_int[2*hashcode]==-1 )
29473  {
29474  if( ae_fp_neq(v,0) )
29475  {
29476  if( tcode!=-1 )
29477  {
29478  hashcode = tcode;
29479  }
29480  s->vals.ptr.p_double[hashcode] = v;
29481  s->idx.ptr.p_int[2*hashcode] = i;
29482  s->idx.ptr.p_int[2*hashcode+1] = j;
29483  if( tcode==-1 )
29484  {
29485  s->nfree = s->nfree-1;
29486  }
29487  }
29488  return;
29489  }
29490  else
29491  {
29492  if( s->idx.ptr.p_int[2*hashcode]==i&&s->idx.ptr.p_int[2*hashcode+1]==j )
29493  {
29494  if( ae_fp_eq(v,0) )
29495  {
29496  s->idx.ptr.p_int[2*hashcode] = -2;
29497  }
29498  else
29499  {
29500  s->vals.ptr.p_double[hashcode] = v;
29501  }
29502  return;
29503  }
29504  if( tcode==-1&&s->idx.ptr.p_int[2*hashcode]==-2 )
29505  {
29506  tcode = hashcode;
29507  }
29508 
29509  /*
29510  * Next step
29511  */
29512  hashcode = (hashcode+1)%k;
29513  }
29514  }
29515  }
29516 
29517  /*
29518  * CRS matrix
29519  */
29520  if( s->matrixtype==1 )
29521  {
29522  ae_assert(ae_fp_neq(v,0), "SparseSet: CRS format does not allow you to write zero elements", _state);
29523  ae_assert(s->ridx.ptr.p_int[i]<=s->ninitialized, "SparseSet: too few initialized elements at some row (you have promised more when called SparceCreateCRS)", _state);
29524  ae_assert(s->ridx.ptr.p_int[i+1]>s->ninitialized, "SparseSet: too many initialized elements at some row (you have promised less when called SparceCreateCRS)", _state);
29525  ae_assert(s->ninitialized==s->ridx.ptr.p_int[i]||s->idx.ptr.p_int[s->ninitialized-1]<j, "SparseSet: incorrect column order (you must fill every row from left to right)", _state);
29526  s->vals.ptr.p_double[s->ninitialized] = v;
29527  s->idx.ptr.p_int[s->ninitialized] = j;
29528  s->ninitialized = s->ninitialized+1;
29529 
29530  /*
29531  * If matrix has been created then
29532  * initiale 'S.UIdx' and 'S.DIdx'
29533  */
29534  if( s->ninitialized==s->ridx.ptr.p_int[s->m] )
29535  {
29536  sparse_sparseinitduidx(s, _state);
29537  }
29538  }
29539 }
29540 
29541 
29542 /*************************************************************************
29543 This function returns S[i,j] - element of the sparse matrix. Matrix can
29544 be in any mode (Hash-Table or CRS), but this function is less efficient
29545 for CRS matrices. Hash-Table matrices can find element in O(1) time,
29546 while CRS matrices need O(log(RS)) time, where RS is an number of non-
29547 zero elements in a row.
29548 
29549 INPUT PARAMETERS
29550  S - sparse M*N matrix in Hash-Table representation.
29551  Exception will be thrown for CRS matrix.
29552  I - row index of the element to modify, 0<=I<M
29553  J - column index of the element to modify, 0<=J<N
29554 
29555 RESULT
29556  value of S[I,J] or zero (in case no element with such index is found)
29557 
29558  -- ALGLIB PROJECT --
29559  Copyright 14.10.2011 by Bochkanov Sergey
29560 *************************************************************************/
29561 double sparseget(sparsematrix* s,
29562  ae_int_t i,
29563  ae_int_t j,
29564  ae_state *_state)
29565 {
29566  ae_int_t hashcode;
29567  ae_int_t k;
29568  ae_int_t k0;
29569  ae_int_t k1;
29570  double result;
29571 
29572 
29573  ae_assert(i>=0, "SparseGet: I<0", _state);
29574  ae_assert(i<s->m, "SparseGet: I>=M", _state);
29575  ae_assert(j>=0, "SparseGet: J<0", _state);
29576  ae_assert(j<s->n, "SparseGet: J>=N", _state);
29577  k = s->vals.cnt;
29578  result = 0;
29579  if( s->matrixtype==0 )
29580  {
29581  hashcode = sparse_hash(i, j, k, _state);
29582  for(;;)
29583  {
29584  if( s->idx.ptr.p_int[2*hashcode]==-1 )
29585  {
29586  return result;
29587  }
29588  if( s->idx.ptr.p_int[2*hashcode]==i&&s->idx.ptr.p_int[2*hashcode+1]==j )
29589  {
29590  result = s->vals.ptr.p_double[hashcode];
29591  return result;
29592  }
29593  hashcode = (hashcode+1)%k;
29594  }
29595  }
29596  if( s->matrixtype==1 )
29597  {
29598  ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseGet: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)", _state);
29599  k0 = s->ridx.ptr.p_int[i];
29600  k1 = s->ridx.ptr.p_int[i+1]-1;
29601  while(k0<=k1)
29602  {
29603  k = (k0+k1)/2;
29604  if( s->idx.ptr.p_int[k]==j )
29605  {
29606  result = s->vals.ptr.p_double[k];
29607  return result;
29608  }
29609  if( s->idx.ptr.p_int[k]<j )
29610  {
29611  k0 = k+1;
29612  }
29613  else
29614  {
29615  k1 = k-1;
29616  }
29617  }
29618  return result;
29619  }
29620  return result;
29621 }
29622 
29623 
29624 /*************************************************************************
29625 This function returns I-th diagonal element of the sparse matrix.
29626 
29627 Matrix can be in any mode (Hash-Table or CRS storage), but this function
29628 is most efficient for CRS matrices - it requires less than 50 CPU cycles
29629 to extract diagonal element. For Hash-Table matrices we still have O(1)
29630 query time, but function is many times slower.
29631 
29632 INPUT PARAMETERS
29633  S - sparse M*N matrix in Hash-Table representation.
29634  Exception will be thrown for CRS matrix.
29635  I - index of the element to modify, 0<=I<min(M,N)
29636 
29637 RESULT
29638  value of S[I,I] or zero (in case no element with such index is found)
29639 
29640  -- ALGLIB PROJECT --
29641  Copyright 14.10.2011 by Bochkanov Sergey
29642 *************************************************************************/
29643 double sparsegetdiagonal(sparsematrix* s, ae_int_t i, ae_state *_state)
29644 {
29645  double result;
29646 
29647 
29648  ae_assert(i>=0, "SparseGetDiagonal: I<0", _state);
29649  ae_assert(i<s->m, "SparseGetDiagonal: I>=M", _state);
29650  ae_assert(i<s->n, "SparseGetDiagonal: I>=N", _state);
29651  result = 0;
29652  if( s->matrixtype==0 )
29653  {
29654  result = sparseget(s, i, i, _state);
29655  return result;
29656  }
29657  if( s->matrixtype==1 )
29658  {
29659  if( s->didx.ptr.p_int[i]!=s->uidx.ptr.p_int[i] )
29660  {
29661  result = s->vals.ptr.p_double[s->didx.ptr.p_int[i]];
29662  }
29663  return result;
29664  }
29665  return result;
29666 }
29667 
29668 
29669 /*************************************************************************
29670 This function converts matrix to CRS format.
29671 
29672 Some algorithms (linear algebra ones, for example) require matrices in
29673 CRS format.
29674 
29675 INPUT PARAMETERS
29676  S - sparse M*N matrix in any format
29677 
29678 OUTPUT PARAMETERS
29679  S - matrix in CRS format
29680 
29681 NOTE: this function has no effect when called with matrix which is
29682 already in CRS mode.
29683 
29684  -- ALGLIB PROJECT --
29685  Copyright 14.10.2011 by Bochkanov Sergey
29686 *************************************************************************/
29687 void sparseconverttocrs(sparsematrix* s, ae_state *_state)
29688 {
29689  ae_frame _frame_block;
29690  ae_int_t i;
29691  ae_vector tvals;
29692  ae_vector tidx;
29693  ae_vector temp;
29694  ae_int_t nonne;
29695  ae_int_t k;
29696 
29697  ae_frame_make(_state, &_frame_block);
29698  ae_vector_init(&tvals, 0, DT_REAL, _state, ae_true);
29699  ae_vector_init(&tidx, 0, DT_INT, _state, ae_true);
29700  ae_vector_init(&temp, 0, DT_INT, _state, ae_true);
29701 
29702  ae_assert(s->matrixtype==0||s->matrixtype==1, "SparseConvertToCRS: invalid matrix type", _state);
29703  if( s->matrixtype==1 )
29704  {
29705  ae_frame_leave(_state);
29706  return;
29707  }
29708  s->matrixtype = 1;
29709  nonne = 0;
29710  k = s->vals.cnt;
29711  ae_swap_vectors(&s->vals, &tvals);
29712  ae_swap_vectors(&s->idx, &tidx);
29713  ae_vector_set_length(&s->ridx, s->m+1, _state);
29714  for(i=0; i<=s->m; i++)
29715  {
29716  s->ridx.ptr.p_int[i] = 0;
29717  }
29718  ae_vector_set_length(&temp, s->m, _state);
29719  for(i=0; i<=s->m-1; i++)
29720  {
29721  temp.ptr.p_int[i] = 0;
29722  }
29723 
29724  /*
29725  * Number of elements per row
29726  */
29727  for(i=0; i<=k-1; i++)
29728  {
29729  if( tidx.ptr.p_int[2*i]>=0 )
29730  {
29731  s->ridx.ptr.p_int[tidx.ptr.p_int[2*i]+1] = s->ridx.ptr.p_int[tidx.ptr.p_int[2*i]+1]+1;
29732  nonne = nonne+1;
29733  }
29734  }
29735 
29736  /*
29737  * Fill RIdx (offsets of rows)
29738  */
29739  for(i=0; i<=s->m-1; i++)
29740  {
29741  s->ridx.ptr.p_int[i+1] = s->ridx.ptr.p_int[i+1]+s->ridx.ptr.p_int[i];
29742  }
29743 
29744  /*
29745  * Allocate memory
29746  */
29747  ae_vector_set_length(&s->vals, nonne, _state);
29748  ae_vector_set_length(&s->idx, nonne, _state);
29749  for(i=0; i<=k-1; i++)
29750  {
29751  if( tidx.ptr.p_int[2*i]>=0 )
29752  {
29753  s->vals.ptr.p_double[s->ridx.ptr.p_int[tidx.ptr.p_int[2*i]]+temp.ptr.p_int[tidx.ptr.p_int[2*i]]] = tvals.ptr.p_double[i];
29754  s->idx.ptr.p_int[s->ridx.ptr.p_int[tidx.ptr.p_int[2*i]]+temp.ptr.p_int[tidx.ptr.p_int[2*i]]] = tidx.ptr.p_int[2*i+1];
29755  temp.ptr.p_int[tidx.ptr.p_int[2*i]] = temp.ptr.p_int[tidx.ptr.p_int[2*i]]+1;
29756  }
29757  }
29758 
29759  /*
29760  * Set NInitialized
29761  */
29762  s->ninitialized = s->ridx.ptr.p_int[s->m];
29763 
29764  /*
29765  * Sorting of elements
29766  */
29767  for(i=0; i<=s->m-1; i++)
29768  {
29769  tagsortmiddleir(&s->idx, &s->vals, s->ridx.ptr.p_int[i], s->ridx.ptr.p_int[i+1]-s->ridx.ptr.p_int[i], _state);
29770  }
29771 
29772  /*
29773  * Initialization 'S.UIdx' and 'S.DIdx'
29774  */
29775  sparse_sparseinitduidx(s, _state);
29776  ae_frame_leave(_state);
29777 }
29778 
29779 
29780 /*************************************************************************
29781 This function calculates matrix-vector product S*x. Matrix S must be
29782 stored in CRS format (exception will be thrown otherwise).
29783 
29784 INPUT PARAMETERS
29785  S - sparse M*N matrix in CRS format (you MUST convert it
29786  to CRS before calling this function).
29787  X - array[N], input vector. For performance reasons we
29788  make only quick checks - we check that array size is
29789  at least N, but we do not check for NAN's or INF's.
29790  Y - output buffer, possibly preallocated. In case buffer
29791  size is too small to store result, this buffer is
29792  automatically resized.
29793 
29794 OUTPUT PARAMETERS
29795  Y - array[M], S*x
29796 
29797 NOTE: this function throws exception when called for non-CRS matrix. You
29798 must convert your matrix with SparseConvertToCRS() before using this
29799 function.
29800 
29801  -- ALGLIB PROJECT --
29802  Copyright 14.10.2011 by Bochkanov Sergey
29803 *************************************************************************/
29804 void sparsemv(sparsematrix* s,
29805  /* Real */ ae_vector* x,
29806  /* Real */ ae_vector* y,
29807  ae_state *_state)
29808 {
29809  double tval;
29810  ae_int_t i;
29811  ae_int_t j;
29812  ae_int_t lt;
29813  ae_int_t rt;
29814 
29815 
29816  ae_assert(s->matrixtype==1, "SparseMV: incorrect matrix type (convert your matrix to CRS)", _state);
29817  ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseMV: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)", _state);
29818  ae_assert(x->cnt>=s->n, "SparseMV: length(X)<N", _state);
29819  rvectorsetlengthatleast(y, s->m, _state);
29820  for(i=0; i<=s->m-1; i++)
29821  {
29822  tval = 0;
29823  lt = s->ridx.ptr.p_int[i];
29824  rt = s->ridx.ptr.p_int[i+1];
29825  for(j=lt; j<=rt-1; j++)
29826  {
29827  tval = tval+x->ptr.p_double[s->idx.ptr.p_int[j]]*s->vals.ptr.p_double[j];
29828  }
29829  y->ptr.p_double[i] = tval;
29830  }
29831 }
29832 
29833 
29834 /*************************************************************************
29835 This function calculates matrix-vector product S^T*x. Matrix S must be
29836 stored in CRS format (exception will be thrown otherwise).
29837 
29838 INPUT PARAMETERS
29839  S - sparse M*N matrix in CRS format (you MUST convert it
29840  to CRS before calling this function).
29841  X - array[M], input vector. For performance reasons we
29842  make only quick checks - we check that array size is
29843  at least M, but we do not check for NAN's or INF's.
29844  Y - output buffer, possibly preallocated. In case buffer
29845  size is too small to store result, this buffer is
29846  automatically resized.
29847 
29848 OUTPUT PARAMETERS
29849  Y - array[N], S^T*x
29850 
29851 NOTE: this function throws exception when called for non-CRS matrix. You
29852 must convert your matrix with SparseConvertToCRS() before using this
29853 function.
29854 
29855  -- ALGLIB PROJECT --
29856  Copyright 14.10.2011 by Bochkanov Sergey
29857 *************************************************************************/
29858 void sparsemtv(sparsematrix* s,
29859  /* Real */ ae_vector* x,
29860  /* Real */ ae_vector* y,
29861  ae_state *_state)
29862 {
29863  ae_int_t i;
29864  ae_int_t j;
29865  ae_int_t lt;
29866  ae_int_t rt;
29867  ae_int_t ct;
29868  double v;
29869 
29870 
29871  ae_assert(s->matrixtype==1, "SparseMTV: incorrect matrix type (convert your matrix to CRS)", _state);
29872  ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseMTV: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)", _state);
29873  ae_assert(x->cnt>=s->m, "SparseMTV: Length(X)<M", _state);
29874  rvectorsetlengthatleast(y, s->n, _state);
29875  for(i=0; i<=s->n-1; i++)
29876  {
29877  y->ptr.p_double[i] = 0;
29878  }
29879  for(i=0; i<=s->m-1; i++)
29880  {
29881  lt = s->ridx.ptr.p_int[i];
29882  rt = s->ridx.ptr.p_int[i+1];
29883  v = x->ptr.p_double[i];
29884  for(j=lt; j<=rt-1; j++)
29885  {
29886  ct = s->idx.ptr.p_int[j];
29887  y->ptr.p_double[ct] = y->ptr.p_double[ct]+v*s->vals.ptr.p_double[j];
29888  }
29889  }
29890 }
29891 
29892 
29893 /*************************************************************************
29894 This function simultaneously calculates two matrix-vector products:
29895  S*x and S^T*x.
29896 S must be square (non-rectangular) matrix stored in CRS format (exception
29897 will be thrown otherwise).
29898 
29899 INPUT PARAMETERS
29900  S - sparse N*N matrix in CRS format (you MUST convert it
29901  to CRS before calling this function).
29902  X - array[N], input vector. For performance reasons we
29903  make only quick checks - we check that array size is
29904  at least N, but we do not check for NAN's or INF's.
29905  Y0 - output buffer, possibly preallocated. In case buffer
29906  size is too small to store result, this buffer is
29907  automatically resized.
29908  Y1 - output buffer, possibly preallocated. In case buffer
29909  size is too small to store result, this buffer is
29910  automatically resized.
29911 
29912 OUTPUT PARAMETERS
29913  Y0 - array[N], S*x
29914  Y1 - array[N], S^T*x
29915 
29916 NOTE: this function throws exception when called for non-CRS matrix. You
29917 must convert your matrix with SparseConvertToCRS() before using this
29918 function. It also throws exception when S is non-square.
29919 
29920  -- ALGLIB PROJECT --
29921  Copyright 14.10.2011 by Bochkanov Sergey
29922 *************************************************************************/
29923 void sparsemv2(sparsematrix* s,
29924  /* Real */ ae_vector* x,
29925  /* Real */ ae_vector* y0,
29926  /* Real */ ae_vector* y1,
29927  ae_state *_state)
29928 {
29929  ae_int_t l;
29930  double tval;
29931  ae_int_t i;
29932  ae_int_t j;
29933  double vx;
29934  double vs;
29935  ae_int_t vi;
29936  ae_int_t j0;
29937  ae_int_t j1;
29938 
29939 
29940  ae_assert(s->matrixtype==1, "SparseMV2: incorrect matrix type (convert your matrix to CRS)", _state);
29941  ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseMV: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)", _state);
29942  ae_assert(s->m==s->n, "SparseMV2: matrix is non-square", _state);
29943  l = x->cnt;
29944  ae_assert(l>=s->n, "SparseMV2: Length(X)<N", _state);
29945  rvectorsetlengthatleast(y0, l, _state);
29946  rvectorsetlengthatleast(y1, l, _state);
29947  for(i=0; i<=s->n-1; i++)
29948  {
29949  y1->ptr.p_double[i] = 0;
29950  }
29951  for(i=0; i<=s->m-1; i++)
29952  {
29953  tval = 0;
29954  vx = x->ptr.p_double[i];
29955  j0 = s->ridx.ptr.p_int[i];
29956  j1 = s->ridx.ptr.p_int[i+1]-1;
29957  for(j=j0; j<=j1; j++)
29958  {
29959  vi = s->idx.ptr.p_int[j];
29960  vs = s->vals.ptr.p_double[j];
29961  tval = tval+x->ptr.p_double[vi]*vs;
29962  y1->ptr.p_double[vi] = y1->ptr.p_double[vi]+vx*vs;
29963  }
29964  y0->ptr.p_double[i] = tval;
29965  }
29966 }
29967 
29968 
29969 /*************************************************************************
29970 This function calculates matrix-vector product S*x, when S is symmetric
29971 matrix. Matrix S must be stored in CRS format (exception will be
29972 thrown otherwise).
29973 
29974 INPUT PARAMETERS
29975  S - sparse M*M matrix in CRS format (you MUST convert it
29976  to CRS before calling this function).
29977  IsUpper - whether upper or lower triangle of S is given:
29978  * if upper triangle is given, only S[i,j] for j>=i
29979  are used, and lower triangle is ignored (it can be
29980  empty - these elements are not referenced at all).
29981  * if lower triangle is given, only S[i,j] for j<=i
29982  are used, and upper triangle is ignored.
29983  X - array[N], input vector. For performance reasons we
29984  make only quick checks - we check that array size is
29985  at least N, but we do not check for NAN's or INF's.
29986  Y - output buffer, possibly preallocated. In case buffer
29987  size is too small to store result, this buffer is
29988  automatically resized.
29989 
29990 OUTPUT PARAMETERS
29991  Y - array[M], S*x
29992 
29993 NOTE: this function throws exception when called for non-CRS matrix. You
29994 must convert your matrix with SparseConvertToCRS() before using this
29995 function.
29996 
29997  -- ALGLIB PROJECT --
29998  Copyright 14.10.2011 by Bochkanov Sergey
29999 *************************************************************************/
30000 void sparsesmv(sparsematrix* s,
30001  ae_bool isupper,
30002  /* Real */ ae_vector* x,
30003  /* Real */ ae_vector* y,
30004  ae_state *_state)
30005 {
30006  ae_int_t i;
30007  ae_int_t j;
30008  ae_int_t id;
30009  ae_int_t lt;
30010  ae_int_t rt;
30011  double v;
30012  double vy;
30013  double vx;
30014 
30015 
30016  ae_assert(s->matrixtype==1, "SparseSMV: incorrect matrix type (convert your matrix to CRS)", _state);
30017  ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseSMV: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)", _state);
30018  ae_assert(x->cnt>=s->n, "SparseSMV: length(X)<N", _state);
30019  ae_assert(s->m==s->n, "SparseSMV: non-square matrix", _state);
30020  rvectorsetlengthatleast(y, s->m, _state);
30021  for(i=0; i<=s->m-1; i++)
30022  {
30023  y->ptr.p_double[i] = 0;
30024  }
30025  for(i=0; i<=s->m-1; i++)
30026  {
30027  if( s->didx.ptr.p_int[i]!=s->uidx.ptr.p_int[i] )
30028  {
30029  y->ptr.p_double[i] = y->ptr.p_double[i]+s->vals.ptr.p_double[s->didx.ptr.p_int[i]]*x->ptr.p_double[s->idx.ptr.p_int[s->didx.ptr.p_int[i]]];
30030  }
30031  if( isupper )
30032  {
30033  lt = s->uidx.ptr.p_int[i];
30034  rt = s->ridx.ptr.p_int[i+1];
30035  vy = 0;
30036  vx = x->ptr.p_double[i];
30037  for(j=lt; j<=rt-1; j++)
30038  {
30039  id = s->idx.ptr.p_int[j];
30040  v = s->vals.ptr.p_double[j];
30041  vy = vy+x->ptr.p_double[id]*v;
30042  y->ptr.p_double[id] = y->ptr.p_double[id]+vx*v;
30043  }
30044  y->ptr.p_double[i] = y->ptr.p_double[i]+vy;
30045  }
30046  else
30047  {
30048  lt = s->ridx.ptr.p_int[i];
30049  rt = s->didx.ptr.p_int[i];
30050  vy = 0;
30051  vx = x->ptr.p_double[i];
30052  for(j=lt; j<=rt-1; j++)
30053  {
30054  id = s->idx.ptr.p_int[j];
30055  v = s->vals.ptr.p_double[j];
30056  vy = vy+x->ptr.p_double[id]*v;
30057  y->ptr.p_double[id] = y->ptr.p_double[id]+vx*v;
30058  }
30059  y->ptr.p_double[i] = y->ptr.p_double[i]+vy;
30060  }
30061  }
30062 }
30063 
30064 
30065 /*************************************************************************
30066 This function calculates matrix-matrix product S*A. Matrix S must be
30067 stored in CRS format (exception will be thrown otherwise).
30068 
30069 INPUT PARAMETERS
30070  S - sparse M*N matrix in CRS format (you MUST convert it
30071  to CRS before calling this function).
30072  A - array[N][K], input dense matrix. For performance reasons
30073  we make only quick checks - we check that array size
30074  is at least N, but we do not check for NAN's or INF's.
30075  K - number of columns of matrix (A).
30076  B - output buffer, possibly preallocated. In case buffer
30077  size is too small to store result, this buffer is
30078  automatically resized.
30079 
30080 OUTPUT PARAMETERS
30081  B - array[M][K], S*A
30082 
30083 NOTE: this function throws exception when called for non-CRS matrix. You
30084 must convert your matrix with SparseConvertToCRS() before using this
30085 function.
30086 
30087  -- ALGLIB PROJECT --
30088  Copyright 14.10.2011 by Bochkanov Sergey
30089 *************************************************************************/
30090 void sparsemm(sparsematrix* s,
30091  /* Real */ ae_matrix* a,
30092  ae_int_t k,
30093  /* Real */ ae_matrix* b,
30094  ae_state *_state)
30095 {
30096  double tval;
30097  double v;
30098  ae_int_t id;
30099  ae_int_t i;
30100  ae_int_t j;
30101  ae_int_t k0;
30102  ae_int_t lt;
30103  ae_int_t rt;
30104 
30105 
30106  ae_assert(s->matrixtype==1, "SparseMV: incorrect matrix type (convert your matrix to CRS)", _state);
30107  ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseMV: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)", _state);
30108  ae_assert(a->rows>=s->n, "SparseMV: Rows(A)<N", _state);
30109  ae_assert(k>0, "SparseMV: K<=0", _state);
30110  rmatrixsetlengthatleast(b, s->m, k, _state);
30111  if( k<sparse_linalgswitch )
30112  {
30113  for(i=0; i<=s->m-1; i++)
30114  {
30115  for(j=0; j<=k-1; j++)
30116  {
30117  tval = 0;
30118  lt = s->ridx.ptr.p_int[i];
30119  rt = s->ridx.ptr.p_int[i+1];
30120  for(k0=lt; k0<=rt-1; k0++)
30121  {
30122  tval = tval+s->vals.ptr.p_double[k0]*a->ptr.pp_double[s->idx.ptr.p_int[k0]][j];
30123  }
30124  b->ptr.pp_double[i][j] = tval;
30125  }
30126  }
30127  }
30128  else
30129  {
30130  for(i=0; i<=s->m-1; i++)
30131  {
30132  for(j=0; j<=k-1; j++)
30133  {
30134  b->ptr.pp_double[i][j] = 0;
30135  }
30136  }
30137  for(i=0; i<=s->m-1; i++)
30138  {
30139  lt = s->ridx.ptr.p_int[i];
30140  rt = s->ridx.ptr.p_int[i+1];
30141  for(j=lt; j<=rt-1; j++)
30142  {
30143  id = s->idx.ptr.p_int[j];
30144  v = s->vals.ptr.p_double[j];
30145  ae_v_addd(&b->ptr.pp_double[i][0], 1, &a->ptr.pp_double[id][0], 1, ae_v_len(0,k-1), v);
30146  }
30147  }
30148  }
30149 }
30150 
30151 
30152 /*************************************************************************
30153 This function calculates matrix-matrix product S^T*A. Matrix S must be
30154 stored in CRS format (exception will be thrown otherwise).
30155 
30156 INPUT PARAMETERS
30157  S - sparse M*N matrix in CRS format (you MUST convert it
30158  to CRS before calling this function).
30159  A - array[M][K], input dense matrix. For performance reasons
30160  we make only quick checks - we check that array size is
30161  at least M, but we do not check for NAN's or INF's.
30162  K - number of columns of matrix (A).
30163  B - output buffer, possibly preallocated. In case buffer
30164  size is too small to store result, this buffer is
30165  automatically resized.
30166 
30167 OUTPUT PARAMETERS
30168  B - array[N][K], S^T*A
30169 
30170 NOTE: this function throws exception when called for non-CRS matrix. You
30171 must convert your matrix with SparseConvertToCRS() before using this
30172 function.
30173 
30174  -- ALGLIB PROJECT --
30175  Copyright 14.10.2011 by Bochkanov Sergey
30176 *************************************************************************/
30177 void sparsemtm(sparsematrix* s,
30178  /* Real */ ae_matrix* a,
30179  ae_int_t k,
30180  /* Real */ ae_matrix* b,
30181  ae_state *_state)
30182 {
30183  ae_int_t i;
30184  ae_int_t j;
30185  ae_int_t k0;
30186  ae_int_t lt;
30187  ae_int_t rt;
30188  ae_int_t ct;
30189  double v;
30190 
30191 
30192  ae_assert(s->matrixtype==1, "SparseMTM: incorrect matrix type (convert your matrix to CRS)", _state);
30193  ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseMTM: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)", _state);
30194  ae_assert(a->rows>=s->m, "SparseMTM: Rows(A)<M", _state);
30195  ae_assert(k>0, "SparseMTM: K<=0", _state);
30196  rmatrixsetlengthatleast(b, s->n, k, _state);
30197  for(i=0; i<=s->n-1; i++)
30198  {
30199  for(j=0; j<=k-1; j++)
30200  {
30201  b->ptr.pp_double[i][j] = 0;
30202  }
30203  }
30204  if( k<sparse_linalgswitch )
30205  {
30206  for(i=0; i<=s->m-1; i++)
30207  {
30208  lt = s->ridx.ptr.p_int[i];
30209  rt = s->ridx.ptr.p_int[i+1];
30210  for(k0=lt; k0<=rt-1; k0++)
30211  {
30212  v = s->vals.ptr.p_double[k0];
30213  ct = s->idx.ptr.p_int[k0];
30214  for(j=0; j<=k-1; j++)
30215  {
30216  b->ptr.pp_double[ct][j] = b->ptr.pp_double[ct][j]+v*a->ptr.pp_double[i][j];
30217  }
30218  }
30219  }
30220  }
30221  else
30222  {
30223  for(i=0; i<=s->m-1; i++)
30224  {
30225  lt = s->ridx.ptr.p_int[i];
30226  rt = s->ridx.ptr.p_int[i+1];
30227  for(j=lt; j<=rt-1; j++)
30228  {
30229  v = s->vals.ptr.p_double[j];
30230  ct = s->idx.ptr.p_int[j];
30231  ae_v_addd(&b->ptr.pp_double[ct][0], 1, &a->ptr.pp_double[i][0], 1, ae_v_len(0,k-1), v);
30232  }
30233  }
30234  }
30235 }
30236 
30237 
30238 /*************************************************************************
30239 This function simultaneously calculates two matrix-matrix products:
30240  S*A and S^T*A.
30241 S must be square (non-rectangular) matrix stored in CRS format (exception
30242 will be thrown otherwise).
30243 
30244 INPUT PARAMETERS
30245  S - sparse N*N matrix in CRS format (you MUST convert it
30246  to CRS before calling this function).
30247  A - array[N][K], input dense matrix. For performance reasons
30248  we make only quick checks - we check that array size is
30249  at least N, but we do not check for NAN's or INF's.
30250  K - number of columns of matrix (A).
30251  B0 - output buffer, possibly preallocated. In case buffer
30252  size is too small to store result, this buffer is
30253  automatically resized.
30254  B1 - output buffer, possibly preallocated. In case buffer
30255  size is too small to store result, this buffer is
30256  automatically resized.
30257 
30258 OUTPUT PARAMETERS
30259  B0 - array[N][K], S*A
30260  B1 - array[N][K], S^T*A
30261 
30262 NOTE: this function throws exception when called for non-CRS matrix. You
30263 must convert your matrix with SparseConvertToCRS() before using this
30264 function. It also throws exception when S is non-square.
30265 
30266  -- ALGLIB PROJECT --
30267  Copyright 14.10.2011 by Bochkanov Sergey
30268 *************************************************************************/
30269 void sparsemm2(sparsematrix* s,
30270  /* Real */ ae_matrix* a,
30271  ae_int_t k,
30272  /* Real */ ae_matrix* b0,
30273  /* Real */ ae_matrix* b1,
30274  ae_state *_state)
30275 {
30276  ae_int_t i;
30277  ae_int_t j;
30278  ae_int_t k0;
30279  ae_int_t lt;
30280  ae_int_t rt;
30281  ae_int_t ct;
30282  double v;
30283  double tval;
30284 
30285 
30286  ae_assert(s->matrixtype==1, "SparseMM2: incorrect matrix type (convert your matrix to CRS)", _state);
30287  ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseMM2: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)", _state);
30288  ae_assert(s->m==s->n, "SparseMM2: matrix is non-square", _state);
30289  ae_assert(a->rows>=s->n, "SparseMM2: Rows(A)<N", _state);
30290  ae_assert(k>0, "SparseMM2: K<=0", _state);
30291  rmatrixsetlengthatleast(b0, s->m, k, _state);
30292  rmatrixsetlengthatleast(b1, s->n, k, _state);
30293  for(i=0; i<=s->n-1; i++)
30294  {
30295  for(j=0; j<=k-1; j++)
30296  {
30297  b1->ptr.pp_double[i][j] = 0;
30298  }
30299  }
30300  if( k<sparse_linalgswitch )
30301  {
30302  for(i=0; i<=s->m-1; i++)
30303  {
30304  for(j=0; j<=k-1; j++)
30305  {
30306  tval = 0;
30307  lt = s->ridx.ptr.p_int[i];
30308  rt = s->ridx.ptr.p_int[i+1];
30309  v = a->ptr.pp_double[i][j];
30310  for(k0=lt; k0<=rt-1; k0++)
30311  {
30312  ct = s->idx.ptr.p_int[k0];
30313  b1->ptr.pp_double[ct][j] = b1->ptr.pp_double[ct][j]+s->vals.ptr.p_double[k0]*v;
30314  tval = tval+s->vals.ptr.p_double[k0]*a->ptr.pp_double[ct][j];
30315  }
30316  b0->ptr.pp_double[i][j] = tval;
30317  }
30318  }
30319  }
30320  else
30321  {
30322  for(i=0; i<=s->m-1; i++)
30323  {
30324  for(j=0; j<=k-1; j++)
30325  {
30326  b0->ptr.pp_double[i][j] = 0;
30327  }
30328  }
30329  for(i=0; i<=s->m-1; i++)
30330  {
30331  lt = s->ridx.ptr.p_int[i];
30332  rt = s->ridx.ptr.p_int[i+1];
30333  for(j=lt; j<=rt-1; j++)
30334  {
30335  v = s->vals.ptr.p_double[j];
30336  ct = s->idx.ptr.p_int[j];
30337  ae_v_addd(&b0->ptr.pp_double[i][0], 1, &a->ptr.pp_double[ct][0], 1, ae_v_len(0,k-1), v);
30338  ae_v_addd(&b1->ptr.pp_double[ct][0], 1, &a->ptr.pp_double[i][0], 1, ae_v_len(0,k-1), v);
30339  }
30340  }
30341  }
30342 }
30343 
30344 
30345 /*************************************************************************
30346 This function calculates matrix-matrix product S*A, when S is symmetric
30347 matrix. Matrix S must be stored in CRS format (exception will be
30348 thrown otherwise).
30349 
30350 INPUT PARAMETERS
30351  S - sparse M*M matrix in CRS format (you MUST convert it
30352  to CRS before calling this function).
30353  IsUpper - whether upper or lower triangle of S is given:
30354  * if upper triangle is given, only S[i,j] for j>=i
30355  are used, and lower triangle is ignored (it can be
30356  empty - these elements are not referenced at all).
30357  * if lower triangle is given, only S[i,j] for j<=i
30358  are used, and upper triangle is ignored.
30359  A - array[N][K], input dense matrix. For performance reasons
30360  we make only quick checks - we check that array size is
30361  at least N, but we do not check for NAN's or INF's.
30362  K - number of columns of matrix (A).
30363  B - output buffer, possibly preallocated. In case buffer
30364  size is too small to store result, this buffer is
30365  automatically resized.
30366 
30367 OUTPUT PARAMETERS
30368  B - array[M][K], S*A
30369 
30370 NOTE: this function throws exception when called for non-CRS matrix. You
30371 must convert your matrix with SparseConvertToCRS() before using this
30372 function.
30373 
30374  -- ALGLIB PROJECT --
30375  Copyright 14.10.2011 by Bochkanov Sergey
30376 *************************************************************************/
30377 void sparsesmm(sparsematrix* s,
30378  ae_bool isupper,
30379  /* Real */ ae_matrix* a,
30380  ae_int_t k,
30381  /* Real */ ae_matrix* b,
30382  ae_state *_state)
30383 {
30384  ae_int_t i;
30385  ae_int_t j;
30386  ae_int_t k0;
30387  ae_int_t id;
30388  ae_int_t lt;
30389  ae_int_t rt;
30390  double v;
30391  double vb;
30392  double va;
30393 
30394 
30395  ae_assert(s->matrixtype==1, "SparseSMM: incorrect matrix type (convert your matrix to CRS)", _state);
30396  ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseSMM: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)", _state);
30397  ae_assert(a->rows>=s->n, "SparseSMM: Rows(X)<N", _state);
30398  ae_assert(s->m==s->n, "SparseSMM: matrix is non-square", _state);
30399  rmatrixsetlengthatleast(b, s->m, k, _state);
30400  for(i=0; i<=s->m-1; i++)
30401  {
30402  for(j=0; j<=k-1; j++)
30403  {
30404  b->ptr.pp_double[i][j] = 0;
30405  }
30406  }
30407  if( k>sparse_linalgswitch )
30408  {
30409  for(i=0; i<=s->m-1; i++)
30410  {
30411  for(j=0; j<=k-1; j++)
30412  {
30413  if( s->didx.ptr.p_int[i]!=s->uidx.ptr.p_int[i] )
30414  {
30415  id = s->didx.ptr.p_int[i];
30416  b->ptr.pp_double[i][j] = b->ptr.pp_double[i][j]+s->vals.ptr.p_double[id]*a->ptr.pp_double[s->idx.ptr.p_int[id]][j];
30417  }
30418  if( isupper )
30419  {
30420  lt = s->uidx.ptr.p_int[i];
30421  rt = s->ridx.ptr.p_int[i+1];
30422  vb = 0;
30423  va = a->ptr.pp_double[i][j];
30424  for(k0=lt; k0<=rt-1; k0++)
30425  {
30426  id = s->idx.ptr.p_int[k0];
30427  v = s->vals.ptr.p_double[k0];
30428  vb = vb+a->ptr.pp_double[id][j]*v;
30429  b->ptr.pp_double[id][j] = b->ptr.pp_double[id][j]+va*v;
30430  }
30431  b->ptr.pp_double[i][j] = b->ptr.pp_double[i][j]+vb;
30432  }
30433  else
30434  {
30435  lt = s->ridx.ptr.p_int[i];
30436  rt = s->didx.ptr.p_int[i];
30437  vb = 0;
30438  va = a->ptr.pp_double[i][j];
30439  for(k0=lt; k0<=rt-1; k0++)
30440  {
30441  id = s->idx.ptr.p_int[k0];
30442  v = s->vals.ptr.p_double[k0];
30443  vb = vb+a->ptr.pp_double[id][j]*v;
30444  b->ptr.pp_double[id][j] = b->ptr.pp_double[id][j]+va*v;
30445  }
30446  b->ptr.pp_double[i][j] = b->ptr.pp_double[i][j]+vb;
30447  }
30448  }
30449  }
30450  }
30451  else
30452  {
30453  for(i=0; i<=s->m-1; i++)
30454  {
30455  if( s->didx.ptr.p_int[i]!=s->uidx.ptr.p_int[i] )
30456  {
30457  id = s->didx.ptr.p_int[i];
30458  v = s->vals.ptr.p_double[id];
30459  ae_v_addd(&b->ptr.pp_double[i][0], 1, &a->ptr.pp_double[s->idx.ptr.p_int[id]][0], 1, ae_v_len(0,k-1), v);
30460  }
30461  if( isupper )
30462  {
30463  lt = s->uidx.ptr.p_int[i];
30464  rt = s->ridx.ptr.p_int[i+1];
30465  for(j=lt; j<=rt-1; j++)
30466  {
30467  id = s->idx.ptr.p_int[j];
30468  v = s->vals.ptr.p_double[j];
30469  ae_v_addd(&b->ptr.pp_double[i][0], 1, &a->ptr.pp_double[id][0], 1, ae_v_len(0,k-1), v);
30470  ae_v_addd(&b->ptr.pp_double[id][0], 1, &a->ptr.pp_double[i][0], 1, ae_v_len(0,k-1), v);
30471  }
30472  }
30473  else
30474  {
30475  lt = s->ridx.ptr.p_int[i];
30476  rt = s->didx.ptr.p_int[i];
30477  for(j=lt; j<=rt-1; j++)
30478  {
30479  id = s->idx.ptr.p_int[j];
30480  v = s->vals.ptr.p_double[j];
30481  ae_v_addd(&b->ptr.pp_double[i][0], 1, &a->ptr.pp_double[id][0], 1, ae_v_len(0,k-1), v);
30482  ae_v_addd(&b->ptr.pp_double[id][0], 1, &a->ptr.pp_double[i][0], 1, ae_v_len(0,k-1), v);
30483  }
30484  }
30485  }
30486  }
30487 }
30488 
30489 
30490 /*************************************************************************
30491 This procedure resizes Hash-Table matrix. It can be called when you have
30492 deleted too many elements from the matrix, and you want to free unneeded
30493 memory.
30494 
30495  -- ALGLIB PROJECT --
30496  Copyright 14.10.2011 by Bochkanov Sergey
30497 *************************************************************************/
30498 void sparseresizematrix(sparsematrix* s, ae_state *_state)
30499 {
30500  ae_frame _frame_block;
30501  ae_int_t k;
30502  ae_int_t k1;
30503  ae_int_t i;
30504  ae_vector tvals;
30505  ae_vector tidx;
30506 
30507  ae_frame_make(_state, &_frame_block);
30508  ae_vector_init(&tvals, 0, DT_REAL, _state, ae_true);
30509  ae_vector_init(&tidx, 0, DT_INT, _state, ae_true);
30510 
30511  ae_assert(s->matrixtype==0, "SparseResizeMatrix: incorrect matrix type", _state);
30512 
30513  /*
30514  * Initialization for length and number of non-null elementd
30515  */
30516  k = s->vals.cnt;
30517  k1 = 0;
30518 
30519  /*
30520  * Calculating number of non-null elements
30521  */
30522  for(i=0; i<=k-1; i++)
30523  {
30524  if( s->idx.ptr.p_int[2*i]>=0 )
30525  {
30526  k1 = k1+1;
30527  }
30528  }
30529 
30530  /*
30531  * Initialization value for free space
30532  */
30533  s->nfree = ae_round(k1/sparse_desiredloadfactor*sparse_growfactor+sparse_additional, _state)-k1;
30534  ae_vector_set_length(&tvals, s->nfree+k1, _state);
30535  ae_vector_set_length(&tidx, 2*(s->nfree+k1), _state);
30536  ae_swap_vectors(&s->vals, &tvals);
30537  ae_swap_vectors(&s->idx, &tidx);
30538  for(i=0; i<=s->nfree+k1-1; i++)
30539  {
30540  s->idx.ptr.p_int[2*i] = -1;
30541  }
30542  for(i=0; i<=k-1; i++)
30543  {
30544  if( tidx.ptr.p_int[2*i]>=0 )
30545  {
30546  sparseset(s, tidx.ptr.p_int[2*i], tidx.ptr.p_int[2*i+1], tvals.ptr.p_double[i], _state);
30547  }
30548  }
30549  ae_frame_leave(_state);
30550 }
30551 
30552 
30553 /*************************************************************************
30554 This function return average length of chain at hash-table.
30555 
30556  -- ALGLIB PROJECT --
30557  Copyright 14.10.2011 by Bochkanov Sergey
30558 *************************************************************************/
30559 double sparsegetaveragelengthofchain(sparsematrix* s, ae_state *_state)
30560 {
30561  ae_int_t nchains;
30562  ae_int_t talc;
30563  ae_int_t l;
30564  ae_int_t i;
30565  ae_int_t ind0;
30566  ae_int_t ind1;
30567  ae_int_t hashcode;
30568  double result;
30569 
30570 
30571 
30572  /*
30573  * If matrix represent in CRS then return zero and exit
30574  */
30575  if( s->matrixtype==1 )
30576  {
30577  result = 0;
30578  return result;
30579  }
30580  nchains = 0;
30581  talc = 0;
30582  l = s->vals.cnt;
30583  for(i=0; i<=l-1; i++)
30584  {
30585  ind0 = 2*i;
30586  if( s->idx.ptr.p_int[ind0]!=-1 )
30587  {
30588  nchains = nchains+1;
30589  hashcode = sparse_hash(s->idx.ptr.p_int[ind0], s->idx.ptr.p_int[ind0+1], l, _state);
30590  for(;;)
30591  {
30592  talc = talc+1;
30593  ind1 = 2*hashcode;
30594  if( s->idx.ptr.p_int[ind0]==s->idx.ptr.p_int[ind1]&&s->idx.ptr.p_int[ind0+1]==s->idx.ptr.p_int[ind1+1] )
30595  {
30596  break;
30597  }
30598  hashcode = (hashcode+1)%l;
30599  }
30600  }
30601  }
30602  if( nchains==0 )
30603  {
30604  result = 0;
30605  }
30606  else
30607  {
30608  result = (double)talc/(double)nchains;
30609  }
30610  return result;
30611 }
30612 
30613 
30614 /*************************************************************************
30615 This function is used to enumerate all elements of the sparse matrix.
30616 Before first call user initializes T0 and T1 counters by zero. These
30617 counters are used to remember current position in a matrix; after each
30618 call they are updated by the function.
30619 
30620 Subsequent calls to this function return non-zero elements of the sparse
30621 matrix, one by one. If you enumerate CRS matrix, matrix is traversed from
30622 left to right, from top to bottom. In case you enumerate matrix stored as
30623 Hash table, elements are returned in random order.
30624 
30625 EXAMPLE
30626  > T0=0
30627  > T1=0
30628  > while SparseEnumerate(S,T0,T1,I,J,V) do
30629  > ....do something with I,J,V
30630 
30631 INPUT PARAMETERS
30632  S - sparse M*N matrix in Hash-Table or CRS representation.
30633  T0 - internal counter
30634  T1 - internal counter
30635 
30636 OUTPUT PARAMETERS
30637  T0 - new value of the internal counter
30638  T1 - new value of the internal counter
30639  I - row index of non-zero element, 0<=I<M.
30640  J - column index of non-zero element, 0<=J<N
30641  V - value of the T-th element
30642 
30643 RESULT
30644  True in case of success (next non-zero element was retrieved)
30645  False in case all non-zero elements were enumerated
30646 
30647  -- ALGLIB PROJECT --
30648  Copyright 14.03.2012 by Bochkanov Sergey
30649 *************************************************************************/
30650 ae_bool sparseenumerate(sparsematrix* s,
30651  ae_int_t* t0,
30652  ae_int_t* t1,
30653  ae_int_t* i,
30654  ae_int_t* j,
30655  double* v,
30656  ae_state *_state)
30657 {
30658  ae_int_t sz;
30659  ae_int_t i0;
30660  ae_bool result;
30661 
30662  *i = 0;
30663  *j = 0;
30664  *v = 0;
30665 
30666  if( *t0<0||(s->matrixtype==1&&*t1<0) )
30667  {
30668  result = ae_false;
30669  return result;
30670  }
30671 
30672  /*
30673  * Hash-table matrix
30674  */
30675  if( s->matrixtype==0 )
30676  {
30677  sz = s->vals.cnt;
30678  for(i0=*t0; i0<=sz-1; i0++)
30679  {
30680  if( s->idx.ptr.p_int[2*i0]==-1||s->idx.ptr.p_int[2*i0]==-2 )
30681  {
30682  continue;
30683  }
30684  else
30685  {
30686  *i = s->idx.ptr.p_int[2*i0];
30687  *j = s->idx.ptr.p_int[2*i0+1];
30688  *v = s->vals.ptr.p_double[i0];
30689  *t0 = i0+1;
30690  result = ae_true;
30691  return result;
30692  }
30693  }
30694  *t0 = 0;
30695  result = ae_false;
30696  return result;
30697  }
30698 
30699  /*
30700  * CRS matrix
30701  */
30702  if( s->matrixtype==1&&*t0<s->ninitialized )
30703  {
30704  ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseEnumerate: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)", _state);
30705  while(*t0>s->ridx.ptr.p_int[*t1+1]-1&&*t1<s->m)
30706  {
30707  *t1 = *t1+1;
30708  }
30709  *i = *t1;
30710  *j = s->idx.ptr.p_int[*t0];
30711  *v = s->vals.ptr.p_double[*t0];
30712  *t0 = *t0+1;
30713  result = ae_true;
30714  return result;
30715  }
30716  *t0 = 0;
30717  *t1 = 0;
30718  result = ae_false;
30719  return result;
30720 }
30721 
30722 
30723 /*************************************************************************
30724 This function rewrites existing (non-zero) element. It returns True if
30725 element exists or False, when it is called for non-existing (zero)
30726 element.
30727 
30728 The purpose of this function is to provide convenient thread-safe way to
30729 modify sparse matrix. Such modification (already existing element is
30730 rewritten) is guaranteed to be thread-safe without any synchronization, as
30731 long as different threads modify different elements.
30732 
30733 INPUT PARAMETERS
30734  S - sparse M*N matrix in Hash-Table or CRS representation.
30735  I - row index of non-zero element to modify, 0<=I<M
30736  J - column index of non-zero element to modify, 0<=J<N
30737  V - value to rewrite, must be finite number
30738 
30739 OUTPUT PARAMETERS
30740  S - modified matrix
30741 RESULT
30742  True in case when element exists
30743  False in case when element doesn't exist or it is zero
30744 
30745  -- ALGLIB PROJECT --
30746  Copyright 14.03.2012 by Bochkanov Sergey
30747 *************************************************************************/
30748 ae_bool sparserewriteexisting(sparsematrix* s,
30749  ae_int_t i,
30750  ae_int_t j,
30751  double v,
30752  ae_state *_state)
30753 {
30754  ae_int_t hashcode;
30755  ae_int_t k;
30756  ae_int_t k0;
30757  ae_int_t k1;
30758  ae_bool result;
30759 
30760 
30761  ae_assert(0<=i&&i<s->m, "SparseRewriteExisting: invalid argument I(either I<0 or I>=S.M)", _state);
30762  ae_assert(0<=j&&j<s->n, "SparseRewriteExisting: invalid argument J(either J<0 or J>=S.N)", _state);
30763  ae_assert(ae_isfinite(v, _state), "SparseRewriteExisting: invalid argument V(either V is infinite or V is NaN)", _state);
30764  result = ae_false;
30765 
30766  /*
30767  * Hash-table matrix
30768  */
30769  if( s->matrixtype==0 )
30770  {
30771  k = s->vals.cnt;
30772  hashcode = sparse_hash(i, j, k, _state);
30773  for(;;)
30774  {
30775  if( s->idx.ptr.p_int[2*hashcode]==-1 )
30776  {
30777  return result;
30778  }
30779  if( s->idx.ptr.p_int[2*hashcode]==i&&s->idx.ptr.p_int[2*hashcode+1]==j )
30780  {
30781  s->vals.ptr.p_double[hashcode] = v;
30782  result = ae_true;
30783  return result;
30784  }
30785  hashcode = (hashcode+1)%k;
30786  }
30787  }
30788 
30789  /*
30790  * CRS matrix
30791  */
30792  if( s->matrixtype==1 )
30793  {
30794  ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseRewriteExisting: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)", _state);
30795  k0 = s->ridx.ptr.p_int[i];
30796  k1 = s->ridx.ptr.p_int[i+1]-1;
30797  while(k0<=k1)
30798  {
30799  k = (k0+k1)/2;
30800  if( s->idx.ptr.p_int[k]==j )
30801  {
30802  s->vals.ptr.p_double[k] = v;
30803  result = ae_true;
30804  return result;
30805  }
30806  if( s->idx.ptr.p_int[k]<j )
30807  {
30808  k0 = k+1;
30809  }
30810  else
30811  {
30812  k1 = k-1;
30813  }
30814  }
30815  }
30816  return result;
30817 }
30818 
30819 
30820 /*************************************************************************
30821 This function returns I-th row of the sparse matrix stored in CRS format.
30822 
30823 NOTE: when incorrect I (outside of [0,M-1]) or matrix (non-CRS) are
30824  passed, this function throws exception.
30825 
30826 INPUT PARAMETERS:
30827  S - sparse M*N matrix in CRS format
30828  I - row index, 0<=I<M
30829  IRow - output buffer, can be preallocated. In case buffer
30830  size is too small to store I-th row, it is
30831  automatically reallocated.
30832 
30833 OUTPUT PARAMETERS:
30834  IRow - array[M], I-th row.
30835 
30836 
30837  -- ALGLIB PROJECT --
30838  Copyright 20.07.2012 by Bochkanov Sergey
30839 *************************************************************************/
30840 void sparsegetrow(sparsematrix* s,
30841  ae_int_t i,
30842  /* Real */ ae_vector* irow,
30843  ae_state *_state)
30844 {
30845  ae_int_t i0;
30846 
30847 
30848  ae_assert(s->matrixtype==1, "SparseGetRow: S must be CRS-based matrix", _state);
30849  ae_assert(i>=0&&i<s->m, "SparseGetRow: I<0 or I>=M", _state);
30850  rvectorsetlengthatleast(irow, s->n, _state);
30851  for(i0=0; i0<=s->n-1; i0++)
30852  {
30853  irow->ptr.p_double[i0] = 0;
30854  }
30855  for(i0=s->ridx.ptr.p_int[i]; i0<=s->ridx.ptr.p_int[i+1]-1; i0++)
30856  {
30857  irow->ptr.p_double[s->idx.ptr.p_int[i0]] = s->vals.ptr.p_double[i0];
30858  }
30859 }
30860 
30861 
30862 /*************************************************************************
30863 This function performs in-place conversion from CRS format to Hash table
30864 storage.
30865 
30866 INPUT PARAMETERS
30867  S - sparse matrix in CRS format.
30868 
30869 OUTPUT PARAMETERS
30870  S - sparse matrix in Hash table format.
30871 
30872 NOTE: this function has no effect when called with matrix which is
30873 already in Hash table mode.
30874 
30875  -- ALGLIB PROJECT --
30876  Copyright 20.07.2012 by Bochkanov Sergey
30877 *************************************************************************/
30878 void sparseconverttohash(sparsematrix* s, ae_state *_state)
30879 {
30880  ae_frame _frame_block;
30881  ae_vector tidx;
30882  ae_vector tridx;
30883  ae_vector tvals;
30884  ae_int_t tn;
30885  ae_int_t tm;
30886  ae_int_t i;
30887  ae_int_t j;
30888 
30889  ae_frame_make(_state, &_frame_block);
30890  ae_vector_init(&tidx, 0, DT_INT, _state, ae_true);
30891  ae_vector_init(&tridx, 0, DT_INT, _state, ae_true);
30892  ae_vector_init(&tvals, 0, DT_REAL, _state, ae_true);
30893 
30894  ae_assert(s->matrixtype==0||s->matrixtype==1, "SparseConvertToHash: invalid matrix type", _state);
30895  if( s->matrixtype==0 )
30896  {
30897  ae_frame_leave(_state);
30898  return;
30899  }
30900  s->matrixtype = 0;
30901  tm = s->m;
30902  tn = s->n;
30903  ae_swap_vectors(&s->idx, &tidx);
30904  ae_swap_vectors(&s->ridx, &tridx);
30905  ae_swap_vectors(&s->vals, &tvals);
30906 
30907  /*
30908  * Delete RIdx
30909  */
30910  ae_vector_set_length(&s->ridx, 0, _state);
30911  sparsecreate(tm, tn, tridx.ptr.p_int[tm], s, _state);
30912 
30913  /*
30914  * Fill the matrix
30915  */
30916  for(i=0; i<=tm-1; i++)
30917  {
30918  for(j=tridx.ptr.p_int[i]; j<=tridx.ptr.p_int[i+1]-1; j++)
30919  {
30920  sparseset(s, i, tidx.ptr.p_int[j], tvals.ptr.p_double[j], _state);
30921  }
30922  }
30923  ae_frame_leave(_state);
30924 }
30925 
30926 
30927 /*************************************************************************
30928 This function performs out-of-place conversion to Hash table storage
30929 format. S0 is copied to S1 and converted on-the-fly.
30930 
30931 INPUT PARAMETERS
30932  S0 - sparse matrix in any format.
30933 
30934 OUTPUT PARAMETERS
30935  S1 - sparse matrix in Hash table format.
30936 
30937 NOTE: if S0 is stored as Hash-table, it is just copied without conversion.
30938 
30939  -- ALGLIB PROJECT --
30940  Copyright 20.07.2012 by Bochkanov Sergey
30941 *************************************************************************/
30942 void sparsecopytohash(sparsematrix* s0,
30943  sparsematrix* s1,
30944  ae_state *_state)
30945 {
30946  double val;
30947  ae_int_t t0;
30948  ae_int_t t1;
30949  ae_int_t i;
30950  ae_int_t j;
30951 
30952  _sparsematrix_clear(s1);
30953 
30954  ae_assert(s0->matrixtype==0||s0->matrixtype==1, "SparseCopyToHash: invalid matrix type", _state);
30955  if( s0->matrixtype==0 )
30956  {
30957  sparsecopy(s0, s1, _state);
30958  }
30959  else
30960  {
30961  t0 = 0;
30962  t1 = 0;
30963  sparsecreate(s0->m, s0->n, s0->ridx.ptr.p_int[s0->m], s1, _state);
30964  while(sparseenumerate(s0, &t0, &t1, &i, &j, &val, _state))
30965  {
30966  sparseset(s1, i, j, val, _state);
30967  }
30968  }
30969 }
30970 
30971 
30972 /*************************************************************************
30973 This function performs out-of-place conversion to CRS format. S0 is
30974 copied to S1 and converted on-the-fly.
30975 
30976 INPUT PARAMETERS
30977  S0 - sparse matrix in any format.
30978 
30979 OUTPUT PARAMETERS
30980  S1 - sparse matrix in CRS format.
30981 
30982 NOTE: if S0 is stored as CRS, it is just copied without conversion.
30983 
30984  -- ALGLIB PROJECT --
30985  Copyright 20.07.2012 by Bochkanov Sergey
30986 *************************************************************************/
30987 void sparsecopytocrs(sparsematrix* s0, sparsematrix* s1, ae_state *_state)
30988 {
30989  ae_frame _frame_block;
30990  ae_vector temp;
30991  ae_int_t nonne;
30992  ae_int_t i;
30993  ae_int_t k;
30994 
30995  ae_frame_make(_state, &_frame_block);
30996  _sparsematrix_clear(s1);
30997  ae_vector_init(&temp, 0, DT_INT, _state, ae_true);
30998 
30999  ae_assert(s0->matrixtype==0||s0->matrixtype==1, "SparseCopyToCRS: invalid matrix type", _state);
31000  if( s0->matrixtype==1 )
31001  {
31002  sparsecopy(s0, s1, _state);
31003  }
31004  else
31005  {
31006 
31007  /*
31008  * Done like ConvertToCRS function
31009  */
31010  s1->matrixtype = 1;
31011  s1->m = s0->m;
31012  s1->n = s0->n;
31013  s1->nfree = s0->nfree;
31014  nonne = 0;
31015  k = s0->vals.cnt;
31016  ae_vector_set_length(&s1->ridx, s1->m+1, _state);
31017  for(i=0; i<=s1->m; i++)
31018  {
31019  s1->ridx.ptr.p_int[i] = 0;
31020  }
31021  ae_vector_set_length(&temp, s1->m, _state);
31022  for(i=0; i<=s1->m-1; i++)
31023  {
31024  temp.ptr.p_int[i] = 0;
31025  }
31026 
31027  /*
31028  * Number of elements per row
31029  */
31030  for(i=0; i<=k-1; i++)
31031  {
31032  if( s0->idx.ptr.p_int[2*i]>=0 )
31033  {
31034  s1->ridx.ptr.p_int[s0->idx.ptr.p_int[2*i]+1] = s1->ridx.ptr.p_int[s0->idx.ptr.p_int[2*i]+1]+1;
31035  nonne = nonne+1;
31036  }
31037  }
31038 
31039  /*
31040  * Fill RIdx (offsets of rows)
31041  */
31042  for(i=0; i<=s1->m-1; i++)
31043  {
31044  s1->ridx.ptr.p_int[i+1] = s1->ridx.ptr.p_int[i+1]+s1->ridx.ptr.p_int[i];
31045  }
31046 
31047  /*
31048  * Allocate memory
31049  */
31050  ae_vector_set_length(&s1->vals, nonne, _state);
31051  ae_vector_set_length(&s1->idx, nonne, _state);
31052  for(i=0; i<=k-1; i++)
31053  {
31054  if( s0->idx.ptr.p_int[2*i]>=0 )
31055  {
31056  s1->vals.ptr.p_double[s1->ridx.ptr.p_int[s0->idx.ptr.p_int[2*i]]+temp.ptr.p_int[s0->idx.ptr.p_int[2*i]]] = s0->vals.ptr.p_double[i];
31057  s1->idx.ptr.p_int[s1->ridx.ptr.p_int[s0->idx.ptr.p_int[2*i]]+temp.ptr.p_int[s0->idx.ptr.p_int[2*i]]] = s0->idx.ptr.p_int[2*i+1];
31058  temp.ptr.p_int[s0->idx.ptr.p_int[2*i]] = temp.ptr.p_int[s0->idx.ptr.p_int[2*i]]+1;
31059  }
31060  }
31061 
31062  /*
31063  * Set NInitialized
31064  */
31065  s1->ninitialized = s1->ridx.ptr.p_int[s1->m];
31066 
31067  /*
31068  * Sorting of elements
31069  */
31070  for(i=0; i<=s1->m-1; i++)
31071  {
31072  tagsortmiddleir(&s1->idx, &s1->vals, s1->ridx.ptr.p_int[i], s1->ridx.ptr.p_int[i+1]-s1->ridx.ptr.p_int[i], _state);
31073  }
31074 
31075  /*
31076  * Initialization 'S.UIdx' and 'S.DIdx'
31077  */
31078  sparse_sparseinitduidx(s1, _state);
31079  }
31080  ae_frame_leave(_state);
31081 }
31082 
31083 
31084 /*************************************************************************
31085 This function returns type of the matrix storage format.
31086 
31087 INPUT PARAMETERS:
31088  S - sparse matrix.
31089 
31090 RESULT:
31091  sparse storage format used by matrix:
31092  0 - Hash-table
31093  1 - CRS-format
31094 
31095 NOTE: future versions of ALGLIB may include additional sparse storage
31096  formats.
31097 
31098 
31099  -- ALGLIB PROJECT --
31100  Copyright 20.07.2012 by Bochkanov Sergey
31101 *************************************************************************/
31102 ae_int_t sparsegetmatrixtype(sparsematrix* s, ae_state *_state)
31103 {
31104  ae_int_t result;
31105 
31106 
31107  ae_assert(s->matrixtype==0||s->matrixtype==1, "SparseGetMatrixType: invalid matrix type", _state);
31108  result = s->matrixtype;
31109  return result;
31110 }
31111 
31112 
31113 /*************************************************************************
31114 This function checks matrix storage format and returns True when matrix is
31115 stored using Hash table representation.
31116 
31117 INPUT PARAMETERS:
31118  S - sparse matrix.
31119 
31120 RESULT:
31121  True if matrix type is Hash table
31122  False if matrix type is not Hash table
31123 
31124  -- ALGLIB PROJECT --
31125  Copyright 20.07.2012 by Bochkanov Sergey
31126 *************************************************************************/
31127 ae_bool sparseishash(sparsematrix* s, ae_state *_state)
31128 {
31129  ae_bool result;
31130 
31131 
31132  ae_assert(s->matrixtype==0||s->matrixtype==1, "SparseIsHash: invalid matrix type", _state);
31133  result = s->matrixtype==0;
31134  return result;
31135 }
31136 
31137 
31138 /*************************************************************************
31139 This function checks matrix storage format and returns True when matrix is
31140 stored using CRS representation.
31141 
31142 INPUT PARAMETERS:
31143  S - sparse matrix.
31144 
31145 RESULT:
31146  True if matrix type is CRS
31147  False if matrix type is not CRS
31148 
31149  -- ALGLIB PROJECT --
31150  Copyright 20.07.2012 by Bochkanov Sergey
31151 *************************************************************************/
31152 ae_bool sparseiscrs(sparsematrix* s, ae_state *_state)
31153 {
31154  ae_bool result;
31155 
31156 
31157  ae_assert(s->matrixtype==0||s->matrixtype==1, "SparseIsCRS: invalid matrix type", _state);
31158  result = s->matrixtype==1;
31159  return result;
31160 }
31161 
31162 
31163 /*************************************************************************
31164 The function frees all memory occupied by sparse matrix. Sparse matrix
31165 structure becomes unusable after this call.
31166 
31167 OUTPUT PARAMETERS
31168  S - sparse matrix to delete
31169 
31170  -- ALGLIB PROJECT --
31171  Copyright 24.07.2012 by Bochkanov Sergey
31172 *************************************************************************/
31173 void sparsefree(sparsematrix* s, ae_state *_state)
31174 {
31175 
31176  _sparsematrix_clear(s);
31177 
31178  s->matrixtype = -1;
31179  s->m = 0;
31180  s->n = 0;
31181  s->nfree = 0;
31182  s->ninitialized = 0;
31183 }
31184 
31185 
31186 /*************************************************************************
31187 The function returns number of rows of a sparse matrix.
31188 
31189 RESULT: number of rows of a sparse matrix.
31190 
31191  -- ALGLIB PROJECT --
31192  Copyright 23.08.2012 by Bochkanov Sergey
31193 *************************************************************************/
31194 ae_int_t sparsegetnrows(sparsematrix* s, ae_state *_state)
31195 {
31196  ae_int_t result;
31197 
31198 
31199  result = s->m;
31200  return result;
31201 }
31202 
31203 
31204 /*************************************************************************
31205 The function returns number of columns of a sparse matrix.
31206 
31207 RESULT: number of columns of a sparse matrix.
31208 
31209  -- ALGLIB PROJECT --
31210  Copyright 23.08.2012 by Bochkanov Sergey
31211 *************************************************************************/
31212 ae_int_t sparsegetncols(sparsematrix* s, ae_state *_state)
31213 {
31214  ae_int_t result;
31215 
31216 
31217  result = s->n;
31218  return result;
31219 }
31220 
31221 
31222 /*************************************************************************
31223 Procedure for initialization 'S.DIdx' and 'S.UIdx'
31224 
31225 
31226  -- ALGLIB PROJECT --
31227  Copyright 14.10.2011 by Bochkanov Sergey
31228 *************************************************************************/
31229 static void sparse_sparseinitduidx(sparsematrix* s, ae_state *_state)
31230 {
31231  ae_int_t i;
31232  ae_int_t j;
31233  ae_int_t lt;
31234  ae_int_t rt;
31235 
31236 
31237  ae_vector_set_length(&s->didx, s->m, _state);
31238  ae_vector_set_length(&s->uidx, s->m, _state);
31239  for(i=0; i<=s->m-1; i++)
31240  {
31241  s->uidx.ptr.p_int[i] = -1;
31242  s->didx.ptr.p_int[i] = -1;
31243  lt = s->ridx.ptr.p_int[i];
31244  rt = s->ridx.ptr.p_int[i+1];
31245  for(j=lt; j<=rt-1; j++)
31246  {
31247  if( i<s->idx.ptr.p_int[j]&&s->uidx.ptr.p_int[i]==-1 )
31248  {
31249  s->uidx.ptr.p_int[i] = j;
31250  break;
31251  }
31252  else
31253  {
31254  if( i==s->idx.ptr.p_int[j] )
31255  {
31256  s->didx.ptr.p_int[i] = j;
31257  }
31258  }
31259  }
31260  if( s->uidx.ptr.p_int[i]==-1 )
31261  {
31262  s->uidx.ptr.p_int[i] = s->ridx.ptr.p_int[i+1];
31263  }
31264  if( s->didx.ptr.p_int[i]==-1 )
31265  {
31266  s->didx.ptr.p_int[i] = s->uidx.ptr.p_int[i];
31267  }
31268  }
31269 }
31270 
31271 
31272 /*************************************************************************
31273 This is hash function.
31274 
31275  -- ALGLIB PROJECT --
31276  Copyright 14.10.2011 by Bochkanov Sergey
31277 *************************************************************************/
31278 static ae_int_t sparse_hash(ae_int_t i,
31279  ae_int_t j,
31280  ae_int_t tabsize,
31281  ae_state *_state)
31282 {
31283  ae_frame _frame_block;
31284  hqrndstate r;
31285  ae_int_t result;
31286 
31287  ae_frame_make(_state, &_frame_block);
31288  _hqrndstate_init(&r, _state, ae_true);
31289 
31290  hqrndseed(i, j, &r, _state);
31291  result = hqrnduniformi(&r, tabsize, _state);
31292  ae_frame_leave(_state);
31293  return result;
31294 }
31295 
31296 
31297 ae_bool _sparsematrix_init(void* _p, ae_state *_state, ae_bool make_automatic)
31298 {
31299  sparsematrix *p = (sparsematrix*)_p;
31300  ae_touch_ptr((void*)p);
31301  if( !ae_vector_init(&p->vals, 0, DT_REAL, _state, make_automatic) )
31302  return ae_false;
31303  if( !ae_vector_init(&p->idx, 0, DT_INT, _state, make_automatic) )
31304  return ae_false;
31305  if( !ae_vector_init(&p->ridx, 0, DT_INT, _state, make_automatic) )
31306  return ae_false;
31307  if( !ae_vector_init(&p->didx, 0, DT_INT, _state, make_automatic) )
31308  return ae_false;
31309  if( !ae_vector_init(&p->uidx, 0, DT_INT, _state, make_automatic) )
31310  return ae_false;
31311  return ae_true;
31312 }
31313 
31314 
31315 ae_bool _sparsematrix_init_copy(void* _dst, void* _src, ae_state *_state, ae_bool make_automatic)
31316 {
31317  sparsematrix *dst = (sparsematrix*)_dst;
31318  sparsematrix *src = (sparsematrix*)_src;
31319  if( !ae_vector_init_copy(&dst->vals, &src->vals, _state, make_automatic) )
31320  return ae_false;
31321  if( !ae_vector_init_copy(&dst->idx, &src->idx, _state, make_automatic) )
31322  return ae_false;
31323  if( !ae_vector_init_copy(&dst->ridx, &src->ridx, _state, make_automatic) )
31324  return ae_false;
31325  if( !ae_vector_init_copy(&dst->didx, &src->didx, _state, make_automatic) )
31326  return ae_false;
31327  if( !ae_vector_init_copy(&dst->uidx, &src->uidx, _state, make_automatic) )
31328  return ae_false;
31329  dst->matrixtype = src->matrixtype;
31330  dst->m = src->m;
31331  dst->n = src->n;
31332  dst->nfree = src->nfree;
31333  dst->ninitialized = src->ninitialized;
31334  return ae_true;
31335 }
31336 
31337 
31338 void _sparsematrix_clear(void* _p)
31339 {
31340  sparsematrix *p = (sparsematrix*)_p;
31341  ae_touch_ptr((void*)p);
31342  ae_vector_clear(&p->vals);
31343  ae_vector_clear(&p->idx);
31344  ae_vector_clear(&p->ridx);
31345  ae_vector_clear(&p->didx);
31346  ae_vector_clear(&p->uidx);
31347 }
31348 
31349 
31350 void _sparsematrix_destroy(void* _p)
31351 {
31352  sparsematrix *p = (sparsematrix*)_p;
31353  ae_touch_ptr((void*)p);
31354  ae_vector_destroy(&p->vals);
31355  ae_vector_destroy(&p->idx);
31356  ae_vector_destroy(&p->ridx);
31357  ae_vector_destroy(&p->didx);
31358  ae_vector_destroy(&p->uidx);
31359 }
31360 
31361 
31362 
31363 
31364 /*************************************************************************
31365 Basic Cholesky solver for ScaleA*Cholesky(A)'*x = y.
31366 
31367 This subroutine assumes that:
31368 * A*ScaleA is well scaled
31369 * A is well-conditioned, so no zero divisions or overflow may occur
31370 
31371 INPUT PARAMETERS:
31372  CHA - Cholesky decomposition of A
31373  SqrtScaleA- square root of scale factor ScaleA
31374  N - matrix size, N>=0.
31375  IsUpper - storage type
31376  XB - right part
31377  Tmp - buffer; function automatically allocates it, if it is too
31378  small. It can be reused if function is called several
31379  times.
31380 
31381 OUTPUT PARAMETERS:
31382  XB - solution
31383 
31384 NOTE 1: no assertion or tests are done during algorithm operation
31385 NOTE 2: N=0 will force algorithm to silently return
31386 
31387  -- ALGLIB --
31388  Copyright 13.10.2010 by Bochkanov Sergey
31389 *************************************************************************/
31390 void fblscholeskysolve(/* Real */ ae_matrix* cha,
31391  double sqrtscalea,
31392  ae_int_t n,
31393  ae_bool isupper,
31394  /* Real */ ae_vector* xb,
31395  /* Real */ ae_vector* tmp,
31396  ae_state *_state)
31397 {
31398  ae_int_t i;
31399  double v;
31400 
31401 
31402  if( n==0 )
31403  {
31404  return;
31405  }
31406  if( tmp->cnt<n )
31407  {
31408  ae_vector_set_length(tmp, n, _state);
31409  }
31410 
31411  /*
31412  * A = L*L' or A=U'*U
31413  */
31414  if( isupper )
31415  {
31416 
31417  /*
31418  * Solve U'*y=b first.
31419  */
31420  for(i=0; i<=n-1; i++)
31421  {
31422  xb->ptr.p_double[i] = xb->ptr.p_double[i]/(sqrtscalea*cha->ptr.pp_double[i][i]);
31423  if( i<n-1 )
31424  {
31425  v = xb->ptr.p_double[i];
31426  ae_v_moved(&tmp->ptr.p_double[i+1], 1, &cha->ptr.pp_double[i][i+1], 1, ae_v_len(i+1,n-1), sqrtscalea);
31427  ae_v_subd(&xb->ptr.p_double[i+1], 1, &tmp->ptr.p_double[i+1], 1, ae_v_len(i+1,n-1), v);
31428  }
31429  }
31430 
31431  /*
31432  * Solve U*x=y then.
31433  */
31434  for(i=n-1; i>=0; i--)
31435  {
31436  if( i<n-1 )
31437  {
31438  ae_v_moved(&tmp->ptr.p_double[i+1], 1, &cha->ptr.pp_double[i][i+1], 1, ae_v_len(i+1,n-1), sqrtscalea);
31439  v = ae_v_dotproduct(&tmp->ptr.p_double[i+1], 1, &xb->ptr.p_double[i+1], 1, ae_v_len(i+1,n-1));
31440  xb->ptr.p_double[i] = xb->ptr.p_double[i]-v;
31441  }
31442  xb->ptr.p_double[i] = xb->ptr.p_double[i]/(sqrtscalea*cha->ptr.pp_double[i][i]);
31443  }
31444  }
31445  else
31446  {
31447 
31448  /*
31449  * Solve L*y=b first
31450  */
31451  for(i=0; i<=n-1; i++)
31452  {
31453  if( i>0 )
31454  {
31455  ae_v_moved(&tmp->ptr.p_double[0], 1, &cha->ptr.pp_double[i][0], 1, ae_v_len(0,i-1), sqrtscalea);
31456  v = ae_v_dotproduct(&tmp->ptr.p_double[0], 1, &xb->ptr.p_double[0], 1, ae_v_len(0,i-1));
31457  xb->ptr.p_double[i] = xb->ptr.p_double[i]-v;
31458  }
31459  xb->ptr.p_double[i] = xb->ptr.p_double[i]/(sqrtscalea*cha->ptr.pp_double[i][i]);
31460  }
31461 
31462  /*
31463  * Solve L'*x=y then.
31464  */
31465  for(i=n-1; i>=0; i--)
31466  {
31467  xb->ptr.p_double[i] = xb->ptr.p_double[i]/(sqrtscalea*cha->ptr.pp_double[i][i]);
31468  if( i>0 )
31469  {
31470  v = xb->ptr.p_double[i];
31471  ae_v_moved(&tmp->ptr.p_double[0], 1, &cha->ptr.pp_double[i][0], 1, ae_v_len(0,i-1), sqrtscalea);
31472  ae_v_subd(&xb->ptr.p_double[0], 1, &tmp->ptr.p_double[0], 1, ae_v_len(0,i-1), v);
31473  }
31474  }
31475  }
31476 }
31477 
31478 
31479 /*************************************************************************
31480 Fast basic linear solver: linear SPD CG
31481 
31482 Solves (A^T*A + alpha*I)*x = b where:
31483 * A is MxN matrix
31484 * alpha>0 is a scalar
31485 * I is NxN identity matrix
31486 * b is Nx1 vector
31487 * X is Nx1 unknown vector.
31488 
31489 N iterations of linear conjugate gradient are used to solve problem.
31490 
31491 INPUT PARAMETERS:
31492  A - array[M,N], matrix
31493  M - number of rows
31494  N - number of unknowns
31495  B - array[N], right part
31496  X - initial approxumation, array[N]
31497  Buf - buffer; function automatically allocates it, if it is too
31498  small. It can be reused if function is called several times
31499  with same M and N.
31500 
31501 OUTPUT PARAMETERS:
31502  X - improved solution
31503 
31504 NOTES:
31505 * solver checks quality of improved solution. If (because of problem
31506  condition number, numerical noise, etc.) new solution is WORSE than
31507  original approximation, then original approximation is returned.
31508 * solver assumes that both A, B, Alpha are well scaled (i.e. they are
31509  less than sqrt(overflow) and greater than sqrt(underflow)).
31510 
31511  -- ALGLIB --
31512  Copyright 20.08.2009 by Bochkanov Sergey
31513 *************************************************************************/
31514 void fblssolvecgx(/* Real */ ae_matrix* a,
31515  ae_int_t m,
31516  ae_int_t n,
31517  double alpha,
31518  /* Real */ ae_vector* b,
31519  /* Real */ ae_vector* x,
31520  /* Real */ ae_vector* buf,
31521  ae_state *_state)
31522 {
31523  ae_int_t k;
31524  ae_int_t offsrk;
31525  ae_int_t offsrk1;
31526  ae_int_t offsxk;
31527  ae_int_t offsxk1;
31528  ae_int_t offspk;
31529  ae_int_t offspk1;
31530  ae_int_t offstmp1;
31531  ae_int_t offstmp2;
31532  ae_int_t bs;
31533  double e1;
31534  double e2;
31535  double rk2;
31536  double rk12;
31537  double pap;
31538  double s;
31539  double betak;
31540  double v1;
31541  double v2;
31542 
31543 
31544 
31545  /*
31546  * Test for special case: B=0
31547  */
31548  v1 = ae_v_dotproduct(&b->ptr.p_double[0], 1, &b->ptr.p_double[0], 1, ae_v_len(0,n-1));
31549  if( ae_fp_eq(v1,0) )
31550  {
31551  for(k=0; k<=n-1; k++)
31552  {
31553  x->ptr.p_double[k] = 0;
31554  }
31555  return;
31556  }
31557 
31558  /*
31559  * Offsets inside Buf for:
31560  * * R[K], R[K+1]
31561  * * X[K], X[K+1]
31562  * * P[K], P[K+1]
31563  * * Tmp1 - array[M], Tmp2 - array[N]
31564  */
31565  offsrk = 0;
31566  offsrk1 = offsrk+n;
31567  offsxk = offsrk1+n;
31568  offsxk1 = offsxk+n;
31569  offspk = offsxk1+n;
31570  offspk1 = offspk+n;
31571  offstmp1 = offspk1+n;
31572  offstmp2 = offstmp1+m;
31573  bs = offstmp2+n;
31574  if( buf->cnt<bs )
31575  {
31576  ae_vector_set_length(buf, bs, _state);
31577  }
31578 
31579  /*
31580  * x(0) = x
31581  */
31582  ae_v_move(&buf->ptr.p_double[offsxk], 1, &x->ptr.p_double[0], 1, ae_v_len(offsxk,offsxk+n-1));
31583 
31584  /*
31585  * r(0) = b-A*x(0)
31586  * RK2 = r(0)'*r(0)
31587  */
31588  rmatrixmv(m, n, a, 0, 0, 0, buf, offsxk, buf, offstmp1, _state);
31589  rmatrixmv(n, m, a, 0, 0, 1, buf, offstmp1, buf, offstmp2, _state);
31590  ae_v_addd(&buf->ptr.p_double[offstmp2], 1, &buf->ptr.p_double[offsxk], 1, ae_v_len(offstmp2,offstmp2+n-1), alpha);
31591  ae_v_move(&buf->ptr.p_double[offsrk], 1, &b->ptr.p_double[0], 1, ae_v_len(offsrk,offsrk+n-1));
31592  ae_v_sub(&buf->ptr.p_double[offsrk], 1, &buf->ptr.p_double[offstmp2], 1, ae_v_len(offsrk,offsrk+n-1));
31593  rk2 = ae_v_dotproduct(&buf->ptr.p_double[offsrk], 1, &buf->ptr.p_double[offsrk], 1, ae_v_len(offsrk,offsrk+n-1));
31594  ae_v_move(&buf->ptr.p_double[offspk], 1, &buf->ptr.p_double[offsrk], 1, ae_v_len(offspk,offspk+n-1));
31595  e1 = ae_sqrt(rk2, _state);
31596 
31597  /*
31598  * Cycle
31599  */
31600  for(k=0; k<=n-1; k++)
31601  {
31602 
31603  /*
31604  * Calculate A*p(k) - store in Buf[OffsTmp2:OffsTmp2+N-1]
31605  * and p(k)'*A*p(k) - store in PAP
31606  *
31607  * If PAP=0, break (iteration is over)
31608  */
31609  rmatrixmv(m, n, a, 0, 0, 0, buf, offspk, buf, offstmp1, _state);
31610  v1 = ae_v_dotproduct(&buf->ptr.p_double[offstmp1], 1, &buf->ptr.p_double[offstmp1], 1, ae_v_len(offstmp1,offstmp1+m-1));
31611  v2 = ae_v_dotproduct(&buf->ptr.p_double[offspk], 1, &buf->ptr.p_double[offspk], 1, ae_v_len(offspk,offspk+n-1));
31612  pap = v1+alpha*v2;
31613  rmatrixmv(n, m, a, 0, 0, 1, buf, offstmp1, buf, offstmp2, _state);
31614  ae_v_addd(&buf->ptr.p_double[offstmp2], 1, &buf->ptr.p_double[offspk], 1, ae_v_len(offstmp2,offstmp2+n-1), alpha);
31615  if( ae_fp_eq(pap,0) )
31616  {
31617  break;
31618  }
31619 
31620  /*
31621  * S = (r(k)'*r(k))/(p(k)'*A*p(k))
31622  */
31623  s = rk2/pap;
31624 
31625  /*
31626  * x(k+1) = x(k) + S*p(k)
31627  */
31628  ae_v_move(&buf->ptr.p_double[offsxk1], 1, &buf->ptr.p_double[offsxk], 1, ae_v_len(offsxk1,offsxk1+n-1));
31629  ae_v_addd(&buf->ptr.p_double[offsxk1], 1, &buf->ptr.p_double[offspk], 1, ae_v_len(offsxk1,offsxk1+n-1), s);
31630 
31631  /*
31632  * r(k+1) = r(k) - S*A*p(k)
31633  * RK12 = r(k+1)'*r(k+1)
31634  *
31635  * Break if r(k+1) small enough (when compared to r(k))
31636  */
31637  ae_v_move(&buf->ptr.p_double[offsrk1], 1, &buf->ptr.p_double[offsrk], 1, ae_v_len(offsrk1,offsrk1+n-1));
31638  ae_v_subd(&buf->ptr.p_double[offsrk1], 1, &buf->ptr.p_double[offstmp2], 1, ae_v_len(offsrk1,offsrk1+n-1), s);
31639  rk12 = ae_v_dotproduct(&buf->ptr.p_double[offsrk1], 1, &buf->ptr.p_double[offsrk1], 1, ae_v_len(offsrk1,offsrk1+n-1));
31640  if( ae_fp_less_eq(ae_sqrt(rk12, _state),100*ae_machineepsilon*ae_sqrt(rk2, _state)) )
31641  {
31642 
31643  /*
31644  * X(k) = x(k+1) before exit -
31645  * - because we expect to find solution at x(k)
31646  */
31647  ae_v_move(&buf->ptr.p_double[offsxk], 1, &buf->ptr.p_double[offsxk1], 1, ae_v_len(offsxk,offsxk+n-1));
31648  break;
31649  }
31650 
31651  /*
31652  * BetaK = RK12/RK2
31653  * p(k+1) = r(k+1)+betak*p(k)
31654  */
31655  betak = rk12/rk2;
31656  ae_v_move(&buf->ptr.p_double[offspk1], 1, &buf->ptr.p_double[offsrk1], 1, ae_v_len(offspk1,offspk1+n-1));
31657  ae_v_addd(&buf->ptr.p_double[offspk1], 1, &buf->ptr.p_double[offspk], 1, ae_v_len(offspk1,offspk1+n-1), betak);
31658 
31659  /*
31660  * r(k) := r(k+1)
31661  * x(k) := x(k+1)
31662  * p(k) := p(k+1)
31663  */
31664  ae_v_move(&buf->ptr.p_double[offsrk], 1, &buf->ptr.p_double[offsrk1], 1, ae_v_len(offsrk,offsrk+n-1));
31665  ae_v_move(&buf->ptr.p_double[offsxk], 1, &buf->ptr.p_double[offsxk1], 1, ae_v_len(offsxk,offsxk+n-1));
31666  ae_v_move(&buf->ptr.p_double[offspk], 1, &buf->ptr.p_double[offspk1], 1, ae_v_len(offspk,offspk+n-1));
31667  rk2 = rk12;
31668  }
31669 
31670  /*
31671  * Calculate E2
31672  */
31673  rmatrixmv(m, n, a, 0, 0, 0, buf, offsxk, buf, offstmp1, _state);
31674  rmatrixmv(n, m, a, 0, 0, 1, buf, offstmp1, buf, offstmp2, _state);
31675  ae_v_addd(&buf->ptr.p_double[offstmp2], 1, &buf->ptr.p_double[offsxk], 1, ae_v_len(offstmp2,offstmp2+n-1), alpha);
31676  ae_v_move(&buf->ptr.p_double[offsrk], 1, &b->ptr.p_double[0], 1, ae_v_len(offsrk,offsrk+n-1));
31677  ae_v_sub(&buf->ptr.p_double[offsrk], 1, &buf->ptr.p_double[offstmp2], 1, ae_v_len(offsrk,offsrk+n-1));
31678  v1 = ae_v_dotproduct(&buf->ptr.p_double[offsrk], 1, &buf->ptr.p_double[offsrk], 1, ae_v_len(offsrk,offsrk+n-1));
31679  e2 = ae_sqrt(v1, _state);
31680 
31681  /*
31682  * Output result (if it was improved)
31683  */
31684  if( ae_fp_less(e2,e1) )
31685  {
31686  ae_v_move(&x->ptr.p_double[0], 1, &buf->ptr.p_double[offsxk], 1, ae_v_len(0,n-1));
31687  }
31688 }
31689 
31690 
31691 /*************************************************************************
31692 Construction of linear conjugate gradient solver.
31693 
31694 State parameter passed using "var" semantics (i.e. previous state is NOT
31695 erased). When it is already initialized, we can reause prevously allocated
31696 memory.
31697 
31698 INPUT PARAMETERS:
31699  X - initial solution
31700  B - right part
31701  N - system size
31702  State - structure; may be preallocated, if we want to reuse memory
31703 
31704 OUTPUT PARAMETERS:
31705  State - structure which is used by FBLSCGIteration() to store
31706  algorithm state between subsequent calls.
31707 
31708 NOTE: no error checking is done; caller must check all parameters, prevent
31709  overflows, and so on.
31710 
31711  -- ALGLIB --
31712  Copyright 22.10.2009 by Bochkanov Sergey
31713 *************************************************************************/
31714 void fblscgcreate(/* Real */ ae_vector* x,
31715  /* Real */ ae_vector* b,
31716  ae_int_t n,
31717  fblslincgstate* state,
31718  ae_state *_state)
31719 {
31720 
31721 
31722  if( state->b.cnt<n )
31723  {
31724  ae_vector_set_length(&state->b, n, _state);
31725  }
31726  if( state->rk.cnt<n )
31727  {
31728  ae_vector_set_length(&state->rk, n, _state);
31729  }
31730  if( state->rk1.cnt<n )
31731  {
31732  ae_vector_set_length(&state->rk1, n, _state);
31733  }
31734  if( state->xk.cnt<n )
31735  {
31736  ae_vector_set_length(&state->xk, n, _state);
31737  }
31738  if( state->xk1.cnt<n )
31739  {
31740  ae_vector_set_length(&state->xk1, n, _state);
31741  }
31742  if( state->pk.cnt<n )
31743  {
31744  ae_vector_set_length(&state->pk, n, _state);
31745  }
31746  if( state->pk1.cnt<n )
31747  {
31748  ae_vector_set_length(&state->pk1, n, _state);
31749  }
31750  if( state->tmp2.cnt<n )
31751  {
31752  ae_vector_set_length(&state->tmp2, n, _state);
31753  }
31754  if( state->x.cnt<n )
31755  {
31756  ae_vector_set_length(&state->x, n, _state);
31757  }
31758  if( state->ax.cnt<n )
31759  {
31760  ae_vector_set_length(&state->ax, n, _state);
31761  }
31762  state->n = n;
31763  ae_v_move(&state->xk.ptr.p_double[0], 1, &x->ptr.p_double[0], 1, ae_v_len(0,n-1));
31764  ae_v_move(&state->b.ptr.p_double[0], 1, &b->ptr.p_double[0], 1, ae_v_len(0,n-1));
31765  ae_vector_set_length(&state->rstate.ia, 1+1, _state);
31766  ae_vector_set_length(&state->rstate.ra, 6+1, _state);
31767  state->rstate.stage = -1;
31768 }
31769 
31770 
31771 /*************************************************************************
31772 Linear CG solver, function relying on reverse communication to calculate
31773 matrix-vector products.
31774 
31775 See comments for FBLSLinCGState structure for more info.
31776 
31777  -- ALGLIB --
31778  Copyright 22.10.2009 by Bochkanov Sergey
31779 *************************************************************************/
31780 ae_bool fblscgiteration(fblslincgstate* state, ae_state *_state)
31781 {
31782  ae_int_t n;
31783  ae_int_t k;
31784  double rk2;
31785  double rk12;
31786  double pap;
31787  double s;
31788  double betak;
31789  double v1;
31790  double v2;
31791  ae_bool result;
31792 
31793 
31794 
31795  /*
31796  * Reverse communication preparations
31797  * I know it looks ugly, but it works the same way
31798  * anywhere from C++ to Python.
31799  *
31800  * This code initializes locals by:
31801  * * random values determined during code
31802  * generation - on first subroutine call
31803  * * values from previous call - on subsequent calls
31804  */
31805  if( state->rstate.stage>=0 )
31806  {
31807  n = state->rstate.ia.ptr.p_int[0];
31808  k = state->rstate.ia.ptr.p_int[1];
31809  rk2 = state->rstate.ra.ptr.p_double[0];
31810  rk12 = state->rstate.ra.ptr.p_double[1];
31811  pap = state->rstate.ra.ptr.p_double[2];
31812  s = state->rstate.ra.ptr.p_double[3];
31813  betak = state->rstate.ra.ptr.p_double[4];
31814  v1 = state->rstate.ra.ptr.p_double[5];
31815  v2 = state->rstate.ra.ptr.p_double[6];
31816  }
31817  else
31818  {
31819  n = -983;
31820  k = -989;
31821  rk2 = -834;
31822  rk12 = 900;
31823  pap = -287;
31824  s = 364;
31825  betak = 214;
31826  v1 = -338;
31827  v2 = -686;
31828  }
31829  if( state->rstate.stage==0 )
31830  {
31831  goto lbl_0;
31832  }
31833  if( state->rstate.stage==1 )
31834  {
31835  goto lbl_1;
31836  }
31837  if( state->rstate.stage==2 )
31838  {
31839  goto lbl_2;
31840  }
31841 
31842  /*
31843  * Routine body
31844  */
31845 
31846  /*
31847  * prepare locals
31848  */
31849  n = state->n;
31850 
31851  /*
31852  * Test for special case: B=0
31853  */
31854  v1 = ae_v_dotproduct(&state->b.ptr.p_double[0], 1, &state->b.ptr.p_double[0], 1, ae_v_len(0,n-1));
31855  if( ae_fp_eq(v1,0) )
31856  {
31857  for(k=0; k<=n-1; k++)
31858  {
31859  state->xk.ptr.p_double[k] = 0;
31860  }
31861  result = ae_false;
31862  return result;
31863  }
31864 
31865  /*
31866  * r(0) = b-A*x(0)
31867  * RK2 = r(0)'*r(0)
31868  */
31869  ae_v_move(&state->x.ptr.p_double[0], 1, &state->xk.ptr.p_double[0], 1, ae_v_len(0,n-1));
31870  state->rstate.stage = 0;
31871  goto lbl_rcomm;
31872 lbl_0:
31873  ae_v_move(&state->rk.ptr.p_double[0], 1, &state->b.ptr.p_double[0], 1, ae_v_len(0,n-1));
31874  ae_v_sub(&state->rk.ptr.p_double[0], 1, &state->ax.ptr.p_double[0], 1, ae_v_len(0,n-1));
31875  rk2 = ae_v_dotproduct(&state->rk.ptr.p_double[0], 1, &state->rk.ptr.p_double[0], 1, ae_v_len(0,n-1));
31876  ae_v_move(&state->pk.ptr.p_double[0], 1, &state->rk.ptr.p_double[0], 1, ae_v_len(0,n-1));
31877  state->e1 = ae_sqrt(rk2, _state);
31878 
31879  /*
31880  * Cycle
31881  */
31882  k = 0;
31883 lbl_3:
31884  if( k>n-1 )
31885  {
31886  goto lbl_5;
31887  }
31888 
31889  /*
31890  * Calculate A*p(k) - store in State.Tmp2
31891  * and p(k)'*A*p(k) - store in PAP
31892  *
31893  * If PAP=0, break (iteration is over)
31894  */
31895  ae_v_move(&state->x.ptr.p_double[0], 1, &state->pk.ptr.p_double[0], 1, ae_v_len(0,n-1));
31896  state->rstate.stage = 1;
31897  goto lbl_rcomm;
31898 lbl_1:
31899  ae_v_move(&state->tmp2.ptr.p_double[0], 1, &state->ax.ptr.p_double[0], 1, ae_v_len(0,n-1));
31900  pap = state->xax;
31901  if( !ae_isfinite(pap, _state) )
31902  {
31903  goto lbl_5;
31904  }
31905  if( ae_fp_less_eq(pap,0) )
31906  {
31907  goto lbl_5;
31908  }
31909 
31910  /*
31911  * S = (r(k)'*r(k))/(p(k)'*A*p(k))
31912  */
31913  s = rk2/pap;
31914 
31915  /*
31916  * x(k+1) = x(k) + S*p(k)
31917  */
31918  ae_v_move(&state->xk1.ptr.p_double[0], 1, &state->xk.ptr.p_double[0], 1, ae_v_len(0,n-1));
31919  ae_v_addd(&state->xk1.ptr.p_double[0], 1, &state->pk.ptr.p_double[0], 1, ae_v_len(0,n-1), s);
31920 
31921  /*
31922  * r(k+1) = r(k) - S*A*p(k)
31923  * RK12 = r(k+1)'*r(k+1)
31924  *
31925  * Break if r(k+1) small enough (when compared to r(k))
31926  */
31927  ae_v_move(&state->rk1.ptr.p_double[0], 1, &state->rk.ptr.p_double[0], 1, ae_v_len(0,n-1));
31928  ae_v_subd(&state->rk1.ptr.p_double[0], 1, &state->tmp2.ptr.p_double[0], 1, ae_v_len(0,n-1), s);
31929  rk12 = ae_v_dotproduct(&state->rk1.ptr.p_double[0], 1, &state->rk1.ptr.p_double[0], 1, ae_v_len(0,n-1));
31930  if( ae_fp_less_eq(ae_sqrt(rk12, _state),100*ae_machineepsilon*state->e1) )
31931  {
31932 
31933  /*
31934  * X(k) = x(k+1) before exit -
31935  * - because we expect to find solution at x(k)
31936  */
31937  ae_v_move(&state->xk.ptr.p_double[0], 1, &state->xk1.ptr.p_double[0], 1, ae_v_len(0,n-1));
31938  goto lbl_5;
31939  }
31940 
31941  /*
31942  * BetaK = RK12/RK2
31943  * p(k+1) = r(k+1)+betak*p(k)
31944  *
31945  * NOTE: we expect that BetaK won't overflow because of
31946  * "Sqrt(RK12)<=100*MachineEpsilon*E1" test above.
31947  */
31948  betak = rk12/rk2;
31949  ae_v_move(&state->pk1.ptr.p_double[0], 1, &state->rk1.ptr.p_double[0], 1, ae_v_len(0,n-1));
31950  ae_v_addd(&state->pk1.ptr.p_double[0], 1, &state->pk.ptr.p_double[0], 1, ae_v_len(0,n-1), betak);
31951 
31952  /*
31953  * r(k) := r(k+1)
31954  * x(k) := x(k+1)
31955  * p(k) := p(k+1)
31956  */
31957  ae_v_move(&state->rk.ptr.p_double[0], 1, &state->rk1.ptr.p_double[0], 1, ae_v_len(0,n-1));
31958  ae_v_move(&state->xk.ptr.p_double[0], 1, &state->xk1.ptr.p_double[0], 1, ae_v_len(0,n-1));
31959  ae_v_move(&state->pk.ptr.p_double[0], 1, &state->pk1.ptr.p_double[0], 1, ae_v_len(0,n-1));
31960  rk2 = rk12;
31961  k = k+1;
31962  goto lbl_3;
31963 lbl_5:
31964 
31965  /*
31966  * Calculate E2
31967  */
31968  ae_v_move(&state->x.ptr.p_double[0], 1, &state->xk.ptr.p_double[0], 1, ae_v_len(0,n-1));
31969  state->rstate.stage = 2;
31970  goto lbl_rcomm;
31971 lbl_2:
31972  ae_v_move(&state->rk.ptr.p_double[0], 1, &state->b.ptr.p_double[0], 1, ae_v_len(0,n-1));
31973  ae_v_sub(&state->rk.ptr.p_double[0], 1, &state->ax.ptr.p_double[0], 1, ae_v_len(0,n-1));
31974  v1 = ae_v_dotproduct(&state->rk.ptr.p_double[0], 1, &state->rk.ptr.p_double[0], 1, ae_v_len(0,n-1));
31975  state->e2 = ae_sqrt(v1, _state);
31976  result = ae_false;
31977  return result;
31978 
31979  /*
31980  * Saving state
31981  */
31982 lbl_rcomm:
31983  result = ae_true;
31984  state->rstate.ia.ptr.p_int[0] = n;
31985  state->rstate.ia.ptr.p_int[1] = k;
31986  state->rstate.ra.ptr.p_double[0] = rk2;
31987  state->rstate.ra.ptr.p_double[1] = rk12;
31988  state->rstate.ra.ptr.p_double[2] = pap;
31989  state->rstate.ra.ptr.p_double[3] = s;
31990  state->rstate.ra.ptr.p_double[4] = betak;
31991  state->rstate.ra.ptr.p_double[5] = v1;
31992  state->rstate.ra.ptr.p_double[6] = v2;
31993  return result;
31994 }
31995 
31996 
31997 /*************************************************************************
31998 Fast least squares solver, solves well conditioned system without
31999 performing any checks for degeneracy, and using user-provided buffers
32000 (which are automatically reallocated if too small).
32001 
32002 This function is intended for solution of moderately sized systems. It
32003 uses factorization algorithms based on Level 2 BLAS operations, thus it
32004 won't work efficiently on large scale systems.
32005 
32006 INPUT PARAMETERS:
32007  A - array[M,N], system matrix.
32008  Contents of A is destroyed during solution.
32009  B - array[M], right part
32010  M - number of equations
32011  N - number of variables, N<=M
32012  Tmp0, Tmp1, Tmp2-
32013  buffers; function automatically allocates them, if they are
32014  too small. They can be reused if function is called
32015  several times.
32016 
32017 OUTPUT PARAMETERS:
32018  B - solution (first N components, next M-N are zero)
32019 
32020  -- ALGLIB --
32021  Copyright 20.01.2012 by Bochkanov Sergey
32022 *************************************************************************/
32023 void fblssolvels(/* Real */ ae_matrix* a,
32024  /* Real */ ae_vector* b,
32025  ae_int_t m,
32026  ae_int_t n,
32027  /* Real */ ae_vector* tmp0,
32028  /* Real */ ae_vector* tmp1,
32029  /* Real */ ae_vector* tmp2,
32030  ae_state *_state)
32031 {
32032  ae_int_t i;
32033  ae_int_t k;
32034  double v;
32035 
32036 
32037  ae_assert(n>0, "FBLSSolveLS: N<=0", _state);
32038  ae_assert(m>=n, "FBLSSolveLS: M<N", _state);
32039  ae_assert(a->rows>=m, "FBLSSolveLS: Rows(A)<M", _state);
32040  ae_assert(a->cols>=n, "FBLSSolveLS: Cols(A)<N", _state);
32041  ae_assert(b->cnt>=m, "FBLSSolveLS: Length(B)<M", _state);
32042 
32043  /*
32044  * Allocate temporaries
32045  */
32046  rvectorsetlengthatleast(tmp0, ae_maxint(m, n, _state)+1, _state);
32047  rvectorsetlengthatleast(tmp1, ae_maxint(m, n, _state)+1, _state);
32048  rvectorsetlengthatleast(tmp2, ae_minint(m, n, _state), _state);
32049 
32050  /*
32051  * Call basecase QR
32052  */
32053  rmatrixqrbasecase(a, m, n, tmp0, tmp1, tmp2, _state);
32054 
32055  /*
32056  * Multiply B by Q'
32057  */
32058  for(k=0; k<=n-1; k++)
32059  {
32060  for(i=0; i<=k-1; i++)
32061  {
32062  tmp0->ptr.p_double[i] = 0;
32063  }
32064  ae_v_move(&tmp0->ptr.p_double[k], 1, &a->ptr.pp_double[k][k], a->stride, ae_v_len(k,m-1));
32065  tmp0->ptr.p_double[k] = 1;
32066  v = ae_v_dotproduct(&tmp0->ptr.p_double[k], 1, &b->ptr.p_double[k], 1, ae_v_len(k,m-1));
32067  v = v*tmp2->ptr.p_double[k];
32068  ae_v_subd(&b->ptr.p_double[k], 1, &tmp0->ptr.p_double[k], 1, ae_v_len(k,m-1), v);
32069  }
32070 
32071  /*
32072  * Solve triangular system
32073  */
32074  b->ptr.p_double[n-1] = b->ptr.p_double[n-1]/a->ptr.pp_double[n-1][n-1];
32075  for(i=n-2; i>=0; i--)
32076  {
32077  v = ae_v_dotproduct(&a->ptr.pp_double[i][i+1], 1, &b->ptr.p_double[i+1], 1, ae_v_len(i+1,n-1));
32078  b->ptr.p_double[i] = (b->ptr.p_double[i]-v)/a->ptr.pp_double[i][i];
32079  }
32080  for(i=n; i<=m-1; i++)
32081  {
32082  b->ptr.p_double[i] = 0.0;
32083  }
32084 }
32085 
32086 
32087 ae_bool _fblslincgstate_init(void* _p, ae_state *_state, ae_bool make_automatic)
32088 {
32089  fblslincgstate *p = (fblslincgstate*)_p;
32090  ae_touch_ptr((void*)p);
32091  if( !ae_vector_init(&p->x, 0, DT_REAL, _state, make_automatic) )
32092  return ae_false;
32093  if( !ae_vector_init(&p->ax, 0, DT_REAL, _state, make_automatic) )
32094  return ae_false;
32095  if( !ae_vector_init(&p->rk, 0, DT_REAL, _state, make_automatic) )
32096  return ae_false;
32097  if( !ae_vector_init(&p->rk1, 0, DT_REAL, _state, make_automatic) )
32098  return ae_false;
32099  if( !ae_vector_init(&p->xk, 0, DT_REAL, _state, make_automatic) )
32100  return ae_false;
32101  if( !ae_vector_init(&p->xk1, 0, DT_REAL, _state, make_automatic) )
32102  return ae_false;
32103  if( !ae_vector_init(&p->pk, 0, DT_REAL, _state, make_automatic) )
32104  return ae_false;
32105  if( !ae_vector_init(&p->pk1, 0, DT_REAL, _state, make_automatic) )
32106  return ae_false;
32107  if( !ae_vector_init(&p->b, 0, DT_REAL, _state, make_automatic) )
32108  return ae_false;
32109  if( !_rcommstate_init(&p->rstate, _state, make_automatic) )
32110  return ae_false;
32111  if( !ae_vector_init(&p->tmp2, 0, DT_REAL, _state, make_automatic) )
32112  return ae_false;
32113  return ae_true;
32114 }
32115 
32116 
32117 ae_bool _fblslincgstate_init_copy(void* _dst, void* _src, ae_state *_state, ae_bool make_automatic)
32118 {
32119  fblslincgstate *dst = (fblslincgstate*)_dst;
32120  fblslincgstate *src = (fblslincgstate*)_src;
32121  dst->e1 = src->e1;
32122  dst->e2 = src->e2;
32123  if( !ae_vector_init_copy(&dst->x, &src->x, _state, make_automatic) )
32124  return ae_false;
32125  if( !ae_vector_init_copy(&dst->ax, &src->ax, _state, make_automatic) )
32126  return ae_false;
32127  dst->xax = src->xax;
32128  dst->n = src->n;
32129  if( !ae_vector_init_copy(&dst->rk, &src->rk, _state, make_automatic) )
32130  return ae_false;
32131  if( !ae_vector_init_copy(&dst->rk1, &src->rk1, _state, make_automatic) )
32132  return ae_false;
32133  if( !ae_vector_init_copy(&dst->xk, &src->xk, _state, make_automatic) )
32134  return ae_false;
32135  if( !ae_vector_init_copy(&dst->xk1, &src->xk1, _state, make_automatic) )
32136  return ae_false;
32137  if( !ae_vector_init_copy(&dst->pk, &src->pk, _state, make_automatic) )
32138  return ae_false;
32139  if( !ae_vector_init_copy(&dst->pk1, &src->pk1, _state, make_automatic) )
32140  return ae_false;
32141  if( !ae_vector_init_copy(&dst->b, &src->b, _state, make_automatic) )
32142  return ae_false;
32143  if( !_rcommstate_init_copy(&dst->rstate, &src->rstate, _state, make_automatic) )
32144  return ae_false;
32145  if( !ae_vector_init_copy(&dst->tmp2, &src->tmp2, _state, make_automatic) )
32146  return ae_false;
32147  return ae_true;
32148 }
32149 
32150 
32151 void _fblslincgstate_clear(void* _p)
32152 {
32153  fblslincgstate *p = (fblslincgstate*)_p;
32154  ae_touch_ptr((void*)p);
32155  ae_vector_clear(&p->x);
32156  ae_vector_clear(&p->ax);
32157  ae_vector_clear(&p->rk);
32158  ae_vector_clear(&p->rk1);
32159  ae_vector_clear(&p->xk);
32160  ae_vector_clear(&p->xk1);
32161  ae_vector_clear(&p->pk);
32162  ae_vector_clear(&p->pk1);
32163  ae_vector_clear(&p->b);
32164  _rcommstate_clear(&p->rstate);
32165  ae_vector_clear(&p->tmp2);
32166 }
32167 
32168 
32169 void _fblslincgstate_destroy(void* _p)
32170 {
32171  fblslincgstate *p = (fblslincgstate*)_p;
32172  ae_touch_ptr((void*)p);
32173  ae_vector_destroy(&p->x);
32174  ae_vector_destroy(&p->ax);
32175  ae_vector_destroy(&p->rk);
32176  ae_vector_destroy(&p->rk1);
32177  ae_vector_destroy(&p->xk);
32178  ae_vector_destroy(&p->xk1);
32179  ae_vector_destroy(&p->pk);
32180  ae_vector_destroy(&p->pk1);
32181  ae_vector_destroy(&p->b);
32182  _rcommstate_destroy(&p->rstate);
32183  ae_vector_destroy(&p->tmp2);
32184 }
32185 
32186 
32187 
32188 
32189 /*************************************************************************
32190 This procedure initializes matrix norm estimator.
32191 
32192 USAGE:
32193 1. User initializes algorithm state with NormEstimatorCreate() call
32194 2. User calls NormEstimatorEstimateSparse() (or NormEstimatorIteration())
32195 3. User calls NormEstimatorResults() to get solution.
32196 
32197 INPUT PARAMETERS:
32198  M - number of rows in the matrix being estimated, M>0
32199  N - number of columns in the matrix being estimated, N>0
32200  NStart - number of random starting vectors
32201  recommended value - at least 5.
32202  NIts - number of iterations to do with best starting vector
32203  recommended value - at least 5.
32204 
32205 OUTPUT PARAMETERS:
32206  State - structure which stores algorithm state
32207 
32208 
32209 NOTE: this algorithm is effectively deterministic, i.e. it always returns
32210 same result when repeatedly called for the same matrix. In fact, algorithm
32211 uses randomized starting vectors, but internal random numbers generator
32212 always generates same sequence of the random values (it is a feature, not
32213 bug).
32214 
32215 Algorithm can be made non-deterministic with NormEstimatorSetSeed(0) call.
32216 
32217  -- ALGLIB --
32218  Copyright 06.12.2011 by Bochkanov Sergey
32219 *************************************************************************/
32220 void normestimatorcreate(ae_int_t m,
32221  ae_int_t n,
32222  ae_int_t nstart,
32223  ae_int_t nits,
32224  normestimatorstate* state,
32225  ae_state *_state)
32226 {
32227 
32228  _normestimatorstate_clear(state);
32229 
32230  ae_assert(m>0, "NormEstimatorCreate: M<=0", _state);
32231  ae_assert(n>0, "NormEstimatorCreate: N<=0", _state);
32232  ae_assert(nstart>0, "NormEstimatorCreate: NStart<=0", _state);
32233  ae_assert(nits>0, "NormEstimatorCreate: NIts<=0", _state);
32234  state->m = m;
32235  state->n = n;
32236  state->nstart = nstart;
32237  state->nits = nits;
32238  state->seedval = 11;
32239  hqrndrandomize(&state->r, _state);
32240  ae_vector_set_length(&state->x0, state->n, _state);
32241  ae_vector_set_length(&state->t, state->m, _state);
32242  ae_vector_set_length(&state->x1, state->n, _state);
32243  ae_vector_set_length(&state->xbest, state->n, _state);
32244  ae_vector_set_length(&state->x, ae_maxint(state->n, state->m, _state), _state);
32245  ae_vector_set_length(&state->mv, state->m, _state);
32246  ae_vector_set_length(&state->mtv, state->n, _state);
32247  ae_vector_set_length(&state->rstate.ia, 3+1, _state);
32248  ae_vector_set_length(&state->rstate.ra, 2+1, _state);
32249  state->rstate.stage = -1;
32250 }
32251 
32252 
32253 /*************************************************************************
32254 This function changes seed value used by algorithm. In some cases we need
32255 deterministic processing, i.e. subsequent calls must return equal results,
32256 in other cases we need non-deterministic algorithm which returns different
32257 results for the same matrix on every pass.
32258 
32259 Setting zero seed will lead to non-deterministic algorithm, while non-zero
32260 value will make our algorithm deterministic.
32261 
32262 INPUT PARAMETERS:
32263  State - norm estimator state, must be initialized with a call
32264  to NormEstimatorCreate()
32265  SeedVal - seed value, >=0. Zero value = non-deterministic algo.
32266 
32267  -- ALGLIB --
32268  Copyright 06.12.2011 by Bochkanov Sergey
32269 *************************************************************************/
32270 void normestimatorsetseed(normestimatorstate* state,
32271  ae_int_t seedval,
32272  ae_state *_state)
32273 {
32274 
32275 
32276  ae_assert(seedval>=0, "NormEstimatorSetSeed: SeedVal<0", _state);
32277  state->seedval = seedval;
32278 }
32279 
32280 
32281 /*************************************************************************
32282 
32283  -- ALGLIB --
32284  Copyright 06.12.2011 by Bochkanov Sergey
32285 *************************************************************************/
32286 ae_bool normestimatoriteration(normestimatorstate* state,
32287  ae_state *_state)
32288 {
32289  ae_int_t n;
32290  ae_int_t m;
32291  ae_int_t i;
32292  ae_int_t itcnt;
32293  double v;
32294  double growth;
32295  double bestgrowth;
32296  ae_bool result;
32297 
32298 
32299 
32300  /*
32301  * Reverse communication preparations
32302  * I know it looks ugly, but it works the same way
32303  * anywhere from C++ to Python.
32304  *
32305  * This code initializes locals by:
32306  * * random values determined during code
32307  * generation - on first subroutine call
32308  * * values from previous call - on subsequent calls
32309  */
32310  if( state->rstate.stage>=0 )
32311  {
32312  n = state->rstate.ia.ptr.p_int[0];
32313  m = state->rstate.ia.ptr.p_int[1];
32314  i = state->rstate.ia.ptr.p_int[2];
32315  itcnt = state->rstate.ia.ptr.p_int[3];
32316  v = state->rstate.ra.ptr.p_double[0];
32317  growth = state->rstate.ra.ptr.p_double[1];
32318  bestgrowth = state->rstate.ra.ptr.p_double[2];
32319  }
32320  else
32321  {
32322  n = -983;
32323  m = -989;
32324  i = -834;
32325  itcnt = 900;
32326  v = -287;
32327  growth = 364;
32328  bestgrowth = 214;
32329  }
32330  if( state->rstate.stage==0 )
32331  {
32332  goto lbl_0;
32333  }
32334  if( state->rstate.stage==1 )
32335  {
32336  goto lbl_1;
32337  }
32338  if( state->rstate.stage==2 )
32339  {
32340  goto lbl_2;
32341  }
32342  if( state->rstate.stage==3 )
32343  {
32344  goto lbl_3;
32345  }
32346 
32347  /*
32348  * Routine body
32349  */
32350  n = state->n;
32351  m = state->m;
32352  if( state->seedval>0 )
32353  {
32354  hqrndseed(state->seedval, state->seedval+2, &state->r, _state);
32355  }
32356  bestgrowth = 0;
32357  state->xbest.ptr.p_double[0] = 1;
32358  for(i=1; i<=n-1; i++)
32359  {
32360  state->xbest.ptr.p_double[i] = 0;
32361  }
32362  itcnt = 0;
32363 lbl_4:
32364  if( itcnt>state->nstart-1 )
32365  {
32366  goto lbl_6;
32367  }
32368  do
32369  {
32370  v = 0;
32371  for(i=0; i<=n-1; i++)
32372  {
32373  state->x0.ptr.p_double[i] = hqrndnormal(&state->r, _state);
32374  v = v+ae_sqr(state->x0.ptr.p_double[i], _state);
32375  }
32376  }
32377  while(ae_fp_eq(v,0));
32378  v = 1/ae_sqrt(v, _state);
32379  ae_v_muld(&state->x0.ptr.p_double[0], 1, ae_v_len(0,n-1), v);
32380  ae_v_move(&state->x.ptr.p_double[0], 1, &state->x0.ptr.p_double[0], 1, ae_v_len(0,n-1));
32381  state->needmv = ae_true;
32382  state->needmtv = ae_false;
32383  state->rstate.stage = 0;
32384  goto lbl_rcomm;
32385 lbl_0:
32386  ae_v_move(&state->x.ptr.p_double[0], 1, &state->mv.ptr.p_double[0], 1, ae_v_len(0,m-1));
32387  state->needmv = ae_false;
32388  state->needmtv = ae_true;
32389  state->rstate.stage = 1;
32390  goto lbl_rcomm;
32391 lbl_1:
32392  ae_v_move(&state->x1.ptr.p_double[0], 1, &state->mtv.ptr.p_double[0], 1, ae_v_len(0,n-1));
32393  v = 0;
32394  for(i=0; i<=n-1; i++)
32395  {
32396  v = v+ae_sqr(state->x1.ptr.p_double[i], _state);
32397  }
32398  growth = ae_sqrt(ae_sqrt(v, _state), _state);
32399  if( ae_fp_greater(growth,bestgrowth) )
32400  {
32401  v = 1/ae_sqrt(v, _state);
32402  ae_v_moved(&state->xbest.ptr.p_double[0], 1, &state->x1.ptr.p_double[0], 1, ae_v_len(0,n-1), v);
32403  bestgrowth = growth;
32404  }
32405  itcnt = itcnt+1;
32406  goto lbl_4;
32407 lbl_6:
32408  ae_v_move(&state->x0.ptr.p_double[0], 1, &state->xbest.ptr.p_double[0], 1, ae_v_len(0,n-1));
32409  itcnt = 0;
32410 lbl_7:
32411  if( itcnt>state->nits-1 )
32412  {
32413  goto lbl_9;
32414  }
32415  ae_v_move(&state->x.ptr.p_double[0], 1, &state->x0.ptr.p_double[0], 1, ae_v_len(0,n-1));
32416  state->needmv = ae_true;
32417  state->needmtv = ae_false;
32418  state->rstate.stage = 2;
32419  goto lbl_rcomm;
32420 lbl_2:
32421  ae_v_move(&state->x.ptr.p_double[0], 1, &state->mv.ptr.p_double[0], 1, ae_v_len(0,m-1));
32422  state->needmv = ae_false;
32423  state->needmtv = ae_true;
32424  state->rstate.stage = 3;
32425  goto lbl_rcomm;
32426 lbl_3:
32427  ae_v_move(&state->x1.ptr.p_double[0], 1, &state->mtv.ptr.p_double[0], 1, ae_v_len(0,n-1));
32428  v = 0;
32429  for(i=0; i<=n-1; i++)
32430  {
32431  v = v+ae_sqr(state->x1.ptr.p_double[i], _state);
32432  }
32433  state->repnorm = ae_sqrt(ae_sqrt(v, _state), _state);
32434  if( ae_fp_neq(v,0) )
32435  {
32436  v = 1/ae_sqrt(v, _state);
32437  ae_v_moved(&state->x0.ptr.p_double[0], 1, &state->x1.ptr.p_double[0], 1, ae_v_len(0,n-1), v);
32438  }
32439  itcnt = itcnt+1;
32440  goto lbl_7;
32441 lbl_9:
32442  result = ae_false;
32443  return result;
32444 
32445  /*
32446  * Saving state
32447  */
32448 lbl_rcomm:
32449  result = ae_true;
32450  state->rstate.ia.ptr.p_int[0] = n;
32451  state->rstate.ia.ptr.p_int[1] = m;
32452  state->rstate.ia.ptr.p_int[2] = i;
32453  state->rstate.ia.ptr.p_int[3] = itcnt;
32454  state->rstate.ra.ptr.p_double[0] = v;
32455  state->rstate.ra.ptr.p_double[1] = growth;
32456  state->rstate.ra.ptr.p_double[2] = bestgrowth;
32457  return result;
32458 }
32459 
32460 
32461 /*************************************************************************
32462 This function estimates norm of the sparse M*N matrix A.
32463 
32464 INPUT PARAMETERS:
32465  State - norm estimator state, must be initialized with a call
32466  to NormEstimatorCreate()
32467  A - sparse M*N matrix, must be converted to CRS format
32468  prior to calling this function.
32469 
32470 After this function is over you can call NormEstimatorResults() to get
32471 estimate of the norm(A).
32472 
32473  -- ALGLIB --
32474  Copyright 06.12.2011 by Bochkanov Sergey
32475 *************************************************************************/
32476 void normestimatorestimatesparse(normestimatorstate* state,
32477  sparsematrix* a,
32478  ae_state *_state)
32479 {
32480 
32481 
32482  normestimatorrestart(state, _state);
32483  while(normestimatoriteration(state, _state))
32484  {
32485  if( state->needmv )
32486  {
32487  sparsemv(a, &state->x, &state->mv, _state);
32488  continue;
32489  }
32490  if( state->needmtv )
32491  {
32492  sparsemtv(a, &state->x, &state->mtv, _state);
32493  continue;
32494  }
32495  }
32496 }
32497 
32498 
32499 /*************************************************************************
32500 Matrix norm estimation results
32501 
32502 INPUT PARAMETERS:
32503  State - algorithm state
32504 
32505 OUTPUT PARAMETERS:
32506  Nrm - estimate of the matrix norm, Nrm>=0
32507 
32508  -- ALGLIB --
32509  Copyright 06.12.2011 by Bochkanov Sergey
32510 *************************************************************************/
32511 void normestimatorresults(normestimatorstate* state,
32512  double* nrm,
32513  ae_state *_state)
32514 {
32515 
32516  *nrm = 0;
32517 
32518  *nrm = state->repnorm;
32519 }
32520 
32521 
32522 /*************************************************************************
32523 This function restarts estimator and prepares it for the next estimation
32524 round.
32525 
32526 INPUT PARAMETERS:
32527  State - algorithm state
32528  -- ALGLIB --
32529  Copyright 06.12.2011 by Bochkanov Sergey
32530 *************************************************************************/
32531 void normestimatorrestart(normestimatorstate* state, ae_state *_state)
32532 {
32533 
32534 
32535  ae_vector_set_length(&state->rstate.ia, 3+1, _state);
32536  ae_vector_set_length(&state->rstate.ra, 2+1, _state);
32537  state->rstate.stage = -1;
32538 }
32539 
32540 
32541 ae_bool _normestimatorstate_init(void* _p, ae_state *_state, ae_bool make_automatic)
32542 {
32543  normestimatorstate *p = (normestimatorstate*)_p;
32544  ae_touch_ptr((void*)p);
32545  if( !ae_vector_init(&p->x0, 0, DT_REAL, _state, make_automatic) )
32546  return ae_false;
32547  if( !ae_vector_init(&p->x1, 0, DT_REAL, _state, make_automatic) )
32548  return ae_false;
32549  if( !ae_vector_init(&p->t, 0, DT_REAL, _state, make_automatic) )
32550  return ae_false;
32551  if( !ae_vector_init(&p->xbest, 0, DT_REAL, _state, make_automatic) )
32552  return ae_false;
32553  if( !_hqrndstate_init(&p->r, _state, make_automatic) )
32554  return ae_false;
32555  if( !ae_vector_init(&p->x, 0, DT_REAL, _state, make_automatic) )
32556  return ae_false;
32557  if( !ae_vector_init(&p->mv, 0, DT_REAL, _state, make_automatic) )
32558  return ae_false;
32559  if( !ae_vector_init(&p->mtv, 0, DT_REAL, _state, make_automatic) )
32560  return ae_false;
32561  if( !_rcommstate_init(&p->rstate, _state, make_automatic) )
32562  return ae_false;
32563  return ae_true;
32564 }
32565 
32566 
32567 ae_bool _normestimatorstate_init_copy(void* _dst, void* _src, ae_state *_state, ae_bool make_automatic)
32568 {
32569  normestimatorstate *dst = (normestimatorstate*)_dst;
32570  normestimatorstate *src = (normestimatorstate*)_src;
32571  dst->n = src->n;
32572  dst->m = src->m;
32573  dst->nstart = src->nstart;
32574  dst->nits = src->nits;
32575  dst->seedval = src->seedval;
32576  if( !ae_vector_init_copy(&dst->x0, &src->x0, _state, make_automatic) )
32577  return ae_false;
32578  if( !ae_vector_init_copy(&dst->x1, &src->x1, _state, make_automatic) )
32579  return ae_false;
32580  if( !ae_vector_init_copy(&dst->t, &src->t, _state, make_automatic) )
32581  return ae_false;
32582  if( !ae_vector_init_copy(&dst->xbest, &src->xbest, _state, make_automatic) )
32583  return ae_false;
32584  if( !_hqrndstate_init_copy(&dst->r, &src->r, _state, make_automatic) )
32585  return ae_false;
32586  if( !ae_vector_init_copy(&dst->x, &src->x, _state, make_automatic) )
32587  return ae_false;
32588  if( !ae_vector_init_copy(&dst->mv, &src->mv, _state, make_automatic) )
32589  return ae_false;
32590  if( !ae_vector_init_copy(&dst->mtv, &src->mtv, _state, make_automatic) )
32591  return ae_false;
32592  dst->needmv = src->needmv;
32593  dst->needmtv = src->needmtv;
32594  dst->repnorm = src->repnorm;
32595  if( !_rcommstate_init_copy(&dst->rstate, &src->rstate, _state, make_automatic) )
32596  return ae_false;
32597  return ae_true;
32598 }
32599 
32600 
32601 void _normestimatorstate_clear(void* _p)
32602 {
32603  normestimatorstate *p = (normestimatorstate*)_p;
32604  ae_touch_ptr((void*)p);
32605  ae_vector_clear(&p->x0);
32606  ae_vector_clear(&p->x1);
32607  ae_vector_clear(&p->t);
32608  ae_vector_clear(&p->xbest);
32609  _hqrndstate_clear(&p->r);
32610  ae_vector_clear(&p->x);
32611  ae_vector_clear(&p->mv);
32612  ae_vector_clear(&p->mtv);
32613  _rcommstate_clear(&p->rstate);
32614 }
32615 
32616 
32617 void _normestimatorstate_destroy(void* _p)
32618 {
32619  normestimatorstate *p = (normestimatorstate*)_p;
32620  ae_touch_ptr((void*)p);
32621  ae_vector_destroy(&p->x0);
32622  ae_vector_destroy(&p->x1);
32623  ae_vector_destroy(&p->t);
32624  ae_vector_destroy(&p->xbest);
32625  _hqrndstate_destroy(&p->r);
32626  ae_vector_destroy(&p->x);
32627  ae_vector_destroy(&p->mv);
32628  ae_vector_destroy(&p->mtv);
32629  _rcommstate_destroy(&p->rstate);
32630 }
32631 
32632 
32633 
32634 
32635 /*************************************************************************
32636 Determinant calculation of the matrix given by its LU decomposition.
32637 
32638 Input parameters:
32639  A - LU decomposition of the matrix (output of
32640  RMatrixLU subroutine).
32641  Pivots - table of permutations which were made during
32642  the LU decomposition.
32643  Output of RMatrixLU subroutine.
32644  N - (optional) size of matrix A:
32645  * if given, only principal NxN submatrix is processed and
32646  overwritten. other elements are unchanged.
32647  * if not given, automatically determined from matrix size
32648  (A must be square matrix)
32649 
32650 Result: matrix determinant.
32651 
32652  -- ALGLIB --
32653  Copyright 2005 by Bochkanov Sergey
32654 *************************************************************************/
32655 double rmatrixludet(/* Real */ ae_matrix* a,
32656  /* Integer */ ae_vector* pivots,
32657  ae_int_t n,
32658  ae_state *_state)
32659 {
32660  ae_int_t i;
32661  ae_int_t s;
32662  double result;
32663 
32664 
32665  ae_assert(n>=1, "RMatrixLUDet: N<1!", _state);
32666  ae_assert(pivots->cnt>=n, "RMatrixLUDet: Pivots array is too short!", _state);
32667  ae_assert(a->rows>=n, "RMatrixLUDet: rows(A)<N!", _state);
32668  ae_assert(a->cols>=n, "RMatrixLUDet: cols(A)<N!", _state);
32669  ae_assert(apservisfinitematrix(a, n, n, _state), "RMatrixLUDet: A contains infinite or NaN values!", _state);
32670  result = 1;
32671  s = 1;
32672  for(i=0; i<=n-1; i++)
32673  {
32674  result = result*a->ptr.pp_double[i][i];
32675  if( pivots->ptr.p_int[i]!=i )
32676  {
32677  s = -s;
32678  }
32679  }
32680  result = result*s;
32681  return result;
32682 }
32683 
32684 
32685 /*************************************************************************
32686 Calculation of the determinant of a general matrix
32687 
32688 Input parameters:
32689  A - matrix, array[0..N-1, 0..N-1]
32690  N - (optional) size of matrix A:
32691  * if given, only principal NxN submatrix is processed and
32692  overwritten. other elements are unchanged.
32693  * if not given, automatically determined from matrix size
32694  (A must be square matrix)
32695 
32696 Result: determinant of matrix A.
32697 
32698  -- ALGLIB --
32699  Copyright 2005 by Bochkanov Sergey
32700 *************************************************************************/
32701 double rmatrixdet(/* Real */ ae_matrix* a,
32702  ae_int_t n,
32703  ae_state *_state)
32704 {
32705  ae_frame _frame_block;
32706  ae_matrix _a;
32707  ae_vector pivots;
32708  double result;
32709 
32710  ae_frame_make(_state, &_frame_block);
32711  ae_matrix_init_copy(&_a, a, _state, ae_true);
32712  a = &_a;
32713  ae_vector_init(&pivots, 0, DT_INT, _state, ae_true);
32714 
32715  ae_assert(n>=1, "RMatrixDet: N<1!", _state);
32716  ae_assert(a->rows>=n, "RMatrixDet: rows(A)<N!", _state);
32717  ae_assert(a->cols>=n, "RMatrixDet: cols(A)<N!", _state);
32718  ae_assert(apservisfinitematrix(a, n, n, _state), "RMatrixDet: A contains infinite or NaN values!", _state);
32719  rmatrixlu(a, n, n, &pivots, _state);
32720  result = rmatrixludet(a, &pivots, n, _state);
32721  ae_frame_leave(_state);
32722  return result;
32723 }
32724 
32725 
32726 /*************************************************************************
32727 Determinant calculation of the matrix given by its LU decomposition.
32728 
32729 Input parameters:
32730  A - LU decomposition of the matrix (output of
32731  RMatrixLU subroutine).
32732  Pivots - table of permutations which were made during
32733  the LU decomposition.
32734  Output of RMatrixLU subroutine.
32735  N - (optional) size of matrix A:
32736  * if given, only principal NxN submatrix is processed and
32737  overwritten. other elements are unchanged.
32738  * if not given, automatically determined from matrix size
32739  (A must be square matrix)
32740 
32741 Result: matrix determinant.
32742 
32743  -- ALGLIB --
32744  Copyright 2005 by Bochkanov Sergey
32745 *************************************************************************/
32746 ae_complex cmatrixludet(/* Complex */ ae_matrix* a,
32747  /* Integer */ ae_vector* pivots,
32748  ae_int_t n,
32749  ae_state *_state)
32750 {
32751  ae_int_t i;
32752  ae_int_t s;
32753  ae_complex result;
32754 
32755 
32756  ae_assert(n>=1, "CMatrixLUDet: N<1!", _state);
32757  ae_assert(pivots->cnt>=n, "CMatrixLUDet: Pivots array is too short!", _state);
32758  ae_assert(a->rows>=n, "CMatrixLUDet: rows(A)<N!", _state);
32759  ae_assert(a->cols>=n, "CMatrixLUDet: cols(A)<N!", _state);
32760  ae_assert(apservisfinitecmatrix(a, n, n, _state), "CMatrixLUDet: A contains infinite or NaN values!", _state);
32761  result = ae_complex_from_d(1);
32762  s = 1;
32763  for(i=0; i<=n-1; i++)
32764  {
32765  result = ae_c_mul(result,a->ptr.pp_complex[i][i]);
32766  if( pivots->ptr.p_int[i]!=i )
32767  {
32768  s = -s;
32769  }
32770  }
32771  result = ae_c_mul_d(result,s);
32772  return result;
32773 }
32774 
32775 
32776 /*************************************************************************
32777 Calculation of the determinant of a general matrix
32778 
32779 Input parameters:
32780  A - matrix, array[0..N-1, 0..N-1]
32781  N - (optional) size of matrix A:
32782  * if given, only principal NxN submatrix is processed and
32783  overwritten. other elements are unchanged.
32784  * if not given, automatically determined from matrix size
32785  (A must be square matrix)
32786 
32787 Result: determinant of matrix A.
32788 
32789  -- ALGLIB --
32790  Copyright 2005 by Bochkanov Sergey
32791 *************************************************************************/
32792 ae_complex cmatrixdet(/* Complex */ ae_matrix* a,
32793  ae_int_t n,
32794  ae_state *_state)
32795 {
32796  ae_frame _frame_block;
32797  ae_matrix _a;
32798  ae_vector pivots;
32799  ae_complex result;
32800 
32801  ae_frame_make(_state, &_frame_block);
32802  ae_matrix_init_copy(&_a, a, _state, ae_true);
32803  a = &_a;
32804  ae_vector_init(&pivots, 0, DT_INT, _state, ae_true);
32805 
32806  ae_assert(n>=1, "CMatrixDet: N<1!", _state);
32807  ae_assert(a->rows>=n, "CMatrixDet: rows(A)<N!", _state);
32808  ae_assert(a->cols>=n, "CMatrixDet: cols(A)<N!", _state);
32809  ae_assert(apservisfinitecmatrix(a, n, n, _state), "CMatrixDet: A contains infinite or NaN values!", _state);
32810  cmatrixlu(a, n, n, &pivots, _state);
32811  result = cmatrixludet(a, &pivots, n, _state);
32812  ae_frame_leave(_state);
32813  return result;
32814 }
32815 
32816 
32817 /*************************************************************************
32818 Determinant calculation of the matrix given by the Cholesky decomposition.
32819 
32820 Input parameters:
32821  A - Cholesky decomposition,
32822  output of SMatrixCholesky subroutine.
32823  N - (optional) size of matrix A:
32824  * if given, only principal NxN submatrix is processed and
32825  overwritten. other elements are unchanged.
32826  * if not given, automatically determined from matrix size
32827  (A must be square matrix)
32828 
32829 As the determinant is equal to the product of squares of diagonal elements,
32830 it’s not necessary to specify which triangle - lower or upper - the matrix
32831 is stored in.
32832 
32833 Result:
32834  matrix determinant.
32835 
32836  -- ALGLIB --
32837  Copyright 2005-2008 by Bochkanov Sergey
32838 *************************************************************************/
32839 double spdmatrixcholeskydet(/* Real */ ae_matrix* a,
32840  ae_int_t n,
32841  ae_state *_state)
32842 {
32843  ae_int_t i;
32844  ae_bool f;
32845  double result;
32846 
32847 
32848  ae_assert(n>=1, "SPDMatrixCholeskyDet: N<1!", _state);
32849  ae_assert(a->rows>=n, "SPDMatrixCholeskyDet: rows(A)<N!", _state);
32850  ae_assert(a->cols>=n, "SPDMatrixCholeskyDet: cols(A)<N!", _state);
32851  f = ae_true;
32852  for(i=0; i<=n-1; i++)
32853  {
32854  f = f&&ae_isfinite(a->ptr.pp_double[i][i], _state);
32855  }
32856  ae_assert(f, "SPDMatrixCholeskyDet: A contains infinite or NaN values!", _state);
32857  result = 1;
32858  for(i=0; i<=n-1; i++)
32859  {
32860  result = result*ae_sqr(a->ptr.pp_double[i][i], _state);
32861  }
32862  return result;
32863 }
32864 
32865 
32866 /*************************************************************************
32867 Determinant calculation of the symmetric positive definite matrix.
32868 
32869 Input parameters:
32870  A - matrix. Array with elements [0..N-1, 0..N-1].
32871  N - (optional) size of matrix A:
32872  * if given, only principal NxN submatrix is processed and
32873  overwritten. other elements are unchanged.
32874  * if not given, automatically determined from matrix size
32875  (A must be square matrix)
32876  IsUpper - (optional) storage type:
32877  * if True, symmetric matrix A is given by its upper
32878  triangle, and the lower triangle isn’t used/changed by
32879  function
32880  * if False, symmetric matrix A is given by its lower
32881  triangle, and the upper triangle isn’t used/changed by
32882  function
32883  * if not given, both lower and upper triangles must be
32884  filled.
32885 
32886 Result:
32887  determinant of matrix A.
32888  If matrix A is not positive definite, exception is thrown.
32889 
32890  -- ALGLIB --
32891  Copyright 2005-2008 by Bochkanov Sergey
32892 *************************************************************************/
32893 double spdmatrixdet(/* Real */ ae_matrix* a,
32894  ae_int_t n,
32895  ae_bool isupper,
32896  ae_state *_state)
32897 {
32898  ae_frame _frame_block;
32899  ae_matrix _a;
32900  ae_bool b;
32901  double result;
32902 
32903  ae_frame_make(_state, &_frame_block);
32904  ae_matrix_init_copy(&_a, a, _state, ae_true);
32905  a = &_a;
32906 
32907  ae_assert(n>=1, "SPDMatrixDet: N<1!", _state);
32908  ae_assert(a->rows>=n, "SPDMatrixDet: rows(A)<N!", _state);
32909  ae_assert(a->cols>=n, "SPDMatrixDet: cols(A)<N!", _state);
32910  ae_assert(isfinitertrmatrix(a, n, isupper, _state), "SPDMatrixDet: A contains infinite or NaN values!", _state);
32911  b = spdmatrixcholesky(a, n, isupper, _state);
32912  ae_assert(b, "SPDMatrixDet: A is not SPD!", _state);
32913  result = spdmatrixcholeskydet(a, n, _state);
32914  ae_frame_leave(_state);
32915  return result;
32916 }
32917 
32918 
32919 
32920 
32921 /*************************************************************************
32922 Algorithm for solving the following generalized symmetric positive-definite
32923 eigenproblem:
32924  A*x = lambda*B*x (1) or
32925  A*B*x = lambda*x (2) or
32926  B*A*x = lambda*x (3).
32927 where A is a symmetric matrix, B - symmetric positive-definite matrix.
32928 The problem is solved by reducing it to an ordinary symmetric eigenvalue
32929 problem.
32930 
32931 Input parameters:
32932  A - symmetric matrix which is given by its upper or lower
32933  triangular part.
32934  Array whose indexes range within [0..N-1, 0..N-1].
32935  N - size of matrices A and B.
32936  IsUpperA - storage format of matrix A.
32937  B - symmetric positive-definite matrix which is given by
32938  its upper or lower triangular part.
32939  Array whose indexes range within [0..N-1, 0..N-1].
32940  IsUpperB - storage format of matrix B.
32941  ZNeeded - if ZNeeded is equal to:
32942  * 0, the eigenvectors are not returned;
32943  * 1, the eigenvectors are returned.
32944  ProblemType - if ProblemType is equal to:
32945  * 1, the following problem is solved: A*x = lambda*B*x;
32946  * 2, the following problem is solved: A*B*x = lambda*x;
32947  * 3, the following problem is solved: B*A*x = lambda*x.
32948 
32949 Output parameters:
32950  D - eigenvalues in ascending order.
32951  Array whose index ranges within [0..N-1].
32952  Z - if ZNeeded is equal to:
32953  * 0, Z hasn’t changed;
32954  * 1, Z contains eigenvectors.
32955  Array whose indexes range within [0..N-1, 0..N-1].
32956  The eigenvectors are stored in matrix columns. It should
32957  be noted that the eigenvectors in such problems do not
32958  form an orthogonal system.
32959 
32960 Result:
32961  True, if the problem was solved successfully.
32962  False, if the error occurred during the Cholesky decomposition of matrix
32963  B (the matrix isn’t positive-definite) or during the work of the iterative
32964  algorithm for solving the symmetric eigenproblem.
32965 
32966 See also the GeneralizedSymmetricDefiniteEVDReduce subroutine.
32967 
32968  -- ALGLIB --
32969  Copyright 1.28.2006 by Bochkanov Sergey
32970 *************************************************************************/
32971 ae_bool smatrixgevd(/* Real */ ae_matrix* a,
32972  ae_int_t n,
32973  ae_bool isuppera,
32974  /* Real */ ae_matrix* b,
32975  ae_bool isupperb,
32976  ae_int_t zneeded,
32977  ae_int_t problemtype,
32978  /* Real */ ae_vector* d,
32979  /* Real */ ae_matrix* z,
32980  ae_state *_state)
32981 {
32982  ae_frame _frame_block;
32983  ae_matrix _a;
32984  ae_matrix r;
32985  ae_matrix t;
32986  ae_bool isupperr;
32987  ae_int_t j1;
32988  ae_int_t j2;
32989  ae_int_t j1inc;
32990  ae_int_t j2inc;
32991  ae_int_t i;
32992  ae_int_t j;
32993  double v;
32994  ae_bool result;
32995 
32996  ae_frame_make(_state, &_frame_block);
32997  ae_matrix_init_copy(&_a, a, _state, ae_true);
32998  a = &_a;
32999  ae_vector_clear(d);
33000  ae_matrix_clear(z);
33001  ae_matrix_init(&r, 0, 0, DT_REAL, _state, ae_true);
33002  ae_matrix_init(&t, 0, 0, DT_REAL, _state, ae_true);
33003 
33004 
33005  /*
33006  * Reduce and solve
33007  */
33008  result = smatrixgevdreduce(a, n, isuppera, b, isupperb, problemtype, &r, &isupperr, _state);
33009  if( !result )
33010  {
33011  ae_frame_leave(_state);
33012  return result;
33013  }
33014  result = smatrixevd(a, n, zneeded, isuppera, d, &t, _state);
33015  if( !result )
33016  {
33017  ae_frame_leave(_state);
33018  return result;
33019  }
33020 
33021  /*
33022  * Transform eigenvectors if needed
33023  */
33024  if( zneeded!=0 )
33025  {
33026 
33027  /*
33028  * fill Z with zeros
33029  */
33030  ae_matrix_set_length(z, n-1+1, n-1+1, _state);
33031  for(j=0; j<=n-1; j++)
33032  {
33033  z->ptr.pp_double[0][j] = 0.0;
33034  }
33035  for(i=1; i<=n-1; i++)
33036  {
33037  ae_v_move(&z->ptr.pp_double[i][0], 1, &z->ptr.pp_double[0][0], 1, ae_v_len(0,n-1));
33038  }
33039 
33040  /*
33041  * Setup R properties
33042  */
33043  if( isupperr )
33044  {
33045  j1 = 0;
33046  j2 = n-1;
33047  j1inc = 1;
33048  j2inc = 0;
33049  }
33050  else
33051  {
33052  j1 = 0;
33053  j2 = 0;
33054  j1inc = 0;
33055  j2inc = 1;
33056  }
33057 
33058  /*
33059  * Calculate R*Z
33060  */
33061  for(i=0; i<=n-1; i++)
33062  {
33063  for(j=j1; j<=j2; j++)
33064  {
33065  v = r.ptr.pp_double[i][j];
33066  ae_v_addd(&z->ptr.pp_double[i][0], 1, &t.ptr.pp_double[j][0], 1, ae_v_len(0,n-1), v);
33067  }
33068  j1 = j1+j1inc;
33069  j2 = j2+j2inc;
33070  }
33071  }
33072  ae_frame_leave(_state);
33073  return result;
33074 }
33075 
33076 
33077 /*************************************************************************
33078 Algorithm for reduction of the following generalized symmetric positive-
33079 definite eigenvalue problem:
33080  A*x = lambda*B*x (1) or
33081  A*B*x = lambda*x (2) or
33082  B*A*x = lambda*x (3)
33083 to the symmetric eigenvalues problem C*y = lambda*y (eigenvalues of this and
33084 the given problems are the same, and the eigenvectors of the given problem
33085 could be obtained by multiplying the obtained eigenvectors by the
33086 transformation matrix x = R*y).
33087 
33088 Here A is a symmetric matrix, B - symmetric positive-definite matrix.
33089 
33090 Input parameters:
33091  A - symmetric matrix which is given by its upper or lower
33092  triangular part.
33093  Array whose indexes range within [0..N-1, 0..N-1].
33094  N - size of matrices A and B.
33095  IsUpperA - storage format of matrix A.
33096  B - symmetric positive-definite matrix which is given by
33097  its upper or lower triangular part.
33098  Array whose indexes range within [0..N-1, 0..N-1].
33099  IsUpperB - storage format of matrix B.
33100  ProblemType - if ProblemType is equal to:
33101  * 1, the following problem is solved: A*x = lambda*B*x;
33102  * 2, the following problem is solved: A*B*x = lambda*x;
33103  * 3, the following problem is solved: B*A*x = lambda*x.
33104 
33105 Output parameters:
33106  A - symmetric matrix which is given by its upper or lower
33107  triangle depending on IsUpperA. Contains matrix C.
33108  Array whose indexes range within [0..N-1, 0..N-1].
33109  R - upper triangular or low triangular transformation matrix
33110  which is used to obtain the eigenvectors of a given problem
33111  as the product of eigenvectors of C (from the right) and
33112  matrix R (from the left). If the matrix is upper
33113  triangular, the elements below the main diagonal
33114  are equal to 0 (and vice versa). Thus, we can perform
33115  the multiplication without taking into account the
33116  internal structure (which is an easier though less
33117  effective way).
33118  Array whose indexes range within [0..N-1, 0..N-1].
33119  IsUpperR - type of matrix R (upper or lower triangular).
33120 
33121 Result:
33122  True, if the problem was reduced successfully.
33123  False, if the error occurred during the Cholesky decomposition of
33124  matrix B (the matrix is not positive-definite).
33125 
33126  -- ALGLIB --
33127  Copyright 1.28.2006 by Bochkanov Sergey
33128 *************************************************************************/
33129 ae_bool smatrixgevdreduce(/* Real */ ae_matrix* a,
33130  ae_int_t n,
33131  ae_bool isuppera,
33132  /* Real */ ae_matrix* b,
33133  ae_bool isupperb,
33134  ae_int_t problemtype,
33135  /* Real */ ae_matrix* r,
33136  ae_bool* isupperr,
33137  ae_state *_state)
33138 {
33139  ae_frame _frame_block;
33140  ae_matrix t;
33141  ae_vector w1;
33142  ae_vector w2;
33143  ae_vector w3;
33144  ae_int_t i;
33145  ae_int_t j;
33146  double v;
33147  matinvreport rep;
33148  ae_int_t info;
33149  ae_bool result;
33150 
33151  ae_frame_make(_state, &_frame_block);
33152  ae_matrix_clear(r);
33153  *isupperr = ae_false;
33154  ae_matrix_init(&t, 0, 0, DT_REAL, _state, ae_true);
33155  ae_vector_init(&w1, 0, DT_REAL, _state, ae_true);
33156  ae_vector_init(&w2, 0, DT_REAL, _state, ae_true);
33157  ae_vector_init(&w3, 0, DT_REAL, _state, ae_true);
33158  _matinvreport_init(&rep, _state, ae_true);
33159 
33160  ae_assert(n>0, "SMatrixGEVDReduce: N<=0!", _state);
33161  ae_assert((problemtype==1||problemtype==2)||problemtype==3, "SMatrixGEVDReduce: incorrect ProblemType!", _state);
33162  result = ae_true;
33163 
33164  /*
33165  * Problem 1: A*x = lambda*B*x
33166  *
33167  * Reducing to:
33168  * C*y = lambda*y
33169  * C = L^(-1) * A * L^(-T)
33170  * x = L^(-T) * y
33171  */
33172  if( problemtype==1 )
33173  {
33174 
33175  /*
33176  * Factorize B in T: B = LL'
33177  */
33178  ae_matrix_set_length(&t, n-1+1, n-1+1, _state);
33179  if( isupperb )
33180  {
33181  for(i=0; i<=n-1; i++)
33182  {
33183  ae_v_move(&t.ptr.pp_double[i][i], t.stride, &b->ptr.pp_double[i][i], 1, ae_v_len(i,n-1));
33184  }
33185  }
33186  else
33187  {
33188  for(i=0; i<=n-1; i++)
33189  {
33190  ae_v_move(&t.ptr.pp_double[i][0], 1, &b->ptr.pp_double[i][0], 1, ae_v_len(0,i));
33191  }
33192  }
33193  if( !spdmatrixcholesky(&t, n, ae_false, _state) )
33194  {
33195  result = ae_false;
33196  ae_frame_leave(_state);
33197  return result;
33198  }
33199 
33200  /*
33201  * Invert L in T
33202  */
33203  rmatrixtrinverse(&t, n, ae_false, ae_false, &info, &rep, _state);
33204  if( info<=0 )
33205  {
33206  result = ae_false;
33207  ae_frame_leave(_state);
33208  return result;
33209  }
33210 
33211  /*
33212  * Build L^(-1) * A * L^(-T) in R
33213  */
33214  ae_vector_set_length(&w1, n+1, _state);
33215  ae_vector_set_length(&w2, n+1, _state);
33216  ae_matrix_set_length(r, n-1+1, n-1+1, _state);
33217  for(j=1; j<=n; j++)
33218  {
33219 
33220  /*
33221  * Form w2 = A * l'(j) (here l'(j) is j-th column of L^(-T))
33222  */
33223  ae_v_move(&w1.ptr.p_double[1], 1, &t.ptr.pp_double[j-1][0], 1, ae_v_len(1,j));
33224  symmetricmatrixvectormultiply(a, isuppera, 0, j-1, &w1, 1.0, &w2, _state);
33225  if( isuppera )
33226  {
33227  matrixvectormultiply(a, 0, j-1, j, n-1, ae_true, &w1, 1, j, 1.0, &w2, j+1, n, 0.0, _state);
33228  }
33229  else
33230  {
33231  matrixvectormultiply(a, j, n-1, 0, j-1, ae_false, &w1, 1, j, 1.0, &w2, j+1, n, 0.0, _state);
33232  }
33233 
33234  /*
33235  * Form l(i)*w2 (here l(i) is i-th row of L^(-1))
33236  */
33237  for(i=1; i<=n; i++)
33238  {
33239  v = ae_v_dotproduct(&t.ptr.pp_double[i-1][0], 1, &w2.ptr.p_double[1], 1, ae_v_len(0,i-1));
33240  r->ptr.pp_double[i-1][j-1] = v;
33241  }
33242  }
33243 
33244  /*
33245  * Copy R to A
33246  */
33247  for(i=0; i<=n-1; i++)
33248  {
33249  ae_v_move(&a->ptr.pp_double[i][0], 1, &r->ptr.pp_double[i][0], 1, ae_v_len(0,n-1));
33250  }
33251 
33252  /*
33253  * Copy L^(-1) from T to R and transpose
33254  */
33255  *isupperr = ae_true;
33256  for(i=0; i<=n-1; i++)
33257  {
33258  for(j=0; j<=i-1; j++)
33259  {
33260  r->ptr.pp_double[i][j] = 0;
33261  }
33262  }
33263  for(i=0; i<=n-1; i++)
33264  {
33265  ae_v_move(&r->ptr.pp_double[i][i], 1, &t.ptr.pp_double[i][i], t.stride, ae_v_len(i,n-1));
33266  }
33267  ae_frame_leave(_state);
33268  return result;
33269  }
33270 
33271  /*
33272  * Problem 2: A*B*x = lambda*x
33273  * or
33274  * problem 3: B*A*x = lambda*x
33275  *
33276  * Reducing to:
33277  * C*y = lambda*y
33278  * C = U * A * U'
33279  * B = U'* U
33280  */
33281  if( problemtype==2||problemtype==3 )
33282  {
33283 
33284  /*
33285  * Factorize B in T: B = U'*U
33286  */
33287  ae_matrix_set_length(&t, n-1+1, n-1+1, _state);
33288  if( isupperb )
33289  {
33290  for(i=0; i<=n-1; i++)
33291  {
33292  ae_v_move(&t.ptr.pp_double[i][i], 1, &b->ptr.pp_double[i][i], 1, ae_v_len(i,n-1));
33293  }
33294  }
33295  else
33296  {
33297  for(i=0; i<=n-1; i++)
33298  {
33299  ae_v_move(&t.ptr.pp_double[i][i], 1, &b->ptr.pp_double[i][i], b->stride, ae_v_len(i,n-1));
33300  }
33301  }
33302  if( !spdmatrixcholesky(&t, n, ae_true, _state) )
33303  {
33304  result = ae_false;
33305  ae_frame_leave(_state);
33306  return result;
33307  }
33308 
33309  /*
33310  * Build U * A * U' in R
33311  */
33312  ae_vector_set_length(&w1, n+1, _state);
33313  ae_vector_set_length(&w2, n+1, _state);
33314  ae_vector_set_length(&w3, n+1, _state);
33315  ae_matrix_set_length(r, n-1+1, n-1+1, _state);
33316  for(j=1; j<=n; j++)
33317  {
33318 
33319  /*
33320  * Form w2 = A * u'(j) (here u'(j) is j-th column of U')
33321  */
33322  ae_v_move(&w1.ptr.p_double[1], 1, &t.ptr.pp_double[j-1][j-1], 1, ae_v_len(1,n-j+1));
33323  symmetricmatrixvectormultiply(a, isuppera, j-1, n-1, &w1, 1.0, &w3, _state);
33324  ae_v_move(&w2.ptr.p_double[j], 1, &w3.ptr.p_double[1], 1, ae_v_len(j,n));
33325  ae_v_move(&w1.ptr.p_double[j], 1, &t.ptr.pp_double[j-1][j-1], 1, ae_v_len(j,n));
33326  if( isuppera )
33327  {
33328  matrixvectormultiply(a, 0, j-2, j-1, n-1, ae_false, &w1, j, n, 1.0, &w2, 1, j-1, 0.0, _state);
33329  }
33330  else
33331  {
33332  matrixvectormultiply(a, j-1, n-1, 0, j-2, ae_true, &w1, j, n, 1.0, &w2, 1, j-1, 0.0, _state);
33333  }
33334 
33335  /*
33336  * Form u(i)*w2 (here u(i) is i-th row of U)
33337  */
33338  for(i=1; i<=n; i++)
33339  {
33340  v = ae_v_dotproduct(&t.ptr.pp_double[i-1][i-1], 1, &w2.ptr.p_double[i], 1, ae_v_len(i-1,n-1));
33341  r->ptr.pp_double[i-1][j-1] = v;
33342  }
33343  }
33344 
33345  /*
33346  * Copy R to A
33347  */
33348  for(i=0; i<=n-1; i++)
33349  {
33350  ae_v_move(&a->ptr.pp_double[i][0], 1, &r->ptr.pp_double[i][0], 1, ae_v_len(0,n-1));
33351  }
33352  if( problemtype==2 )
33353  {
33354 
33355  /*
33356  * Invert U in T
33357  */
33358  rmatrixtrinverse(&t, n, ae_true, ae_false, &info, &rep, _state);
33359  if( info<=0 )
33360  {
33361  result = ae_false;
33362  ae_frame_leave(_state);
33363  return result;
33364  }
33365 
33366  /*
33367  * Copy U^-1 from T to R
33368  */
33369  *isupperr = ae_true;
33370  for(i=0; i<=n-1; i++)
33371  {
33372  for(j=0; j<=i-1; j++)
33373  {
33374  r->ptr.pp_double[i][j] = 0;
33375  }
33376  }
33377  for(i=0; i<=n-1; i++)
33378  {
33379  ae_v_move(&r->ptr.pp_double[i][i], 1, &t.ptr.pp_double[i][i], 1, ae_v_len(i,n-1));
33380  }
33381  }
33382  else
33383  {
33384 
33385  /*
33386  * Copy U from T to R and transpose
33387  */
33388  *isupperr = ae_false;
33389  for(i=0; i<=n-1; i++)
33390  {
33391  for(j=i+1; j<=n-1; j++)
33392  {
33393  r->ptr.pp_double[i][j] = 0;
33394  }
33395  }
33396  for(i=0; i<=n-1; i++)
33397  {
33398  ae_v_move(&r->ptr.pp_double[i][i], r->stride, &t.ptr.pp_double[i][i], 1, ae_v_len(i,n-1));
33399  }
33400  }
33401  }
33402  ae_frame_leave(_state);
33403  return result;
33404 }
33405 
33406 
33407 
33408 
33409 /*************************************************************************
33410 Inverse matrix update by the Sherman-Morrison formula
33411 
33412 The algorithm updates matrix A^-1 when adding a number to an element
33413 of matrix A.
33414 
33415 Input parameters:
33416  InvA - inverse of matrix A.
33417  Array whose indexes range within [0..N-1, 0..N-1].
33418  N - size of matrix A.
33419  UpdRow - row where the element to be updated is stored.
33420  UpdColumn - column where the element to be updated is stored.
33421  UpdVal - a number to be added to the element.
33422 
33423 
33424 Output parameters:
33425  InvA - inverse of modified matrix A.
33426 
33427  -- ALGLIB --
33428  Copyright 2005 by Bochkanov Sergey
33429 *************************************************************************/
33430 void rmatrixinvupdatesimple(/* Real */ ae_matrix* inva,
33431  ae_int_t n,
33432  ae_int_t updrow,
33433  ae_int_t updcolumn,
33434  double updval,
33435  ae_state *_state)
33436 {
33437  ae_frame _frame_block;
33438  ae_vector t1;
33439  ae_vector t2;
33440  ae_int_t i;
33441  double lambdav;
33442  double vt;
33443 
33444  ae_frame_make(_state, &_frame_block);
33445  ae_vector_init(&t1, 0, DT_REAL, _state, ae_true);
33446  ae_vector_init(&t2, 0, DT_REAL, _state, ae_true);
33447 
33448  ae_assert(updrow>=0&&updrow<n, "RMatrixInvUpdateSimple: incorrect UpdRow!", _state);
33449  ae_assert(updcolumn>=0&&updcolumn<n, "RMatrixInvUpdateSimple: incorrect UpdColumn!", _state);
33450  ae_vector_set_length(&t1, n-1+1, _state);
33451  ae_vector_set_length(&t2, n-1+1, _state);
33452 
33453  /*
33454  * T1 = InvA * U
33455  */
33456  ae_v_move(&t1.ptr.p_double[0], 1, &inva->ptr.pp_double[0][updrow], inva->stride, ae_v_len(0,n-1));
33457 
33458  /*
33459  * T2 = v*InvA
33460  */
33461  ae_v_move(&t2.ptr.p_double[0], 1, &inva->ptr.pp_double[updcolumn][0], 1, ae_v_len(0,n-1));
33462 
33463  /*
33464  * Lambda = v * InvA * U
33465  */
33466  lambdav = updval*inva->ptr.pp_double[updcolumn][updrow];
33467 
33468  /*
33469  * InvA = InvA - correction
33470  */
33471  for(i=0; i<=n-1; i++)
33472  {
33473  vt = updval*t1.ptr.p_double[i];
33474  vt = vt/(1+lambdav);
33475  ae_v_subd(&inva->ptr.pp_double[i][0], 1, &t2.ptr.p_double[0], 1, ae_v_len(0,n-1), vt);
33476  }
33477  ae_frame_leave(_state);
33478 }
33479 
33480 
33481 /*************************************************************************
33482 Inverse matrix update by the Sherman-Morrison formula
33483 
33484 The algorithm updates matrix A^-1 when adding a vector to a row
33485 of matrix A.
33486 
33487 Input parameters:
33488  InvA - inverse of matrix A.
33489  Array whose indexes range within [0..N-1, 0..N-1].
33490  N - size of matrix A.
33491  UpdRow - the row of A whose vector V was added.
33492  0 <= Row <= N-1
33493  V - the vector to be added to a row.
33494  Array whose index ranges within [0..N-1].
33495 
33496 Output parameters:
33497  InvA - inverse of modified matrix A.
33498 
33499  -- ALGLIB --
33500  Copyright 2005 by Bochkanov Sergey
33501 *************************************************************************/
33502 void rmatrixinvupdaterow(/* Real */ ae_matrix* inva,
33503  ae_int_t n,
33504  ae_int_t updrow,
33505  /* Real */ ae_vector* v,
33506  ae_state *_state)
33507 {
33508  ae_frame _frame_block;
33509  ae_vector t1;
33510  ae_vector t2;
33511  ae_int_t i;
33512  ae_int_t j;
33513  double lambdav;
33514  double vt;
33515 
33516  ae_frame_make(_state, &_frame_block);
33517  ae_vector_init(&t1, 0, DT_REAL, _state, ae_true);
33518  ae_vector_init(&t2, 0, DT_REAL, _state, ae_true);
33519 
33520  ae_vector_set_length(&t1, n-1+1, _state);
33521  ae_vector_set_length(&t2, n-1+1, _state);
33522 
33523  /*
33524  * T1 = InvA * U
33525  */
33526  ae_v_move(&t1.ptr.p_double[0], 1, &inva->ptr.pp_double[0][updrow], inva->stride, ae_v_len(0,n-1));
33527 
33528  /*
33529  * T2 = v*InvA
33530  * Lambda = v * InvA * U
33531  */
33532  for(j=0; j<=n-1; j++)
33533  {
33534  vt = ae_v_dotproduct(&v->ptr.p_double[0], 1, &inva->ptr.pp_double[0][j], inva->stride, ae_v_len(0,n-1));
33535  t2.ptr.p_double[j] = vt;
33536  }
33537  lambdav = t2.ptr.p_double[updrow];
33538 
33539  /*
33540  * InvA = InvA - correction
33541  */
33542  for(i=0; i<=n-1; i++)
33543  {
33544  vt = t1.ptr.p_double[i]/(1+lambdav);
33545  ae_v_subd(&inva->ptr.pp_double[i][0], 1, &t2.ptr.p_double[0], 1, ae_v_len(0,n-1), vt);
33546  }
33547  ae_frame_leave(_state);
33548 }
33549 
33550 
33551 /*************************************************************************
33552 Inverse matrix update by the Sherman-Morrison formula
33553 
33554 The algorithm updates matrix A^-1 when adding a vector to a column
33555 of matrix A.
33556 
33557 Input parameters:
33558  InvA - inverse of matrix A.
33559  Array whose indexes range within [0..N-1, 0..N-1].
33560  N - size of matrix A.
33561  UpdColumn - the column of A whose vector U was added.
33562  0 <= UpdColumn <= N-1
33563  U - the vector to be added to a column.
33564  Array whose index ranges within [0..N-1].
33565 
33566 Output parameters:
33567  InvA - inverse of modified matrix A.
33568 
33569  -- ALGLIB --
33570  Copyright 2005 by Bochkanov Sergey
33571 *************************************************************************/
33572 void rmatrixinvupdatecolumn(/* Real */ ae_matrix* inva,
33573  ae_int_t n,
33574  ae_int_t updcolumn,
33575  /* Real */ ae_vector* u,
33576  ae_state *_state)
33577 {
33578  ae_frame _frame_block;
33579  ae_vector t1;
33580  ae_vector t2;
33581  ae_int_t i;
33582  double lambdav;
33583  double vt;
33584 
33585  ae_frame_make(_state, &_frame_block);
33586  ae_vector_init(&t1, 0, DT_REAL, _state, ae_true);
33587  ae_vector_init(&t2, 0, DT_REAL, _state, ae_true);
33588 
33589  ae_vector_set_length(&t1, n-1+1, _state);
33590  ae_vector_set_length(&t2, n-1+1, _state);
33591 
33592  /*
33593  * T1 = InvA * U
33594  * Lambda = v * InvA * U
33595  */
33596  for(i=0; i<=n-1; i++)
33597  {
33598  vt = ae_v_dotproduct(&inva->ptr.pp_double[i][0], 1, &u->ptr.p_double[0], 1, ae_v_len(0,n-1));
33599  t1.ptr.p_double[i] = vt;
33600  }
33601  lambdav = t1.ptr.p_double[updcolumn];
33602 
33603  /*
33604  * T2 = v*InvA
33605  */
33606  ae_v_move(&t2.ptr.p_double[0], 1, &inva->ptr.pp_double[updcolumn][0], 1, ae_v_len(0,n-1));
33607 
33608  /*
33609  * InvA = InvA - correction
33610  */
33611  for(i=0; i<=n-1; i++)
33612  {
33613  vt = t1.ptr.p_double[i]/(1+lambdav);
33614  ae_v_subd(&inva->ptr.pp_double[i][0], 1, &t2.ptr.p_double[0], 1, ae_v_len(0,n-1), vt);
33615  }
33616  ae_frame_leave(_state);
33617 }
33618 
33619 
33620 /*************************************************************************
33621 Inverse matrix update by the Sherman-Morrison formula
33622 
33623 The algorithm computes the inverse of matrix A+u*v’ by using the given matrix
33624 A^-1 and the vectors u and v.
33625 
33626 Input parameters:
33627  InvA - inverse of matrix A.
33628  Array whose indexes range within [0..N-1, 0..N-1].
33629  N - size of matrix A.
33630  U - the vector modifying the matrix.
33631  Array whose index ranges within [0..N-1].
33632  V - the vector modifying the matrix.
33633  Array whose index ranges within [0..N-1].
33634 
33635 Output parameters:
33636  InvA - inverse of matrix A + u*v'.
33637 
33638  -- ALGLIB --
33639  Copyright 2005 by Bochkanov Sergey
33640 *************************************************************************/
33641 void rmatrixinvupdateuv(/* Real */ ae_matrix* inva,
33642  ae_int_t n,
33643  /* Real */ ae_vector* u,
33644  /* Real */ ae_vector* v,
33645  ae_state *_state)
33646 {
33647  ae_frame _frame_block;
33648  ae_vector t1;
33649  ae_vector t2;
33650  ae_int_t i;
33651  ae_int_t j;
33652  double lambdav;
33653  double vt;
33654 
33655  ae_frame_make(_state, &_frame_block);
33656  ae_vector_init(&t1, 0, DT_REAL, _state, ae_true);
33657  ae_vector_init(&t2, 0, DT_REAL, _state, ae_true);
33658 
33659  ae_vector_set_length(&t1, n-1+1, _state);
33660  ae_vector_set_length(&t2, n-1+1, _state);
33661 
33662  /*
33663  * T1 = InvA * U
33664  * Lambda = v * T1
33665  */
33666  for(i=0; i<=n-1; i++)
33667  {
33668  vt = ae_v_dotproduct(&inva->ptr.pp_double[i][0], 1, &u->ptr.p_double[0], 1, ae_v_len(0,n-1));
33669  t1.ptr.p_double[i] = vt;
33670  }
33671  lambdav = ae_v_dotproduct(&v->ptr.p_double[0], 1, &t1.ptr.p_double[0], 1, ae_v_len(0,n-1));
33672 
33673  /*
33674  * T2 = v*InvA
33675  */
33676  for(j=0; j<=n-1; j++)
33677  {
33678  vt = ae_v_dotproduct(&v->ptr.p_double[0], 1, &inva->ptr.pp_double[0][j], inva->stride, ae_v_len(0,n-1));
33679  t2.ptr.p_double[j] = vt;
33680  }
33681 
33682  /*
33683  * InvA = InvA - correction
33684  */
33685  for(i=0; i<=n-1; i++)
33686  {
33687  vt = t1.ptr.p_double[i]/(1+lambdav);
33688  ae_v_subd(&inva->ptr.pp_double[i][0], 1, &t2.ptr.p_double[0], 1, ae_v_len(0,n-1), vt);
33689  }
33690  ae_frame_leave(_state);
33691 }
33692 
33693 
33694 
33695 
33696 /*************************************************************************
33697 Subroutine performing the Schur decomposition of a general matrix by using
33698 the QR algorithm with multiple shifts.
33699 
33700 The source matrix A is represented as S'*A*S = T, where S is an orthogonal
33701 matrix (Schur vectors), T - upper quasi-triangular matrix (with blocks of
33702 sizes 1x1 and 2x2 on the main diagonal).
33703 
33704 Input parameters:
33705  A - matrix to be decomposed.
33706  Array whose indexes range within [0..N-1, 0..N-1].
33707  N - size of A, N>=0.
33708 
33709 
33710 Output parameters:
33711  A - contains matrix T.
33712  Array whose indexes range within [0..N-1, 0..N-1].
33713  S - contains Schur vectors.
33714  Array whose indexes range within [0..N-1, 0..N-1].
33715 
33716 Note 1:
33717  The block structure of matrix T can be easily recognized: since all
33718  the elements below the blocks are zeros, the elements a[i+1,i] which
33719  are equal to 0 show the block border.
33720 
33721 Note 2:
33722  The algorithm performance depends on the value of the internal parameter
33723  NS of the InternalSchurDecomposition subroutine which defines the number
33724  of shifts in the QR algorithm (similarly to the block width in block-matrix
33725  algorithms in linear algebra). If you require maximum performance on
33726  your machine, it is recommended to adjust this parameter manually.
33727 
33728 Result:
33729  True,
33730  if the algorithm has converged and parameters A and S contain the result.
33731  False,
33732  if the algorithm has not converged.
33733 
33734 Algorithm implemented on the basis of the DHSEQR subroutine (LAPACK 3.0 library).
33735 *************************************************************************/
33736 ae_bool rmatrixschur(/* Real */ ae_matrix* a,
33737  ae_int_t n,
33738  /* Real */ ae_matrix* s,
33739  ae_state *_state)
33740 {
33741  ae_frame _frame_block;
33742  ae_vector tau;
33743  ae_vector wi;
33744  ae_vector wr;
33745  ae_matrix a1;
33746  ae_matrix s1;
33747  ae_int_t info;
33748  ae_int_t i;
33749  ae_int_t j;
33750  ae_bool result;
33751 
33752  ae_frame_make(_state, &_frame_block);
33753  ae_matrix_clear(s);
33754  ae_vector_init(&tau, 0, DT_REAL, _state, ae_true);
33755  ae_vector_init(&wi, 0, DT_REAL, _state, ae_true);
33756  ae_vector_init(&wr, 0, DT_REAL, _state, ae_true);
33757  ae_matrix_init(&a1, 0, 0, DT_REAL, _state, ae_true);
33758  ae_matrix_init(&s1, 0, 0, DT_REAL, _state, ae_true);
33759 
33760 
33761  /*
33762  * Upper Hessenberg form of the 0-based matrix
33763  */
33764  rmatrixhessenberg(a, n, &tau, _state);
33765  rmatrixhessenbergunpackq(a, n, &tau, s, _state);
33766 
33767  /*
33768  * Convert from 0-based arrays to 1-based,
33769  * then call InternalSchurDecomposition
33770  * Awkward, of course, but Schur decompisiton subroutine
33771  * is too complex to fix it.
33772  *
33773  */
33774  ae_matrix_set_length(&a1, n+1, n+1, _state);
33775  ae_matrix_set_length(&s1, n+1, n+1, _state);
33776  for(i=1; i<=n; i++)
33777  {
33778  for(j=1; j<=n; j++)
33779  {
33780  a1.ptr.pp_double[i][j] = a->ptr.pp_double[i-1][j-1];
33781  s1.ptr.pp_double[i][j] = s->ptr.pp_double[i-1][j-1];
33782  }
33783  }
33784  internalschurdecomposition(&a1, n, 1, 1, &wr, &wi, &s1, &info, _state);
33785  result = info==0;
33786 
33787  /*
33788  * convert from 1-based arrays to -based
33789  */
33790  for(i=1; i<=n; i++)
33791  {
33792  for(j=1; j<=n; j++)
33793  {
33794  a->ptr.pp_double[i-1][j-1] = a1.ptr.pp_double[i][j];
33795  s->ptr.pp_double[i-1][j-1] = s1.ptr.pp_double[i][j];
33796  }
33797  }
33798  ae_frame_leave(_state);
33799  return result;
33800 }
33801 
33802 
33803 
33804 }
33805 
void smp_rmatrixlefttrsm(const ae_int_t m, const ae_int_t n, const real_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const real_2d_array &x, const ae_int_t i2, const ae_int_t j2)
Definition: linalg.cpp:463
void hpdmatrixrndcond(ae_int_t n, double c, ae_matrix *a, ae_state *_state)
Definition: linalg.cpp:22083
void cmatrixlu(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *pivots, ae_state *_state)
Definition: linalg.cpp:22816
ae_bool spdmatrixcholesky(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_state *_state)
Definition: linalg.cpp:22913
ae_int_t sparsegetncols(const sparsematrix &s)
Definition: linalg.cpp:6035
void ae_v_cmove(ae_complex *vdst, ae_int_t stride_dst, const ae_complex *vsrc, ae_int_t stride_src, const char *conj_src, ae_int_t n)
Definition: ap.cpp:3871
void smp_cmatrixgemm(const ae_int_t m, const ae_int_t n, const ae_int_t k, const alglib::complex alpha, const complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const complex_2d_array &b, const ae_int_t ib, const ae_int_t jb, const ae_int_t optypeb, const alglib::complex beta, const complex_2d_array &c, const ae_int_t ic, const ae_int_t jc)
Definition: linalg.cpp:571
struct alglib_impl::ae_state ae_state
double rmatrixrcond1(ae_matrix *a, ae_int_t n, ae_state *_state)
Definition: linalg.cpp:24306
void cmatrixinverse(complex_2d_array &a, const ae_int_t n, ae_int_t &info, matinvreport &rep)
Definition: linalg.cpp:4027
double rmatrixrcondinf(ae_matrix *a, ae_int_t n, ae_state *_state)
Definition: linalg.cpp:24369
ae_int_t ablasblocksize(ae_matrix *a, ae_state *_state)
Definition: linalg.cpp:7695
double sparseget(sparsematrix *s, ae_int_t i, ae_int_t j, ae_state *_state)
Definition: linalg.cpp:29561
double cmatrixtrrcondinf(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_bool isunit, ae_state *_state)
Definition: linalg.cpp:25184
void smp_rmatrixgemm(const ae_int_t m, const ae_int_t n, const ae_int_t k, const double alpha, const real_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const real_2d_array &b, const ae_int_t ib, const ae_int_t jb, const ae_int_t optypeb, const double beta, const real_2d_array &c, const ae_int_t ic, const ae_int_t jc)
Definition: linalg.cpp:607
alglib_impl::matinvreport * p_struct
Definition: linalg.h:130
void rmatrixlqunpackq(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *tau, ae_int_t qrows, ae_matrix *q, ae_state *_state)
Definition: linalg.cpp:11152
void cmatrixtranspose(const ae_int_t m, const ae_int_t n, const complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, complex_2d_array &b, const ae_int_t ib, const ae_int_t jb)
Definition: linalg.cpp:53
void rmatrixgemm(const ae_int_t m, const ae_int_t n, const ae_int_t k, const double alpha, const real_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const real_2d_array &b, const ae_int_t ib, const ae_int_t jb, const ae_int_t optypeb, const double beta, const real_2d_array &c, const ae_int_t ic, const ae_int_t jc)
Definition: linalg.cpp:590
void rmatrixsyrk(const ae_int_t n, const ae_int_t k, const double alpha, const real_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const double beta, const real_2d_array &c, const ae_int_t ic, const ae_int_t jc, const bool isupper)
Definition: linalg.cpp:518
double spdmatrixcholeskydet(ae_matrix *a, ae_int_t n, ae_state *_state)
Definition: linalg.cpp:32839
void sparsecopy(sparsematrix *s0, sparsematrix *s1, ae_state *_state)
Definition: linalg.cpp:29262
void rmatrixmv(const ae_int_t m, const ae_int_t n, const real_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t opa, const real_1d_array &x, const ae_int_t ix, real_1d_array &y, const ae_int_t iy)
Definition: linalg.cpp:319
void ablascomplexsplitlength(ae_matrix *a, ae_int_t n, ae_int_t *n1, ae_int_t *n2, ae_state *_state)
Definition: linalg.cpp:7661
void sparsemm2(const sparsematrix &s, const real_2d_array &a, const ae_int_t k, real_2d_array &b0, real_2d_array &b1)
Definition: linalg.cpp:5572
ae_int_t sparsegetnrows(sparsematrix *s, ae_state *_state)
Definition: linalg.cpp:31194
void sparseconverttohash(const sparsematrix &s)
Definition: linalg.cpp:5805
void cmatrixqr(complex_2d_array &a, const ae_int_t m, const ae_int_t n, complex_1d_array &tau)
Definition: linalg.cpp:746
void rmatrixqr(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *tau, ae_state *_state)
Definition: linalg.cpp:10371
void rmatrixgemm(ae_int_t m, ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_int_t optypeb, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_state *_state)
Definition: linalg.cpp:9104
ae_bool rmatrixsyrkf(ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_bool isupper, ae_state *_state)
void cmatrixlq(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *tau, ae_state *_state)
Definition: linalg.cpp:10810
void sparsemv(sparsematrix *s, ae_vector *x, ae_vector *y, ae_state *_state)
Definition: linalg.cpp:29804
int * mmax
void rmatrixbdmultiplybyp(ae_matrix *qp, ae_int_t m, ae_int_t n, ae_vector *taup, ae_matrix *z, ae_int_t zrows, ae_int_t zcolumns, ae_bool fromtheright, ae_bool dotranspose, ae_state *_state)
Definition: linalg.cpp:12368
void cmatrixlq(complex_2d_array &a, const ae_int_t m, const ae_int_t n, complex_1d_array &tau)
Definition: linalg.cpp:783
bool sparserewriteexisting(const sparsematrix &s, const ae_int_t i, const ae_int_t j, const double v)
Definition: linalg.cpp:5737
_matinvreport_owner & operator=(const _matinvreport_owner &rhs)
Definition: linalg.cpp:3692
ae_bool ae_is_symmetric(ae_matrix *a)
Definition: ap.cpp:2248
double sparsegetdiagonal(const sparsematrix &s, const ae_int_t i)
Definition: linalg.cpp:5236
void normestimatorsetseed(const normestimatorstate &state, const ae_int_t seedval)
Definition: linalg.cpp:6185
void write(std::ostream &os, const datablock &db)
Definition: cif2pdb.cpp:3747
void ae_v_muld(double *vdst, ae_int_t stride_dst, ae_int_t n, double alpha)
Definition: ap.cpp:4538
void rmatrixbdunpackdiagonals(ae_matrix *b, ae_int_t m, ae_int_t n, ae_bool *isupper, ae_vector *d, ae_vector *e, ae_state *_state)
Definition: linalg.cpp:12529
normestimatorstate & operator=(const normestimatorstate &rhs)
Definition: linalg.cpp:6109
double sparseget(const sparsematrix &s, const ae_int_t i, const ae_int_t j)
Definition: linalg.cpp:5201
void hmatrixtdunpackq(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_vector *tau, ae_matrix *q, ae_state *_state)
Definition: linalg.cpp:13368
void sparsegetrow(const sparsematrix &s, const ae_int_t i, real_1d_array &irow)
Definition: linalg.cpp:5773
alglib_impl::normestimatorstate * c_ptr()
Definition: linalg.cpp:6092
double spdmatrixcholeskydet(const real_2d_array &a, const ae_int_t n)
Definition: linalg.cpp:6574
void smp_cmatrixsyrk(const ae_int_t n, const ae_int_t k, const double alpha, const complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const double beta, const complex_2d_array &c, const ae_int_t ic, const ae_int_t jc, const bool isupper)
Definition: linalg.cpp:499
ae_bool rmatrixsyrkmkl(ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_bool isupper, ae_state *_state)
void sparseresizematrix(sparsematrix *s, ae_state *_state)
Definition: linalg.cpp:30498
doublereal * c
void normestimatorsetseed(normestimatorstate *state, ae_int_t seedval, ae_state *_state)
Definition: linalg.cpp:32270
ae_bool cmatrixrank1f(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_vector *u, ae_int_t iu, ae_vector *v, ae_int_t iv, ae_state *_state)
doublereal * g
void cmatrixlefttrsm(const ae_int_t m, const ae_int_t n, const complex_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const complex_2d_array &x, const ae_int_t i2, const ae_int_t j2)
Definition: linalg.cpp:374
ae_bool smatrixevdr(ae_matrix *a, ae_int_t n, ae_int_t zneeded, ae_bool isupper, double b1, double b2, ae_int_t *m, ae_vector *w, ae_matrix *z, ae_state *_state)
Definition: linalg.cpp:15539
#define ae_false
Definition: ap.h:196
void * ae_malloc(size_t size, ae_state *state)
Definition: ap.cpp:222
ae_int_t stride
Definition: ap.h:446
void _normestimatorstate_clear(void *_p)
Definition: linalg.cpp:32601
ae_bool hmatrixevdi(ae_matrix *a, ae_int_t n, ae_int_t zneeded, ae_bool isupper, ae_int_t i1, ae_int_t i2, ae_vector *w, ae_matrix *z, ae_state *_state)
Definition: linalg.cpp:15977
sparsematrix & operator=(const sparsematrix &rhs)
Definition: linalg.cpp:4792
ae_bool _sparsematrix_init(void *_p, ae_state *_state, ae_bool make_automatic)
Definition: linalg.cpp:31297
double beta(const double a, const double b)
void _sparsematrix_clear(void *_p)
Definition: linalg.cpp:31338
double rmatrixludet(const real_2d_array &a, const integer_1d_array &pivots, const ae_int_t n)
Definition: linalg.cpp:6280
union alglib_impl::ae_matrix::@12 ptr
void cmatrixrighttrsm(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
Definition: linalg.cpp:8276
void _pexec_rmatrixlefttrsm(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
Definition: linalg.cpp:8739
void ae_frame_make(ae_state *state, ae_frame *tmp)
Definition: ap.cpp:402
static double * y
bool smatrixgevd(const real_2d_array &a, const ae_int_t n, const bool isuppera, const real_2d_array &b, const bool isupperb, const ae_int_t zneeded, const ae_int_t problemtype, real_1d_array &d, real_2d_array &z)
Definition: linalg.cpp:6778
void cmatrixcopy(const ae_int_t m, const ae_int_t n, const complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, complex_2d_array &b, const ae_int_t ib, const ae_int_t jb)
Definition: linalg.cpp:137
void normestimatorresults(normestimatorstate *state, double *nrm, ae_state *_state)
Definition: linalg.cpp:32511
void _pexec_rmatrixsyrk(ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_bool isupper, ae_state *_state)
Definition: linalg.cpp:8954
void cmatrixgemmk(ae_int_t m, ae_int_t n, ae_int_t k, ae_complex alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_int_t optypeb, ae_complex beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_state *_state)
ae_bool hpdmatrixcholesky(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_state *_state)
Definition: linalg.cpp:22860
ae_int_t ablascomplexblocksize(ae_matrix *a, ae_state *_state)
Definition: linalg.cpp:7712
ae_bool smatrixgevdreduce(ae_matrix *a, ae_int_t n, ae_bool isuppera, ae_matrix *b, ae_bool isupperb, ae_int_t problemtype, ae_matrix *r, ae_bool *isupperr, ae_state *_state)
Definition: linalg.cpp:33129
alglib_impl::sparsematrix * p_struct
Definition: linalg.h:160
ae_complex ae_c_conj(ae_complex lhs, ae_state *state)
Definition: ap.cpp:3623
void smatrixrndmultiply(ae_matrix *a, ae_int_t n, ae_state *_state)
Definition: linalg.cpp:22561
ae_complex ae_complex_from_d(double v)
Definition: ap.cpp:3607
void cmatrixtrinverse(complex_2d_array &a, const ae_int_t n, const bool isupper, const bool isunit, ae_int_t &info, matinvreport &rep)
Definition: linalg.cpp:4658
virtual ~matinvreport()
Definition: linalg.cpp:3733
void sparsecopytocrs(const sparsematrix &s0, sparsematrix &s1)
Definition: linalg.cpp:5867
ae_bool ae_force_hermitian(ae_matrix *a)
Definition: ap.cpp:2272
ae_bool rmatrixschur(ae_matrix *a, ae_int_t n, ae_matrix *s, ae_state *_state)
Definition: linalg.cpp:33736
void cmatrixsyrk(const ae_int_t n, const ae_int_t k, const double alpha, const complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const double beta, const complex_2d_array &c, const ae_int_t ic, const ae_int_t jc, const bool isupper)
Definition: linalg.cpp:482
double rmatrixdet(ae_matrix *a, ae_int_t n, ae_state *_state)
Definition: linalg.cpp:32701
doublereal * w
void cmatrixlqunpackq(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *tau, ae_int_t qrows, ae_matrix *q, ae_state *_state)
Definition: linalg.cpp:11557
double * p_double
Definition: ap.h:437
void rmatrixlefttrsm(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
Definition: linalg.cpp:8639
void _pexec_rmatrixgemm(ae_int_t m, ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_int_t optypeb, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_state *_state)
Definition: linalg.cpp:9233
void sparsemtv(sparsematrix *s, ae_vector *x, ae_vector *y, ae_state *_state)
Definition: linalg.cpp:29858
ae_int_t sparsegetmatrixtype(const sparsematrix &s)
Definition: linalg.cpp:5901
double cmatrixlurcond1(ae_matrix *lua, ae_int_t n, ae_state *_state)
Definition: linalg.cpp:25033
void cmatrixqr(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *tau, ae_state *_state)
Definition: linalg.cpp:10668
ae_bool _matinvreport_init_copy(void *_dst, void *_src, ae_state *_state, ae_bool make_automatic)
Definition: linalg.cpp:29018
void cmatrixmv(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t opa, ae_vector *x, ae_int_t ix, ae_vector *y, ae_int_t iy, ae_state *_state)
Definition: linalg.cpp:8100
double spdmatrixdet(const real_2d_array &a, const ae_int_t n, const bool isupper)
Definition: linalg.cpp:6660
void ae_state_clear(ae_state *state)
Definition: ap.cpp:373
void rmatrixinvupdaterow(ae_matrix *inva, ae_int_t n, ae_int_t updrow, ae_vector *v, ae_state *_state)
Definition: linalg.cpp:33502
const alglib_impl::ae_matrix * c_ptr() const
Definition: ap.cpp:6463
glob_prnt iter
void sparsesmm(sparsematrix *s, ae_bool isupper, ae_matrix *a, ae_int_t k, ae_matrix *b, ae_state *_state)
Definition: linalg.cpp:30377
void rmatrixgemmk(ae_int_t m, ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_int_t optypeb, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_state *_state)
ae_bool ae_fp_eq(double v1, double v2)
Definition: ap.cpp:1313
double rmatrixludet(ae_matrix *a, ae_vector *pivots, ae_int_t n, ae_state *_state)
Definition: linalg.cpp:32655
void sparsemtm(sparsematrix *s, ae_matrix *a, ae_int_t k, ae_matrix *b, ae_state *_state)
Definition: linalg.cpp:30177
void rmatrixhessenberg(ae_matrix *a, ae_int_t n, ae_vector *tau, ae_state *_state)
Definition: linalg.cpp:12607
ae_bool sparserewriteexisting(sparsematrix *s, ae_int_t i, ae_int_t j, double v, ae_state *_state)
Definition: linalg.cpp:30748
void sparseconverttocrs(sparsematrix *s, ae_state *_state)
Definition: linalg.cpp:29687
double spdmatrixdet(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_state *_state)
Definition: linalg.cpp:32893
void ae_v_cmulc(ae_complex *vdst, ae_int_t stride_dst, ae_int_t n, ae_complex alpha)
Definition: ap.cpp:4310
void rmatrixinvupdateuv(real_2d_array &inva, const ae_int_t n, const real_1d_array &u, const real_1d_array &v)
Definition: linalg.cpp:6994
void sparsecopytohash(const sparsematrix &s0, sparsematrix &s1)
Definition: linalg.cpp:5836
void rmatrixinvupdatecolumn(real_2d_array &inva, const ae_int_t n, const ae_int_t updcolumn, const real_1d_array &u)
Definition: linalg.cpp:6957
void cmatrixrndcond(ae_int_t n, double c, ae_matrix *a, ae_state *_state)
Definition: linalg.cpp:21787
void sparsemtv(const sparsematrix &s, const real_1d_array &x, real_1d_array &y)
Definition: linalg.cpp:5350
ae_bool rmatrixlefttrsmf(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
ae_int_t sparsegetmatrixtype(sparsematrix *s, ae_state *_state)
Definition: linalg.cpp:31102
void rmatrixenforcesymmetricity(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_state *_state)
Definition: linalg.cpp:7872
ae_bool ae_matrix_init(ae_matrix *dst, ae_int_t rows, ae_int_t cols, ae_datatype datatype, ae_state *state, ae_bool make_automatic)
Definition: ap.cpp:756
doublereal * x
#define i
ql0001_ & k(htemp+1),(cvec+1),(atemp+1),(bj+1),(bl+1),(bu+1),(x+1),(clamda+1), &iout, infoqp, &zero,(w+1), &lenw,(iw+1), &leniw, &glob_grd.epsmac
void cmatrixrighttrsm(const ae_int_t m, const ae_int_t n, const complex_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const complex_2d_array &x, const ae_int_t i2, const ae_int_t j2)
Definition: linalg.cpp:338
void sparsemv2(const sparsematrix &s, const real_1d_array &x, real_1d_array &y0, real_1d_array &y1)
Definition: linalg.cpp:5396
bool smatrixgevdreduce(real_2d_array &a, const ae_int_t n, const bool isuppera, const real_2d_array &b, const bool isupperb, const ae_int_t problemtype, real_2d_array &r, bool &isupperr)
Definition: linalg.cpp:6846
ae_complex cmatrixdet(ae_matrix *a, ae_int_t n, ae_state *_state)
Definition: linalg.cpp:32792
doublereal * d
void cmatrixrndorthogonalfromtheright(ae_matrix *a, ae_int_t m, ae_int_t n, ae_state *_state)
Definition: linalg.cpp:22370
void sparseconverttohash(sparsematrix *s, ae_state *_state)
Definition: linalg.cpp:30878
double hpdmatrixrcond(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_state *_state)
Definition: linalg.cpp:24687
void cmatrixlqunpackl(ae_matrix *a, ae_int_t m, ae_int_t n, ae_matrix *l, ae_state *_state)
Definition: linalg.cpp:11707
void sparseset(const sparsematrix &s, const ae_int_t i, const ae_int_t j, const double v)
Definition: linalg.cpp:5166
void rmatrixsyrk(ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_bool isupper, ae_state *_state)
Definition: linalg.cpp:8857
void spdmatrixrndcond(ae_int_t n, double c, ae_matrix *a, ae_state *_state)
Definition: linalg.cpp:21927
void rmatrixrndorthogonal(ae_int_t n, ae_matrix *a, ae_state *_state)
Definition: linalg.cpp:21637
ae_bool sparseishash(sparsematrix *s, ae_state *_state)
Definition: linalg.cpp:31127
void hmatrixrndcond(ae_int_t n, double c, ae_matrix *a, ae_state *_state)
Definition: linalg.cpp:22003
void sparsemtm(const sparsematrix &s, const real_2d_array &a, const ae_int_t k, real_2d_array &b)
Definition: linalg.cpp:5525
void normestimatorcreate(const ae_int_t m, const ae_int_t n, const ae_int_t nstart, const ae_int_t nits, normestimatorstate &state)
Definition: linalg.cpp:6152
void rmatrixrndcond(ae_int_t n, double c, ae_matrix *a, ae_state *_state)
Definition: linalg.cpp:21680
void sparseset(sparsematrix *s, ae_int_t i, ae_int_t j, double v, ae_state *_state)
Definition: linalg.cpp:29440
void rmatrixrndorthogonalfromtheleft(ae_matrix *a, ae_int_t m, ae_int_t n, ae_state *_state)
Definition: linalg.cpp:22267
ae_int_t ae_v_len(ae_int_t a, ae_int_t b)
Definition: ap.cpp:4562
void rmatrixlqunpackl(ae_matrix *a, ae_int_t m, ae_int_t n, ae_matrix *l, ae_state *_state)
Definition: linalg.cpp:11300
void rmatrixlefttrsm(const ae_int_t m, const ae_int_t n, const real_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const real_2d_array &x, const ae_int_t i2, const ae_int_t j2)
Definition: linalg.cpp:446
ae_bool cmatrixsyrkf(ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_bool isupper, ae_state *_state)
bool rmatrixschur(real_2d_array &a, const ae_int_t n, real_2d_array &s)
Definition: linalg.cpp:7050
void rmatrixtrinverse(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_bool isunit, ae_int_t *info, matinvreport *rep, ae_state *_state)
Definition: linalg.cpp:27906
doublereal * b
void rmatrixluinverse(real_2d_array &a, const integer_1d_array &pivots, const ae_int_t n, ae_int_t &info, matinvreport &rep)
Definition: linalg.cpp:3771
void cmatrixqrunpackq(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *tau, ae_int_t qcolumns, ae_matrix *q, ae_state *_state)
Definition: linalg.cpp:11353
matinvreport & operator=(const matinvreport &rhs)
Definition: linalg.cpp:3725
void sparsemv(const sparsematrix &s, const real_1d_array &x, real_1d_array &y)
Definition: linalg.cpp:5310
#define y0
alglib::complex cmatrixdet(const complex_2d_array &a, const ae_int_t n)
Definition: linalg.cpp:6499
void sparsesmm(const sparsematrix &s, const bool isupper, const real_2d_array &a, const ae_int_t k, real_2d_array &b)
Definition: linalg.cpp:5620
ae_bool _normestimatorstate_init_copy(void *_dst, void *_src, ae_state *_state, ae_bool make_automatic)
Definition: linalg.cpp:32567
void sparsecreate(const ae_int_t m, const ae_int_t n, const ae_int_t k, sparsematrix &s)
Definition: linalg.cpp:4878
void hpdmatrixinverse(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_int_t *info, matinvreport *rep, ae_state *_state)
Definition: linalg.cpp:27841
void smp_cmatrixlefttrsm(const ae_int_t m, const ae_int_t n, const complex_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const complex_2d_array &x, const ae_int_t i2, const ae_int_t j2)
Definition: linalg.cpp:391
void sparsesmv(const sparsematrix &s, const bool isupper, const real_1d_array &x, real_1d_array &y)
Definition: linalg.cpp:5443
void rmatrixcopy(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_state *_state)
Definition: linalg.cpp:7954
void ae_v_move(double *vdst, ae_int_t stride_dst, const double *vsrc, ae_int_t stride_src, ae_int_t n)
Definition: ap.cpp:4371
void rmatrixtrinverse(real_2d_array &a, const ae_int_t n, const bool isupper, const bool isunit, ae_int_t &info, matinvreport &rep)
Definition: linalg.cpp:4543
viol type
ae_complex ae_c_div(ae_complex lhs, ae_complex rhs)
Definition: ap.cpp:3701
void sparsemm(sparsematrix *s, ae_matrix *a, ae_int_t k, ae_matrix *b, ae_state *_state)
Definition: linalg.cpp:30090
void rmatrixqrunpackq(const real_2d_array &a, const ae_int_t m, const ae_int_t n, const real_1d_array &tau, const ae_int_t qcolumns, real_2d_array &q)
Definition: linalg.cpp:820
double cmatrixtrrcond1(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_bool isunit, ae_state *_state)
Definition: linalg.cpp:25101
int in
double * f
ae_complex ae_c_add(ae_complex lhs, ae_complex rhs)
Definition: ap.cpp:3677
void rmatrixbdunpackq(ae_matrix *qp, ae_int_t m, ae_int_t n, ae_vector *tauq, ae_int_t qcolumns, ae_matrix *q, ae_state *_state)
Definition: linalg.cpp:12056
void cmatrixmv(const ae_int_t m, const ae_int_t n, const complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t opa, const complex_1d_array &x, const ae_int_t ix, complex_1d_array &y, const ae_int_t iy)
Definition: linalg.cpp:274
void ae_vector_clear(ae_vector *dst)
Definition: ap.cpp:692
void ae_v_csubc(ae_complex *vdst, ae_int_t stride_dst, const ae_complex *vsrc, ae_int_t stride_src, const char *conj_src, ae_int_t n, ae_complex alpha)
Definition: ap.cpp:4276
void hpdmatrixcholeskyinverse(complex_2d_array &a, const ae_int_t n, const bool isupper, ae_int_t &info, matinvreport &rep)
Definition: linalg.cpp:4325
ae_bool ae_force_symmetric(ae_matrix *a)
Definition: ap.cpp:2264
ae_int_t length() const
Definition: ap.cpp:5882
void smatrixrndcond(ae_int_t n, double c, ae_matrix *a, ae_state *_state)
Definition: linalg.cpp:21855
void rmatrixcopy(const ae_int_t m, const ae_int_t n, const real_2d_array &a, const ae_int_t ia, const ae_int_t ja, real_2d_array &b, const ae_int_t ib, const ae_int_t jb)
Definition: linalg.cpp:166
void rmatrixqr(real_2d_array &a, const ae_int_t m, const ae_int_t n, real_1d_array &tau)
Definition: linalg.cpp:658
void rmatrixtranspose(const ae_int_t m, const ae_int_t n, const real_2d_array &a, const ae_int_t ia, const ae_int_t ja, real_2d_array &b, const ae_int_t ib, const ae_int_t jb)
Definition: linalg.cpp:82
ae_complex ** pp_complex
Definition: ap.h:456
void spdmatrixinverse(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_int_t *info, matinvreport *rep, ae_state *_state)
Definition: linalg.cpp:27675
void sparsecreatecrs(const ae_int_t m, const ae_int_t n, const integer_1d_array &ner, sparsematrix &s)
Definition: linalg.cpp:5059
void cmatrixtrinverse(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_bool isunit, ae_int_t *info, matinvreport *rep, ae_state *_state)
Definition: linalg.cpp:27998
void rmatrixinvupdaterow(real_2d_array &inva, const ae_int_t n, const ae_int_t updrow, const real_1d_array &v)
Definition: linalg.cpp:6920
void sparsefree(sparsematrix &s)
Definition: linalg.cpp:5987
virtual ~sparsematrix()
Definition: linalg.cpp:4800
ae_bool cmatrixmvf(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t opa, ae_vector *x, ae_int_t ix, ae_vector *y, ae_int_t iy, ae_state *_state)
void sparsemv2(sparsematrix *s, ae_vector *x, ae_vector *y0, ae_vector *y1, ae_state *_state)
Definition: linalg.cpp:29923
double cmatrixrcondinf(ae_matrix *a, ae_int_t n, ae_state *_state)
Definition: linalg.cpp:24837
void cmatrixrank1(const ae_int_t m, const ae_int_t n, complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, complex_1d_array &u, const ae_int_t iu, complex_1d_array &v, const ae_int_t iv)
Definition: linalg.cpp:196
void rmatrixinvupdatesimple(ae_matrix *inva, ae_int_t n, ae_int_t updrow, ae_int_t updcolumn, double updval, ae_state *_state)
Definition: linalg.cpp:33430
void hmatrixtd(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_vector *tau, ae_vector *d, ae_vector *e, ae_state *_state)
Definition: linalg.cpp:13181
void sparsegetrow(sparsematrix *s, ae_int_t i, ae_vector *irow, ae_state *_state)
Definition: linalg.cpp:30840
void ae_v_caddc(ae_complex *vdst, ae_int_t stride_dst, const ae_complex *vsrc, ae_int_t stride_src, const char *conj_src, ae_int_t n, ae_complex alpha)
Definition: ap.cpp:4169
void _pexec_cmatrixrighttrsm(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
Definition: linalg.cpp:8383
void _pexec_cmatrixgemm(ae_int_t m, ae_int_t n, ae_int_t k, ae_complex alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_int_t optypeb, ae_complex beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_state *_state)
Definition: linalg.cpp:9083
void sparsecreatecrs(ae_int_t m, ae_int_t n, ae_vector *ner, sparsematrix *s, ae_state *_state)
Definition: linalg.cpp:29217
void rmatrixhessenbergunpackh(ae_matrix *a, ae_int_t n, ae_matrix *h, ae_state *_state)
Definition: linalg.cpp:12754
#define ae_bool
Definition: ap.h:194
void rmatrixinvupdateuv(ae_matrix *inva, ae_int_t n, ae_vector *u, ae_vector *v, ae_state *_state)
Definition: linalg.cpp:33641
void rmatrixlu(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *pivots, ae_state *_state)
Definition: linalg.cpp:22770
ae_complex ae_c_sub(ae_complex lhs, ae_complex rhs)
Definition: ap.cpp:3693
ae_bool ae_fp_neq(double v1, double v2)
Definition: ap.cpp:1321
void _pexec_cmatrixlefttrsm(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
Definition: linalg.cpp:8500
ae_bool rmatrixmvf(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t opa, ae_vector *x, ae_int_t ix, ae_vector *y, ae_int_t iy, ae_state *_state)
bool sparseishash(const sparsematrix &s)
Definition: linalg.cpp:5931
void rmatrixtranspose(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_state *_state)
Definition: linalg.cpp:7814
double rmatrixtrrcond1(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_bool isunit, ae_state *_state)
Definition: linalg.cpp:24522
void cmatrixrank1(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_vector *u, ae_int_t iu, ae_vector *v, ae_int_t iv, ae_state *_state)
Definition: linalg.cpp:7992
double z
void cmatrixinverse(ae_matrix *a, ae_int_t n, ae_int_t *info, matinvreport *rep, ae_state *_state)
Definition: linalg.cpp:27512
__host__ __device__ float length(float2 v)
void hpdmatrixcholeskyinverse(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_int_t *info, matinvreport *rep, ae_state *_state)
Definition: linalg.cpp:27733
void sparsecopytohash(sparsematrix *s0, sparsematrix *s1, ae_state *_state)
Definition: linalg.cpp:30942
void rmatrixinverse(ae_matrix *a, ae_int_t n, ae_int_t *info, matinvreport *rep, ae_state *_state)
Definition: linalg.cpp:27368
void sparseadd(const sparsematrix &s, const ae_int_t i, const ae_int_t j, const double v)
Definition: linalg.cpp:5124
void sparseadd(sparsematrix *s, ae_int_t i, ae_int_t j, double v, ae_state *_state)
Definition: linalg.cpp:29339
void rmatrixinvupdatecolumn(ae_matrix *inva, ae_int_t n, ae_int_t updcolumn, ae_vector *u, ae_state *_state)
Definition: linalg.cpp:33572
void rmatrixrank1(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_vector *u, ae_int_t iu, ae_vector *v, ae_int_t iv, ae_state *_state)
Definition: linalg.cpp:8037
ae_error_type
Definition: ap.h:201
void rmatrixbdmultiplybyq(ae_matrix *qp, ae_int_t m, ae_int_t n, ae_vector *tauq, ae_matrix *z, ae_int_t zrows, ae_int_t zcolumns, ae_bool fromtheright, ae_bool dotranspose, ae_state *_state)
Definition: linalg.cpp:12132
ae_complex ae_v_cdotproduct(const ae_complex *v0, ae_int_t stride0, const char *conj0, const ae_complex *v1, ae_int_t stride1, const char *conj1, ae_int_t n)
Definition: ap.cpp:3807
void rmatrixlq(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *tau, ae_state *_state)
Definition: linalg.cpp:10527
void mode
void rmatrixinvupdatesimple(real_2d_array &inva, const ae_int_t n, const ae_int_t updrow, const ae_int_t updcolumn, const double updval)
Definition: linalg.cpp:6883
ae_bool sparseiscrs(sparsematrix *s, ae_state *_state)
Definition: linalg.cpp:31152
ae_bool sparseenumerate(sparsematrix *s, ae_int_t *t0, ae_int_t *t1, ae_int_t *i, ae_int_t *j, double *v, ae_state *_state)
Definition: linalg.cpp:30650
void rmatrixrank1(const ae_int_t m, const ae_int_t n, real_2d_array &a, const ae_int_t ia, const ae_int_t ja, real_1d_array &u, const ae_int_t iu, real_1d_array &v, const ae_int_t iv)
Definition: linalg.cpp:226
ae_bool ae_vector_set_length(ae_vector *dst, ae_int_t newsize, ae_state *state)
Definition: ap.cpp:658
alglib_impl::ae_complex * c_ptr()
Definition: ap.cpp:4828
double cmatrixlurcondinf(ae_matrix *lua, ae_int_t n, ae_state *_state)
Definition: linalg.cpp:25067
ae_int_t ablasmicroblocksize(ae_state *_state)
Definition: linalg.cpp:7730
void applyreflectionfromtheleft(ae_matrix *c, double tau, ae_vector *v, ae_int_t m1, ae_int_t m2, ae_int_t n1, ae_int_t n2, ae_vector *work, ae_state *_state)
ae_bool hmatrixevd(ae_matrix *a, ae_int_t n, ae_int_t zneeded, ae_bool isupper, ae_vector *d, ae_matrix *z, ae_state *_state)
Definition: linalg.cpp:15687
ae_bool smatrixgevd(ae_matrix *a, ae_int_t n, ae_bool isuppera, ae_matrix *b, ae_bool isupperb, ae_int_t zneeded, ae_int_t problemtype, ae_vector *d, ae_matrix *z, ae_state *_state)
Definition: linalg.cpp:32971
void applyreflectionfromtheright(ae_matrix *c, double tau, ae_vector *v, ae_int_t m1, ae_int_t m2, ae_int_t n1, ae_int_t n2, ae_vector *work, ae_state *_state)
void normestimatorresults(const normestimatorstate &state, double &nrm)
Definition: linalg.cpp:6244
void smp_rmatrixrighttrsm(const ae_int_t m, const ae_int_t n, const real_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const real_2d_array &x, const ae_int_t i2, const ae_int_t j2)
Definition: linalg.cpp:427
ae_int_t sparsegetncols(sparsematrix *s, ae_state *_state)
Definition: linalg.cpp:31212
void _matinvreport_clear(void *_p)
Definition: linalg.cpp:29028
void normestimatorcreate(ae_int_t m, ae_int_t n, ae_int_t nstart, ae_int_t nits, normestimatorstate *state, ae_state *_state)
Definition: linalg.cpp:32220
ae_bool smatrixtdevdi(ae_vector *d, ae_vector *e, ae_int_t n, ae_int_t zneeded, ae_int_t i1, ae_int_t i2, ae_matrix *z, ae_state *_state)
Definition: linalg.cpp:16568
double rmatrixdet(const real_2d_array &a, const ae_int_t n)
Definition: linalg.cpp:6353
double rmatrixlurcond1(ae_matrix *lua, ae_int_t n, ae_state *_state)
Definition: linalg.cpp:24892
ae_complex cmatrixludet(ae_matrix *a, ae_vector *pivots, ae_int_t n, ae_state *_state)
Definition: linalg.cpp:32746
double rmatrixtrrcondinf(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_bool isunit, ae_state *_state)
Definition: linalg.cpp:24605
struct alglib_impl::ae_vector ae_vector
void ablassplitlength(ae_matrix *a, ae_int_t n, ae_int_t *n1, ae_int_t *n2, ae_state *_state)
Definition: linalg.cpp:7633
const alglib_impl::ae_vector * c_ptr() const
Definition: ap.cpp:5907
void rmatrixmv(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t opa, ae_vector *x, ae_int_t ix, ae_vector *y, ae_int_t iy, ae_state *_state)
Definition: linalg.cpp:8211
#define j
void rmatrixqrunpackr(ae_matrix *a, ae_int_t m, ae_int_t n, ae_matrix *r, ae_state *_state)
Definition: linalg.cpp:11099
ae_complex ae_c_d_div(double lhs, ae_complex rhs)
Definition: ap.cpp:3781
ae_bool rmatrixrighttrsmf(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
void cmatrixgemm(const ae_int_t m, const ae_int_t n, const ae_int_t k, const alglib::complex alpha, const complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const complex_2d_array &b, const ae_int_t ib, const ae_int_t jb, const ae_int_t optypeb, const alglib::complex beta, const complex_2d_array &c, const ae_int_t ic, const ae_int_t jc)
Definition: linalg.cpp:554
void smp_rmatrixsyrk(const ae_int_t n, const ae_int_t k, const double alpha, const real_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const double beta, const real_2d_array &c, const ae_int_t ic, const ae_int_t jc, const bool isupper)
Definition: linalg.cpp:535
void sparseresizematrix(const sparsematrix &s)
Definition: linalg.cpp:5644
int m
_sparsematrix_owner & operator=(const _sparsematrix_owner &rhs)
Definition: linalg.cpp:4759
void spdmatrixinverse(real_2d_array &a, const ae_int_t n, const bool isupper, ae_int_t &info, matinvreport &rep)
Definition: linalg.cpp:4218
double spdmatrixrcond(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_state *_state)
Definition: linalg.cpp:24433
ae_bool rmatrixevd(ae_matrix *a, ae_int_t n, ae_int_t vneeded, ae_vector *wr, ae_vector *wi, ae_matrix *vl, ae_matrix *vr, ae_state *_state)
Definition: linalg.cpp:16878
void cmatrixgemm(ae_int_t m, ae_int_t n, ae_int_t k, ae_complex alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_int_t optypeb, ae_complex beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_state *_state)
Definition: linalg.cpp:8971
void rmatrixqrunpackq(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *tau, ae_int_t qcolumns, ae_matrix *q, ae_state *_state)
Definition: linalg.cpp:10951
double cmatrixrcond1(ae_matrix *a, ae_int_t n, ae_state *_state)
Definition: linalg.cpp:24774
struct alglib_impl::ae_matrix ae_matrix
ae_bool rmatrixbdsvd(ae_vector *d, ae_vector *e, ae_int_t n, ae_bool isupper, ae_bool isfractionalaccuracyrequired, ae_matrix *u, ae_int_t nru, ae_matrix *c, ae_int_t ncc, ae_matrix *vt, ae_int_t ncvt, ae_state *_state)
Definition: linalg.cpp:13854
ae_bool smatrixtdevd(ae_vector *d, ae_vector *e, ae_int_t n, ae_int_t zneeded, ae_matrix *z, ae_state *_state)
Definition: linalg.cpp:16129
void cmatrixlefttrsm(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
Definition: linalg.cpp:8399
#define len
ae_bool cmatrixlefttrsmf(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
ae_complex * p_complex
Definition: ap.h:438
double ** pp_double
Definition: ap.h:455
ae_bool rmatrixsvd(ae_matrix *a, ae_int_t m, ae_int_t n, ae_int_t uneeded, ae_int_t vtneeded, ae_int_t additionalmemory, ae_vector *w, ae_matrix *u, ae_matrix *vt, ae_state *_state)
Definition: linalg.cpp:15147
void ae_state_init(ae_state *state)
Definition: ap.cpp:309
void rmatrixhessenbergunpackq(ae_matrix *a, ae_int_t n, ae_vector *tau, ae_matrix *q, ae_state *_state)
Definition: linalg.cpp:12679
void cmatrixsyrk(ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_bool isupper, ae_state *_state)
Definition: linalg.cpp:8755
void rmatrixluinverse(ae_matrix *a, ae_vector *pivots, ae_int_t n, ae_int_t *info, matinvreport *rep, ae_state *_state)
Definition: linalg.cpp:27267
void rmatrixrighttrsm(const ae_int_t m, const ae_int_t n, const real_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const real_2d_array &x, const ae_int_t i2, const ae_int_t j2)
Definition: linalg.cpp:410
void ae_assert(ae_bool cond, const char *msg, ae_state *state)
Definition: ap.cpp:1227
union alglib_impl::ae_vector::@11 ptr
bool sparseenumerate(const sparsematrix &s, ae_int_t &t0, ae_int_t &t1, ae_int_t &i, ae_int_t &j, double &v)
Definition: linalg.cpp:5696
ae_int_t rows() const
Definition: ap.cpp:6419
double spdmatrixcholeskyrcond(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_state *_state)
Definition: linalg.cpp:24962
bool sparseiscrs(const sparsematrix &s)
Definition: linalg.cpp:5961
void cmatrixtranspose(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_state *_state)
Definition: linalg.cpp:7753
ae_bool smatrixevdi(ae_matrix *a, ae_int_t n, ae_int_t zneeded, ae_bool isupper, ae_int_t i1, ae_int_t i2, ae_vector *w, ae_matrix *z, ae_state *_state)
Definition: linalg.cpp:15614
ae_int_t sparsegetnrows(const sparsematrix &s)
Definition: linalg.cpp:6011
_normestimatorstate_owner & operator=(const _normestimatorstate_owner &rhs)
Definition: linalg.cpp:6076
const char *volatile error_msg
Definition: ap.h:389
void cmatrixrndorthogonalfromtheleft(ae_matrix *a, ae_int_t m, ae_int_t n, ae_state *_state)
Definition: linalg.cpp:22465
void rmatrixenforcesymmetricity(const real_2d_array &a, const ae_int_t n, const bool isupper)
Definition: linalg.cpp:108
void sparseconverttocrs(const sparsematrix &s)
Definition: linalg.cpp:5270
ae_bool hmatrixevdr(ae_matrix *a, ae_int_t n, ae_int_t zneeded, ae_bool isupper, double b1, double b2, ae_int_t *m, ae_vector *w, ae_matrix *z, ae_state *_state)
Definition: linalg.cpp:15831
void sparsemm(const sparsematrix &s, const real_2d_array &a, const ae_int_t k, real_2d_array &b)
Definition: linalg.cpp:5484
ptrdiff_t ae_int_t
Definition: ap.h:186
void rmatrixbdunpackpt(ae_matrix *qp, ae_int_t m, ae_int_t n, ae_vector *taup, ae_int_t ptrows, ae_matrix *pt, ae_state *_state)
Definition: linalg.cpp:12292
void cmatrixqrunpackr(ae_matrix *a, ae_int_t m, ae_int_t n, ae_matrix *r, ae_state *_state)
Definition: linalg.cpp:11504
void complexapplyreflectionfromtheright(ae_matrix *c, ae_complex tau, ae_vector *v, ae_int_t m1, ae_int_t m2, ae_int_t n1, ae_int_t n2, ae_vector *work, ae_state *_state)
void _pexec_rmatrixrighttrsm(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
Definition: linalg.cpp:8623
doublereal * u
void hpdmatrixinverse(complex_2d_array &a, const ae_int_t n, const bool isupper, ae_int_t &info, matinvreport &rep)
Definition: linalg.cpp:4429
void ae_v_subd(double *vdst, ae_int_t stride_dst, const double *vsrc, ae_int_t stride_src, ae_int_t n, double alpha)
Definition: ap.cpp:4533
ae_bool ae_vector_init(ae_vector *dst, ae_int_t size, ae_datatype datatype, ae_state *state, ae_bool make_automatic)
Definition: ap.cpp:580
ae_int_t ae_maxint(ae_int_t m1, ae_int_t m2, ae_state *state)
Definition: ap.cpp:1567
ae_complex ae_c_mul_d(ae_complex lhs, double rhs)
Definition: ap.cpp:3749
void sparsefree(sparsematrix *s, ae_state *_state)
Definition: linalg.cpp:31173
void rmatrixlqbasecase(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *work, ae_vector *t, ae_vector *tau, ae_state *_state)
Definition: linalg.cpp:11802
void cmatrixrndorthogonal(ae_int_t n, ae_matrix *a, ae_state *_state)
Definition: linalg.cpp:21743
constexpr int K
void complexapplyreflectionfromtheleft(ae_matrix *c, ae_complex tau, ae_vector *v, ae_int_t m1, ae_int_t m2, ae_int_t n1, ae_int_t n2, ae_vector *work, ae_state *_state)
void rmatrixinverse(real_2d_array &a, const ae_int_t n, ae_int_t &info, matinvreport &rep)
Definition: linalg.cpp:3865
void sparsecreate(ae_int_t m, ae_int_t n, ae_int_t k, sparsematrix *s, ae_state *_state)
Definition: linalg.cpp:29118
integer * ifail
ae_bool _normestimatorstate_init(void *_p, ae_state *_state, ae_bool make_automatic)
Definition: linalg.cpp:32541
void rmatrixbd(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *tauq, ae_vector *taup, ae_state *_state)
Definition: linalg.cpp:11896
ae_bool smatrixtdevdr(ae_vector *d, ae_vector *e, ae_int_t n, ae_int_t zneeded, double a, double b, ae_int_t *m, ae_matrix *z, ae_state *_state)
Definition: linalg.cpp:16273
void smp_cmatrixrighttrsm(const ae_int_t m, const ae_int_t n, const complex_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const complex_2d_array &x, const ae_int_t i2, const ae_int_t j2)
Definition: linalg.cpp:355
void ae_v_addd(double *vdst, ae_int_t stride_dst, const double *vsrc, ae_int_t stride_src, ae_int_t n, double alpha)
Definition: ap.cpp:4479
double rmatrixlurcondinf(ae_matrix *lua, ae_int_t n, ae_state *_state)
Definition: linalg.cpp:24925
void ae_v_cmuld(ae_complex *vdst, ae_int_t stride_dst, ae_int_t n, double alpha)
Definition: ap.cpp:4283
ae_bool ae_is_hermitian(ae_matrix *a)
Definition: ap.cpp:2256
alglib::complex cmatrixludet(const complex_2d_array &a, const integer_1d_array &pivots, const ae_int_t n)
Definition: linalg.cpp:6426
ae_bool rmatrixgemmmkl(ae_int_t m, ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_int_t optypeb, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_state *_state)
void cmatrixluinverse(ae_matrix *a, ae_vector *pivots, ae_int_t n, ae_int_t *info, matinvreport *rep, ae_state *_state)
Definition: linalg.cpp:27415
void rmatrixqrbasecase(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *work, ae_vector *t, ae_vector *tau, ae_state *_state)
Definition: linalg.cpp:11749
void cmatrixluinverse(complex_2d_array &a, const integer_1d_array &pivots, const ae_int_t n, ae_int_t &info, matinvreport &rep)
Definition: linalg.cpp:3948
void rmatrixlq(real_2d_array &a, const ae_int_t m, const ae_int_t n, real_1d_array &tau)
Definition: linalg.cpp:709
void spdmatrixcholeskyinverse(real_2d_array &a, const ae_int_t n, const bool isupper, ae_int_t &info, matinvreport &rep)
Definition: linalg.cpp:4114
void smatrixtd(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_vector *tau, ae_vector *d, ae_vector *e, ae_state *_state)
Definition: linalg.cpp:12858
alglib_impl::ae_int_t ae_int_t
Definition: ap.h:889
void sparsesmv(sparsematrix *s, ae_bool isupper, ae_vector *x, ae_vector *y, ae_state *_state)
Definition: linalg.cpp:30000
void _pexec_cmatrixsyrk(ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_bool isupper, ae_state *_state)
Definition: linalg.cpp:8840
void ae_frame_leave(ae_state *state)
Definition: ap.cpp:415
ae_bool cmatrixrighttrsmf(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
alglib_impl::sparsematrix * c_ptr()
Definition: linalg.cpp:4775
void ae_matrix_clear(ae_matrix *dst)
Definition: ap.cpp:891
ae_bool _sparsematrix_init_copy(void *_dst, void *_src, ae_state *_state, ae_bool make_automatic)
Definition: linalg.cpp:31315
#define ae_true
Definition: ap.h:195
void hmatrixrndmultiply(ae_matrix *a, ae_int_t n, ae_state *_state)
Definition: linalg.cpp:22656
int * n
ae_int_t cols() const
Definition: ap.cpp:6426
alglib_impl::matinvreport * c_ptr()
Definition: linalg.cpp:3708
double hpdmatrixcholeskyrcond(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_state *_state)
Definition: linalg.cpp:25000
ae_bool ae_matrix_set_length(ae_matrix *dst, ae_int_t rows, ae_int_t cols, ae_state *state)
Definition: ap.cpp:854
doublereal * a
double sparsegetdiagonal(sparsematrix *s, ae_int_t i, ae_state *_state)
Definition: linalg.cpp:29643
ql0001_ & zero(ctemp+1),(cvec+1),(a+1),(b+1),(bl+1),(bu+1),(x+1),(w+1), &iout, ifail, &zero,(w+3), &lwar2,(iw+1), &leniw, &glob_grd.epsmac
void spdmatrixcholeskyinverse(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_int_t *info, matinvreport *rep, ae_state *_state)
Definition: linalg.cpp:27567
void sparsecopytocrs(sparsematrix *s0, sparsematrix *s1, ae_state *_state)
Definition: linalg.cpp:30987
ae_bool rmatrixrank1f(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_vector *u, ae_int_t iu, ae_vector *v, ae_int_t iv, ae_state *_state)
ae_int_t ae_minint(ae_int_t m1, ae_int_t m2, ae_state *state)
Definition: ap.cpp:1572
void normestimatorestimatesparse(normestimatorstate *state, sparsematrix *a, ae_state *_state)
Definition: linalg.cpp:32476
void smatrixtdunpackq(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_vector *tau, ae_matrix *q, ae_state *_state)
Definition: linalg.cpp:13034
void sparsecopy(const sparsematrix &s0, sparsematrix &s1)
Definition: linalg.cpp:5084
void ae_free(void *p)
Definition: ap.cpp:237
void rmatrixrighttrsm(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
Definition: linalg.cpp:8516
ae_bool smatrixevd(ae_matrix *a, ae_int_t n, ae_int_t zneeded, ae_bool isupper, ae_vector *d, ae_matrix *z, ae_state *_state)
Definition: linalg.cpp:15465
void normestimatorestimatesparse(const normestimatorstate &state, const sparsematrix &a)
Definition: linalg.cpp:6216
ae_bool _matinvreport_init(void *_p, ae_state *_state, ae_bool make_automatic)
Definition: linalg.cpp:29010
float r1
double ae_v_dotproduct(const double *v0, ae_int_t stride0, const double *v1, ae_int_t stride1, ae_int_t n)
Definition: ap.cpp:4344
void cmatrixcopy(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_state *_state)
Definition: linalg.cpp:7917
alglib_impl::normestimatorstate * p_struct
Definition: linalg.h:189
void rmatrixrndorthogonalfromtheright(ae_matrix *a, ae_int_t m, ae_int_t n, ae_state *_state)
Definition: linalg.cpp:22166
void sparsemm2(sparsematrix *s, ae_matrix *a, ae_int_t k, ae_matrix *b0, ae_matrix *b1, ae_state *_state)
Definition: linalg.cpp:30269